From: Gérald NICOLAS Date: Thu, 29 Oct 2020 13:36:52 +0000 (+0100) Subject: Homard executable X-Git-Tag: V9_8_0a1~10 X-Git-Url: http://git.salome-platform.org/gitweb/?p=modules%2Fhomard.git;a=commitdiff_plain;h=b49fd63653d53c87f7b1d6a0a2a46aebf78ad19c Homard executable --- diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 15aa8edc..14d8fc2c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -29,6 +29,7 @@ SET(SUBDIRS_COMMON FrontTrack FrontTrack_SWIG tests + tool ) SET(SUBDIRS diff --git a/src/tool/AP_Conversion/CMakeLists.txt b/src/tool/AP_Conversion/CMakeLists.txt new file mode 100644 index 00000000..5b65bd36 --- /dev/null +++ b/src/tool/AP_Conversion/CMakeLists.txt @@ -0,0 +1,175 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de AP_Conversion + +SET(AP_Conversion_SOURCES + ./pccac1.F + ./pccac2.F + ./pccafo.F + ./pccapf.F + ./pccapg.F + ./pccapr.F + ./pcceq1.F + ./pcceq2.F + ./pcceq3.F + ./pcceq4.F + ./pcehe1.F + ./pcepe1.F + ./pcequ1.F + ./pcequ2.F + ./pcequ3.F + ./pcequ4.F + ./pcete1.F + ./pcetr1.F + ./pcetr2.F + ./pcetr3.F + ./pcetr4.F + ./pcfaa1.F + ./pcfaa2.F + ./pcfaa3.F + ./pcfaat.F + ./pcfor1.F + ./pcfor2.F + ./pcfore.F + ./pcma21.F + ./pcma22.F + ./pcma23.F + ./pcmaa0.F + ./pcmaar.F + ./pcmac1.F + ./pcmaco.F + ./pcmafa.F + ./pcmahe.F + ./pcmaig.F + ./pcmail.F + ./pcmamp.F + ./pcmanc.F + ./pcmano.F + ./pcmape.F + ./pcmapy.F + ./pcmaq0.F + ./pcmaqu.F + ./pcmar0.F + ./pcmar1.F + ./pcmar2.F + ./pcmar3.F + ./pcmarc.F + ./pcmat0.F + ./pcmate.F + ./pcmatr.F + ./pcmex0.F + ./pcmex1.F + ./pcmex2.F + ./pcmex3.F + ./pcmext.F + ./pcmmen.F + ./pcs0he.F + ./pcs0pe.F + ./pcs0qu.F + ./pcs0te.F + ./pcs0tr.F + ./pcs1ar.F + ./pcs1he.F + ./pcs1pe.F + ./pcs1qu.F + ./pcs2ar.F + ./pcs2h1.F + ./pcs2h2.F + ./pcs2h3.F + ./pcs2h4.F + ./pcs2h5.F + ./pcs2he.F + ./pcs2p1.F + ./pcs2p2.F + ./pcs2p3.F + ./pcs2p4.F + ./pcs2p5.F + ./pcs2p6.F + ./pcs2pe.F + ./pcs2qu.F + ./pcs2te.F + ./pcs2tr.F + ./pcs3tr.F + ./pcsar0.F + ./pcsar1.F + ./pcseh0.F + ./pcseh1.F + ./pcseh8.F + ./pcseh9.F + ./pcsehy.F + ./pcsehz.F + ./pcsep0.F + ./pcsep1.F + ./pcsep8.F + ./pcsep9.F + ./pcsepy.F + ./pcsepz.F + ./pcseq0.F + ./pcseq1.F + ./pcseq2.F + ./pcseq3.F + ./pcseq4.F + ./pcset0.F + ./pcset2.F + ./pcset4.F + ./pcset8.F + ./pcshe0.F + ./pcsi00.F + ./pcsiar.F + ./pcsihe.F + ./pcsipe.F + ./pcsiqu.F + ./pcsite.F + ./pcsitr.F + ./pcsmar.F + ./pcsoar.F + ./pcsohe.F + ./pcsolu.F + ./pcsono.F + ./pcsope.F + ./pcsoqu.F + ./pcsote.F + ./pcsotr.F + ./pcsovr.F + ./pcspe0.F + ./pcsprn.F + ./pcspt0.F + ./pcspt2.F + ./pcspt4.F + ./pcspt8.F + ./pcsptd.F + ./pcsptq.F + ./pcsptz.F + ./pcsqu0.F + ./pcsqug.F + ./pcsrc0.F + ./pcsrho.F + ./pcste0.F + ./pcsteg.F + ./pcstr0.F + ./pcstrg.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/AP_Conversion ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (AP_Conversion ${AP_Conversion_SOURCES}) + +INSTALL(TARGETS AP_Conversion EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/AP_Conversion/pccac1.F b/src/tool/AP_Conversion/pccac1.F new file mode 100644 index 00000000..b41cca89 --- /dev/null +++ b/src/tool/AP_Conversion/pccac1.F @@ -0,0 +1,256 @@ + subroutine pccac1 ( nbcham, nocham, + > nnfonc, npfonc, obprof, oblopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques des Champs - 1 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcham . e . 1 . nombre de champs . +c . nocham . es . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nnfonc . e . char8 . nom de la fonction iteration n . +c . npfonc . e . char8 . nom de la fonction iteration n+1 . +c . obprof . e . char8 . nom de l'objet profil eventuel . +c . oblopg . e . char8 . nom de l'objet localisation eventuelle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAC1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbcham +c + character*8 nocham(nbcham) + character*8 npfonc, nnfonc, obprof, oblopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3 + integer codre0 +c + integer nrocha, nrotv + integer nbtvch + integer adcaen, adcaca + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Etape '',a1,'' : nom de la fonction = '',a8)' + texte(1,5) = '(''... Le remplacement de la fonction a eu lieu.'')' +c + texte(2,4) = '(''Stage '',a1,'' : name of the function = '',a8)' + texte(2,5) = '(''... Change of function occured.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n', nnfonc + write (ulsort,texte(langue,4)) 'p' ,npfonc +#endif +c +c==== +c 2. on passe en revue tous les champs +c==== +c + do 20 , nrocha = 1 , nbcham +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. Nom du champ = ',nocham(nrocha) + call gmprsx (nompro, nocham(nrocha)//'.Cham_Car' ) +#endif +c +c 2.1. ==> reperage des noms des fonctions +c + if ( codret.eq.0 ) then +c + call gmliat ( nocham(nrocha), 2, nbtvch, codre1 ) + call gmadoj ( nocham(nrocha)//'.Cham_Ent', adcaen, iaux, codre2 ) + call gmadoj ( nocham(nrocha)//'.Cham_Car', adcaca, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 2.2. ==> on parcourt les tableaux +c on opere un traitement quand on tombe sur la bonne fonction +c + if ( codret.eq.0 ) then +c + do 21 , nrotv = 1, nbtvch +c + jaux = adcaca + nbincc*(nrotv-1) +c + if ( smem(jaux).eq.nnfonc ) then +c +c 2.2.1. ==> on met a jour le nombre de valeurs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( npfonc, + > iaux, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c Rappel : +c 1. type de support au sens MED +c 2. numero du pas de temps +c 4. 1, si numero d'ordre, 0 sinon +c 3. numero d'ordre +c 4. nombre de points de Gauss +c 5. nombre d'entites support +c 6. nombre de valeurs du profil eventuel +c 7. nombre de supports associes +c 8. noeuds par elements/points de Gauss/autre +c 9. numero du 1er tableau dans la fonction +c 10. -1 ou champ elga/champ elno +c 11. type interpolation +c 21-nbinec. type des supports associes +c + jaux = adcaen + nbinec*(nrotv-1) + imem(jaux+4) = nbenmx + imem(jaux+5) = nbvapr + imem(jaux+6) = nbtyas +cgn print *,nbtyas +cgn print *,(imem(adtyas+kaux-1),kaux = 1 , nbtyas) + do 211 , kaux = 1 , nbtyas + imem(jaux+19+kaux) = imem(adtyas+kaux-1) + 211 continue +c + endif +c +c 2.2.2. ==> on remplace l'ancien nom de la fonction par le nouveau +c + jaux = adcaca + nbincc*(nrotv-1) + smem(jaux) = npfonc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) +#endif +c +c 2.2.3. ==> on archive le nom de l'eventuel profil +c + if ( nbvapr.gt.0 ) then + smem(jaux+1) = obprof + else + smem(jaux+1) = blan08 + endif +c +c 2.2.4. ==> on archive le nom de l'eventuelle localisation +c + smem(jaux+2) = oblopg +c + endif +c + 21 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nocham(nrocha) ) + call gmprsx (nompro, nocham(nrocha)//'.Cham_Ent' ) + call gmprsx (nompro, nocham(nrocha)//'.Cham_Car' ) + endif +#endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pccac2.F b/src/tool/AP_Conversion/pccac2.F new file mode 100644 index 00000000..e28bc8e8 --- /dev/null +++ b/src/tool/AP_Conversion/pccac2.F @@ -0,0 +1,218 @@ + subroutine pccac2 ( nofonc, nnfonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques des Champs - 2 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nofonc . e . char8 . nom de la fonction a ajouter . +c . nnfonc . e . char8 . nom de la fonction associee . +c . adinch . s . 1 . adresse de l'information sur les champs . +c . adinpf . s . 1 . adresse de l'information sur les fonctions . +c . adinpr . s . 1 . adresse de l'information sur les profils . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAC2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 nofonc + character*8 nnfonc +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + integer nbtafo + integer adobch + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca +c + character*8 nocham, saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom de la fonction a ajouter : '',a8)' + texte(1,5) = '(''Nom de la fonction associee : '',a8)' + texte(1,6) = '(''..... Tableau'',i4,'' ==> Nom du champ : '',a)' + texte(1,7) = '(''..... Avant l''''ajout de la fonction :'')' + texte(1,8) = '(''..... Apres l''''ajout de la fonction :'')' + texte(1,9) = '(''Nombre de tableaux :'',i8)' +c + texte(2,4) = '(''Name of the function to add : '',a8)' + texte(2,5) = '(''Name of the associated function : '',a8)' + texte(2,6) = '(''..... Array'',i4,'' ==> Name of field : '',a)' + texte(2,7) = '(''..... Before the addition of function :'')' + texte(2,8) = '(''..... Following the addition of function :'')' + texte(2,9) = '(''Number of arrays :'',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nofonc + call gmprsx (nompro, nofonc ) + write (ulsort,texte(langue,5)) nnfonc + call gmprsx (nompro, nnfonc ) + call gmprsx (nompro, nnfonc//'.InfoCham' ) +#endif +c +c==== +c 2. mise a jour des caracteristiques du champ +c==== +c +c 2.1. ==> reperage des tableaux et des champs associes a cette fonction +c + if ( codret.eq.0 ) then +c + call gmliat ( nofonc, 7, nbtafo, codre1 ) + call gmadoj ( nofonc//'.InfoCham', adobch, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) nbtafo +#endif +c +c 2.2. ==> enregistrement du champ associe a chaque tableau de +c cette fonction +c + if ( codret.eq.0 ) then +c + saux08 = ' ' +c 12345678 +c + do 22 , jaux = 1 , nbtafo +c + nocham = smem(adobch+jaux-1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) jaux, nocham +#endif +c + if ( nocham.ne.saux08 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,7)) + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Car' ) + endif +#endif +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOCH', nompro +#endif + call utmoch ( nocham, iaux, + > nofonc, nnfonc, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + saux08 = nocham +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,8)) + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Car' ) + endif +#endif +c + endif +c + 22 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pccafo.F b/src/tool/AP_Conversion/pccafo.F new file mode 100644 index 00000000..eeae5e8f --- /dev/null +++ b/src/tool/AP_Conversion/pccafo.F @@ -0,0 +1,324 @@ + subroutine pccafo ( nrfonc, nofonc, obprof, oblopg, + > nbpara, carenf, carach, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques des FOnctions +c - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrfonc . e . 1 . numero de la fonction a examiner . +c . nofonc . s . char8 . nom de la fonction iteration n+1 . +c . obprof . s . char8 . nom de l'objet profil eventuel . +c . oblopg . s . char8 . nom de l'objet localisation points de Gauss. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carach . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAFO' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer nrfonc + integer nbpara + integer carenf(nbpara,*) + integer option +c + character*8 nofonc, obprof, oblopg + character*8 carach(nbpara,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer typfon, typcha, typgeo, typass + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer n1vale, n1valr, n1prpg, n1obch, n1lipr + integer npenmx, npvapr + integer p1vale, p1valr, p1prpg, p1obch, p1vatt + integer p1vane, p1tyas + integer adpcan, adpcap + integer nrfon2, nrfon3 + integer adinch +c + character*8 obpcan, obpcap + character*8 obinch +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Fonction numero '',i6)' + texte(1,5) = '(''Nom de la fonction = '',a8)' +c + texte(2,4) = '(''.. Function #'',i6)' + texte(2,5) = '(''Name of the function ='',a8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc + write (ulsort,90002) 'option', option +#endif +cgn print *, nompro +cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara) +cgn 1788 format(5I8) +cgn print 1789,(carach(iaux,nrfonc),iaux=1,nbpara) +cgn 1789 format(5(a8,1x)) +c +c==== +c 2. caracteristiques de la fonction +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carach, + > iaux, + > typfon, typcha, typgeo, typass, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > n1vale, n1valr, n1prpg, n1obch, n1lipr, + > npenmx, npvapr, + > p1vale, p1valr, p1prpg, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblopg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nofonc +#endif +c +c==== +c 3. mise a jour des informations +c==== +c +c 3.1. ==> nombre de valeurs du profil +c + if ( codret.eq.0 ) then +c + call gmecat ( nofonc, 4, npvapr, codret ) +c + endif +c +c 3.2. ==> les noms +c + if ( codret.eq.0 ) then +c + smem(p1prpg ) = obprof + smem(p1prpg+1) = oblopg +c + endif +c +c 3.3. ==> changement de degre +c + if ( option.eq.1 ) then +c +c 3.3.1. ==> le champ associe a la fonction +c remarque : on aurait pu modifier utmoch +c + do 332 , iaux = 1 , nbtafo +c + if ( codret.eq.0 ) then +c + obinch = smem(n1obch-1+iaux) + call gmadoj ( obinch//'.Cham_Ent', adinch, jaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(adinch ) = carenf(3,nrfonc) + imem(adinch+3) = carenf(5,nrfonc) +c + endif +c + 332 continue +c + endif +c +c==== +c 4. compactage des valeurs pour les fonctions sur les elements +c remarque : le traitement sur les fonctions aux noeuds est +c different. Il est fait directement dans pcsono. +c==== +c + if ( codret.eq.0 ) then +cgn print *,nompro +cgn print *,'p1vatt = ',p1vatt +cgn print *,'rmem(p1vatt+13) = ',rmem(p1vatt+13) +c + if ( typgeo.ne.0 ) then +c + if ( ngauss.eq.ednopg ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSRC1', nompro +#endif + call utsrc1 ( nbtafo, rseutc, + > imem(adpcap), rmem(p1vatt), rmem(p1valr) ) +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSRC2', nompro +#endif + call utsrc2 ( nbtafo, ngauss, rseutc, + > imem(adpcap), rmem(p1vatt), rmem(p1valr) ) +c + endif +c +cgn print *,nompro,' ==> codret = ',codret +cgn print 1790,(rmem(p1valr+iaux-1),iaux=1,nbtafo*rsevca) +cgn 1790 format(10g13.5) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nofonc) + call gmprsx (nompro,nofonc//'.ValeursR') + call gmprsx (nompro,nofonc//'.InfoPrPG') + if ( npvapr.gt.0 ) then + call gmprsx (nompro,obprof) + endif + if ( oblopg.ne.blan08 ) then + call gmprsx (nompro,oblopg) + endif +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pccapf.F b/src/tool/AP_Conversion/pccapf.F new file mode 100644 index 00000000..1a2875cb --- /dev/null +++ b/src/tool/AP_Conversion/pccapf.F @@ -0,0 +1,358 @@ + subroutine pccapf ( nppafo, npfopa, nbcham, nocham, + > nbpara, carenf, carchf, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques +c - -- +c des Paquets de Fonctions +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nppafo . e . 1 . nom du paquet de fonctions iteration p . +c . npfopa . e . 1 . nombre de fonctions a traiter . +c . nbcham . e . 1 . nombre de champs . +c . nocham . es . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : adprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAPF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbpara + integer npfopa, nbcham + integer carenf(nbpara,*) + integer option +c + character*8 nppafo + character*8 nocham(nbcham) + character*8 carchf(nbpara,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nrfonc + integer tbiaux(1) + integer typgpf, ngauss, carsup, typint + integer apobfo +c + character*8 nnfonc + character*8 npfonc, opprof, oplopg + character*8 nnpafo + character*8 tbsaux(1) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nom de la fonction '',a,'' numero'',i3,'' : '',a8)' + texte(1,5) = '(''... Nom du profil = '',a8)' + texte(1,6) = '(''... fonction nouvelle'')' + texte(1,7) = '(''... fonction ancienne isolee'')' + texte(1,8) = '(''... fonction ancienne associee a une autre'')' + texte(1,9) = '(''Suppression de la fonction '',a)' + texte(1,10) = '(''... '',a,'' : '',i6)' + texte(1,11) = + > '(''Remplacement du nom de la fonction dans le paquet :'')' + texte(1,12) = '(3x,a,'' devient '',a)' + texte(1,13) = + > '(''Ajout du nom de la fonction '',a,'' dans le paquet'')' + texte(1,20) = '(''Nombre de fonctions dans le paquet :'',i4)' +c + texte(2,4) = '(''Name of the function '',a,'' #'',i3,'' : '',a8)' + texte(2,5) = '(''... Name of the profile = '',a8)' + texte(2,6) = '(''... new function'')' + texte(2,7) = '(''... old lonesome function'')' + texte(2,8) = '(''... old function connected to another one'')' + texte(2,9) = '(''Deleting of the function '',a)' + texte(2,10) = '(''... '',a,'' : '',i6)' + texte(2,11) = '(''Change of function name in the pack'')' + texte(2,12) = '(3x,a,'' becomes '',a)' + texte(2,13) = + > '(''Addition of function name '',a,'' to the pack'')' + texte(2,20) = '(''Number of functions in the pack :'',i4)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) npfopa + write (ulsort,90002) 'option', option +#endif +c +c==== +c 2. mise a jour des caracteristiques des fonctions +c==== +c + do 20 , nrfonc = 1 , npfopa +c +c 2.1. ==> mise a jour des caracteristiques des fonctions +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,texte(langue,10)), 'nrfonc', nrfonc +cgn write (ulsort,91010) (carenf(iaux,nrfonc),iaux=1,nbpara) +cgn write (ulsort,93010) (carchf(iaux,nrfonc),iaux=1,nbpara) +c + iaux = nrfonc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCAFO', nompro +#endif + call pccafo ( iaux, npfonc, opprof, oplopg, + > nbpara, carenf, carchf, + > option, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) 'p', nrfonc, npfonc + write (ulsort,texte(langue,5)) opprof + call gmprsx (nompro,npfonc) + call gmprot (nompro,npfonc//'.ValeursR',1,20) +cgn call gmprsx (nompro,npfonc//'.InfoPrPG') +#endif +c +c 2.2. ==> mise a jour des caracteristiques des champs +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2. mise a jour ; codret =', codret +#endif +c + iaux = carenf(1,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7+iaux)) +#endif +c +c 2.2.1. ==> remplacement quand la fonction existait deja +c + if ( iaux.ge.0 ) then +c + if ( codret.eq.0 ) then +c + nnfonc = carchf( 2,nrfonc) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n', nrfonc, nnfonc + write (ulsort,texte(langue,11)) + write (ulsort,texte(langue,12)) nnfonc, npfonc +cgn call gmprsx (nompro,nnfonc) +cgn call gmprsx (nompro,nnfonc//'.InfoPrPG') + write (ulsort,texte(langue,3)) 'PCCAC1', nompro +#endif + call pccac1 ( nbcham, nocham, + > nnfonc, npfonc, opprof, oplopg, + > ulsort, langue, codret ) +c + endif +c +c 2.2.2. ==> ajout sinon +c + else +c + if ( codret.eq.0 ) then +c + nnfonc = carchf( 3,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n', nrfonc, nnfonc + write (ulsort,texte(langue,13)) npfonc + write (ulsort,texte(langue,3)) 'PCCAC2', nompro +#endif + call pccac2 ( npfonc, nnfonc, + > ulsort, langue, codret ) +c + endif +c + endif +c + 20 continue +c +c==== +c 3. suppression des anciennes fonctions +c attention a ne le faire qu'a ce moment, car le nom connu peut +c etre le meme pour plusieurs fonctions p dans le cas de conformite. +c Si on le faisait dans la boucle 20, on perdrait tout ! +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. suppression ; codret =', codret +#endif +c + do 30 , nrfonc = 1 , npfopa +c + if ( codret.eq.0 ) then +c + iaux = carenf(1,nrfonc) +c + if ( iaux.eq.0 ) then +c + nnfonc = carchf( 2,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) nnfonc +#endif +c + call gmobal ( nnfonc, jaux ) +c + if ( jaux.eq.1 ) then + call gmsgoj ( nnfonc , codret ) + elseif ( jaux.ne.0 ) then + codret = 3 + endif +c + endif +c + endif +c + 30 continue +c +c==== +c 4. degre du type geometrique +c==== +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif + iaux = 6 + call utmopf ( nppafo, iaux, + > jaux, tbsaux, tbiaux, + > nnpafo, + > npfopa, typgpf, ngauss, carsup, typint, + > apobfo, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pccapg.F b/src/tool/AP_Conversion/pccapg.F new file mode 100644 index 00000000..4190199b --- /dev/null +++ b/src/tool/AP_Conversion/pccapg.F @@ -0,0 +1,262 @@ + subroutine pccapg ( npfopa, nplopg, lilopg, + > nbpara, carenf, carach, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques +c - -- +c des Points de Gauss +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . npfopa . e . 1 . nombre de fonctions a traiter . +c . nplopg . es . 1 . nbre de localisations en sortie enregistres. +c . lilopg . es . char*8 . nom des objets de type 'LocaPG' enregistres. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : ngauss . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : adprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : ngauss . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carach . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAPG' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer npfopa, nplopg + integer nbpara + integer carenf(nbpara,*) +c + character*8 lilopg(*) + character*8 carach(nbpara,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nrfonc + integer ngauss, carsup +c + character*8 oblopg +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Fonction numero '',i6)' + texte(1,5) = '(''Nom de l''''objet localisation = '',a8)' +c + texte(2,4) = '(''.. Function # '',i6)' + texte(2,5) = '(''Name of the localization object = '',a8)' +c +#include "impr03.h" +c +c==== +c 2. mise a jour des caracteristiques des localications +c==== +c + do 20 , nrfonc = 1 , npfopa +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +#endif +cgn write (ulsort,90002) nompro, +cgn >(carenf(iaux,nrfonc),iaux=1,nbpara) +cgn print 1789,(carach(iaux,nrfonc),iaux=1,nbpara) +cgn 1789 format(5(a8,1x)) +c + if ( codret.eq.0 ) then +c + ngauss = carenf(5,nrfonc) + carsup = carenf(8,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ancien ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,*) 'carach( 7,nrfonc) : ', carach( 7,nrfonc)//'XX' + write (ulsort,*) ' blan08 : ', blan08//'XX' +#endif +c + endif +c +c 2.1. ==> creation de la localisation eventuelle +c + oblopg = blan08 +c + if ( carach( 7,nrfonc).ne.blan08 ) then +c + if ( codret.eq.0 ) then +c + oblopg = carach( 7,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) oblopg + call gmprsx (nompro, oblopg ) +#endif +c + endif +c + endif +c + if ( ngauss.eq.ednopg ) then + ngauss = 1 + endif +c +c 2.2. ==> archivages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nouveau ngauss', ngauss +#endif + carenf( 5,nrfonc) = ngauss + carach( 7,nrfonc) = oblopg +c + endif +c +c 2.3. ==> si la localisation n'est pas dans la liste, on l'ajoute +c + if ( codret.eq.0 ) then +c + if ( oblopg.ne.blan08 ) then +c + do 231 , iaux = 1 , nplopg +c + if ( lilopg(iaux).eq.oblopg ) then + goto 232 + endif +c + 231 continue +c + nplopg = nplopg + 1 + lilopg(nplopg) = oblopg +c + 232 continue +c + endif +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nplopg', nplopg +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pccapr.F b/src/tool/AP_Conversion/pccapr.F new file mode 100644 index 00000000..8e74c58d --- /dev/null +++ b/src/tool/AP_Conversion/pccapr.F @@ -0,0 +1,325 @@ + subroutine pccapr ( npfopa, npprof, liprof, + > nbpara, carenf, carach, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - mise a jour des CAracteristiques +c - -- +c des PRofils +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . npfopa . e . 1 . nombre de fonctions a traiter . +c . npprof . es . 1 . nombre de profils en sortie enregistres . +c . liprof . es . char*8 . nom des objets de type 'Profil' enregistres. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : adprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carach . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCAPR' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombsr.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer npfopa, npprof + integer nbpara + integer carenf(nbpara,*) +c + character*8 liprof(*) + character*8 carach(nbpara,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nrfonc + integer rsenac, adpcap + integer typgeo + integer nnvapr, npvapr +c + character*8 obpcap, opprof +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom de l''''objet profil etape n = '',a8)' +c + texte(2,4) = '(''Name of the profile object #n: '',a8)' +c +#include "impr03.h" +c +c==== +c 2. mise a jour des caracteristiques des profils +c==== +c + do 20 , nrfonc = 1 , npfopa +c + if ( codret.eq.0 ) then +c + nnvapr = carenf(7,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '============================' + write (ulsort,90002) 'nnvapr', nnvapr +#endif +c + endif +c +c 2.1. ==> creation du profil eventuel +c +c 2.1.1. ==> recuperation des informations +c + if ( nnvapr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + obpcap = carach( 5,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) obpcap +cgn call gmprsx (nompro, obpcap ) +#endif + call gmadoj ( obpcap, adpcap, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + typgeo = carenf( 3,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo +#endif +c +c Par convention HOMARD, les mailles sont rangees ainsi : +c . les tetraedres +c . les triangles +c . les aretes +c . les mailles-points +c . les quadrangles +c . les hexaedres +c . les pyramides +c . les pentaedres +c + if ( typgeo.eq.0 ) then + rsenac = rsnoto + iaux = 1 + jaux = 0 + elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then + rsenac = rsteac + iaux = 1 + jaux = 0 + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then + rsenac = rstrac + iaux = 1 + jaux = nbtetr + elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then + rsenac = rsarac + iaux = 1 + jaux = nbtetr + nbtria + elseif ( typgeo.eq.edpoi1 ) then + rsenac = rsmpac + iaux = 1 + jaux = nbtetr + nbtria + nbsegm + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then + rsenac = rsquac + iaux = 1 + jaux = nbtetr + nbtria + nbsegm + nbmapo + elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then + rsenac = rsheac + iaux = 1 + jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad + elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then +cc rsenac = rspyac + iaux = 1 + jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then +cc rsenac = rspeac + iaux = 1 + jaux = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra + else + goto 20 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'rsenac', rsenac + write (ulsort,90002) 'iaux ', iaux + write (ulsort,90002) 'jaux ', jaux +#endif +c +c 2.1.2. ==> creation du profil +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR01', nompro +#endif + call utpr01 ( iaux, jaux, + > rsenac, imem(adpcap), imem(iaux), + > npvapr, opprof, + > npprof, liprof, + > ulsort, langue, codret ) +c +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,opprof) + call gmprsx (nompro,opprof//'.ListEnti') +#endif +c + endif +c +c 2.2. ==> sans profil +c + else +c + npvapr = -1 + opprof = ' ' +c 12345678 +c + endif +c +c 2.3. ==> archivages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'npvapr', npvapr +#endif + carenf(16,nrfonc) = npvapr + carach( 6,nrfonc) = opprof +c + endif +c +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcceq1.F b/src/tool/AP_Conversion/pcceq1.F new file mode 100644 index 00000000..f54d04f5 --- /dev/null +++ b/src/tool/AP_Conversion/pcceq1.F @@ -0,0 +1,273 @@ + subroutine pcceq1 ( cfanoe, famnoe, nnosho, + > cfampo, fammpo, nmpsho, + > cfaare, famare, narsho, + > cfatri, famtri, ntrsho, + > cfaqua, famqua, nqusho, + > typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - Creation des EQuivalences - phase 1 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . + l : appartenance a l'equivalence l . +c . famnoe . e . nbnoto . famille des aretes . +c . nnosho . e . rsnoto . numero des noeuds dans HOMARD . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . + l : appartenance a l'equivalence l . +c . fammpo . e . nbmpto . famille des mailles-points . +c . nmpsho . e . rsmpac . numero des mailles-points dans HOMARD . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . . nbquto . famille des quadrangles . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . typele . e . nbelem . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCEQ1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nbfami.h" +#include "nombar.h" +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nbutil.h" +#include "dicfen.h" +#include "refert.h" +c +c 0.3. ==> arguments +c + integer nnosho(rsnoto), nmpsho(rsmpac), narsho(rsarac) + integer ntrsho(rstrac), nqusho(rsteac) + integer typele(nbelem) +c + integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto) + integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(/,''Decompte des equivalences - Phase 1 :'')' +c + texte(2,10) = '(/,''Description of equivalences - Phase # 1 :'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) +#endif +c + codret = 0 +c +c==== +c 2. on compte combien d'entites appartiennent a des equivalences. +c==== +c +c 2.1. ==> les noeuds +c + if ( codret.eq.0 ) then +c + iaux = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ2_no', nompro +#endif + call pcceq2 ( iaux, + > nbnoto, nctfno, nbfnoe, + > ncefno, nbeqno, jaux, jaux, rsnoto, + > cfanoe, famnoe, nnosho, + > typele, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> les mailles-points +c + if ( codret.eq.0 ) then +c + iaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ2_mp', nompro +#endif + call pcceq2 ( iaux, + > nbmpto, nctfmp, nbfmpo, + > ncefmp, nbeqmp, tyhmpo, tyhmpo, nbelem, + > cfampo, fammpo, nmpsho, + > typele, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> les aretes +c + if ( codret.eq.0 ) then +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ2_ar', nompro +#endif + call pcceq2 ( iaux, + > nbarto, nctfar, nbfare, + > ncefar, nbeqar, tyhse1, tyhse2, nbelem, + > cfaare, famare, narsho, + > typele, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> les triangles +c + if ( codret.eq.0 ) then +c + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ2_tr', nompro +#endif + call pcceq2 ( iaux, + > nbtrto, nctftr, nbftri, + > nceftr, nbeqtr, tyhtr1, tyhtr2, nbelem, + > cfatri, famtri, ntrsho, + > typele, + > ulsort, langue, codret ) +c + endif +c +c 2.5. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + iaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ2_qu', nompro +#endif + call pcceq2 ( iaux, + > nbquto, nctfqu, nbfqua, + > ncefqu, nbeqqu, tyhqu1, tyhqu2, nbelem, + > cfaqua, famqua, nqusho, + > typele, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcceq2.F b/src/tool/AP_Conversion/pcceq2.F new file mode 100644 index 00000000..03fa8835 --- /dev/null +++ b/src/tool/AP_Conversion/pcceq2.F @@ -0,0 +1,224 @@ + subroutine pcceq2 ( option, + > nbento, nctfen, nbfent, + > ncefen, nbeqen, tyhen1, tyhen2, nbenca, + > cfaent, fament, nensho, + > typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - Creation des EQuivalences - phase 2 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . nbento . e . 1 . nombre d'entites total . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfent . e . 1 . nombre de familles de l'entite . +c . ncefen . e . 1 . nombre de caracteristiques d'equivalence . +c . . . . dans les familles de l'entite . +c . nbeqen . s . 1 . estimation du nombre de paires d'entites . +c . tyhen1 . e . 1 . 1er type homard representant cette entite . +c . tyhen2 . e . 1 . 2nd type homard representant cette entite . +c . nbenca . e . 1 . nombre d'entites du calcul . +c . cfaent . e . nctfen*. codes des familles des entites . +c . . . nbfent . . +c . fament . e . nbento . famille des entites . +c . nensho . e . rsenac . numero des entites dans HOMARD . +c . typele . e . nbelem . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCEQ2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "rftmed.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer nbento, nctfen, nbfent + integer ncefen, nbeqen, tyhen1, tyhen2, nbenca + integer nensho(*) + integer typele(*) +c + integer cfaent(nctfen,nbfent), fament(nbento) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nucode + integer iaux, jaux, ideb, ifin +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Decompte des equivalences sur les '',a)' + texte(1,5) = '(''--> Ce nombre doit etre pair !'')' + texte(1,8) = + > '(8x,''. Nombre a apparier :'',i10)' +c + texte(2,4) = '(/,''Description of equivalences over '',a)' + texte(2,5) = '(''--> This number should be even !'')' + texte(2,8) = + > '(8x,''. Number of entities :'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,option) +#endif +c + codret = 0 +c +c==== +c 2. on compte combien d'elements appartiennent a des equivalences. +c on trie les entites qui sont vraiment des elements : cela se +c reconnait en utilisant les codes lies au type des elements. +c +c remarque : il vaut mieux que la boucle sur les entites soit a +c l'interieur car elle sera toujours plus longue que +c celle sur les equivalences, d'ou une meilleure +c vectorisation +c==== +c + nbeqen = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbento', nbento +#endif +c + if ( nbento.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbenca', nbenca + if ( option.ge.0 ) then + write (ulsort,90002) 'tyhen1', tyhen1 + write (ulsort,90002) 'tyhen2', tyhen2 + endif + write (ulsort,90002) 'ncefen', ncefen +#endif +c + iaux = 0 + ideb = nctfen - ncefen + 1 + ifin = nctfen +c + do 21 , nucode = ideb , ifin +c +c 2.1. ==> cas particulier des noeuds +c + if ( option.lt.0 ) then +c + do 211 , jaux = 1, nbenca + if ( cfaent(nucode,fament(nensho(jaux))).ne.0 ) then + nbeqen = nbeqen + 1 + endif + 211 continue +c +c 2.2. ==> les elements +c + else +c + do 212 , jaux = 1, nbenca + if ( medtrf(typele(jaux)).eq.tyhen1 .or. + > medtrf(typele(jaux)).eq.tyhen2 ) then + if ( cfaent(nucode,fament(nensho(jaux))).ne.0 ) then + nbeqen = nbeqen + 1 + endif + endif + 212 continue +c + endif +c + if ( iaux.ne.nbeqen ) then + iaux = nbeqen + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ncefen', ncefen +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcceq3.F b/src/tool/AP_Conversion/pcceq3.F new file mode 100644 index 00000000..1de09ec9 --- /dev/null +++ b/src/tool/AP_Conversion/pcceq3.F @@ -0,0 +1,369 @@ + subroutine pcceq3 ( cfanoe, famnoe, nnosho, nnosca, + > cfampo, fammpo, nmpsho, nmpsca, + > cfaare, famare, narsho, narsca, + > cfatri, famtri, ntrsho, ntrsca, + > cfaqua, famqua, nqusho, nqusca, + > typele, + > noehom, mpohom, arehom, trihom, quahom, + > eqpntr, + > eqnoeu, eqmapo, eqaret, eqtria, eqquad, + > nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - Creation des EQuivalences - phase 3 +c - - - -- - +c ______________________________________________________________________ +c +c remarque : on trie les mailles en ne prenant que celles qui +c sont vraiment des elements : cela se reconnait en +c utilisant les codes lies au type des elements. +c +c remarque : il vaut mieux que la boucle sur les entites soit a +c l'interieur car elle sera toujours plus longue que +c celle sur les equivalences, d'ou une meilleure +c vectorisation +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . + l : appartenance a l'equivalence l . +c . famnoe . e . nbnoto . famille des aretes . +c . nnosho . e . rsnoto . numero des noeuds dans HOMARD . +c . nnosca . e . rsnoto . numero des noeuds dans le code de calcul . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . + l : appartenance a l'equivalence l . +c . fammpo . e . nbmpto . famille des mailles-points . +c . nmpsho . e . rsmpac . numero des mailles-points dans HOMARD . +c . nmpsca . e . rsmpto . numero des mailles-points du calcul . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . narsca . e . rsarto . numero des aretes du calcul . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . . nbquto . famille des quadrangles . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . typele . e . nbelem . type des elements . +c . noehom . e . nbnoto . liste etendue des homologues par noeuds . +c . mpohom . e . nbmpto . liste etendue des homologues par ma.pts . +c . arehom . e . nbarto . liste etendue des homologues par aretes . +c . trihom . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . eqpntr . s .5*nbequi. 5i-4 : nombre de paires de noeuds pour . +c . . . . l'equivalence i . +c . . . . 5i-3 : idem pour les mailles-points . +c . . . . 5i-2 : idem pour les aretes . +c . . . . 5i-1 : idem pour les triangles . +c . . . . 5i : idem pour les quadrangles . +c . eqnoeu . s .2*nbeqno. liste des paires de noeuds equivalents avec. +c . . . . la convention : eqnoeu(i)<-->eqnoeu(i+1) . +c . eqmapo . s .2*nbeqmp. idem pour les mailles-points . +c . eqaret . s .2*nbeqar. idem pour les aretes . +c . eqtria . s .2*nbeqtr. idem pour les triangles . +c . eqquad . s .2*nbeqqu. idem pour les quadrangles . +c . nbeqno . s . 1 . nombre total de noeuds dans les equivalen. . +c . nbeqmp . s . 1 . nombre total de mailles-points dans les eq.. +c . nbeqar . s . 1 . nombre total d'aretes dans les eq. . +c . nbeqtr . s . 1 . nombre total de triangles dans les eq. . +c . nbeqqu . s . 1 . nombre total de quadrangles dans les eq. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCEQ3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nbfami.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nbutil.h" +#include "dicfen.h" +#include "refert.h" +c +c 0.3. ==> arguments +c + integer nqusca(rsquto), nqusho(rsquac) + integer ntrsca(rstrto), ntrsho(rstrac) + integer nmpsca(rsmpto), nmpsho(rsmpac) + integer narsca(rsarto), narsho(rsarac) + integer nnosca(rsnoto), nnosho(rsnoac) + integer typele(nbelem) +c + integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto) + integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer noehom(nbnoto), mpohom(nbmpto) + integer arehom(nbarto), trihom(nbtrto) + integer quahom(nbquto) +c + integer eqpntr(5*nbequi) + integer eqnoeu(2*nbeqno), eqmapo(2*nbeqmp) + integer eqaret(2*nbeqar), eqtria(2*nbeqtr) + integer eqquad(2*nbeqqu) + integer nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, ideb, ifin +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. a priori, aucune entite n'appartient a une equivalence +c==== +c + ideb = 1 + ifin = 5*nbequi + do 21 , iaux = ideb , ifin + eqpntr(iaux) = 0 + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'nbnoto = ', nbnoto + write (ulsort,*) 'nbmapo = ', nbmapo + write (ulsort,*) 'nbsegm = ', nbsegm + write (ulsort,*) 'nbtria = ', nbtria + write (ulsort,*) 'nbquad = ', nbquad +#endif +c +c==== +c 3. Les noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Les noeuds ; codret = ', codret +#endif +c + if ( nbeqno.ne.0 ) then +c + iaux = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ4_no', nompro +#endif + call pcceq4 ( iaux, + > nbnoto, nctfno, nbfnoe, ncffno, ncefno, + > nbeqno, jaux, jaux, jaux, rsnoto, + > noehom, cfanoe, famnoe, nnosho, nnosca, + > typele, + > eqpntr, eqnoeu, nbeqnn, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Les mailles-points +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Les mailles-points ; codret = ', codret +#endif +c + if ( nbeqmp.ne.0 ) then +c + iaux = 0 + jaux = nbtetr + nbtria + nbquad + nbsegm +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ4_mp', nompro +#endif + call pcceq4 ( iaux, + > nbmpto, nctfmp, nbfmpo, ncffmp, ncefmp, + > nbeqmp, jaux, tyhmpo, tyhmpo, nbelem, + > mpohom, cfampo, fammpo, nmpsho, nmpsca, + > typele, + > eqpntr, eqmapo, nbeqmn, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Les aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Les aretes ; codret = ', codret +#endif +c + if ( nbeqar.ne.0 ) then +c + iaux = 1 + jaux = nbtetr + nbtria +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ4_ar', nompro +#endif + call pcceq4 ( iaux, + > nbarto, nctfar, nbfare, ncffar, ncefar, + > nbeqar, jaux, tyhse1, tyhse2, nbelem, + > arehom, cfaare, famare, narsho, narsca, + > typele, + > eqpntr, eqaret, nbeqan, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Les triangles ; codret = ', codret +#endif +c + if ( nbeqtr.ne.0 ) then +c + iaux = 2 + jaux = nbtetr +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ4_tr', nompro +#endif + call pcceq4 ( iaux, + > nbtrto, nctftr, nbftri, ncfftr, nceftr, + > nbeqtr, jaux, tyhtr1, tyhtr2, nbelem, + > trihom, cfatri, famtri, ntrsho, ntrsca, + > typele, + > eqpntr, eqtria, nbeqtn, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. Les quadrangles : tri selon les equivalences +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. Les quadrangles ; codret = ', codret +#endif +c + if ( nbeqqu.ne.0 ) then +c + iaux = 4 + jaux = nbtetr + nbtria + nbsegm + nbmpto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ4_qu', nompro +#endif + call pcceq4 ( iaux, + > nbquto, nctfqu, nbfqua, ncffqu, ncefqu, + > nbeqqu, jaux, tyhqu1, tyhqu2, nbelem, + > quahom, cfaqua, famqua, nqusho, nqusca, + > typele, + > eqpntr, eqquad, nbeqqn, + > ulsort, langue, codret ) +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcceq4.F b/src/tool/AP_Conversion/pcceq4.F new file mode 100644 index 00000000..b1f62d24 --- /dev/null +++ b/src/tool/AP_Conversion/pcceq4.F @@ -0,0 +1,306 @@ + subroutine pcceq4 ( option, + > nbento, nctfen, nbfent, ncffen, ncefen, + > nbeqen, ibenti, tyhen1, tyhen2, nbenca, + > enthom, cfaent, fament, nensho, nensca, + > typele, + > eqpntr, eqenti, nbeqev, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - Creation des EQuivalences - phase 4 +c - - - -- - +c ______________________________________________________________________ +c +c remarque : il vaut mieux que la boucle sur les entites soit a +c l'interieur car elle sera toujours plus longue que +c celle sur les equivalences, d'ou une meilleure +c vectorisation +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . nbento . e . 1 . nombre d'entites total . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfent . e . 1 . nombre de familles de l'entite . +c . ncffen . e . 1 . . +c . ncefen . e . 1 . nombre de caracteristiques d'equivalence . +c . . . . dans les familles de l'entite . +c . nbeqen . e . 1 . nombre d'equivalences de l'entite . +c . ibenti . e . 1 . decalage dans la numerotation . +c . tyhen1 . e . 1 . 1er type homard representant cette entite . +c . tyhen2 . e . 1 . 2nd type homard representant cette entite . +c . nbenca . e . 1 . nombre d'entites du calcul . +c . enthom . e . nbento . liste etendue des entites homologues . +c . . . . enthom(i) = abs(hom(i)) ssi i sur face 2 . +c . . . . enthom(i) = -abs(hom(i)) ssi i sur face 1 . +c . cfaent . e . nctfen*. codes des familles des entites . +c . . . nbfent . . +c . fament . e . nbento . famille des entites . +c . nensho . e . rsenac . numero des entites dans HOMARD . +c . nensca . e . rsento . numero des entites du calcul . +c . typele . e . nbelem . type des elements . +c . eqpntr . s .5*nbequi. 5i-4 : nombre de paires de noeuds pour . +c . . . . l'equivalence i . +c . . . . 5i-3 : idem pour les mailles-points . +c . . . . 5i-2 : idem pour les aretes . +c . . . . 5i-1 : idem pour les triangles . +c . . . . 5i : idem pour les quadrangles . +c . eqenti . s .2*nbeqen. liste des paires d'entites equivalentes . +c . . . . avec la convention : . +c . . . . eqenti(i)<-->eqenti(i+1) . +c . nbeqev . s . 1 . vrai nombre d'equivalences de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCCEQ4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "rftmed.h" +c +#include "impr02.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer option + integer nbento, nctfen, nbfent, ncffen, ncefen + integer nbeqen, ibenti, tyhen1, tyhen2, nbenca + integer nensca(*), nensho(*) + integer typele(*) +c + integer cfaent(nctfen,nbfent), fament(nbento) + integer enthom(nbento) +c + integer eqpntr(5*nbequi) + integer eqenti(2*nbeqen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nucode, nroequ, decala + integer iaux, jaux, kaux, ifin + integer nbeqev +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Creation des equivalences sur les '',a)' + texte(1,6) = + > '(8x,a14,'' : nombre d''''equivalences :'',i10)' + texte(1,7) = + > '(8x,''. Nombre de paires :'',i10)' + texte(2,6) = + > '(8x,a14,'' : number of equivalences :'',i10)' + texte(2,7) = + > '(8x,''. Number of pairs :'',i10)' +c + texte(2,4) = '(/,''Creation of equivalences over '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,option) + write (ulsort,90002) 'nbeqen', nbeqen +#endif +c + codret = 0 +c +c==== +c 2. Tri selon les equivalences +c==== +c + nbeqev = 0 +c + if ( nbeqen.ne.0 ) then +c +c 2.1. ==> initialisations +c + if ( option.eq.4 ) then + decala = 0 + else + decala = option - 3 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'enthom', enthom + write (ulsort,90002) 'nbequi', nbequi + write (ulsort,90002) 'nbento', nbento + write (ulsort,90002) 'nbenca', nbenca + write (ulsort,90002) 'ibenti', ibenti + write (ulsort,90002) 'tyhen1', tyhen1 + write (ulsort,90002) 'tyhen2', tyhen2 + write (ulsort,90002) 'decala', decala +#endif +c + ifin = 2*nbeqen + do 21 , iaux = 1 , ifin + eqenti(iaux) = 0 + 21 continue +c + kaux = 0 +c +c 2.2. ==> on passe en revue toutes les equivalences +c attention au bon rangement dans les faces 1 et 2 selon le +c signe de enthom : on filtre seulement ceux pour lesquels +c enthom est > 0. Cela permet de capturer les axes de symetrie. +c + do 22 , nroequ = 1 , nbequi +c + nucode = ncffen + nroequ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nroequ', nroequ + write (ulsort,90002) '5*nroequ+decala', 5*nroequ+decala + write (ulsort,90002) 'nucode', nucode +#endif +c +c 2.2.1. ==> cas particulier des noeuds +c + if ( option.lt.0 ) then +c + do 221 , iaux = 1, nbenca + if ( cfaent(nucode,fament(nensho(iaux))).ne.0 ) then + if ( enthom(nensho(iaux)).gt.0 ) then + kaux = kaux + 2 + jaux = nensca(enthom(nensho(iaux))) + eqenti(kaux-1) = jaux + eqenti(kaux) = iaux + eqpntr(5*nroequ+decala) = eqpntr(5*nroequ+decala) + 1 + endif + endif + 221 continue +c +c 2.2.2. ==> les mailles +c + else +c + do 222 , iaux = 1, nbenca + if ( medtrf(typele(iaux)).eq.tyhen1 .or. + > medtrf(typele(iaux)).eq.tyhen2 ) then + if ( cfaent(nucode,fament(nensho(iaux))).ne.0 ) then + if ( enthom(nensho(iaux)).gt.0 ) then + jaux = nensca(enthom(nensho(iaux))) + kaux = kaux + 2 + eqenti(kaux-1) = jaux - ibenti + eqenti(kaux) = iaux - ibenti + eqpntr(5*nroequ+decala) = eqpntr(5*nroequ+decala)+1 + endif + endif + endif + 222 continue +c + endif +c + nbeqev = nbeqev + eqpntr(5*nroequ+decala) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'fin de la boucle 22, eqenti = ', eqenti +#endif +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,option) + write (ulsort,90002) 'nbeqen nouveau', nbeqev +#endif +c + endif +c +c==== +c 3. impressions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. impressions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbento.ne.0 ) then +c + write(ulsort,texte(langue,6)) mess14(langue,4,option), ncefen + if ( ncefen.ne.0 ) then + write(ulsort,texte(langue,7)) nbeqev + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcehe1.F b/src/tool/AP_Conversion/pcehe1.F new file mode 100644 index 00000000..8bbadaa2 --- /dev/null +++ b/src/tool/AP_Conversion/pcehe1.F @@ -0,0 +1,214 @@ + subroutine pcehe1 ( nbfonc, ngauss, deraff, + > prfcan, prfcap, + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anhehe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c HExaedres - degre 1 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nbanhe . e . 1 . nombre de hexaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfihe . e . nbanhe . tableau filhex du maillage de l'iteration n. +c . anhehe . e . nbanhe . tableau hethex du maillage de l'iteration n. +c . anpthe . e . 2** . tableau fhpyte du maillage de l'iteration n. +c . nheeca . e . * . hexaedres en entree dans le calcul . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul . +c . nteeca . e . * . tetraedres en entree dans le calcul . +c . ntesca . e . rsteto . tetraedres en sortie dans le calcul . +c . npyeca . e . * . pyramides en entree dans le calcul . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEHE1' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombsr.h" +#include "nomber.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss + integer prfcan(*), prfcap(*) + integer hethex(nbheto), anchex(*) + integer filhex(nbheto), fhpyte(2,nbheco) + integer nbanhe, anfihe(nbanhe), anhehe(nbanhe), anpthe(2,*) + integer nheeca(reheto), nhesca(rsheto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) +c + double precision vafoen(*) + double precision vafott(*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c hehn = Hexaedre courant en numerotation Homard a l'it. N +c hehnp1 = Hexaedre courant en numerotation Homard a l'it. N+1 +c + integer hehn, hehnp1 +c +c etan = ETAt de l'hexaedre a l'iteration N +c etanp1 = ETAt de l'hexaedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 2. on boucle sur tous les hexaedres du maillage HOMARD n+1 +c on trie en fonction de l'etat de l'hexaedre dans le maillage n +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , hehnp1 = 1 , nbheto +c +c 2.1. ==> caracteristiques de l'hexaedre : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + hehn = anchex(hehnp1) + else + hehn = hehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etat = 0 : le hexaedre est actif. +c etat = 5 : l'hexaedre n'existe pas. +c etat = 8 : l'hexaedre est coupe en 8. +c etat = 9 : l'hexaedre est coupe en 8 et un de ses fils est coupe. +c etat >= 11 : l'hexaedre est coupe en conformite. +c + etanp1 = mod(hethex(hehnp1),1000) + etan = (hethex(hehnp1)-etanp1) / 1000 +c +cgn write (ulsort,1792) 'Hexaedre', hehn, etan, hehnp1, etanp1 +c +c======================================================================= +c 2.1. ==> etan = 0 : le hexaedre etait actif +c======================================================================= +c + codret = 20 + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcepe1.F b/src/tool/AP_Conversion/pcepe1.F new file mode 100644 index 00000000..4e55c73d --- /dev/null +++ b/src/tool/AP_Conversion/pcepe1.F @@ -0,0 +1,224 @@ + subroutine pcepe1 ( nbfonc, ngauss, deraff, + > prfcan, prfcap, + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anhehe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c PEntaedres - degre 1 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hethex . e . nbheto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . nbanhe . e . 1 . nombre de pentaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfihe . e . nbanhe . tableau filhex du maillage de l'iteration n. +c . anhehe . e . nbanhe . tableau hethex du maillage de l'iteration n. +c . anpthe . e . 2** . tableau fhpyte du maillage de l'iteration n. +c . nheeca . e . * . pentaedres en entree dans le calcul . +c . nhesca . e . rsheto . numero des pentaedres dans le calcul . +c . nteeca . e . * . tetraedres en entree dans le calcul . +c . ntesca . e . rsteto . tetraedres en sortie dans le calcul . +c . npyeca . e . * . pyramides en entree dans le calcul . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEPE1' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombsr.h" +#include "nomber.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss + integer prfcan(*), prfcap(*) + integer hethex(nbheto), anchex(*) + integer filhex(nbheto), fhpyte(2,nbheco) + integer nbanhe, anfihe(nbanhe), anhehe(nbanhe), anpthe(2,*) + integer nheeca(reheto), nhesca(rsheto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) +c + double precision vafoen(*) + double precision vafott(*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c pehn = Pentaedre courant en numerotation Homard a l'it. N +c pehnp1 = Pentaedre courant en numerotation Homard a l'it. N+1 +c + integer pehn, pehnp1 +c +c etan = ETAt du pentaedre a l'iteration N +c etanp1 = ETAt du pentaedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 2. on boucle sur tous les pentaedres du maillage HOMARD n+1 +c on trie en fonction de l'etat de l'pentaedre dans le maillage n +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , pehnp1 = 1 , nbheto +c +c 2.1. ==> caracteristiques de l'pentaedre : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + pehn = anchex(pehnp1) + else + pehn = pehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etat = 0 : le pentaedre est actif. +c etat = 1, ..., 24 : l'pentaedre est coupe en 2 pyramides et +c 12 tetraedres ; il y a eu deraffinement. +c etat = 31, ..., 35 : l'pentaedre est coupe en 2 pyramides et +c 12 tetraedres ; il y a eu deraffinement. +c etat = 41, ..., 46 : l'pentaedre est coupe en 5 pyramides et +c 4 tetraedres selon la face 1, ..., 6 ; il y +c a eu deraffinement. +c etat = 61, ..., 72 : l'pentaedre est coupe en 4 pyramides selon +c l'arete 1, .., 12 ; il y a eu deraffinement. +c etat = 55 : l'pentaedre n'existait pas ; il a ete produit par +c un decoupage. +c etat = 80 : l'pentaedre est coupe en 8. +c etat = 81, ..., 88 : l'pentaedre est coupe en 18 tetraedres ; il +c y a eu deraffinement. +c + etanp1 = mod(hethex(pehnp1),1000) + etan = (hethex(pehnp1)-etanp1) / 1000 +c +cgn write (ulsort,1792) 'Hexaedre', pehn, etan, pehnp1, etanp1 +c +c======================================================================= +c 2.1. ==> etan = 0 : le pentaedre etait actif +c======================================================================= + codret = 20 +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcequ1.F b/src/tool/AP_Conversion/pcequ1.F new file mode 100644 index 00000000..2834aa4b --- /dev/null +++ b/src/tool/AP_Conversion/pcequ1.F @@ -0,0 +1,632 @@ + subroutine pcequ1 ( nbfonc, nnomai, deraff, + > prfcan, prfcap, + > hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c QUadrangles - degre 1 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . nnomai . e . 1 . nombre de noeuds par maille . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . anhequ . e . nbanqu . tableau hetqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . .nnomai**. . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . .nnomai**. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEQU1' ) +c +#include "nblang.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer nnomai + integer prfcan(*), prfcap(*) + integer hetqua(nbquto), ancqua(*) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu), anhequ(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,nnomai,*) + double precision vafott(nbfonc,nnomai,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c quhnp1 = QUadrangle courant en numerotation Homard a l'it. N+1 +c + integer qucn, qucnp1, quhn, quhnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c etan = ETAt du quadrangle a l'iteration N +c etanp1 = ETAt du quadrangle a l'iteration N+1 +c + integer etan, etanp1 +c + integer nrofon, nugaus +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, nnomai, nbquto = ',nbfonc, nnomai, nbquto +#endif +c + texte(1,4) = + >'(/,''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = + >'(/,''Quadrangle decoupe en triangles : on ne sait pas faire.'')' +c + texte(2,4) = + >'(/,''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' + texte(2,6) = + >'(/,''Quadrangle cut into triangles : not available.'')' +c + codret = 0 +c +c==== +c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du quadrangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un quadrangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , quhnp1 = 1 , nbquto +c +c 2.1. ==> caracteristiques du quadrangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + quhn = ancqua(quhnp1) + else + quhn = quhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le quadrangle etait actif +c etan = 4 : le quadrangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 55 : le quadrangle n'existait pas ; il a ete produit +c par un decoupage. +c etan = 31, 32, 33, 34 : le quadrangle etait coupe en 3 +c quadrangles ; il y a eu deraffinement. +c + etanp1 = mod(hetqua(quhnp1),100) + etan = (hetqua(quhnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c +c 2.1.3. ==> les numeros locaux des noeuds +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le quadrangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +c on repere son ancien numero dans le calcul +c + qucn = nqueca(quhn) +c + if ( prfcan(qucn).gt.0 ) then +c +cgn print 1789,(vafoen(nrofon,nugaus,qucn), nugaus = 1 , nnomai) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c doc.0.0. ===> etanp1 = 0 : le quadrangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du quadrangle. +c +c ................. ................. +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc +cgn write(ulsort,7778) +cgn > (vafoen(nrofon,nugaus,prfcan(qucn)),nugaus=1,nnomai) + do 2211 , nugaus = 1 , nnomai + vafott(nrofon,nugaus,qucnp1) = + > vafoen(nrofon,nugaus,prfcan(qucn)) + 2211 continue + 221 continue +cgn write(21,7777) qucnp1 +cgn write(ulsort,7777) qucn,-1,qucnp1 +cgn 7777 format(I3) +cgn 7778 format(8g14.7) +c +c doc.0.1/2/3 ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle etait actif +c et est decoupe en 3 triangles. +c les trois fils prennent la valeur de la fonction sur +c le pere +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . ===> . . . . +c . . . . . . +c . . . . . . +c . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + write (ulsort,texte(langue,6)) + codret = codret + 1 +c +c doc.0.4/6/7/8. ==> etanp1 = 4 : le quadrangle etait actif et +c est decoupe en 4. +c les quaque fils prennent la valeur de la fonction +c sur le pere +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.eq.4 ) then +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 223 , nrofon = 1 , nbfonc + do 2231 , nugaus = 1 , nnomai + daux = vafoen(nrofon,nugaus,prfcan(qucn)) + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 2231 continue + 223 continue +c +c doc.0.erreur. ==> aucun autre etat sur le quadrangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 31, 32, 33 ou 34 : le quadrangle etait coupe +c en 3 triangles +c======================================================================= +c + elseif ( etan.ge.31 .and. etan.le.34 ) then +c +c on repere les numeros dans le calcul pour ses trois fils a +c l'iteration n +c + f1hn = -anfiqu(quhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 ) then +c + write (ulsort,texte(langue,6)) + codret = codret + 1 +c +c doc.1/2/3.0. ===> etanp1 = 0 : le quadrangle est actif. il est +c reactive. +c on lui attribue la valeur moyenne sur les trois +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . . . ===> . . +c . . . . . . +c . . . . . . +c .. .. . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le quadrangle est decoupe en +c trois selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c quadrangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdqu), le premier fils +c est toujours le meme, le 2eme et le 3eme egalement. +c on prendra alors la valeur sur le fils de rang identique +c a l'iteration n. +c ................. ................. +c . . . . . . . . +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. .. .. +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 31, 32, 33 ou 34 et different de +c etan : le quadrangle est encore decoupe +c en trois, mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . .. .. +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4 : le quadrangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur l'un des fils. +c +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 ) then +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le quadrangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.4. ==> le quadrangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 ) then +c +c on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) + f3cn = nqueca(f1hn+2) + f4cn = nqueca(f1hn+3) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c doc.4.0. ===> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 241 , nrofon = 1 , nbfonc + do 2411 , nugaus = 1 , nnomai + vafott(nrofon,nugaus,qucnp1) = + > unsqu * ( vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) ) + 2411 continue + 241 continue +c +c doc.4.1/2/3. ===> etanp1 = 31, 32, 33 ou 34 : le quadrangle est +c decoupe en trois. +c on attribue la valeur moyenne sur les quatre anciens +c fils a chacune des trois nouveaux fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + write (ulsort,texte(langue,6)) + codret = codret + 1 +c + endif +c + endif +c +c======================================================================= +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +cgn do 922 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +cgn iaux = 0 +cgn do 9222 , quhnp1 = 1 , nbtrto +cgn if ( mod(hettri(quhnp1),100).eq.0 ) then +cgn iaux = iaux+1 +cgn print 1788,quhnp1, +cgn > (vafott(nrofon,nugaus,iaux), nugaus = 1 , nnomai) +cgn endif +cgn 9222 continue +cgn 922 continue + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcequ2.F b/src/tool/AP_Conversion/pcequ2.F new file mode 100644 index 00000000..23170428 --- /dev/null +++ b/src/tool/AP_Conversion/pcequ2.F @@ -0,0 +1,699 @@ + subroutine pcequ2 ( nbfonc, ngauss, deraff, + > prfcan, prfcap, + > hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > nbantr, anfatr, + > ntreca, ntrsca, + > vafoen, vafott, + > vatren, vatrtt, + > prftrn, prftrp, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c QUadrangles - degre 2 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . anhequ . e . nbanqu . tableau hetqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . nbantr . e . 1 . nombre de triangles issus du decoupage par . +c . . . . conformite sur le maillage avant adaptation. +c . anfatr . e . nbantr . tableau famtri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatren . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les triangles de conformite . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEQU2' ) +c +#include "nblang.h" +c + integer nbnoqu + parameter ( nbnoqu = 8 ) + integer nbnotr + parameter ( nbnotr = 6 ) +c +#include "fracta.h" +#include "fractb.h" +#include "fractc.h" +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss + integer prfcan(*), prfcap(*) + integer hetqua(nbquto), ancqua(*) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu), anhequ(nbanqu) + integer nbantr, anfatr(nbantr) + integer nqueca(requto), nqusca(rsquto) + integer ntreca(retrto), ntrsca(rstrto) + integer prftrn(*), prftrp(*) +c + double precision vafoen(nbfonc,nbnoqu,*) + double precision vafott(nbfonc,nbnoqu,*) + double precision vatren(nbfonc,nbnotr,*) + double precision vatrtt(nbfonc,nbnotr,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c quhnp1 = QUadrangle courant en numerotation Homard a l'it. N+1 +c + integer qucn, qucnp1, quhn, quhnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, f1fhp + integer f1cp, f2cp, f3cp, f4cp + integer f1fcp, f2fcp, f3fcp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c + integer prqucn, prf1cn, prf2cn, prf3cn, prf4cn +c +c etan = ETAt du quadrangle a l'iteration N +c etanp1 = ETAt du quadrangle a l'iteration N+1 +c + integer etan, etanp1 +c +c qi = numero local du i-eme noeud du quadrangle, en fonction +c de l'orientation + integer q1, q2, q3, q4, q5, q6, q7, q8 + integer q1t, q2t, q3t, q4t, q5t, q6t + integer q1tp,q2tp, q3tp, q4tp, q5tp, q6tp + + integer g1, g2, g3, d1, d2, d3 + integer pf, prfg2n, prfg1n, prfg3n, prfd2n, prfd1n, prfd3n +c + integer nrofon +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, ngauss, nbquto = ',nbfonc, ngauss, nbquto + write(ulsort,*) 'nbnotr, nbnoqu = ',nbnotr, nbnoqu +#endif +c + texte(1,4) = + >'(/,''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + codret = 0 +cgn print 1789, (nqusca(iaux),iaux=1,rsquto) +cgn 1789 format(10i4) +c +c==== +c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du quadrcangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un quadrangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , quhnp1 = 1 , nbquto +c + if ( codret.eq.0 ) then +c +c 2.1. ==> caracteristiques du quadrangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + quhn = ancqua(quhnp1) + else + quhn = quhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le quadrangle etait actif +c etan = 4 : le quadrangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 55 : le quadrangle n'existait pas ; il a ete produit +c par un decoupage. +c etan = 31, 32, 33, 34 : le quadrangle etait coupe en 3 +c triangles ; il y a eu deraffinement. +c + etanp1 = mod(hetqua(quhnp1),100) + etan = (hetqua(quhnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c +c 2.1.3. ==> les numeros locaux des noeuds +c + q1 = 1 + q2 = 2 + q3 = 3 + q4 = 4 + q5 = 5 + q6 = 6 + q7 = 7 + q8 = 8 +cgn print *,'qi =',q1,q2,q3,q4,q5,q6,q7,q8 +c + +c======================================================================= +c doc.0.p. ==> etan = 0 : le quadrangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +c on repere son ancien numero dans le calcul +c + qucn = nqueca(quhn) + prqucn = prfcan(qucn) +c + if ( prqucn.gt.0 ) then +c +cgn print 1789,(vafoen(nrofon,iaux,qucn), iaux = 1 , nbnoqu) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c doc.0.0. ===> etanp1 = 0 : le quadrangle etait actif et l'est encore ; +c il est inchange +c +c ................. ................. +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc +cgn write(ulsort,7778) +cgn > (vafoen(nrofon,iaux,prfcan(qucn)),iaux = 1 , nbnoqu) + do 2211 , iaux = 1 , nbnoqu + vafott(nrofon,iaux,qucnp1) = + > vafoen(nrofon,iaux,prqucn) + 2211 continue + 221 continue +cgn write(21,7777) qucnp1 +cgn write(ulsort,7777) qucn,-1,qucnp1 +cgn 7777 format(I3) +cgn 7778 format(8g14.7) +c +c doc.0.1/2/3 ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle etait actif +c et est decoupe en 3 triangles. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . ===> . . . . +c . . . . . . +c . . . . . . +c . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c +#include "pcsqu2_1.h" +c +c doc.0.4/6/7/8. ==> etanp1 = 4 : le quadrangle etait actif et +c est decoupe en 4. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.eq.4 ) then +c +#include "pcsqu2_2.h" + +c doc.0.erreur. ==> aucun autre etat sur le quadrangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 31, 32, 33 ou 34 : le quadrangle etait coupe +c en 3 triangles +c======================================================================= +c + elseif ( etan.ge.31 .and. etan.le.34 ) then +c +cgn print *,'etan.ge.31 .and. etan.le.34' +c on repere les numeros dans le calcul pour ses trois fils a +c l'iteration n +c + f1hn = -anfiqu(quhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) + prf1cn = prftrn(f1cn) + prf2cn = prftrn(f2cn) + prf3cn = prftrn(f3cn) +c + q1t = 1 + q2t = 2 + q3t = 3 + q4t = 4 + q5t = 5 + q6t = 6 +c + if ( prf1cn.gt.0 .and. prf2cn.gt.0 .and. + > prf3cn.gt.0 ) then +c +c doc.1/2/3.0. ===> etanp1 = 0 : le quadrangle est actif. il est +c reactive. +c on lui attribue la valeur moyenne sur les trois +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . . . ===> . . +c . . . . . . +c . . . . . . +c .. .. . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c +cgn print *,'.. etanp1.eq.0' +c +#include "pcsqu2_3.h" +c +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le quadrangle est decoupe en +c trois selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c quadrangles autour n'ont pas change entre les deux +c iterations. +c Comme la procedure de numerotation est la meme (voir +c cmcdqu), le premier fils est toujours le meme, le 2eme et +c le 3eme egalement. +c on prendra alors les valeurs sur les fils de rang +c identique a l'iteration n. +c ................. ................. +c . . . . . . . . +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. .. .. +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +cgn print *,'.. etanp1.eq.etan' +c + f1hp = -filqua(quhnp1) +c + q1tp = 1 + q2tp = 2 + q3tp = 3 + q4tp = 4 + q5tp = 5 + q6tp = 6 +c + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + do 232 , nrofon = 1 , nbfonc +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q1t,prf1cn) + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q2t,prf1cn) + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf1cn) + vatrtt(nrofon,q4tp,f1cp) = vatren(nrofon,q4t,prf1cn) + vatrtt(nrofon,q5tp,f1cp) = vatren(nrofon,q5t,prf1cn) + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf2cn) + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q2t,prf2cn) + vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q3t,prf2cn) + vatrtt(nrofon,q4tp,f2cp) = vatren(nrofon,q4t,prf2cn) + vatrtt(nrofon,q5tp,f2cp) = vatren(nrofon,q5t,prf2cn) + vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q1t,prf3cn) + vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q2t,prf3cn) + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q3t,prf3cn) + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q4t,prf3cn) + vatrtt(nrofon,q5tp,f3cp) = vatren(nrofon,q5t,prf3cn) + vatrtt(nrofon,q6tp,f3cp) = vatren(nrofon,q6t,prf3cn) +c + 232 continue +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 31, 32, 33 ou 34 et different de +c etan : le quadrangle est encore decoupe +c en trois, mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +cc remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . .. .. +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c +cgn print *,'.. etanp1.ge.31 .and. etanp1.le.34' +#include "pcsqu2_4.h" +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4 : le quadrangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur l'un des fils. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 ) then +c +cgn print *,'.. etanp1.eq.4' +c +#include "pcsqu2_5.h" +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le quadrangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.4. ==> le quadrangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 ) then +c +c on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) + f3cn = nqueca(f1hn+2) + f4cn = nqueca(f1hn+3) + prf1cn = prfcan(f1cn) + prf2cn = prfcan(f2cn) + prf3cn = prfcan(f3cn) + prf4cn = prfcan(f4cn) +c + if ( prf1cn.gt.0 .and. prf2cn.gt.0 .and. + > prf3cn.gt.0 .and. prf4cn.gt.0 ) then +c +c doc.4.0. ===> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 241 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,qucnp1) = vafoen(nrofon,q1,prf1cn) + vafott(nrofon,q2,qucnp1) = vafoen(nrofon,q1,prf2cn) + vafott(nrofon,q3,qucnp1) = vafoen(nrofon,q1,prf3cn) + vafott(nrofon,q4,qucnp1) = vafoen(nrofon,q1,prf4cn) + vafott(nrofon,q5,qucnp1) = + > unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) + vafott(nrofon,q6,qucnp1) = + > unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) + vafott(nrofon,q7,qucnp1) = + > unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) + vafott(nrofon,q8,qucnp1) = + > unsde*(vafoen(nrofon,q2,prf4cn)+ + > vafoen(nrofon,q4,prf1cn)) +c + 241 continue +c +c doc.4.1/2/3. ===> etanp1 = 31, 32, 33 ou 34 : le quadrangle est +c decoupe en trois. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn print *,'etanp1.ge.31 .and. etanp1.le.34' +c +#include "pcsqu2_6.h" +c + elseif ( etanp1.eq.4 .or. etanp1.eq.99 ) then +c + codret = codret +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c + endif +c +c======================================================================= +c doc.4. ==> le quadrangle etait coupe en 4 et au moins un de ses +c fils etait lui-meme decoupe : +c======================================================================= +c + elseif ( etan.eq.99 ) then +c +#include "pcsqu2_7.h" +c + endif +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +cgn do 922 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +cgn iaux = 0 +cgn do 9222 , quhnp1 = 1 , nbtrto +cgn if ( mod(hettri(quhnp1),100).eq.0 ) then +cgn iaux = iaux+1 +cgn print 1788,quhnp1, +cgn > (vafott(nrofon,nugaus,iaux), nugaus = 1 , ngauss) +cgn endif +cgn 9222 continue +cgn 922 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/AP_Conversion/pcequ3.F b/src/tool/AP_Conversion/pcequ3.F new file mode 100644 index 00000000..7fb07231 --- /dev/null +++ b/src/tool/AP_Conversion/pcequ3.F @@ -0,0 +1,199 @@ + subroutine pcequ3 ( nbfonc, nnmold, nnmnew, + > prfcan, prfcap, + > nqueca, nqusca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c QUadrangles - cas 3 - degre 2 vers degre 1 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . nnmold . e . 1 . ancien nombre de noeuds par maille . +c . nnmnew . e . 1 . nouveau nombre de noeuds par maille . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . .nnmold**. . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . .nnmnew**. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEQU3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer nnmold, nnmnew + integer prfcan(*), prfcap(*) + integer nqueca(requto), nqusca(rsquto) +c + double precision vafoen(nbfonc,nnmold,*) + double precision vafott(nbfonc,nnmnew,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c + integer qucn, qucnp1, quhn +c + integer nrofon, nunoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbfonc, nbquto', nbfonc, nbquto + write(ulsort,90002) 'nnmold, nnmnew', nnmold, nnmnew +#endif +c + codret = 0 +c +c==== +c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , quhn = 1 , nbquto +c +c 2.1. ==> ancien numero du quadrangle dans le calcul +c + qucn = nqueca(quhn) +c +cgn write (ulsort,90002) 'Quadrangle', quhn, prfcan(qucn) +c + if ( prfcan(qucn).gt.0 ) then +c + qucnp1 = nqusca(quhn) + prfcap(qucnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc +c +cgn write (ulsort,90002) 'fonction numero', nrofon +cgn write (ulsort,90004) ' ', +cgn > (vafoen(nrofon,nunoel,prfcan(qucn)),nunoel=1,nnmold) + do 211 , nunoel = 1 , nnmnew + vafott(nrofon,nunoel,qucnp1) = + > vafoen(nrofon,nunoel,prfcan(qucn)) + 211 continue +c + 21 continue +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + do 922 , iaux = 1 , nbquto, -1 + write (ulsort,90002) 'Quadrangle', iaux + do 9222 , nrofon = 1 , nbfonc + write (ulsort,90002) 'fonction numero', nrofon + write(ulsort,90004) ' ', + > (vafott(nrofon,nunoel,iaux), nunoel = 1 , nnmnew) + 9222 continue + 922 continue +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcequ4.F b/src/tool/AP_Conversion/pcequ4.F new file mode 100644 index 00000000..27416efc --- /dev/null +++ b/src/tool/AP_Conversion/pcequ4.F @@ -0,0 +1,213 @@ + subroutine pcequ4 ( nbfonc, nnmold, nnmnew, + > prfcan, prfcap, + > nqueca, nqusca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c QUadrangles - cas 4 - degre 1 vers degre 2 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . nnmold . e . 1 . ancien nombre de noeuds par maille . +c . nnmnew . e . 1 . nouveau nombre de noeuds par maille . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . .nnmold**. . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . .nnmnew**. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCEQU4' ) +c +#include "nblang.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer nnmold, nnmnew + integer prfcan(*), prfcap(*) + integer nqueca(requto), nqusca(rsquto) +c + double precision vafoen(nbfonc,nnmold,*) + double precision vafott(nbfonc,nnmnew,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c + integer qucn, qucnp1, quhn +c + integer nrofon, nunoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbfonc, nbquto', nbfonc, nbquto + write(ulsort,90002) 'nnmold, nnmnew', nnmold, nnmnew +#endif +c + codret = 0 +c +c==== +c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , quhn = 1 , nbquto +c +c 2.1. ==> ancien numero du quadrangle dans le calcul +c + qucn = nqueca(quhn) +c +cgn write (ulsort,90002) 'Quadrangle', quhn, prfcan(qucn) +c + if ( prfcan(qucn).gt.0 ) then +c + qucnp1 = nqusca(quhn) + prfcap(qucnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc +c +cgn write (ulsort,90002) 'fonction numero', nrofon +cgn write (ulsort,90004) ' ', +cgn > (vafoen(nrofon,nunoel,prfcan(qucn)),nunoel=1,nnmold) +c +c recopie des valeurs sur les sommets +c + do 211 , nunoel = 1 , nnmold + vafott(nrofon,nunoel,qucnp1) = + > vafoen(nrofon,nunoel,prfcan(qucn)) + 211 continue +c +c calcul des valeurs sur les noeuds milieux +c + do 212 , iaux = 1 , 4 + nunoel = 4 + iaux + vafott(nrofon,nunoel,qucnp1) = unsde + > * ( vafoen(nrofon, iaux,prfcan(qucn)) + + > vafoen(nrofon,per1a4(1,iaux),prfcan(qucn)) ) + 212 continue +c + 21 continue +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + do 922 , iaux = 1 , nbquto, -1 + write (ulsort,90002) 'Quadrangle', iaux + do 9222 , nrofon = 1 , nbfonc + write (ulsort,90002) 'fonction numero', nrofon + write(ulsort,90004) ' ', + > (vafott(nrofon,nunoel,iaux), nunoel = 1 , nnmnew) + 9222 continue + 922 continue +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcete1.F b/src/tool/AP_Conversion/pcete1.F new file mode 100644 index 00000000..d877f91e --- /dev/null +++ b/src/tool/AP_Conversion/pcete1.F @@ -0,0 +1,289 @@ + subroutine pcete1 ( nbfonc, ngauss, deraff, + > prfcan, prfcap, + > hettet, anctet, + > filtet, + > nbante, anfite, anhete, + > nteeca, ntesca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c TEtraedres - degre 1 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n. +c . anhete . e . nbante . tableau hettet du maillage de l'iteration n. +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCETE1' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss + integer prfcan(*), prfcap(*) + integer hettet(nbteto), anctet(*) + integer filtet(nbteto) + integer nbante, anfite(nbante), anhete(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(*) + double precision vafott(*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c tehn = TEtraedre courant en numerotation Homard a l'it. N +c tehnp1 = TEtraedre courant en numerotation Homard a l'it. N+1 +c + integer tehn, tehnp1 +c +c etan = ETAt du tetraedre a l'iteration N +c etanp1 = ETAt du tetraedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 2. on boucle sur tous les tetraedres du maillage HOMARD n+1 +c on trie en fonction de l'etat du tetraedre dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un tetraedre dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , tehnp1 = 1 , nbteto +c +c 2.1. ==> caracteristiques du tetraedre : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + tehn = anctet(tehnp1) + else + tehn = tehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le tetraedre etait actif. +c etan = 21, ..., 26 : le tetraedre etait coupe en 2 selon +c l'arete 1, ..., 6 ; il y a eu deraffinement. +c etan = 41, ..., 44 : le tetraedre etait coupe en 4 selon la +c face 1, ..., 4 ; il y a eu deraffinement. +c etan = 45, 46, 47 : le tetraedre etait coupe en 4 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c etan = 55 : le tetraedre n'existait pas ; il a ete produit par +c un decoupage. +c etan = 85, 86, 87 : le tetraedre etait coupe en 8 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c + etanp1 = mod(hettet(tehnp1),100) + etan = (hettet(tehnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Tetraedre', tehn, etan, tehnp1, etanp1 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le tetraedre etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT0', nompro +#endif +c + call pcspt0 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.21-26.p. ==> etan = 21, ..., 26 : le tetraedre etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.21 .and. etan.le.26 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT2', nompro +#endif +c + call pcspt2 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.41-44.p. ==> etan = 41, ..., 44 : le tetraedre etait coupe en 4 +c selon la face 1, 2, 3, 4 +c doc.45-47.p. ==> etan = 45, 46, 47 : le tetraedre etait coupe en 4 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.41 .and. etan.le.47 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT4', nompro +#endif +c + call pcspt4 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.85-87.p. ==> etan = 85, 86, 87 : le tetraedre etait coupe en 8 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.85 .and. etan.le.87 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT8', nompro +#endif +c + call pcspt8 ( etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcetr1.F b/src/tool/AP_Conversion/pcetr1.F new file mode 100644 index 00000000..7880e21f --- /dev/null +++ b/src/tool/AP_Conversion/pcetr1.F @@ -0,0 +1,760 @@ + subroutine pcetr1 ( nbfonc, deraff, + > prfcan, prfcap, + > hettri, anctri, filtri, + > nbantr, anfitr, anhetr, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c TRiangles - degre 1 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n +c . anhetr . e . nbantr . tableau hettri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbnoel . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCETR1' ) +c +#include "nblang.h" +#include "fractc.h" +#include "fracta.h" +c + integer nbnoel + parameter ( nbnoel = 3 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer prfcan(*), prfcap(*) + integer hettri(nbtrto), anctri(*) + integer filtri(nbtrto) + integer nbantr, anfitr(nbantr), anhetr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,nbnoel,*) + double precision vafott(nbfonc,nbnoel,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c trcn = TRiangle courant en numerotation Calcul a l'iteration N +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c trhn = TRiangle courant en numerotation Homard a l'iteration N +c trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1 +c + integer trcn, trcnp1, trhn, trhnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du triangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du triangle en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du triangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du triangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du triangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du triangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du triangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c prxxxx = numero du triangle xxxx dans le profil de la solution +c + integer prtrcn, prf1cn, prf2cn, prf3cn, prf4cn +c +c etan = ETAt du triangle a l'iteration N +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etan, etanp1 +c +c qi = numero local du i-eme noeud, en fonction de l'orientation +c + integer q1 +c + integer nrofon + integer iaux +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, nbnoel, nbtrto = ',nbfonc, nbnoel, nbtrto +#endif +c + texte(1,4) = + > '(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i8)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + > '(/,''Current triangle : # at iteration '',a3,'' : '',i8)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +cgn write (6,*)nbfonc,nbnoel +cgn do 122 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +cgnc remarque : il faut ajuster a la main la borne maximale +cgn do 1222 , trcn = 1 , 2 +cgn print 1788,trcn, +cgn > (vafoen(nrofon,iaux,trcn), iaux = 1 , nbnoel) +cgn 1222 continue +cgn 122 continue +cgn 1788 format(i2,13g12.5) +c + codret = 0 +c +c==== +c 2. on boucle sur tous les triangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du triangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un triangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , trhnp1 = 1 , nbtrto +c +c 2.1. ==> caracteristiques du triangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + trhn = anctri(trhnp1) + else + trhn = trhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le triangle etait actif +c etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete +c 1, 2, 3 ; il y a eu deraffinement. +c etan = 4 : le triangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 5 : le triangle n'existait pas ; il a ete produit par +c un decoupage. +c etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule +c de l'arete etan-5 pour le suivi de +c frontiere ; il y a eu deraffinement. +c + etanp1 = mod(hettri(trhnp1),10) + etan = (hettri(trhnp1)-etanp1) / 10 +cgn write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1 +c +c 2.1.3. ==> les numeros locaux des noeuds +c + q1 = 1 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le triangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +c on repere son ancien numero dans le calcul +c + trcn = ntreca(trhn) + prtrcn = prfcan(trcn) +c + if ( prtrcn.gt.0 ) then +c +cgn nrofon = 1 +cgn print 1789,(vafoen(nrofon,iaux,prtrcn),iaux=1,nbnoel) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c doc.0.0. ===> etanp1 = 0 : le triangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on recopie les valeurs +c precedentes, noeud par noeud +c . . +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc +cgn write(ulsort,7778) (vafoen(nrofon,iaux,trcn),iaux=1,nbnoel) + do 2211 , iaux = 1 , nbnoel + vafott(nrofon,iaux,trcnp1) = vafoen(nrofon,iaux,prtrcn) + 2211 continue + 221 continue +cgn write(21,7777) trcnp1 +cgn write(ulsort,7777) trcn,-1,trcnp1 +cgn7777 format(I3) +cgn7778 format(8g14.7) +c +c doc.0.1/2/3 ==> etanp1 = 1, 2 ou 3 : le triangle etait actif et est +c maintenant decoupe en 2. +c . . +c . . ... +c . . . . . +c . . . . . +c . . ===> . . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c Pour un decoupage selon l'arete numero 1 : +c + elseif ( etanp1.eq.1 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2221 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + 2221 continue +c +c Pour un decoupage selon l'arete numero 2 : +c + elseif ( etanp1.eq.2 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2222 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + 2222 continue +c +c Pour un decoupage selon l'arete numero 3 : +c + elseif ( etanp1.eq.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2223 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + 2223 continue +c +c doc.0.4/6/7/8. ==> etanp1 = 4, 6, 7 ou 8 : le triangle etait actif et +c est maintenant decoupe en 4. +c . . +c . . . . +c . . . . +c . . . . +c . . ===> ......... +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +c + do 223 , nrofon = 1 , nbfonc +c +c Pour le fils aine (centre) +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prtrcn) +c + 223 continue +c +c doc.0.erreur. ==> aucun autre etat sur le triangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 1, 2 ou 3 : le triangle etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.1 .and. etan.le.3 ) then +c +c on repere les numeros dans le calcul pour ses deux fils a +c l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + prf1cn = prfcan(f1cn) + prf2cn = prfcan(f2cn) +c + if ( prf1cn.gt.0 .and. prf2cn.gt.0 ) then +c +c doc.1/2/3.0. ===> etanp1 = 0 : le triangle est actif. il est reactive. +c on lui attribue la valeur moyenne sur les deux +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 231 , nrofon = 1 , nbfonc + do 2311 , iaux = 1 , nbnoel + vafott(nrofon,iaux,trcnp1) = + > unsde * ( vafoen(nrofon,iaux,prf1cn) + > + vafoen(nrofon,iaux,prf2cn) ) + 2311 continue + 231 continue +c +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le triangle est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c triangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdtr), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c . . +c ... ... +c . . . . . . +c . . . . . . +c . . . ===> . . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 232 , nrofon = 1 , nbfonc + do 2321 , iaux = 1 , nbnoel + vafott(nrofon,iaux,f1cp) = + > vafoen(nrofon,iaux,prf1cn) + vafott(nrofon,iaux,f2cp) = + > vafoen(nrofon,iaux,prf2cn) + 2321 continue + 232 continue +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 1, 2 ou 3 et different de etan : +c le triangle est encore decoupe en deux +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 233 , nrofon = 1 , nbfonc + do 2331 , iaux = 1 , nbnoel + daux = unsde * ( vafoen(nrofon,iaux,prf1cn) + > + vafoen(nrofon,iaux,prf2cn) ) + vafott(nrofon,iaux,f1cp) = daux + vafott(nrofon,iaux,f2cp) = daux + 2331 continue + 233 continue +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4, 6, 7 ou 8 : le triangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du triangle. qui plus est, par suite +c de la regle des ecarts de niveau, on peut avoir induit +c un decoupage de conformite sur l'un des fils. +c remarque : c'est toujours un des fils du cote qui etait +c decoupe qui subit le decoupage, et c'est toujours par +c une subdivision du dit cote. +c +c . pour le triangle central et le triangle dans le coin +c oppose a l'arete initialement decoupee, on attribue la +c valeur moyenne de la fonction sur les deux anciens fils. +c . pour les deux autres triangles, on repere dans lequel +c des deux fils ils se trouvent. si un de ces triangles est +c decoupe, c'est en 2 et par la meme arete que le triangle +c courant ; on affecte la valeur du fils du maillage n +c a ces deux fils. si un des triangles est actif, on lui +c attribue la valeur. +c +c . on pose i, j et k comme etant les numeros locaux des +c aretes du triangle courant. +c si etan vaut i, c'est que la i-eme arete du triangle +c etait coupee. les numerotations des 2 fils sont obtenues +c par la fonction nutrde : a = nutrde(i,j), b = nutrde(i,k) +c les numerotations des 4 fils sont +0, +i, +j et +k. +c on voit donc que : +c . les fils +O et +i doivent recevoir la moyenne +c . le fils +k, ou ses fils, doit recevoir la valeur +c de +nutrde(i,j) +c . le fils +j, ou ses fils, doit recevoir la valeur +c de +nutrde(i,k) +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . . . +c . +a . +b . . .+0 . . +c . . . . +k . . +j . +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . ... +c . +a . +b . . .+0 . . . +c . . . . +k . .+j.+j. +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . ... ... +c . +a . +b . . . .+0 . . . +c . . . .+k.+k. .+j.+j. +c ................. ................. +c i i +c +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +c +c ==> les deux triangles central et opposee +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le triangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.4. ==> le triangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 .or. + > etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then +c +c on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) + f4cn = ntreca(f1hn+3) + prf1cn = prfcan(f1cn) + prf2cn = prfcan(f2cn) + prf3cn = prfcan(f3cn) + prf4cn = prfcan(f4cn) +c + if ( prf1cn.gt.0 .and. prf2cn.gt.0 .and. + > prf3cn.gt.0 .and. prf4cn.gt.0 ) then +c +c doc.4.0. ===> etanp1 = 0 : le triangle est actif ; il est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c . . . . +c . . . . +c . . . . +c ......... ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 241 , nrofon = 1 , nbfonc + do 2411 , iaux = 1 , nbnoel + vafott(nrofon,iaux,trcnp1) = + > unsqu * ( vafoen(nrofon,iaux,prf1cn) + > + vafoen(nrofon,iaux,prf2cn) + > + vafoen(nrofon,iaux,prf3cn) + > + vafoen(nrofon,iaux,prf4cn) ) + 2411 continue + 241 continue +c +c doc.4.1/2/3. ===> etanp1 = 1, 2 ou 3 : le triangle est decoupe en +c deux. +c on attribue la valeur moyenne sur les quatre anciens +c fils a chacune des deux nouveaux fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 242 , nrofon = 1 , nbfonc + do 2421 , iaux = 1 , nbnoel + daux = unsqu * ( vafoen(nrofon,iaux,prf1cn) + > + vafoen(nrofon,iaux,prf2cn) + > + vafoen(nrofon,iaux,prf3cn) + > + vafoen(nrofon,iaux,prf4cn) ) + vafott(nrofon,iaux,f1cp) = daux + vafott(nrofon,iaux,f2cp) = daux + 2421 continue + 242 continue +c + endif +c + endif +c +c======================================================================= +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end +c + diff --git a/src/tool/AP_Conversion/pcetr2.F b/src/tool/AP_Conversion/pcetr2.F new file mode 100644 index 00000000..c9e47b57 --- /dev/null +++ b/src/tool/AP_Conversion/pcetr2.F @@ -0,0 +1,645 @@ + subroutine pcetr2 ( nbfonc, deraff, + > prfcan, prfcap, + > hettri, anctri, filtri, + > nbantr, anfitr, anhetr, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c TRiangles - degre 2 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n +c . anhetr . e . nbantr . tableau hettri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbnoel . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCETR2' ) +c +#include "nblang.h" +c + integer nbnoel + parameter ( nbnoel = 6 ) +c +#include "fracta.h" +#include "fractb.h" +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer prfcan(*), prfcap(*) + integer hettri(nbtrto), anctri(*) + integer filtri(nbtrto) + integer nbantr, anfitr(nbantr), anhetr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,nbnoel,*) + double precision vafott(nbfonc,nbnoel,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c trcn = TRiangle courant en numerotation Calcul a l'iteration N +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c trhn = TRiangle courant en numerotation Homard a l'iteration N +c trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1 +c + integer trcn, trcnp1, trhn, trhnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du triangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du triangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du triangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du triangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du triangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du triangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du triangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c prxxxx = numero du triangle xxxx dans le profil de la solution +c + integer prtrcn, prf1cn, prf2cn, prf3cn, prf4cn +c +c etan = ETAt du triangle a l'iteration N +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etan, etanp1 +c +c qi = numero local du i-eme noeud +c + integer q1, q2, q3, q4, q5, q6 +c + integer g1, g2, d1, d2, pf, prfg2n, prfg1n, prfd2n, prfd1n +c + integer nrofon + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, nbnoel, nbtrto = ',nbfonc, nbnoel, nbtrto +#endif +c + texte(1,4) = + > '(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i8)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = '(''Cet etat est impossible !'')' +c + texte(2,4) = + > '(/,''Current triangle : # at iteration '',a3,'' : '',i8)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' + texte(2,6) = '(''This state cannot be found !'')' +c +cgn do 122 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +c remarque : il faut ajuster a la main la borne maximale +cgn do 1222 , trcn = 1 , 12 +cgn print 1788,trcn, +cgn > (vafoen(nrofon,iaux,trcn), iaux = 1 , nbnoel) +cgn 1222 continue +cgn 122 continue +cgn 1788 format(i2,10g13.5) +c + codret = 0 +c +c==== +c 2. on boucle sur tous les triangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du triangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un triangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , trhnp1 = 1 , nbtrto +c + if ( codret.eq.0 ) then +c +c 2.1. ==> caracteristiques du triangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + trhn = anctri(trhnp1) + else + trhn = trhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le triangle etait actif +c etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete +c 1, 2, 3 ; il y a eu deraffinement. +c etan = 4 : le triangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 5 : le triangle n'existait pas ; il a ete produit par +c un decoupage. +c etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule +c de l'arete etan-5 pour le suivi de +c frontiere ; il y a eu deraffinement. +c + etanp1 = mod(hettri(trhnp1),10) + etan = (hettri(trhnp1)-etanp1) / 10 +cgn write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1 +c +c 2.1.3. ==> les numeros locaux des noeuds +c + q1 = 1 + q2 = 2 + q3 = 3 + q4 = 4 + q5 = 5 + q6 = 6 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le triangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +c on repere son ancien numero dans le calcul +c + trcn = ntreca(trhn) + prtrcn = prfcan(trcn) +cgn print 17891, prtrcn +cgn17891 format('prtrcn = ',i8) +c + if ( prtrcn.gt.0 ) then +c +cgn nrofon = 1 +cgn print 1789,(vafoen(nrofon,iaux,prtrcn),iaux=1,nbnoel) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c doc.0.0. ===> etanp1 = 0 : le triangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on recopie les valeurs +c precedentes, noeud par noeud +c . . +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc +cgn write(ulsort,7778) (vafoen(nrofon,iaux,trcn),iaux=1,nbnoel) + do 2211 , iaux = 1 , nbnoel + vafott(nrofon,iaux,trcnp1) = vafoen(nrofon,iaux,prtrcn) + 2211 continue + 221 continue +cgn write(21,7777) trcnp1 +cgn write(ulsort,7777) trcn,-1,trcnp1 +cgn7777 format(I3) +cgn7778 format(8g14.7) +c +c doc.0.1/2/3 ==> etanp1 = 1, 2 ou 3 : le triangle etait actif et est +c maintenant decoupe en 2. +c . . +c . . ... +c . . . . . +c . . . . . +c . . ===> . . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c +#include "pcstr2_1.h" +c +c doc.0.4/6/7/8. ==> etanp1 = 4, 6, 7 ou 8 : le triangle etait actif et +c est maintenant decoupe en 4. +c . . +c . . . . +c . . . . +c . . . . +c . . ===> ......... +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c +#include "pcstr2_2.h" +c +c doc.0.erreur. ==> aucun autre etat sur le triangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + write (ulsort,texte(langue,6)) +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 1, 2 ou 3 : le triangle etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.1 .and. etan.le.3 ) then +c +c on repere les numeros dans le calcul pour ses deux fils a +c l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + prf1cn = prfcan(f1cn) + prf2cn = prfcan(f2cn) +cgn print 17892, prf1cn, prf2cn +cgn17892 format('prf1cn = ',i8,', prf2cn = ',i8) +c + if ( prf1cn.gt.0 .and. prf2cn.gt.0 ) then +c +c doc.1/2/3.0. ===> etanp1 = 0 : le triangle est actif. il est reactive. +c on lui attribue la valeur moyenne sur les deux +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + if ( etan.eq.1 ) then +c + do 2311 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,trcnp1) = + > unsde * ( vafoen(nrofon,q1,prf1cn) + > + vafoen(nrofon,q1,prf2cn) ) + vafott(nrofon,q2,trcnp1) = vafoen(nrofon,q2,prf2cn) + vafott(nrofon,q3,trcnp1) = vafoen(nrofon,q3,prf1cn) + vafott(nrofon,q4,trcnp1) = vafoen(nrofon,q4,prf2cn) + vafott(nrofon,q5,trcnp1) = + > unsde * ( vafoen(nrofon,q2,prf1cn) + > + vafoen(nrofon,q3,prf2cn) ) + vafott(nrofon,q6,trcnp1) = vafoen(nrofon,q6,prf1cn) +c + 2311 continue +c + elseif ( etan.eq.2 ) then +c + do 2312 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,trcnp1) = vafoen(nrofon,q1,prf2cn) + vafott(nrofon,q2,trcnp1) = + > unsde * ( vafoen(nrofon,q2,prf1cn) + > + vafoen(nrofon,q2,prf2cn) ) + vafott(nrofon,q3,trcnp1) = vafoen(nrofon,q3,prf1cn) + vafott(nrofon,q4,trcnp1) = vafoen(nrofon,q4,prf2cn) + vafott(nrofon,q5,trcnp1) = vafoen(nrofon,q5,prf1cn) + vafott(nrofon,q6,trcnp1) = + > unsde * ( vafoen(nrofon,q1,prf1cn) + > + vafoen(nrofon,q3,prf2cn) ) +c + 2312 continue +c + elseif ( etan.eq.3 ) then +c + do 2313 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,trcnp1) = vafoen(nrofon,q1,prf2cn) + vafott(nrofon,q2,trcnp1) = vafoen(nrofon,q2,prf1cn) + vafott(nrofon,q3,trcnp1) = + > unsde * ( vafoen(nrofon,q3,prf1cn) + > + vafoen(nrofon,q3,prf2cn) ) + vafott(nrofon,q4,trcnp1) = + > unsde * ( vafoen(nrofon,q1,prf1cn) + > + vafoen(nrofon,q2,prf2cn) ) + vafott(nrofon,q5,trcnp1) = vafoen(nrofon,q5,prf1cn) + vafott(nrofon,q6,trcnp1) = vafoen(nrofon,q6,prf2cn) +c + 2313 continue +c + endif +c + +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le triangle est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c triangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdtr), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c . . +c ... ... +c . . . . . . +c . . . . . . +c . . . ===> . . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 232 , nrofon = 1 , nbfonc + do 2321 , iaux = 1 , nbnoel + vafott(nrofon,iaux,f1cp) = vafoen(nrofon,iaux,prf1cn) + vafott(nrofon,iaux,f2cp) = vafoen(nrofon,iaux,prf2cn) + 2321 continue + 232 continue +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 1, 2 ou 3 et different de etan : +c le triangle est encore decoupe en deux +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c +#include "pcstr2_4.h" +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4, 6, 7 ou 8 : le triangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du triangle. qui plus est, par suite +c de la regle des ecarts de niveau, on peut avoir induit +c un decoupage de conformite sur l'un des fils. +c remarque : c'est toujours un des fils du cote qui etait +c decoupe qui subit le decoupage, et c'est toujours par +c une subdivision du dit cote. +c +c . pour le triangle central et le triangle dans le coin +c oppose a l'arete initialement decoupee, on attribue la +c valeur moyenne de la fonction sur les deux anciens fils. +c . pour les deux autres triangles, on repere dans lequel +c des deux fils ils se trouvent. si un de ces triangles est +c decoupe, c'est en 2 et par la meme arete que le triangle +c courant ; on affecte la valeur du fils du maillage n +c a ces deux fils. si un des triangles est actif, on lui +c attribue la valeur. +c +c . on pose i, j et k comme etant les numeros locaux des +c aretes du triangle courant. +c si etan vaut i, c'est que la i-eme arete du triangle +c etait coupee. les numerotations des 2 fils sont obtenues +c par la fonction nutrde : a = nutrde(i,j), b = nutrde(i,k) +c les numerotations des 4 fils sont +0, +i, +j et +k. +c on voit donc que : +c . les fils +O et +i doivent recevoir la moyenne +c . le fils +k, ou ses fils, doit recevoir la valeur +c de +nutrde(i,j) +c . le fils +j, ou ses fils, doit recevoir la valeur +c de +nutrde(i,k) +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . . . +c . +a . +b . . .+0 . . +c . . . . +k . . +j . +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . ... +c . +a . +b . . .+0 . . . +c . . . . +k . .+j.+j. +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . ... ... +c . +a . +b . . . .+0 . . . +c . . . .+k.+k. .+j.+j. +c ................. ................. +c i i +c +c +#include "pcstr2_3.h" +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le triangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + write (ulsort,texte(langue,6)) +c + endif +c + endif +c +c +c======================================================================= +c doc.4. ==> le triangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 .or. + > etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then +c +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'pcetr2_5', nompro +#endif +#include "pcstr2_5.h" +c +c======================================================================= +c + endif +c + endif +c + 20 continue +c + endif +cgn do 999 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +c remarque : il faut ajuster a la main la borne maximale +cgn do 9992 , trcn = 50, 55 +cgn print 1788,trcn, +cgn > (vafott(nrofon,iaux,trcn), iaux = 1 , nbnoel) +cgn 9992 continue +cgn 999 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end +c + diff --git a/src/tool/AP_Conversion/pcetr3.F b/src/tool/AP_Conversion/pcetr3.F new file mode 100644 index 00000000..eff0d451 --- /dev/null +++ b/src/tool/AP_Conversion/pcetr3.F @@ -0,0 +1,199 @@ + subroutine pcetr3 ( nbfonc, nnmold, nnmnew, + > prfcan, prfcap, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c TRiangles - cas 3 - degre 2 vers degre 1 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . nnmold . e . 1 . ancien nombre de noeuds par maille . +c . nnmnew . e . 1 . nouveau nombre de noeuds par maille . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . .nnmold**. . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . .nnmnew**. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCETR3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer nnmold, nnmnew + integer prfcan(*), prfcap(*) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,nnmold,*) + double precision vafott(nbfonc,nnmnew,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c trcn = triangle courant en numerotation Calcul a l'it. N +c trcnp1 = triangle courant en numerotation Calcul a l'it. N+1 +c trhn = triangle courant en numerotation Homard a l'it. N +c + integer trcn, trcnp1, trhn +c + integer nrofon, nunoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbfonc, nbtrto', nbfonc, nbtrto + write(ulsort,90002) 'nnmold, nnmnew', nnmold, nnmnew +#endif +c + codret = 0 +c +c==== +c 2. on boucle sur tous les triangles du maillage HOMARD n+1 +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , trhn = 1 , nbtrto +c +c 2.1. ==> ancien numero du triangle dans le calcul +c + trcn = ntreca(trhn) +c +cgn write (ulsort,90002) 'triangle', trhn, prfcan(trcn) +c + if ( prfcan(trcn).gt.0 ) then +c + trcnp1 = ntrsca(trhn) + prfcap(trcnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc +c +cgn write (ulsort,90002) 'fonction numero', nrofon +cgn write (ulsort,90004) ' ', +cgn > (vafoen(nrofon,nunoel,prfcan(trcn)),nunoel=1,nnmold) + do 211 , nunoel = 1 , nnmnew + vafott(nrofon,nunoel,trcnp1) = + > vafoen(nrofon,nunoel,prfcan(trcn)) + 211 continue +c + 21 continue +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + do 922 , iaux = 1 , nbtrto, -1 + write (ulsort,90002) 'triangle', iaux + do 9222 , nrofon = 1 , nbfonc + write (ulsort,90002) 'fonction numero', nrofon + write(ulsort,90004) ' ', + > (vafott(nrofon,nunoel,iaux), nunoel = 1 , nnmnew) + 9222 continue + 922 continue +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcetr4.F b/src/tool/AP_Conversion/pcetr4.F new file mode 100644 index 00000000..da71ff0e --- /dev/null +++ b/src/tool/AP_Conversion/pcetr4.F @@ -0,0 +1,211 @@ + subroutine pcetr4 ( nbfonc, nnmold, nnmnew, + > prfcan, prfcap, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c aPres adaptation - Conversion de solution - aux noeuds par Element +c - - - +c TRiangles - cas 4 - degre 1 vers degre 2 +c -- - +c ______________________________________________________________________ +c +c remarque : cette interpolation suppose que l'on est en presence de +c variables intensives. C'est-a-dire independantes de la +c taille de la maille. +c Une densite par exemple mais pas une masse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . nnmold . e . 1 . ancien nombre de noeuds par maille . +c . nnmnew . e . 1 . nouveau nombre de noeuds par maille . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . .nnmold**. . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . .nnmnew**. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCETR4' ) +c +#include "nblang.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer nnmold, nnmnew + integer prfcan(*), prfcap(*) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,nnmold,*) + double precision vafott(nbfonc,nnmnew,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c trcn = triangle courant en numerotation Calcul a l'it. N +c trcnp1 = triangle courant en numerotation Calcul a l'it. N+1 +c trhn = triangle courant en numerotation Homard a l'it. N +c + integer trcn, trcnp1, trhn +c + integer nrofon, nunoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbfonc, nbtrto', nbfonc, nbtrto + write(ulsort,90002) 'nnmold, nnmnew', nnmold, nnmnew +#endif +c +c==== +c 2. on boucle sur tous les triangles du maillage HOMARD n+1 +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , trhn = 1 , nbtrto +c +c 2.1. ==> ancien numero du triangle dans le calcul +c + trcn = ntreca(trhn) +c +cgn write (ulsort,90002) 'triangle', trhn, prfcan(trcn) +c + if ( prfcan(trcn).gt.0 ) then +c + trcnp1 = ntrsca(trhn) + prfcap(trcnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc +c +cgn write (ulsort,90002) 'fonction numero', nrofon +cgn write (ulsort,90004) ' ', +cgn > (vafoen(nrofon,nunoel,prfcan(trcn)),nunoel=1,nnmold) +c +c recopie des valeurs sur les sommets +c + do 211 , nunoel = 1 , nnmold + vafott(nrofon,nunoel,trcnp1) = + > vafoen(nrofon,nunoel,prfcan(trcn)) + 211 continue +c +c calcul des valeurs sur les noeuds milieux +c + do 212 , iaux = 1 , 3 + nunoel = 3 + iaux + vafott(nrofon,nunoel,trcnp1) = unsde + > * ( vafoen(nrofon, iaux,prfcan(trcn)) + + > vafoen(nrofon,per1a3(1,iaux),prfcan(trcn)) ) + 212 continue +c + 21 continue +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + do 922 , iaux = 1 , nbtrto, -1 + write (ulsort,90002) 'triangle', iaux + do 9222 , nrofon = 1 , nbfonc + write (ulsort,90002) 'fonction numero', nrofon + write(ulsort,90004) ' ', + > (vafott(nrofon,nunoel,iaux), nunoel = 1 , nnmnew) + 9222 continue + 922 continue +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfaa1.F b/src/tool/AP_Conversion/pcfaa1.F new file mode 100644 index 00000000..9f5b0369 --- /dev/null +++ b/src/tool/AP_Conversion/pcfaa1.F @@ -0,0 +1,565 @@ + subroutine pcfaa1 ( nbblqu, + > nbattr, nbfold, nbfn00, nbfnew, nbfq00, + > perqua, nivqua, + > famqua, cfaqua, + > ptabol, ptabne, + > vattol, vattne, + > nufmol, nufmne, + > nofmol, nofmne, + > descol, descne, + > tabaux, lapile, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - FAmilles pour ATHENA - Phase 1 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbblqu . e . 1 . nombre de blocs . +c . nbattr . e . 1 . nombre d'attributs decrivant les familles . +c . nbfn00 . e . 1 . nouveau nombre de familles MED (estimation). +c . nbfnew . s . 1 . nouveau nombre de familles MED . +c . nbfold . e . 1 . ancien nombre de familles MED . +c . nbfq00 . e . 1 . nouveau nombre de familles HOMARD pour . +c . . . . les quadrangles (estimation) . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ptabol . e . * . pointeur dans tables d'attributs (ancien) . +c . ptabne . s . * . pointeur dans tables d'attributs (nouveau) . +c . vattol . e . * . table des valeurs des attributs (ancien) . +c . vattne . s . * . table des valeurs des attributs (nouveau) . +c . nufmol . e . * . numero de la famille MED (ancien) . +c . nufmne . s . * . numero de la famille MED (nouveau) . +c . nofmol . e . * . nom de la famille MED (ancien) . +c . nofmne . s . * . nom de la famille MED (nouveau) . +c . descol . e . * . description des attributs (ancien) . +c . descne . s . * . description des attributs (nouveau) . +c . tabaux . a . * . tableau de travail . +c . lapile . a . * . tableau de travail . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFAA1' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "nombqu.h" +#include "envada.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer nbblqu + integer nbattr, nbfold, nbfn00, nbfnew, nbfq00 +c + integer perqua(nbquto), nivqua(nbquto) +c + integer famqua(nbquto), cfaqua(nctfqu,nbfq00) +c + integer ptabol(0:nbfold), ptabne(0:nbfn00) + integer vattol(*), vattne(*) + integer nufmol(nbfold), nufmne(nbfn00) +c + integer tabaux(-nbquto:*), lapile(*) +c + character*8 nofmol(*), nofmne(*) + character*8 descol(*), descne(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lequad, lequ00 + integer lgpile + integer iaux, jaux, kaux + integer adrold, adrnew + integer nubloc, niveau + integer numfam, numfa0, nivboi, numboi, nuboim + integer nfmed0, nromat + integer fahope, fahoqu + integer attri(4) +c + logical cpcamf, prem, noufam +c +#ifdef _DEBUG_HOMARD_ + character*8 saux08 + character*64 saux64 +#endif + character*200 bla200 + character*200 descri(4) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a14,'' : nombre de familles crees : '',i6)' + texte(1,5) = '(/,''. Famille MED numero :'',i6,/,22(''-''))' + texte(1,6) = '(/,60(''=''),/,''. Niveau numero'',i6,/,21(''-''))' + texte(1,7) = '(''Ce nombre est superieur au maximum :'',i6)' + texte(1,9) = '(/,''.. Bloc numero'',i6,/)' + texte(1,10) = '(''Impossible de trouver la famille du pere'')' + texte(1,11) = '(''Impossible de trouver le materiau du pere'')' + texte(1,18) = + >'(a,'' de la'',i6''-ieme famille MED, de numero'',i6)' + texte(1,19) = '(/,''Nombre de familles MED crees : '',i6)' + texte(1,20) = '(''Modifier le programme PCFAAT'',/)' +c + texte(2,4) = '(/,a14,'' : number of created families : '',i6)' + texte(2,5) = '(/,''. MED family #'',i6,/,14(''-''))' + texte(2,6) = '(/,60(''=''),/,''. Level #'',i6,/,15(''-''))' + texte(2,7) = '(''This number is greater than maximum :'',i6)' + texte(2,9) = '(/,''.. Block #'',i6,/)' + texte(2,10) = '(''Father family cannot be found.'')' + texte(2,11) = '(''Father material cannot be found.'')' + texte(2,18) = + >'(a,'' of the'',i6,''th MED family, with #'',i6)' + texte(2,19) = '(/,''Number of created MED families : '',i6)' + texte(2,20) = '(''Modify PCFAAT program.'',/)' +c +cgn 1000 format(20i6) +cgn 1004 format(4i6) +cgn 2000 format('.... ',a,' = ',10i6) +c + do 11 , iaux = 1 , 200 + bla200(iaux:iaux) = ' ' + 11 continue +c +c==== +c 2. les familles inchangees +c==== +cgn write (ulsort,1000) (ptabol(iaux),iaux=0,nbfold) +cgn write (ulsort,1000) (vattol(iaux),iaux=1,nbattr*nbfold) +cgn write (ulsort,*) (nofmol(iaux),iaux=1,4*nbfold) +cgn write (ulsort,*) (descol(iaux),iaux=1,nbattr * 25 * (nbfold-1)) +c + nbfnew = 0 + ptabne(0) = 0 + prem = .true. + numfa0 = 0 +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nbfold +c + if ( codret.eq.0 ) then +c + cpcamf = .false. +c + numfam = nufmol(iaux) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) numfam +#endif +c +c 2.1. ==> la famille nulle +c + if ( numfam.eq.0 ) then +c + nbfnew = nbfnew + 1 + ptabne(nbfnew) = ptabne(nbfnew-1) + cpcamf = .true. +c +c 2.2. ==> une famille correspondant a une boite de niveau 0 +c + else +c + nivboi = vattol(ptabol(iaux-1)+2) + if ( nivboi.eq.0 ) then + nbfnew = nbfnew + 1 + ptabne(nbfnew) = ptabne(nbfnew-1) + nbattr + do 221 , jaux = 1 , nbattr + vattne(ptabne(nbfnew-1)+jaux) =vattol(ptabol(iaux-1)+jaux) + adrold = 25*(ptabol(iaux-1)+jaux-1) + adrnew = 25*(ptabne(nbfnew-1)+jaux-1) + do 222 , kaux = 1 , 25 + descne(adrnew+kaux) = descol(adrold+kaux) + 222 continue + 221 continue + cpcamf = .true. +cgn print *,vattol(ptabol(iaux-1)+3) + if ( prem ) then + numboi = vattol(ptabol(iaux-1)+3) + prem = .false. + else + numboi = max(numboi,vattol(ptabol(iaux-1)+3)) + endif + endif +c + endif +c +c 2.3. ==> copie des caracteristiques de la famille +c + if ( cpcamf ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,18)) 'Reproduction', nbfnew, numfam +#endif + nofmne(10*(nbfnew-1)+1) = nofmol(10*(iaux-1)+1) + nofmne(10*(nbfnew-1)+2) = nofmol(10*(iaux-1)+2) + nofmne(10*(nbfnew-1)+3) = nofmol(10*(iaux-1)+3) + nofmne(10*(nbfnew-1)+4) = nofmol(10*(iaux-1)+4) + nofmne(10*(nbfnew-1)+5) = nofmol(10*(iaux-1)+5) + nofmne(10*(nbfnew-1)+6) = nofmol(10*(iaux-1)+6) + nofmne(10*(nbfnew-1)+7) = nofmol(10*(iaux-1)+7) + nofmne(10*(nbfnew-1)+8) = nofmol(10*(iaux-1)+8) + nufmne(nbfnew) = numfam + numfa0 = max(numfa0,abs(numfam)) +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.eq.0 ) then +c + saux64 = nofmne(10*(nbfnew-1)+1)//nofmne(10*(nbfnew-1)+2)// + > nofmne(10*(nbfnew-1)+3)//nofmne(10*(nbfnew-1)+4)// + > nofmne(10*(nbfnew-1)+5)//nofmne(10*(nbfnew-1)+6)// + > nofmne(10*(nbfnew-1)+7)//nofmne(10*(nbfnew-1)+8) + call utinfm ( numfam, saux64, + > 0, saux08, + > -1, -1, + > ulsort, langue, codret ) +c + endif +#endif +c + endif +c + endif +c + 21 continue +c + numfam = -numfa0 +c + endif +cgn write(ulsort,2000) '.. vattne apres copie du depart' +cgn write(ulsort,1004) (vattne(iaux),iaux=1,nbattr*(nbfnew-1)) +c +c==== +c 3. creation des nouvelles boites, en allant des niveaux inferieurs +c vers les niveaux superieurs +c Il est fondamental d'aller dans cet ordre pour memoriser les +c parentes des boites +c un bloc equivaut a une boite. mais cette boite peut etre repartie +c sur plusieurs familles med si elle recouvre des materiaux +c differents +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains quadrangles ont des peres adoptifs de numero +c negatif. on ne court pas le risque d'utiliser un tel +c pere car on ne s'interesse qu'a des peres de quadrangles +c de niveau au moins egal a 1 +c==== +c + if ( codret.eq.0 ) then +c + do 30 , niveau = 1 , nivsup +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) niveau +#endif +c + do 300 , nubloc = 1, nbblqu +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,9)) nubloc +#endif +c +c 3.1. ==> Le bloc est-il du bon niveau ? +c On repere le premier quadrangle concerne +c + do 31 , lequad = 1 , nbquto +c + if ( tabaux(-lequad).eq.nubloc .and. + > nivqua(lequad).eq.niveau ) then + lequ00 = lequad +cgn write(ulsort,2000) 'lequ00', lequ00 + goto 320 + endif +c + 31 continue +c + goto 300 +c +c 3.2. ==> Ce bloc est une nouvelle boite +c + 320 continue +c + nivboi = niveau + numboi = numboi + 1 +c +cgn write(ulsort,2000) 'numboi', numboi +cgn write(ulsort,2000) 'nivboi', nivboi +c +c 3.2.1. ==> recherche de la boite mere : c'est la boite du pere du +c premier quadrangle. C'est ici qu'il est important de monter +c dans les niveaux pour avoir des numeros de boite a jour. +c + fahope = famqua(perqua(lequ00)) +cgn write(ulsort,2000) 'fahope', fahope + jaux = cfaqua(cofamd,fahope) +cgn write(ulsort,2000) 'jaux', jaux + do 321 , iaux = 1 , nbfnew + if ( nufmne(iaux).eq.jaux ) then + nuboim = vattne(ptabne(iaux-1)+3) + goto 3210 + endif + 321 continue +c + write (ulsort,texte(langue,10)) + codret = 5 + goto 40 +c + 3210 continue +c +cgn write(ulsort,2000) 'nuboim', nuboim +c +c 3.2.2. ==> les caracteristiques immuables +c + do 322 , iaux = 1 , nbattr + descri(iaux) = bla200 +#ifdef _DEBUG_HOMARD_ + descri(iaux)(198:200) = 'FIN' +#endif + 322 continue +c 123456789012345678 + descri(1)(1:18) = 'Numero du materiau' + descri(2)(1:18) = 'Niveau de la boite' + attri(2) = nivboi +c 123456789012345678 + descri(3)(1:18) = 'Numero de la boite' + attri(3) = numboi +c 12345678901234567890123 + descri(4)(1:23) = 'Numero de la boite mere' + attri(4) = nuboim +c +c 3.2.3. ==> on parcourt tous les quadrangles de ce bloc +c par heritage du raffinement, chaque quadrangle est deja +c dans une famille HOMARD. On en deduit les caracteristiques +c de la famille MED associ�e. +c + lgpile = 0 +c + do 323 , lequad = lequ00 , nbquto +c + if ( codret.eq.0 ) then +c + if ( tabaux(-lequad).eq.nubloc ) then +c +cgn write(ulsort,*) '********************************' +cgn write(ulsort,2000) 'quadrangle', lequad +c +c 3.2.3.1. ==> par heritage du raffinement, ce quadrangle lequad est de +c la meme famille homard que son pere. On utilise sa +c famille MED initiale pour retrouver le materiau. +c +cgn write(ulsort,2000) 'perqua(lequad)', perqua(lequad) +cgn write(ulsort,2000) 'famqua(..)', famqua(perqua(lequad)) + fahope = famqua(perqua(lequad)) + nfmed0 = cfaqua(cofamd,fahope) +cgn write(ulsort,2000) 'nfmed0', nfmed0 +cgn write(ulsort,2000) '.. vattne' +cgn write(ulsort,1004) (vattne(iaux),iaux=1,nbattr*(nbfnew-1)) + do 32311 , iaux = 1 , nbfnew + if ( nufmne(iaux).eq.nfmed0 ) then + nromat = vattne(ptabne(iaux-1)+1) + goto 32312 + endif +32311 continue +c + write (ulsort,texte(langue,11)) + codret = 5 + goto 40 +c +32312 continue +cgn write(ulsort,2000) 'nromat', nromat +c +c 3.2.3.2. ==> On recherche dans les nouvelles familles MED creees s'il +c en existe une avec les memes caracteristiques que celle +c voulue pour ce quadrangle +c Attention, l'orientation est importante pour HOMARD, +c mais sans interet pour les boites. +c + noufam = .true. +c +cgn write(ulsort,1007) (lapile(iaux),iaux=1,lgpile * (nctfqu+3)) +cgn write(ulsort,2000) 'mate voulu',nromat +cgn write(ulsort,2000) 'boit voulu',numboi +cgn write(ulsort,2000) 'cara voulu', +cgn > (cfaqua(jaux,fahope),jaux=1,nctfqu) +c + do 32321 , iaux = 1 , lgpile +c +cgn write(ulsort,2000) '.. Famille',iaux + kaux = (iaux-1) * (nctfqu+3) +c +c controle du materiau et du numero de boite +cgn write(ulsort,2000) '.... materiau',lapile(kaux+2) +cgn write(ulsort,2000) '.... boite ',lapile(kaux+3) + if ( lapile(kaux+2).ne.nromat .or. + > lapile(kaux+3).ne.numboi ) then + goto 32321 + endif +c +c controle des caracteristiques HOMARD + do 32322 , jaux = 1 , nctfqu +cgn write(ulsort,2000) '.... cara ',lapile(kaux+3+jaux) + if ( jaux.ne.cofamd ) then + if ( lapile(kaux+3+jaux).ne.cfaqua(jaux,fahope) ) then + goto 32321 + endif + endif +32322 continue +c + noufam = .false. +c +c c'est la bonne famille MED, on repere le numero de la +c famille homard et on passe a l'element suivant. +c + fahoqu = lapile(kaux+1) + goto 3235 +c +32321 continue +c +c 3.2.3.3. ==> creation d'une nouvelle famille med +c + if ( codret.eq.0 ) then +c + if ( noufam ) then +c + call pcfaa3 ( nbblqu, nbfold, nbfnew, numfam, + > nromat, numboi, nbattr, attri, descri, + > ptabne, vattne, + > nufmne, nofmne, descne, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2.3.4. ==> creation d'une nouvelle famille homard +c + if ( codret.eq.0 ) then +c + call pcfaa2 ( fahope, numfam, nromat, numboi, + > cfaqua, lgpile, lapile, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + fahoqu = nbfqua +c + endif +c +c 3.2.3.5. ==> affectation du numero de famille homard au quadrangle +c + 3235 continue +c +cgn write(ulsort,2000) '===> fahoqu', fahoqu +cgn if ( lequad.eq.15001 ) then +cgn write(ulsort,2000) '===> fahoqu', fahoqu +cgn endif + famqua(lequad) = fahoqu +c + endif +c + endif +c + 323 continue +c + 300 continue +c + 30 continue +c + endif +cgn write(ulsort,2000) 'famqua(..)', famqua( 1) +cgn write(ulsort,2000) 'nbquto', nbquto +cgn write(ulsort,2000) 'famqua(..)', famqua(nbquto) +c +c==== +c 4. la fin +c==== +c + 40 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfaa2.F b/src/tool/AP_Conversion/pcfaa2.F new file mode 100644 index 00000000..9373ac96 --- /dev/null +++ b/src/tool/AP_Conversion/pcfaa2.F @@ -0,0 +1,208 @@ + subroutine pcfaa2 ( fahope, numfam, nromat, numboi, + > cfaqua, lgpile, lapile, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - FAmilles pour ATHENA - Phase 2 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fahope . e . 1 . famille HOMARD du quadrangle pere . +c . numfam . e . 1 . famille MED a associer a cette famille . +c . nromat . e . 1 . numero du materiau de la boite . +c . numboi . e . 1 . numero de la boite . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . lgpile . es . 1 . longueur de la pile . +c . lapile . a . * . tableau de travail . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFAA2' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +#include "nbfami.h" +#include "nbfamm.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer fahope, numfam, nromat, numboi +c + integer cfaqua(nctfqu,*) +c + integer lgpile, lapile(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Creation de la famille HOMARD numero : '',i8)' + texte(1,5) = '(/,a14,'' : nombre de familles crees : '',i8)' + texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,7) = '(''Modifier le programme UTINCG'',/)' +c + texte(2,4) = '(''Creation of HOMARD family # : '',i8)' + texte(2,5) = '(/,a14,'' : number of created families : '',i8)' + texte(2,6) = '(''This number is greater than maximum :'',i8)' + texte(2,7) = '(''Modify UTINCG program.'',/)' +c + codret = 0 +c +c==== +c 2. creation d'une nouvelle famille homard pour les quadrangles +c==== +c +c 2.1. ==> numero de cette famille +c + nbfqua = nbfqua + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbfqua +#endif +c + if ( nbfqua.gt.nbfqum ) then + write (ulsort,texte(langue,5)) mess14(langue,4,8), nbfqua + write (ulsort,texte(langue,6)) nbfqum + write (ulsort,texte(langue,7)) + codret = 1 + endif +c +c 2.2. ==> les caracteristiques : celles du pere, sauf la famille MED +c + if ( codret.eq.0 ) then +c + do 22 , iaux = 1 , nctfqu + cfaqua(iaux,nbfqua) = cfaqua(iaux,fahope) + 22 continue + cfaqua(cofamd,nbfqua) = numfam +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,60030) + write (ulsort,60031) nbfqua, + > (cfaqua(jaux,nbfqua),jaux=1,ncffqu) + write (ulsort,60032) +60030 format( + >/,5x,41('*'), + >/,5x,'* Numero code * 1 * 2 * 3 *', + >/,5x,41('*'), + >/,5x,'* Numero de la * Fami. * Type * Fami. *', + >/,5x,'* famille * MED * * tria. *', + >/,5x,41('*')) +60031 format( + > 5x,'*', i8,' *',i6,' *',i6,' *',i6,' *') +60032 format( + > 5x,41('*'),/) +#endif +c + endif +c +c 2.3. ==> memorisation des caracteristiques dans la pile +c + if ( codret.eq.0 ) then +c + jaux = lgpile * (nctfqu+3) + lgpile = lgpile + 1 +cgn write(ulsort,*) '.. lgpile', lgpile + lapile(jaux+1) = nbfqua + lapile(jaux+2) = nromat + lapile(jaux+3) = numboi + do 23 , iaux = 1 , nctfqu + lapile(jaux+3+iaux) = cfaqua(iaux,nbfqua) + 23 continue +cgn write(ulsort,1007) (lapile(iaux),iaux=1,lgpile * (nctfqu+3)) +cgn 1007 format(7i6) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfaa3.F b/src/tool/AP_Conversion/pcfaa3.F new file mode 100644 index 00000000..6f9afb34 --- /dev/null +++ b/src/tool/AP_Conversion/pcfaa3.F @@ -0,0 +1,241 @@ + subroutine pcfaa3 ( nbblqu, nbfold, nbfnew, numfam, + > nromat, numboi, nbattr, attri, descri, + > ptabne, vattne, + > nufmne, nofmne, descne, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - FAmilles pour ATHENA - Phase 3 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbblqu . e . 1 . nombre de blocs . +c . nbfold . e . 1 . ancien nombre de familles MED . +c . nbfnew . es . 1 . nombre de nouvelles familles MED . +c . numfam . es . 1 . numero de la famille MED a creer . +c . nromat . e . 1 . numero du materiau de la boite . +c . numboi . e . 1 . numero de la boite . +c . nbattr . e . 1 . nombre d'attributs decrivant les familles . +c . attri . e .char*200. les caracteristiques immuables . +c . descri . e .char*200. les caracteristiques immuables . +c . ptabne . s . * . pointeur dans tables d'attributs (nouveau) . +c . vattne . s . * . table des valeurs des attributs (nouveau) . +c . nufmne . s . * . numero de la famille MED (nouveau) . +c . nofmne . s . * . nom de la famille MED (nouveau) . +c . descne . s . * . description des attributs (nouveau) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFAA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbblqu, nbfold, nbfnew, numfam + integer nromat, numboi, nbattr +c + integer attri(nbattr) + integer ptabne(0:*) + integer vattne(*) + integer nufmne(*) +c + character*8 nofmne(*) + character*8 descne(*) + character*200 descri(nbattr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer adrnew +c + character*8 saux08 +#ifdef _DEBUG_HOMARD_ + character*64 saux64 +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(a,'' de la'',i6''-ieme famille MED, de numero'',i6)' + texte(1,5) = '(/,''Nombre de familles MED crees : '',i8)' + texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,8) = '(''Modifier le programme UTINCG'',/)' + texte(1,7) = '(''Modifier le programme PCFAAT'',/)' + texte(1,9) = '(/,''.. Bloc numero'',i6,/)' + texte(1,10) = '(''Impossible de trouver la famille du pere'')' + texte(1,11) = '(''Impossible de trouver le materiau du pere'')' +c + texte(2,4) = + >'(a,'' of the'',i6,''th MED family, with #'',i6)' + texte(2,5) = '(/,''Number of created MED families : '',i8)' + texte(2,6) = '(''This number is greater than maximum :'',i8)' + texte(2,7) = '(''Modify PCFAAT program.'',/)' + texte(2,8) = '(''Modify UTINCG program.'',/)' + texte(2,9) = '(/,''.. Block #'',i6,/)' + texte(2,10) = '(''Father family cannot be found.'')' + texte(2,11) = '(''Father material cannot be found.'')' +c +cgn 1004 format(4i6) +cgn 2000 format('.... ',a,' = ',10i6) +c + codret = 0 +c +c==== +c 2. creation d'une nouvelle famille med +c==== +c +c 2.1. ==> numero de cette famille +c + nbfnew = nbfnew + 1 + numfam = numfam - 1 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) 'Creation', nbfnew, numfam +#endif +cgn write(ulsort,2000) '.. nbfnew', nbfnew +c + if ( nbfnew.gt.nbblqu*nbfold ) then + write (ulsort,texte(langue,5)) nbfnew + write (ulsort,texte(langue,6)) nbblqu*nbfold + write (ulsort,texte(langue,7)) + codret = 1 + endif +c +c 2.2. ==> les attributs +c + if ( codret.eq.0 ) then +c + attri(1) = nromat + ptabne(nbfnew) = ptabne(nbfnew-1) + nbattr + do 221 , iaux = 1 , nbattr + vattne(ptabne(nbfnew-1)+iaux) = attri(iaux) + adrnew = 25*(ptabne(nbfnew-1)+iaux-1) + do 222 , jaux = 1 , 25 + descne(adrnew+jaux) = descri(iaux)(8*(jaux-1)+1:8*jaux) + 222 continue + 221 continue +cgn write(ulsort,2000) '.. vattne' +cgn write(ulsort,1004) (vattne(iaux),iaux=1,nbattr*(nbfnew-1)) +c + endif +c +c 2.3. ==> le nom de la famille +c +cgn write(ulsort,*) '.. numboi', numboi + nofmne(8*(nbfnew-1)+1)(1:6) = 'Boite_' + if ( codret.eq.0 ) then + call utench ( numboi, '0', iaux, saux08, + > ulsort, langue, codret ) + endif + if ( codret.eq.0 ) then + nofmne(8*(nbfnew-1)+1)(7:8) = saux08(1:2) + nofmne(8*(nbfnew-1)+2)(1:6) = saux08(3:8) + nofmne(8*(nbfnew-1)+2)(7:8) = '_M' + nofmne(8*(nbfnew-1)+2) = 'ateriau_' + call utench ( nromat, '0', iaux, saux08, + > ulsort, langue, codret ) + nofmne(8*(nbfnew-1)+4) = saux08 + nofmne(8*(nbfnew-1)+5) = saux08 + nofmne(8*(nbfnew-1)+6) = saux08 + nofmne(8*(nbfnew-1)+7) = saux08 + nofmne(8*(nbfnew-1)+8) = saux08 + endif +c +c 2.4. ==> le numero de la famille +c + nufmne(nbfnew) = numfam +cgn write(ulsort,2000) '.. numfam', numfam +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + saux64 = nofmne(8*(nbfnew-1)+1)//nofmne(8*(nbfnew-1)+2)// + > nofmne(8*(nbfnew-1)+3)//nofmne(8*(nbfnew-1)+4)// + > nofmne(8*(nbfnew-1)+5)//nofmne(8*(nbfnew-1)+6)// + > nofmne(8*(nbfnew-1)+7)//nofmne(8*(nbfnew-1)+8) + call utinfm ( numfam, saux64, + > 0, saux08, + > -1, -1, + > ulsort, langue, codret ) + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + call dmflsh (iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfaat.F b/src/tool/AP_Conversion/pcfaat.F new file mode 100644 index 00000000..c49da051 --- /dev/null +++ b/src/tool/AP_Conversion/pcfaat.F @@ -0,0 +1,533 @@ + subroutine pcfaat ( typcca, + > nhsupe, nhsups, nhqufa, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > perqua, nivqua, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, pcfaqu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - FAmilles pour ATHENA +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typcca . e . 1 . type du code de calcul . +c . nhsupe . es . char8 . informations supplementaires entieres . +c . nhsups . es . char8 . informations supplementaires caracteres 8 . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nhqufa . e . char8 . nom de l'objet des familles de quadrangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . povoso . e .0:nbnoto. pointeur des voisins par noeud . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . es . nbquto . famille des quadrangles . +c . pcfaqu . es . 1 . adresse des codes des familles de quad. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFAAT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "nbutil.h" +#include "nbfami.h" +#include "nbfamm.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +#include "dicfen.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typcca +c + integer hetare(nbarto), somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer perqua(nbquto), nivqua(nbquto) + integer povoso(0:nbnoto), voisom(*) + integer posifa(0:nbarto), facare(nbfaar) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto) + integer pcfaqu +c + character*8 nhsupe, nhsups, nhqufa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer ptra15, ptra16 + integer ptrae3, ptrae4, ptrae9, ptras4, ptras5 + integer adsue3, adsue4, adsue9, adsus4, adsus9 +c + integer un + integer nbblqu + integer nattrc, nbattr, nbfold, nbfn00, nbfnew, nbfq00 +c + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*8 ntra15, ntra16 + character*8 ntrae3, ntrae4, ntrae9, ntras4, ntras9 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Traitement specifique a ATHENA'')' + texte(1,5) = '(i6,'' blocs de '',a,/)' + texte(1,10) = '(''Type du code de calcul (typcca) :'',i5)' +c + texte(2,4) = '(''Specific treatment to ATHENA'')' + texte(2,5) = '(i6,'' blocks of '',a,/)' + texte(2,10) = '(''Type of calculation code (typcca) :'',i5)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) typcca +#endif +c + if ( typcca.eq.16 ) then + codret = 0 + else + codret = 1 + write (ulsort,texte(langue,10)) typcca + write (ulsort,texte(langue,4)) + endif +c + un = 1 +c +c==== +c 2. tableaux de travail +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. tableaux de travail ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbquto, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', nbarto, ptrav3, codre3 ) + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre4 ) + iaux = nbquto + 1 + call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmalot ( ntra15, 'entier ', nbarto, ptra15, codre1 ) + call gmalot ( ntra16, 'entier ', nbarto, ptra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. recherche des blocs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. recherche des blocs ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c on examine toutes les faces +c + jaux = nbquto + nbtrto + do 42 , iaux = 0, jaux + imem(ptrav4+iaux) = 1 + 42 continue + imem(ptrav4+nbquto) = 0 + iaux = 0 + jaux = 0 + call utb11c ( nbblqu, iaux, imem(ptrav4), + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, imem(pcfaqu), + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > imem(ptra15), imem(ptra16), + > imem(ptrav5), + > jaux, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +10000 format(3x,20i4) +10001 format(4x,80('-')) + write(ulsort,*) 'Fin etape 3 avec codret = ', codret + write(ulsort,texte(langue,5)) nbblqu, mess14(langue,3,4) + write(ulsort,10000) (iaux,iaux=1,min(20,nbquto)) + write(ulsort,10001) + write(ulsort,10000) (imem(ptrav5+iaux),iaux=0,min(20,nbquto-1)) + write(ulsort,10000) (imem(pcfaqu+iaux),iaux=0,nctfqu*nbfqua-1) + write(ulsort,10000) (famqua(iaux),iaux=1,min(20,nbquto)) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav2, codret ) +c + endif +c +c==== +c 4. Gestion des tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Gestion des tableaux ; codret = ', codret +#endif +c + nbattr = 4 +c +c 4.1. ==> Description actuelle des attributs +c +c nhsupe//'.Tab3' : Pointeur dans la table des attributs +c nhsupe//'.Tab4' : Table des attributs +c nhsupe//'.Tab5' : Pointeur dans la table des groupes +c nhsupe//'.Tab6' : Taille des noms des groupes +c nhsupe//'.Tab9' : Numero des familles MED +c nhsups//'.Tab2' : Noms des groupes (char*80) +c nhsups//'.Tab4' : Noms des familles MED (char*64) +c nhsups//'.Tab9' : Descriptions des attributs (char*200) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsupe ) + call gmprsx (nompro, nhsupe//'.Tab3' ) + call gmprsx (nompro, nhsupe//'.Tab4' ) + call gmprsx (nompro, nhsupe//'.Tab9' ) + call gmprsx (nompro, nhsups ) + call gmprsx (nompro, nhsups//'.Tab4' ) + call gmprsx (nompro, nhsups//'.Tab9' ) +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhsupe//'.Tab3', adsue3, iaux, codre1 ) + call gmadoj ( nhsupe//'.Tab4', adsue4, iaux, codre2 ) + call gmadoj ( nhsupe//'.Tab9', adsue9, iaux, codre3 ) + call gmadoj ( nhsups//'.Tab4', adsus4, iaux, codre4 ) + call gmadoj ( nhsups//'.Tab9', adsus9, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c 4.2. ==> Caracteristiques des familles MED +c + nbfn00 = nbblqu*nbfmed + nbfq00 = nbfqum +c + if ( codret.eq.0 ) then +c + iaux = nbfn00 + 1 + call gmalot ( ntrae3, 'entier ', iaux, ptrae3, codre1 ) + iaux = nbattr * (nbfn00-1) + call gmalot ( ntrae4, 'entier ', iaux, ptrae4, codre2 ) + call gmalot ( ntrae9, 'entier ', nbfn00, ptrae9, codre3 ) + iaux = 10 * nbfn00 + call gmalot ( ntras4, 'chaine ', iaux, ptras4, codre4 ) + iaux = 25 * nbattr * (nbfn00-1) + call gmalot ( ntras9, 'chaine ', iaux, ptras5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmmod ( nhqufa//'.Codes', pcfaqu, + > nctfqu, nctfqu, nbfqua, nbfq00, codre1 ) + iaux = nbfn00 * (nctfqu+3) + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 5. Creation des familles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Creation des familles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFAA1', nompro +#endif + nbfold = nbfmed + call pcfaa1 ( nbblqu, + > nbattr, nbfold, nbfn00, nbfnew, nbfq00, + > perqua, nivqua, + > famqua, imem(pcfaqu), + > imem(adsue3), imem(ptrae3), + > imem(adsue4), imem(ptrae4), + > imem(adsue9), imem(ptrae9), + > smem(adsus4), smem(ptras4), + > smem(adsus9), smem(ptras5), + > imem(ptrav5), imem(ptrav2), + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Gestion des tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Gestion des tableaux ; codret = ', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ntrae3 ) + call gmprsx (nompro, ntrae4 ) + call gmprsx (nompro, ntrae9 ) + call gmprsx (nompro, ntras4 ) + call gmprsx (nompro, ntras9 ) +#endif +c +c 6.1. ==> Redimensionnement des tableaux lies aux attributs +c + if ( codret.eq.0 ) then +c + nbfmed = nbfnew + nattrc = nbattr*(nbfmed-1) +c + iaux = nbfn00 + 1 + jaux = nbfmed + 1 + call gmmod ( ntrae3, ptrae3, iaux, jaux, un, un, codre1 ) + call gmmod ( ntrae4, ptrae4, + > nbattr, nbattr, nbfn00-1, nbfmed-1, codre2 ) + call gmmod ( ntrae9, ptrae9, nbfn00, nbfmed, un, un, codre3 ) + iaux = 4 + call gmmod ( ntras4, ptras4, iaux, iaux, nbfn00, nbfmed, codre4 ) + iaux = nbattr * 25 + call gmmod ( ntras9, ptras5, + > iaux, iaux, nbfn00-1, nbfmed-1, codre5 ) + call gmmod ( nhqufa//'.Codes', pcfaqu, + > nctfqu, nctfqu, nbfq00, nbfqua, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ntrae3 ) + call gmprsx (nompro, ntrae4 ) + call gmprsx (nompro, ntrae9 ) + call gmprsx (nompro, ntras4 ) + call gmprsx (nompro, ntras9 ) +#endif +c + endif +c +c 6.2. ==> Remplacement dans la structure generale des tableaux +c lies aux attributs +c + if ( codret.eq.0 ) then +c + call gmcpoj ( ntrae3, nhsupe//'.Tab3', codre1 ) + call gmcpoj ( ntrae4, nhsupe//'.Tab4', codre2 ) + call gmcpoj ( ntrae9, nhsupe//'.Tab9', codre3 ) + call gmcpoj ( ntras4, nhsups//'.Tab4', codre4 ) + call gmcpoj ( ntras9, nhsups//'.Tab9', codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmecat ( nhsupe, 3, nbfmed+1, codre1 ) + call gmecat ( nhsupe, 4, nattrc, codre2 ) + iaux = 25 * nattrc + call gmecat ( nhsups, 9, iaux, codre3 ) + call gmecat ( nhsupe, 9, nbfmed, codre4 ) + iaux = 4*nbfmed + call gmecat ( nhsups, 4, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsupe ) + call gmprsx (nompro, nhsupe//'.Tab3' ) + call gmprsx (nompro, nhsupe//'.Tab4' ) + call gmprsx (nompro, nhsupe//'.Tab9' ) + call gmprsx (nompro, nhsups ) + call gmprsx (nompro, nhsups//'.Tab4' ) + call gmprsx (nompro, nhsups//'.Tab9' ) +#endif +c + endif +c +c 6.3. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) + call gmlboj ( ntrav4, codre4 ) + call gmlboj ( ntrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmlboj ( ntra15, codre1 ) + call gmlboj ( ntra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + call gmlboj ( ntrae3, codre1 ) + call gmlboj ( ntrae4, codre2 ) + call gmlboj ( ntrae9, codre3 ) + call gmlboj ( ntras4, codre4 ) + call gmlboj ( ntras9, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 7. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ +70000 format(3x,20i4) + write(ulsort,*) 'Etape 7 avec codret = ', codret + write(ulsort,70000) (imem(pcfaqu+iaux),iaux=0,nctfqu*nbfqua-1) + write(ulsort,70000) (famqua(iaux),iaux=1,min(20,nbquto)) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfor1.F b/src/tool/AP_Conversion/pcfor1.F new file mode 100644 index 00000000..a509f958 --- /dev/null +++ b/src/tool/AP_Conversion/pcfor1.F @@ -0,0 +1,553 @@ + subroutine pcfor1 ( option, + > nofonc, nrfonc, + > nbpara, carenf, carchf, + > nopafo, nbfopa, + > nbtrav, litrav, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nbenmx, nbvapr, + > carsup, nbtafo, typint, + > lgtbix, tbiaux, + > advale, advalr, adobch, adprpg, adtyas, + > advatt, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Fonctions - Recuperation - phase 1 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . nofonc . e . char8 . nom de l'objet fonction similaire . +c . nrfonc . e . 1 . numero de la fonction dans le tableau . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : nbtafo . +c . . . . 9 : libre . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nopafo . es . 1 . nom du paquet de fonctions a enrichir . +c . nbfopa . s . 1 . nombre de fonctions du paquet a enrichir . +c . nbtrav . es . 1 . nombre de tableaux de travail crees . +c . litrav . es . * . liste des noms de tableaux de travail crees. +c . typcha . e . 1 . edin64/edfl64 selon entier/reel . +c . typgeo . e . 1 . type geometrique au sens MED . +c . ngauss . e . 1 . nombre de points de Gauss . +c . nbenmx . e . 1 . nombre d'entites maximum . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . nbtyas . e . 1 . nombre de types de support associes . +c . carsup . e . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par element . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . typint . e . . type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . lgtbix . e . 1 . nouveau nombre de types de support associes. +c . tbiaux . e . lgtbix . nouveaux types de support associes . +c . advale . s . 1 . adresse du tableau de valeurs entieres . +c . advalr . s . 1 . adresse du tableau de valeurs reelles . +c . adobch . s . 1 . adresse des noms des objets 'Champ' . +c . adprpg . s . 1 . adresse des noms des objets 'Profil' et . +c . . . . 'LocaPG' eventuellement associes . +c . adtyas . s . 1 . adresse des types associes . +c . advatt . s . 1 . adresse du tableau de travail . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFOR1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombsr.h" +#include "gmenti.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer option + integer nbpara + integer carenf(nbpara,*) +c + integer nrfonc + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nbenmx, nbvapr + integer carsup, nbtafo, typint + integer nbfopa, nbtrav + integer advale, advalr, adprpg, adtyas + integer adobch, advatt + integer lgtbix, tbiaux(lgtbix) +c + character*8 nofonc + character*8 carchf(nbpara,*) + character*8 litrav(*) + character*8 nopafo +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux + integer adobfo +c + integer ngausa, nnenma, nnvapa, nbtyaa + integer carsua, nbtafa, typina + integer apvane, anvala, anobca, anprpa, antyaa + integer codre1, codre2 + integer codre0 +c + character*8 nofon2 + character*8 saux08 + character*8 tbsaux(1) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Fonction de depart : '',a)' + texte(1,5) = '(''Fonction creee : '',a)' + texte(1,6) = '(''En retour de '',a,'', codret ='',i13)' +c + texte(2,4) = '(''Initial function : '',a)' + texte(2,5) = '(''Created function : '',a)' + texte(2,6) = '(''Back from '',a,'', codret ='',i13)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nofonc + write (ulsort,90002) 'option', option +#endif +cgn print *, 'DEBUT DE ',nompro, ' pour la fonction numero ',nrfonc +cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara) +cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9) +c +c==== +c 2. modification eventuelle des caracteristiques +c==== +c + if ( codret.eq.0 ) then +c + if ( option.eq.1 ) then +c +cgn write (ulsort,90002) 'typgeo initial', typgeo + typgeo = medt12(typgeo) +cgn write (ulsort,90002) 'ngauss typgeo', typgeo +c + if ( carsup.eq.1 ) then +cgn write (ulsort,90002) 'ngauss initial', ngauss + ngauss = mednnm(typgeo) +cgn write (ulsort,90002) 'nouveau ngauss', ngauss + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbenmx', nbenmx + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'typint', typint + write (ulsort,90002) 'lgtbix', lgtbix + if ( lgtbix.gt.0 ) then + write (ulsort,90002) '==> ', (tbiaux(iaux),iaux=1,lgtbix) + endif +#endif +c + endif +c +c==== +c 3. allocation de la fonction +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFO', nompro +#endif + call utalfo ( nofon2, typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then + write (ulsort,texte(langue,6)) 'utalfo', codret + endif + write (ulsort,texte(langue,5)) nofon2 + call gmprsx (nompro, nofon2 ) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + carenf( 1,nrfonc) = typfon + carenf( 2,nrfonc) = typcha + carenf( 3,nrfonc) = typgeo + carenf( 4,nrfonc) = nbtyas + carenf( 5,nrfonc) = ngauss + carenf( 6,nrfonc) = 0 + carenf( 7,nrfonc) = nbvapr + carenf( 8,nrfonc) = carsup + carenf( 9,nrfonc) = nbtafo + carenf(15,nrfonc) = nbenmx + carenf(16,nrfonc) = nbvapr + carenf(17,nrfonc) = advale + carenf(18,nrfonc) = advalr + carenf(19,nrfonc) = adobch + carenf(20,nrfonc) = adprpg + carenf(23,nrfonc) = adtyas +c + carchf( 1,nrfonc) = nofon2 +c + endif +c +c==== +c 4. caracteristiques des supports associes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. supports associes ; codret = ', codret +#endif +c +c 4.1. ==> S'il n'y a pas d'ajout de fonction pour la conformite, +c lgtbix vaut nbtyas. +c Donc si on avait deja des supports (nbtyas>0), il faut +c recopier le tableau. +c + if ( lgtbix.eq.nbtyas ) then +c + if ( nbtyas.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Copie de', nofonc//'.TypeSuAs', + > ' vers', nofon2//'.TypeSuAs' +#endif + call gmcpgp ( nofonc//'.TypeSuAs', + > nofon2//'.TypeSuAs', codret ) +c + endif +c + endif +c +c 4.2. ==> S'il y a de nouveau support, lgtbix est different de nbtyas. +c Il faut creer la liste des supports. +c + else +c + if ( lgtbix.gt.0 ) then +c +c 4.2.1. ==> On commence par detruire le tableau s'il existait +c + if ( codret.eq.0 ) then + if ( nbtyas.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Destruction de', nofon2//'.TypeSuAs' +#endif + call gmlboj( nofon2//'.TypeSuAs', codret ) + endif + endif +c +c 4.2.2. ==> Allocation du tableau et mise a jour de l'attribut +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Allocation de', nofon2//'.TypeSuAs' +#endif + iaux = lgtbix - 1 + call gmaloj ( nofon2//'.TypeSuAs', ' ', + > iaux, adtyas, codre1 ) + call gmecat ( nofon2, 5, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + endif +c +c 4.2.3. ==> Valeurs +c + if ( codret.eq.0 ) then +c + carenf( 4,nrfonc) = lgtbix - 1 + carenf(23,nrfonc) = adtyas +c + jaux = adtyas - 1 + do 423 , iaux = 1 , lgtbix + if ( tbiaux(iaux).ne.typgeo ) then + jaux = jaux + 1 + imem(jaux) = tbiaux(iaux) + endif + 423 continue +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nofon2 ) + call gmprsx ( nompro, nofon2//'.TypeSuAs' ) +#endif +c +c==== +c 5. copie des caracteristiques du champ +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. champ ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmcpgp ( nofonc//'.InfoCham', + > nofon2//'.InfoCham', codret ) +c + endif +c +c==== +c 6. dans le cas de support element, creation d'un tableau de +c travail pour gerer la renumerotation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. support element ; codret = ', codret +#endif +c + if ( typgeo.ne.0 ) then +c +c 6.1. ==> Taille +c + if ( codret.eq.0 ) then +c + iaux = nbtafo * rseutc +c + if ( ngauss.ne.ednopg ) then + iaux = ngauss*iaux + endif +c + endif +c +c 6.2. ==> Allocation +c + if ( codret.eq.0 ) then +cgn write (ulsort,90002) 'allocation a la taille', iaux +c + call gmalot ( saux08, 'reel ', iaux, advatt, codret ) +cgn write (ulsort,90003) 'allocation de', saux08 +c + endif +c +c 6.3. ==> Archivage +c + if ( codret.eq.0 ) then +c + nbtrav = nbtrav + 1 + litrav(nbtrav) = saux08 +cgn print *,nompro,' 2.3 nbtrav = ', nbtrav +cgn print *,'litrav(',nbtrav,') = ',saux08 +cgn carenf( 5,nrfonc) = ngauss + carenf(21,nrfonc) = advatt +c + endif +c + endif +c +c==== +c 7. dans le cas d'un champ aux points de Gauss avec un champ aux +c noeuds par elements associe, reperage de la fonction associee +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. support Gauss ; codret = ', codret +#endif +c + if ( carsup.eq.2 ) then +c + if ( codret.eq.0 ) then +c + saux08 = carchf(9,nrfonc) +cgn call gmprsx (nompro,saux08) +cgn call gmprsx (nompro,saux08//'.ValeursR') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( saux08, + > typcha, + > typgeo, ngausa, nnenma, nnvapa, nbtyaa, + > carsua, nbtafa, typina, + > anvala, apvane, anobca, anprpa, antyaa, + > ulsort, langue, codret ) +c + carenf(22,nrfonc) = apvane +cgn print *,'apvane = ',apvane +c + endif +c + endif +c +c==== +c 8. ajout de la fonction au paquet de sortie +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '8. ajout ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif + iaux = 1 + call utmopf ( nopafo, iaux, + > iaux, tbsaux, tbiaux, + > nofon2, + > nbfopa, jaux, kaux, laux, maux, + > adobfo, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nopafo ) + call gmprsx (nompro, nopafo//'.Fonction' ) + call gmprsx (nompro, nofon2//'.ValeursR' ) + call gmprsx (nompro, nofon2//'.InfoPrPG' ) +#endif +c +c==== +c 9. la fin +c==== +c +cgn print *, 'FIN DE ',nompro, ' pour la fonction numero ',nrfonc +cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara) +cgn 1788 format(10I8) +cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9) +cgn 1789 format(10(a8,1x)) +cgn print *, ' ' +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfor2.F b/src/tool/AP_Conversion/pcfor2.F new file mode 100644 index 00000000..ec6e9713 --- /dev/null +++ b/src/tool/AP_Conversion/pcfor2.F @@ -0,0 +1,364 @@ + subroutine pcfor2 ( nbpara, carenf, carchf, + > nrfonc, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > anvale, anvalr, anprpg, anobch, anlipr, + > npenmx, npvapr, + > apvale, apvalr, apprpg, apobch, apvatt, + > apvane, aptyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Fonctions - Recuperation - phase 2 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . e .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . e .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction a examiner . +c . typfon . s . 1 . 0, si ancienne isolee, 1, si ancienne . +c . . . . associee a une autre fonction, -1, si . +c . . . . nouvelle . +c . typcha . s . 1 . edin64/edfl64 selon entier/reel . +c . typgeo . s . 1 . type geometrique au sens MED . +c . ngauss . s . 1 . nombre de points de Gauss . +c . nbenmx . s . 1 . nombre d'entites maximum . +c . nbvapr . s . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . nbtyas . s . 1 . 0, si aucun autre type geometrique n'est . +c . . . . associe dans une autre fonction . +c . . . . n, produit des types associes . +c . nbtafo . s . 1 . nombre de tableaux de la fonction . +c . anvale . s . 1 . adresse du tableau de valeurs entieres . +c . anvalr . s . 1 . adresse du tableau de valeurs reelles . +c . anobch . s . 1 . adresse des noms des objets 'Champ' . +c . anprpg . s . 1 . adresse des noms des objets 'Profil' et . +c . . . . 'LocaPG' eventuellement associes . +c . anlipr . s . 1 . adresse du tableau de travail . +c . npenmx . s . 1 . nombre d'entites maximum . +c . npvapr . s . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . apvale . s . 1 . adresse du tableau de valeurs entieres . +c . apvalr . s . 1 . adresse du tableau de valeurs reelles . +c . apobch . s . 1 . adresse des noms des objets 'Champ' . +c . apprpg . s . 1 . adresse des noms des objets 'Profil' et . +c . . . . 'LocaPG' eventuellement associes . +c . apvatt . s . 1 . adresse du tableau de travail . +c . nofonc . s . char*8 . nom de la fonction . +c . obpcan . s . char*8 . objet du profil en entree . +c . obpcap . s . char*8 . objet du profil en sortie . +c . obprof . s . char*8 . objet du profil global . +c . oblopg . s . char*8 . objet de la localisation des pts de Gauss . +c . adpcan . s . 1 . adresse du profil en entree . +c . adpcap . s . 1 . adresse du profil en sortie . +c . nrfon2 . s . 1 . numero de la 1ere fonction associee . +c . nrfon3 . s . 1 . numero de la 2nde fonction associee . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFOR2' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbpara + integer carenf(nbpara,*) +c + integer nrfonc + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer anvale, anvalr, anprpg, anobch, anlipr + integer npenmx, npvapr + integer apvale, apvalr, apprpg, apobch, apvatt + integer apvane, aptyas + integer adpcan, adpcap + integer nrfon2, nrfon3 +c + character*8 carchf(nbpara,*) + character*8 nofonc, obpcan, obpcap, obprof + character*8 oblopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(''.... profil '',a,'' : '',a)' +c + texte(2,6) = '(''.... profile '',a,'' : '',a)' +c +#include "pcimp1.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +cgn write(ulsort,90002) 'carenf ',(carenf(iaux,nrfonc),iaux= 1,10) +cgn write(ulsort,90002) 'carenf ',(carenf(iaux,nrfonc),iaux=11,20) +cgn write(ulsort,90002) 'carenf ', +cgn > (carenf(iaux,nrfonc),iaux=21,nbpara) +cgn write(ulsort,90003) 'carchf ',(carchf(iaux,nrfonc),iaux= 1,9) +#endif +c +c==== +c 2. le nom de l'objet fonction +c==== +c + if ( codret.eq.0 ) then +c + nofonc = carchf( 1,nrfonc) +c + endif +c +c==== +c 3. les entiers +c==== +c + if ( codret.eq.0 ) then +c + typfon = carenf( 1,nrfonc) + typcha = carenf( 2,nrfonc) + typgeo = carenf( 3,nrfonc) + nbtyas = carenf( 4,nrfonc) + ngauss = carenf( 5,nrfonc) + nnenmx = carenf( 6,nrfonc) + nnvapr = carenf( 7,nrfonc) + carsup = carenf( 8,nrfonc) + nbtafo = carenf( 9,nrfonc) +c + anvale = carenf(10,nrfonc) + anvalr = carenf(11,nrfonc) + anobch = carenf(12,nrfonc) + anprpg = carenf(13,nrfonc) + anlipr = carenf(14,nrfonc) +c + npenmx = carenf(15,nrfonc) + npvapr = carenf(16,nrfonc) +c + apvale = carenf(17,nrfonc) + apvalr = carenf(18,nrfonc) + apobch = carenf(19,nrfonc) + apprpg = carenf(20,nrfonc) + apvatt = carenf(21,nrfonc) +c + apvane = carenf(22,nrfonc) +c + aptyas = carenf(24,nrfonc) +c + nrfon2 = carenf(25,nrfonc) + nrfon3 = carenf(26,nrfonc) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nnenmx', nnenmx + write (ulsort,90002) 'nnvapr', nnvapr + write (ulsort,90002) 'nbtafo', nbtafo +c + write (ulsort,90002) 'npenmx', npenmx + write (ulsort,90002) 'npvapr', npvapr +c + write (ulsort,90002) 'anvale', anvale + write (ulsort,90002) 'anvalr', anvalr + write (ulsort,90002) 'anobch', anobch + write (ulsort,90002) 'anprpg', anprpg + write (ulsort,90002) 'anlipr', anlipr +c + write (ulsort,90002) 'apvale', apvale + write (ulsort,90002) 'apvalr', apvalr + write (ulsort,90002) 'apobch', apobch + write (ulsort,90002) 'apprpg', apprpg + write (ulsort,90002) 'apvatt', apvatt +c + write (ulsort,90002) 'apvane', apvane +c + write (ulsort,90002) 'aptyas', aptyas +c + write (ulsort,90002) 'nrfon2', nrfon2 + write (ulsort,90002) 'nrfon3', nrfon3 +#endif +c +c==== +c 4. les noms des profils +c==== +c + if ( codret.eq.0 ) then +c + obpcan = carchf( 4,nrfonc) + obpcap = carchf( 5,nrfonc) + obprof = carchf( 6,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,6)) 'n', obpcan + call gmprsx (nompro,obpcan) + write (ulsort,texte(langue,6)) 'p', obpcap + call gmprsx (nompro,obpcap) + write (ulsort,texte(langue,6)) 'g', obprof +#endif +c + if ( typfon.ge.0 ) then + call gmadoj ( obpcan, adpcan, iaux, codre1 ) + else + codre1 = 0 + endif + call gmadoj ( obpcap, adpcap, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 5. les localisations de points de Gauss +c==== +c + if ( codret.eq.0 ) then +c + oblopg = carchf( 7,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + if ( oblopg.ne.blan08 ) then + write (ulsort,*) ' ' + write (ulsort,*) 'Objet localisations des points de Gauss' + call gmprsx (nompro,oblopg) + endif +#endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcfore.F b/src/tool/AP_Conversion/pcfore.F new file mode 100644 index 00000000..fcbe4cc5 --- /dev/null +++ b/src/tool/AP_Conversion/pcfore.F @@ -0,0 +1,1104 @@ + subroutine pcfore ( option, extrus, + > nnfopa, anobfo, + > npfopa, nppafo, + > nbpara, carenf, carchf, + > nbtrav, litrav, + > adpetr, adhequ, + > adnohn, admphn, adarhn, adtrhn, adquhn, + > adtehn, adpyhn, adhehn, adpehn, + > adnocn, admpcn, adarcn, adtrcn, adqucn, + > adtecn, adpycn, adhecn, adpecn, + > adnoin, admpin, adarin, adtrin, adquin, + > adtein, adpyin, adhein, adpein, + > lgnoin, lgmpin, lgarin, lgtrin, lgquin, + > lgtein, lgpyin, lghein, lgpein, + > decanu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Fonctions - REcuperation +c - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . extrus . e . 1 . prise en compte d'extrusion . +c . nnfopa . e . 1 . nombre de fonctions du paquet iteration n . +c . anobfo . e . 1 . adresse des noms des fonctions n . +c . npfopa . s . 1 . nombre de fonctions du paquet iteration p . +c . nppafo . es . 1 . nom du paquet de fonctions iteration p . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nbtrav . es . 1 . nombre de tableaux de travail crees . +c . litrav . es . * . liste des noms de tableaux de travail crees. +c . adnohn . e . 1 . adresse de la renum. des noeuds en entree . +c . admphn . e . 1 . adresse de la renum. des m.poi. en entree . +c . adarhn . e . 1 . adresse de la renum. des aretes en entree . +c . adtrhn . e . 1 . adresse de la renum. des tria. en entree . +c . adquhn . e . 1 . adresse de la renum. des quad. en entree . +c . adtehn . e . 1 . adresse de la renum. des tetras. en entree . +c . adpyhn . e . 1 . adresse de la renum. des pyras. en entree . +c . adhehn . e . 1 . adresse de la renum. des hexas. en entree . +c . adpehn . e . 1 . adresse de la renum. des pentas. en entree . +c . decanu . e . -1:7 . decalage des numerotations selon le type . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCFORE' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#ifdef _DEBUG_HOMARD_ +#include "gmreel.h" +#endif +#include "gmenti.h" +#include "gmstri.h" +c +#include "nombtr.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nbutil.h" +#include "nomber.h" +#include "nombsr.h" +#include "esutil.h" +c +c 0.3. ==> arguments +c + integer option + integer nbpara + integer nnfopa, anobfo + integer npfopa + integer nbtrav + integer adpetr, adhequ + integer carenf(nbpara,*) + integer adnohn, admphn, adarhn, adtrhn, adquhn + integer adtehn, adpyhn, adhehn, adpehn + integer adnocn, admpcn, adarcn, adtrcn, adqucn + integer adtecn, adpycn, adhecn, adpecn + integer adnoin, admpin, adarin, adtrin, adquin + integer adtein, adpyin, adhein, adpein + integer lgnoin, lgmpin, lgarin, lgtrin, lgquin + integer lgtein, lgpyin, lghein, lgpein + integer decanu(-1:7) +c + character*8 nppafo + character*8 carchf(nbpara,*) + character*8 litrav(*) +c + logical extrus +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux, naux + integer nrfonc, nrfonm + integer nbent2, ngaus2, dimcp2, typge2, nrfon2 + integer nbent3, ngaus3, dimcp3, typge3, nrfon3 +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, nnvapr + integer carsup, nbtafo, typint + integer anvale, anvalr, anobch, anprpg, antyas + integer apvale, apvalr, apobch, apprpg, aptyas + integer nbpg, nbsufo + integer anlipr + integer apvatt + integer apobfo, aptyge + integer apobfa, aptyga + integer adtra1 +c + integer reenac, rsenac + integer advofa, advohn, advocn + integer adenhn, adencn + integer lgenin, adenin + integer adpcan, adpcap + integer tbiaux(nbinec), lgtbix + integer decala +c + character*8 nnfonc + character*8 obpcan, obpcap, oblopg + character*8 oblop2 + character*8 oblop3 + character*8 nppafa + character*8 saux08 + character*8 tbsaux(1) + character*8 ntrav1 + character*64 noprof + character*64 nolop2 + character*64 nolop3 +c + logical afair2, afair3 + logical extrul +c + integer nbmess + parameter ( nbmess = 120 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,60(''-''),/,''Fonction '',i3,'', objet = '',a)' + texte(1,5) = '(''Type de support geometrique :'',i5)' + texte(1,6) = '(''On ne sait pas faire aujourd''''hui.'',/)' + texte(1,7) = '(/,''Creation de la fonction a l''''iteration p'')' + texte(1,8) = '(/,''Probleme de conformite ?'')' + texte(1,9) = + > '(/,''Creation d''''une fonction pour la conformite'')' + texte(1,10) = '(''En retour de '',a,'', codret ='',i13)' + texte(1,13) = '(''... Premiere valeur : '',g14.7)' + texte(1,14) = '(''... Derniere valeur : '',g14.7)' + texte(1,15) = '(''... Profil : '',a32)' + texte(1,16) = '(''... Premiere(s) valeur(s) : '',5i10)' + texte(1,17) = '(''... Derniere(s) valeur(s) : '',5i10)' + texte(1,18) = + > '(''Les deux longueurs de profil sont differentes !'')' + texte(1,19) = '(''Caracteristiques du support :'',i5)' +c + texte(2,4) = '(/,60(''-''),/,''Function '',i3,'', objet = '',a)' + texte(2,5) = '(''Geometric support type :'',i5)' + texte(2,6) = '(''It cannot be solved.'',/)' + texte(2,7) = '(/,''Creation of a function for iteration # p'')' + texte(2,8) = '(/,''Pending nodes ?'')' + texte(2,9) = '(/,''Creation of a function for pending nodes'')' + texte(2,10) = '(''Back from '',a,'', codret ='',i13)' + texte(2,13) = '(''... First value : '',g14.7)' + texte(2,14) = '(''... Last value : '',g14.7)' + texte(2,15) = '(''... Profile : '',a32)' + texte(2,16) = '(''... First value(s) : '',5i10)' + texte(2,17) = '(''... Last value(s) : '',5i10)' + texte(2,18) = + > '(''The two lengths of profile are not the same !'')' + texte(2,19) = '(''Characteristics of the support:'',i5)' +c +#include "impr03.h" +c + npfopa = 0 + nrfonm = nnfopa +c +c==== +c 2. prealable pour les couples (aux noeuds par element/aux points +c de Gauss) +c==== +c +c 2.1. ==> decodage de nppafo, paquet a l'iteration p +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,nppafo) +cgn call gmprsx (nompro,nppafo//'.Fonction') +cgn call gmprsx (nompro,nppafo//'.TypeSuAs') + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( nppafo, + > iaux, jaux, kaux, laux, maux, + > apobfo, aptyge, + > ulsort, langue, codret ) +c +c 2.2. ==> si c'est un champ aux points de Gauss, on repere nppafa, +c paquet correspondant, a l'iteration p. +c + if ( laux.eq.2 ) then +c + if ( codret.eq.0 ) then +c + nppafa = smem(apobfo+npfopa) +cgn write (ulsort,*) 'Paquet correspondant ==> ',nppafa +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro + call gmprsx (nompro,nppafa) + call gmprsx (nompro,nppafa//'.Fonction') +#endif + call utcapf ( nppafa, + > iaux, jaux, kaux, laux, maux, + > apobfa, aptyga, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. parcours des fonctions du paquet a l'iteration n +c==== +c + do 30 , nrfonc = 1 , nnfopa +c + nnfonc = smem(anobfo+nrfonc-1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc, nnfonc + call gmprsx (nompro,nnfonc) + call gmprsx (nompro,nnfonc//'.InfoPrPG') + call gmprsx (nompro,nnfonc//'.TypeSuAs') +#endif +c +c 3.1. ==> caracteristiques de la fonction a l'iteration n +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nnfonc, + > typcha, + > typgeo, ngauss, nnenmx, nnvapr, nbtyas, + > carsup, nbtafo, typint, + > anvale, anvalr, anobch, anprpg, antyas, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'utcafo', codret +#endif +c + nbpg = ngauss + oblopg = smem(anprpg+1) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nnenmx', nnenmx + write (ulsort,90002) 'nnvapr', nnvapr + write (ulsort,90002) 'nbtyas', nbtyas + if ( nbtyas.gt.0 ) then + write (ulsort,90002) + > '==> typass', (imem(antyas+iaux-1),iaux=1,nbtyas) + endif + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,*) '.. oblopg : ', oblopg +cgn write (ulsort,texte(langue,13)) rmem(anvalr) +cgn write (ulsort,texte(langue,14)) +cgn > rmem(anvalr+nnenmx*nbtafo*nbpg-1) +#endif +c + if ( nbtyas.ge.1 ) then + typfon = 1 + else + typfon = 0 + endif + carenf( 1,nrfonc) = typfon + carenf( 2,nrfonc) = typcha + carenf( 3,nrfonc) = typgeo + carenf( 4,nrfonc) = nbtyas + carenf( 5,nrfonc) = nbpg + carenf( 6,nrfonc) = nnenmx + carenf( 7,nrfonc) = nnvapr + carenf( 8,nrfonc) = carsup + carenf( 9,nrfonc) = nbtafo + carenf(10,nrfonc) = anvale + carenf(11,nrfonc) = anvalr + carenf(12,nrfonc) = anobch + carenf(13,nrfonc) = anprpg + carenf(23,nrfonc) = antyas +c + carchf( 2,nrfonc) = nnfonc + carchf( 7,nrfonc) = oblopg +c + endif +c +c 3.2. ==> pour une fonction aux points de Gausss avec un champ aux +c noeuds par elements associe, la fonction associee +c + if ( carsup.eq.2 ) then +c + if ( codret.eq.0 ) then +c + carchf(8,nrfonc) = smem(anprpg+2) + carchf(9,nrfonc) = smem(apobfa+nrfonc-1) +cgn call gmprsx (nompro,carchf(9,nrfonc)) +c + endif +c + endif +c +c 3.3. ==> le profil eventuel +c + if ( nnvapr.gt.0 ) then +c +c 3.3.1. ==> les caracteristiques du profil +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( smem(anprpg), + > jaux, noprof, anlipr, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'utcapr', codret + write (ulsort,texte(langue,13)) 'jaux', jaux + write (ulsort,texte(langue,15)) noprof + write (ulsort,texte(langue,16)) + > (imem(anlipr+iaux),iaux=0,min(4,jaux-1)) + if ( nnvapr.gt.5 ) then + write (ulsort,texte(langue,17)) + > (imem(anlipr+iaux),iaux=jaux-5,jaux-1) + endif +#endif +c +c 3.3.2. ==> on verifie que les longueurs sont bien les memes : celle +c enregistree dans le profil, jaux, et celle enregistree +c dans la fonction, nnvapr. +c + if ( jaux.ne.nnvapr ) then + write (ulsort,90002) 'nnvapr', nnvapr + write (ulsort,90002) 'jaux ', jaux + write (ulsort,texte(langue,18)) + codret = 3 + endif +c + carenf(14,nrfonc) = anlipr +c + endif +c + endif +c +c 3.4. ==> creation de fonctions associees pour la conformite : +c . quand la fonction courante est definie sur des quadrangles, +c des hexaedres ou des pentaedres +c . que des mailles de conformite sont presentes +c . qu'il n'a pas de fonction associee sur ces mailles de conformite +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. creer une fonction ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'nbtrq3', nbtrq3 + write (ulsort,90002) 'nbheco', nbheco + write (ulsort,90002) 'nbpeco', nbpeco + write (ulsort,90002) 'nbtyas', nbtyas +#endif +c + nrfon2 = -1 + afair2 = .false. + ngaus2 = ngauss + nrfon3 = -1 + afair3 = .false. + ngaus3 = ngauss + typge3 = 0 +c + if ( ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) .and. + > nbtrq3.gt.0 ) then + if ( typgeo.eq.edqua4 ) then + nbent2 = nbtria + typge2 = edtri3 + if ( carsup.eq.1 ) then + ngaus2 = 3 + dimcp2 = 2 + elseif ( carsup.eq.2 .or. carsup.eq.3 ) then + codret = 341 + endif + else + nbent2 = nbtria + typge2 = edtri6 + if ( carsup.eq.1 ) then + ngaus2 = 6 + dimcp2 = 2 + elseif ( carsup.eq.2 .or. carsup.eq.3 ) then + codret = 342 + endif + endif + afair2 = .true. + do 341 , iaux = 1 , nbtyas + if ( imem(antyas+iaux-1).eq.typge2 ) then + nrfon2 = iaux + afair2 = .false. + endif + 341 continue +c + elseif ( ( ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) .and. + > nbheco.ne.0 ) .or. + > ( ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) .and. + > nbpeco.ne.0 ) ) then + if ( typgeo.eq.edhex8 .or. typgeo.eq.edpen6 ) then + nbent2 = nbtetr + typge2 = edtet4 + nbent3 = nbpyra + typge3 = edpyr5 + if ( carsup.eq.1 ) then + ngaus2 = 4 + ngaus3 = 5 + dimcp2 = 3 + dimcp3 = 3 + elseif ( carsup.eq.2 .or. carsup.eq.3 ) then + codret = 343 + endif + elseif ( typgeo.eq.edhe20 .or. typgeo.eq.edpe15 ) then + nbent2 = nbtetr + typge2 = edte10 + nbent3 = nbpyra + typge3 = edpy13 + if ( carsup.eq.1 ) then + ngaus2 = 10 + ngaus3 = 13 + dimcp2 = 3 + dimcp3 = 3 + elseif ( carsup.eq.2 .or. carsup.eq.3 ) then + codret = 344 + endif + else + codret = 340 + endif + afair2 = .true. + afair3 = .true. + do 342 , iaux = 1 , nbtyas + if ( imem(antyas+iaux-1).eq.typge2 ) then + nrfon2 = iaux + afair2 = .false. + endif + if ( imem(antyas+iaux-1).eq.typge3 ) then + nrfon3 = iaux + afair3 = .false. + endif + 342 continue +c + endif +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,5)) typgeo + write (ulsort,texte(langue,19)) carsup + write (ulsort,texte(langue,68)) + write (ulsort,texte(langue,6)) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'afair2', afair2 + write (ulsort,99001) 'afair3', afair3 +#endif +c +c 3.5. ==> bilan sur les types +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. bilan type ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c memorisation des eventuels types associes deja presents +c + lgtbix = 0 + do 35 , iaux = 1 , nbtyas + lgtbix = lgtbix + 1 + tbiaux(lgtbix) = imem(antyas+iaux-1) + 35 continue +c +c si conformite, ajout du type courant et du/des types associes +c + if ( afair2 .or. afair3 ) then +c + lgtbix = lgtbix + 1 + tbiaux(lgtbix) = typgeo + if ( afair2 ) then + lgtbix = lgtbix + 1 + tbiaux(lgtbix) = typge2 + endif + if ( afair3 ) then + lgtbix = lgtbix + 1 + tbiaux(lgtbix) = typge3 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tbiaux = ', (tbiaux(iaux),iaux=1,lgtbix) +#endif + endif +c +c 3.6. ==> la fonction similaire a l'iteration p +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. similaire ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) +#endif +c + if ( typgeo.eq.0 ) then + nbsufo = rsnoto + elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then + nbsufo = nbsegm + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then + nbsufo = nbtria + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then + nbsufo = nbquad + elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then + nbsufo = nbtetr + elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then + nbsufo = nbhexa + elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then + nbsufo = nbpyra + elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then + nbsufo = nbpent + else + write (ulsort,texte(langue,5)) typgeo + write (ulsort,texte(langue,6)) + codret = 3 + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = nrfonc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR1_p', nompro +#endif + call pcfor1 ( option, + > nnfonc, iaux, + > nbpara, carenf, carchf, + > nppafo, npfopa, + > nbtrav, litrav, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nbsufo, nnvapr, + > carsup, nbtafo, typint, + > lgtbix, tbiaux, + > apvale, apvalr, apobch, apprpg, aptyas, + > apvatt, + > ulsort, langue, codret ) +c + endif +c +c 3.7. ==> pour les champs aux noeuds par elements, creation de la +c localisation des pseudo "points de Gauss" +c REMARQUE : on ne cree plus rien +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7. pseudo ; codret', codret + write (ulsort,90002) 'carsup', carsup + write (ulsort,99001) 'afair2', afair2 + write (ulsort,99001) 'afair3', afair3 +#endif +c + if ( afair2 .and. carsup.eq.1793 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCRPG-2', nompro +#endif + call utcrpg ( oblop2, + > nolop2, typge2, ngaus2, dimcp2, carsup, + > ulsort, langue, codret ) +c + endif +c + else +c + oblop2 = blan08 +c + endif +c + if ( afair3 .and. carsup.eq.1793 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCRPG-3', nompro +#endif + call utcrpg ( oblop3, + > nolop3, typge3, ngaus3, dimcp3, carsup, + > ulsort, langue, codret ) +c + endif +c + else +c + oblop3 = blan08 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'oblop2', oblop2 + write (ulsort,90003) 'oblop3', oblop3 +#endif +c +c 3.8. ==> creation des fonctions pour la conformite +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.8. conformite ; codret', codret +#endif +c 3.8.1. ==> 1ere fonction +c + if ( afair2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) +#endif +c + nrfonm = nrfonm + 1 + nrfon2 = nrfonm + typfon = -1 + laux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR1_2', nompro +#endif + call pcfor1 ( option, + > nnfonc, nrfon2, + > nbpara, carenf, carchf, + > nppafo, npfopa, + > nbtrav, litrav, + > typfon, typcha, typge2, nbtyas, + > ngaus2, nbent2, laux, + > carsup, nbtafo, typint, + > lgtbix, tbiaux, + > apvale, apvalr, apobch, apprpg, aptyas, + > apvatt, + > ulsort, langue, codret ) +c + carchf( 2,nrfon2) = nnfonc + carchf( 3,nrfon2) = carchf( 1,nrfonc) + carchf( 7,nrfon2) = oblop2 +c + endif +c + endif +c +c 3.8.2. ==> 2nde fonction +c + if ( afair3 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) +#endif +c + nrfonm = nrfonm + 1 + nrfon3 = nrfonm + typfon = -1 + laux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR1_3', nompro +#endif + call pcfor1 ( option, + > nnfonc, nrfon3, + > nbpara, carenf, carchf, + > nppafo, npfopa, + > nbtrav, litrav, + > typfon, typcha, typge3, nbtyas, + > ngaus3, nbent3, laux, + > carsup, nbtafo, typint, + > lgtbix, tbiaux, + > apvale, apvalr, apobch, apprpg, aptyas, + > apvatt, + > ulsort, langue, codret ) +c + carchf( 2,nrfon3) = nnfonc + carchf( 3,nrfon3) = carchf( 1,nrfonc) + carchf( 7,nrfon3) = oblop3 +c + endif +c + endif +c +c 3.9. ==> modification des types associes du paquet de fonction +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.9. modification ; codret', codret +#endif +c + if ( afair2 .or. afair3 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif + iaux = 5 + call utmopf ( nppafo, iaux, + > lgtbix, tbsaux, tbiaux, + > saux08, + > jaux, nbtyas, ngauss, laux, maux, + > naux, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nppafo ) + call gmprsx (nompro, nppafo//'.Fonction' ) + call gmprsx (nompro, nppafo//'.TypeSuAs') + endif +#endif +c +c 3.10. ==> Enregistrement des numeros de fonctions associees, +c reelles ou fictives +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrfon2', nrfon2 + write (ulsort,90002) 'nrfon3', nrfon3 +#endif +c + carenf(25,nrfonc) = nrfon2 + carenf(26,nrfonc) = nrfon3 +c + endif +c + 30 continue +c +c==== +c 4. preparation des profils des fonctions du paquet +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Preparation ; codret', codret +#endif +c + do 40 , nrfonc = 1 , nrfonm +c +cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara) +c +c 4.1. ==> recuperation des informations +c + if ( codret.eq.0 ) then +c + typgeo = carenf( 3,nrfonc) + nnvapr = carenf( 7,nrfonc) + anlipr = carenf(14,nrfonc) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nnvapr', nnvapr +#endif +c + extrul = .false. + if ( typgeo.eq.0 ) then + reenac = renoac + rsenac = rsnoto + adenhn = adnohn + adencn = adnocn + lgenin = lgnoin + adenin = adnoin + decala = decanu(-1) + elseif ( typgeo.eq.edpoi1 ) then + reenac = rempac + rsenac = rsmpac + adenhn = admphn + adencn = admpcn + lgenin = lgmpin + adenin = admpin + decala = decanu(0) + elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then + reenac = rearac + rsenac = rsarac + adenhn = adarhn + adencn = adarcn + lgenin = lgarin + adenin = adarin + decala = decanu(1) + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then + reenac = retrac + rsenac = rstrac + adenhn = adtrhn + adencn = adtrcn + lgenin = lgtrin + adenin = adtrin + decala = decanu(2) + extrul = extrus + advofa = adpetr + advohn = adpehn + advocn = adpecn + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then + reenac = requac + rsenac = rsquac + adenhn = adquhn + adencn = adqucn + lgenin = lgquin + adenin = adquin + decala = decanu(4) + extrul = extrus + advofa = adhequ + advohn = adhehn + advocn = adhecn + elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then + reenac = reteac + rsenac = rsteac + adenhn = adtehn + adencn = adtecn + lgenin = lgtein + adenin = adtein + decala = decanu(3) + elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then + reenac = repyac + rsenac = rspyac + adenhn = adpyhn + adencn = adpycn + lgenin = lgpyin + adenin = adpyin + decala = decanu(5) + elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then + reenac = reheac + rsenac = rsheac + adenhn = adhehn + adencn = adhecn + lgenin = lghein + adenin = adhein + decala = decanu(6) + elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then + reenac = repeac + rsenac = rspeac + adenhn = adpehn + adencn = adpecn + lgenin = lgpein + adenin = adpein + decala = decanu(7) + else + codret = 41 + endif +c + endif +c +c 4.2. ==> tableau reciproque de nenin +c + if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', reenac, adtra1, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTBRC', nompro +#endif + call uttbrc ( iaux, + > lgenin, imem(adenin), reenac, imem(adtra1), + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.3. ==> prise en compte du profil +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nnvapr', nnvapr + write (ulsort,90002) 'reenac', reenac + write (ulsort,90002) 'rsenac', rsenac + write (ulsort,90002) 'decala', decala + write (ulsort,99001) 'extrul', extrul +#endif +c + if ( .not.extrul ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05', nompro +#endif + call utpr05 ( iaux, nnvapr, imem(anlipr), + > reenac, rsenac, + > imem(adenhn), imem(adencn), decala, + > lgenin, imem(adenin), imem(adtra1), + > obpcan, obpcap, + > adpcan, adpcap, + > ulsort, langue, codret ) +c + endif +c + else +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR06', nompro +#endif + call utpr06 ( iaux, + > reenac, rsenac, + > imem(advofa), imem(adenhn), + > imem(advohn), imem(advocn), + > obpcan, obpcap, + > adpcan, adpcap, + > ulsort, langue, codret ) +c + endif +c + endif +cgn call gmprsx (nompro,obpcap) +c +c 4.4. ==> archivage +c + if ( codret.eq.0 ) then +c + carchf (4,nrfonc) = obpcan + nbtrav = nbtrav + 1 + litrav(nbtrav) = obpcan +cgn write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcan = ', obpcan +cgn print *,'litrav(',nbtrav,') = ',litrav(nbtrav) +c + carchf (5,nrfonc) = obpcap + nbtrav = nbtrav + 1 + litrav(nbtrav) = obpcap +cgn write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcap = ', obpcap +cgn print *,'litrav(',nbtrav,') = ',litrav(nbtrav) +c + endif +c + nnfonc = carchf(1,nrfonc) +cgn write (*,texte(langue,4)) nrfonc, nnfonc +cgn write (*,1788)(carenf(iaux,nrfonc),iaux=1,nbpara) +cgn 1788 format(10I8) +cgn write (*,1789)(carchf(iaux,nrfonc),iaux=1,nbpara) +cgn 1789 format(10(a8,1x)) +c +c 4.5. ==> menage +c + if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codret ) +c + endif +c + endif +c + 40 continue +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcimp0.h b/src/tool/AP_Conversion/pcimp0.h new file mode 100644 index 00000000..1f81b8ad --- /dev/null +++ b/src/tool/AP_Conversion/pcimp0.h @@ -0,0 +1,3 @@ + 1792 format(/,a, + > /,'Etape n : numero homard',i6,', etat etan =',i3, + > /,'Etape n+1 : numero homard',i6,', etat etanp1 =',i3) diff --git a/src/tool/AP_Conversion/pcimp1.h b/src/tool/AP_Conversion/pcimp1.h new file mode 100644 index 00000000..7d5065e9 --- /dev/null +++ b/src/tool/AP_Conversion/pcimp1.h @@ -0,0 +1,9 @@ + texte(1,4) = '(''.. Fonction numero '',i6)' + texte(1,8) = '(''Champ aux noeuds par '',a)' + texte(1,9) = '(''Champ aux points de Gauss sur les '',a)' + texte(1,10) = '(''Interpolation non disponible'')' +c + texte(2,4) = '(''.. Function # '',i6)' + texte(2,8) = '(''Field over nodes per '',a)' + texte(2,9) = '(''Field over the Gauss points of the '',a)' + texte(2,10) = '(''Non available interpolation'')' diff --git a/src/tool/AP_Conversion/pcimp2.h b/src/tool/AP_Conversion/pcimp2.h new file mode 100644 index 00000000..8860abf3 --- /dev/null +++ b/src/tool/AP_Conversion/pcimp2.h @@ -0,0 +1,4 @@ +c + texte(1,4) = '(''Hexaedre '',i10,'', d''''etat'',i5)' +c + texte(2,4) = '(''Hexahedron #'',i10,'', with state'',i5)' diff --git a/src/tool/AP_Conversion/pcma21.F b/src/tool/AP_Conversion/pcma21.F new file mode 100644 index 00000000..8c01e49e --- /dev/null +++ b/src/tool/AP_Conversion/pcma21.F @@ -0,0 +1,412 @@ + subroutine pcma21 ( choixd, deltac, + > nbnoto, nbelem, famnoe, coonoe, + > famnzz, nbno3d, + > typele, noeele, + > nu3dno, famn3d, coon3d, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - 2D/3D - phase 1 +c - - -- - - +c Creation des noeuds supplementaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choixd . e . 1 . choix sur le calcul de delta coordonnes : . +c . . . . 1 : coordonnees initiales (defaut) . +c . . . . 2 : valeur imposee . +c . . . . 3 : moyenne arithmetique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 4 : moyenne geometrique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 5 : ecart initial, divise par 2**nivsup . +c . deltac . e . 1 . valeur de delta si impose (choixd=1) . +c . nbnoto . e . 1 . nombre de noeuds du maillage externe . +c . nbelem . e . 1 . nombre d'elements du maillage externe . +c . famnoe . e . nbnoto . famille des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . famnzz . e . 1 . famille du noeud memorisant cooinf et coosup . +c . nbno3d . e . 1 . nombre de noeuds du maillage 3d . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . nu3dno . s . nbnoto . numero du calcul des noeuds . +c . famn3d . s . nbno3d . famille des noeuds du maillage 3d . +c . coon3d . s .nbno3d*3. coordonnees des noeuds du maillage 3d . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMA21' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "meddc0.h" +#include "envca1.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + integer choixd + integer nbnoto, nbelem, famnzz, nbno3d + integer nu3dno(nbnoto) + integer famnoe(nbnoto), famn3d(nbno3d) + integer typele(nbelem), noeele(nbelem,*) +c + double precision deltac + double precision coon3d(nbno3d,3) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer iaux1, iaux2 +c + double precision cooinf, coosup + double precision daux, daux1, daux2 + double precision minx, miny, maxx, maxy +c + character*1 saux01 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,5) = + >'(''Nombre de noeuds attendus pour le maillage 2D :'',i10)' + texte(1,6) = + >'(''Nombre de noeuds trouves pour le maillage 2D :'',i10)' + texte(1,7) = '(''Recherche du noeud de la famille '',i8)' + texte(1,8) = '(''Aucun noeud n''''est de la famille '',i8)' + texte(1,9) = '(''Impossible de retrouver cooinf et coosup.'')' + texte(1,10) = + > '(''Maille en '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,11) = '(''Choix du calcul de delta '',a1,'' :'',i8)' + texte(1,12) = '(''Ce choix est inconnu.'')' + texte(1,13) = '(''Delta '',a1,'' initial.'')' + texte(1,14) = '(''Delta '',a1,'' impose.'')' + texte(1,15) = + >'(''D'',a1,'' = moyenne arithmetique des mini/maxi des mailles'')' + texte(1,16) = + > '(''D'',a1,'' = moyenne geometrique des mini/maxi des mailles'')' + texte(1,17) = '(''D'',a1,'' = D initial / 2**nivsup'')' +c + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,5) = + > '(''Expected number of nodes for the 2D mesh :'',i10)' + texte(2,6) = + > '(''Found number of nodes for the 2D mesh :'',i10)' + texte(2,7) = '(''Searching for node with family # '',i8)' + texte(2,8) = '(''No node belongs to family # '',i8)' + texte(2,9) = '(''cooinf and coosup cannot be found.'')' + texte(2,10) = + > '(''Mesh along '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,11) = '(''Choice for delta '',a1,'' calculation :'',i8)' + texte(2,12) = '(''This choice is unknown :'',i8)' + texte(2,13) = '(''Initial Delta '',a1,''.'')' + texte(2,14) = '(''Imposed Delta '',a1,''.'')' + texte(2,15) = + > '(''D'',a1,'' = arithmetic mean of mini/maxi of meshes'')' + texte(2,16) = + > '(''D'',a1,'' = geometric mean of mini/maxi of meshes'')' + texte(2,17) = '(''D'',a1,'' = initial / 2**nivsup'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maextr', maextr +#endif + if ( maextr.eq.1 ) then + saux01 = 'X' + iaux1 = 2 + iaux2 = 3 + elseif ( maextr.eq.2 ) then + saux01 = 'Y' + iaux1 = 1 + iaux2 = 3 + elseif ( maextr.eq.3 ) then + saux01 = 'Z' + iaux1 = 1 + iaux2 = 2 + else + codret = 1 + endif +c +c==== +c 2. Quelle epaisseur ? +c==== +c 2.1. ==> recuperation des cotes initiales des faces inferieures et +c superieures, en examinant le noeud supplementaire : +c ( x = cooinf , y = coosup ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) famnzz +#endif +c + do 21 , iaux = 1 , nbnoto +c + if ( famnoe(iaux).eq.famnzz ) then +c + cooinf = coonoe(iaux,1) + coosup = coonoe(iaux,2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) saux01, cooinf, coosup +#endif + goto 210 +c + endif +c + 21 continue +c + write (ulsort,texte(langue,8)) famnzz + write (ulsort,texte(langue,9)) + codret = 12 +c + 210 continue +c + endif +c +c 2.2. ==> recherche eventuelle des tailles mini/maxi des mailles, selon +c les axes perpendicalaires a la direction d'extrusion +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. recherche ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) saux01, choixd +#endif +c + if ( choixd.eq.3 .or. choixd.eq.4 ) then +c + if ( codret.eq.0 ) then +c +c 2.2.1. ==> initialisation des extrema pour la premiere maille trouvee +c + do 221 , iaux = 1 , nbelem +c + if ( typele(iaux).eq.edqua4 ) then +c + daux1 = + > abs(coonoe(noeele(iaux,2),iaux1)-coonoe(noeele(iaux,1),iaux1)) + daux2 = + > abs(coonoe(noeele(iaux,3),iaux1)-coonoe(noeele(iaux,2),iaux1)) + maxx = max ( daux1, daux2 ) + minx = maxx +c + daux1 = + > abs(coonoe(noeele(iaux,2),iaux2)-coonoe(noeele(iaux,1),iaux2)) + daux2 = + > abs(coonoe(noeele(iaux,3),iaux2)-coonoe(noeele(iaux,2),iaux2)) + maxy = max ( daux1, daux2 ) + miny = maxy + goto 222 +c + endif +c + 221 continue +c + 222 continue +c +c 2.2.2. ==> parcours de toutes les mailles +c on teste la non nullite au millionieme de l'ecart initial +c entre le dessus et le dessous, divise par +c 10 puissance le niveau superieur atteint +c + daux = 1.d-6*(coosup-cooinf)/10.d0**nivsup +c + do 223 , iaux = 1 , nbelem +c + if ( typele(iaux).eq.edqua4 ) then +c + daux1 = + > abs(coonoe(noeele(iaux,2),iaux1)-coonoe(noeele(iaux,1),iaux1)) + daux2 = + > abs(coonoe(noeele(iaux,3),iaux1)-coonoe(noeele(iaux,2),iaux1)) +c + maxx = max ( maxx, daux1, daux2 ) + if ( daux1.gt.daux ) then + minx = min ( minx, daux1 ) + else + minx = min ( minx, daux2 ) + endif +c + daux1 = + > abs(coonoe(noeele(iaux,2),iaux2)-coonoe(noeele(iaux,1),iaux2)) + daux2 = + > abs(coonoe(noeele(iaux,3),iaux2)-coonoe(noeele(iaux,2),iaux2)) + maxy = max ( maxy, daux1, daux2 ) + if ( daux1.gt.daux ) then + miny = min ( miny, daux1 ) + else + miny = min ( miny, daux2 ) + endif +c + endif +c + 223 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) '1', minx, maxx + write (ulsort,texte(langue,10)) '2', miny, maxy +#endif +c + endif +c + endif +c +c==== +c 3. les noeuds de depart sont dans le plan cooinf +c on cree leur correspondant dans le plan coosup +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Noeuds de depart ; codret', codret +#endif +c +c 3.0. ==> Calcul de l'ecart cooinf<-->coosup +c + if ( codret.eq.0 ) then +c + if ( choixd.ge.1 .and. choixd.le.5 ) then + write (ulsort,texte(langue,12+choixd)) saux01 + else + write (ulsort,texte(langue,11)) saux01, choixd + write (ulsort,texte(langue,12)) + codret = 1 + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( choixd.eq.1 ) then + daux = coosup - cooinf + elseif ( choixd.eq.2 ) then + daux = deltac + elseif ( choixd.eq.3 ) then + daux = (minx+miny+maxx+maxy) * 0.25d0 + elseif ( choixd.eq.4 ) then + daux = (minx*miny*maxx*maxy) ** 0.25d0 + elseif ( choixd.eq.5 ) then + write (ulsort,90002) 'nivinf, nivsup',nivinf, nivsup + daux = ( coosup - cooinf ) / 2.d0**nivsup + endif +c + coosup = cooinf + daux + write (ulsort,texte(langue,4)) saux01, cooinf, coosup +c + jaux = 0 +c + do 31 , iaux = 1 , nbnoto +c + if ( famnoe(iaux).eq.famnzz ) then +c + nu3dno(iaux) = 0 +c + else +c + jaux = jaux + 1 + coon3d(jaux,iaux1) = coonoe(iaux,1) + coon3d(jaux,iaux2) = coonoe(iaux,2) + coon3d(jaux,maextr) = cooinf + famn3d(jaux) = famnoe(iaux) + nu3dno(iaux) = jaux +c + kaux = jaux + nbnoto - 1 + coon3d(kaux,iaux1) = coonoe(iaux,1) + coon3d(kaux,iaux2) = coonoe(iaux,2) + coon3d(kaux,maextr) = coosup + famn3d(kaux) = famnoe(iaux) +c + endif +c + 31 continue +c + if ( kaux.ne.nbno3d ) then + write (ulsort,texte(langue,5)) nbno3d + write (ulsort,texte(langue,6)) jaux + codret = 3 + endif +c + endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. fin ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcma22.F b/src/tool/AP_Conversion/pcma22.F new file mode 100644 index 00000000..52082ce2 --- /dev/null +++ b/src/tool/AP_Conversion/pcma22.F @@ -0,0 +1,448 @@ + subroutine pcma22 ( nbnoto, nbelem, + > nbtr3d, nbqu3d, nbhe3d, nbpe3d, nbele3, + > fameel, typele, noeele, + > fame3d, type3d, noee3d, + > faminf, famsup, nu3dno, + > nparrc, npqurc, + > arerec, quarec, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - 2D/3D - phase 2 +c - - -- - - +c Creation des mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnoto . e . 1 . nombre de noeuds du maillage externe . +c . nbtr3d . e . 1 . nombre de triangles du maillage 3d . +c . nbqu3d . e . 1 . nombre de quadrangles du maillage 3d . +c . nbhe3d . e . 1 . nombre d'hexaedres du maillage 3d . +c . nbpe3d . e . 1 . nombre de pentaedres du maillage 3d . +c . nbelem . e . 1 . nombre d'elements du maillage externe . +c . nu3dno . e . nbnoto . numero du calcul des noeuds . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . fame3d . s . nbele3 . famille med des elements du maillage 3d . +c . type3d . s . nbele3 . type des elements du maillage 3d . +c . noee3d . s . nbele3 . noeuds des elements du maillage 3d . +c . . .*nbman3 . . +c . faminf . e . 1 . famille med des quad de la face inferieure . +c . famsup . e . 1 . famille med des quad de la face superieure . +c . nu3dno . e . nbnoto . numero du calcul des noeuds . +c . nparrc . es . 1 . nombre de paires d'aretes a recoller . +c . npqurc . s . 1 . nombre de paires de quadrangles a recoller . +c . arerec . e .2*nparrc. paires des aretes a recoller . +c . quarec . s . 2** . paires des quadrangles a recoller . +c . tabaux . a . nbarto . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMA22' ) +c +#include "nblang.h" +#include "consts.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "meddc0.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbnoto + integer nbtr3d, nbqu3d, nbhe3d, nbpe3d, nbele3 + integer nbelem + integer faminf, famsup + integer fameel(nbelem), typele(nbelem), noeele(nbelem,*) + integer fame3d(nbele3), type3d(nbele3), noee3d(nbele3,*) + integer nu3dno(nbnoto) +c + integer nparrc, npqurc + integer arerec(2,*), quarec(2,*) + integer tabaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer el, nuel3d +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Maille numero :'',i10,'', de noeuds '',8i10)' + texte(1,5) = '(i1,'' noeud(s) sont dans le plan zinf.'')' + texte(1,6) = '(''Pour un '',a,'', il en faudrait '',a)' + texte(1,7) = '(''Famille de la face '',a,'' : '',i6)' + texte(1,8) = '(''Famille du '',a,i10,'' : '',i6)' + texte(1,9) = + >'(''Nombre de '',a,'' attendus pour le maillage 3D :'',i10)' + texte(1,10) = + >'(''Nombre de '',a,'' trouves pour le maillage 3D :'',i10)' +c + texte(2,4) = '(''Mesh # :'',i10,'', with nodes '',8i10)' + texte(2,5) = '(i1,'' node(s) are in zinf plane.'')' + texte(2,6) = '(''For '',a,'', '',a,'' were expected.'')' + texte(2,7) = '(''Family for '',a,'' face : '',i6)' + texte(2,8) = '(''Family for '',a,'' #'',i10,'' : '',i6)' + texte(2,9) = + > '(''Expected number of '',a,'' for the 3D mesh :'',i10)' + texte(2,10) = + > '(''Found number of '',a,'' for the 3D mesh :'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbele3', nbele3 +#endif + nuel3d = 0 +c +c==== +c 2. transformations des quadrangles en hexaedres +c Convention MED des hexaedres : +c +c 1 4 +c -------------------- +c / /. +c / / . +c / / . +c / / . +c 2 -------------------- 3 . +c . . . +c . . . +c . 5 . . 8 +c . . / +c . . / +c . . / +c . ./ +c -------------------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (12,15,14) est direct +c +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. quad -> hexa ; codret', codret + write (ulsort,90002) 'nbhe3d', nbhe3d +#endif +c + if ( nbhe3d.ne.0 ) then +c + if ( codret.eq.0 ) then +c + do 21 , el = 1 , nbelem +c + if ( typele(el).eq.edqua4 ) then +c + nuel3d = nuel3d + 1 + do 211 , iaux = 1 , 4 + noee3d(nuel3d,iaux) = nu3dno(noeele(el,iaux)) + nbnoto - 1 + noee3d(nuel3d,iaux+4) = nu3dno(noeele(el,iaux)) + 211 continue + fame3d(nuel3d) = fameel(el) + type3d(nuel3d) = edhex8 +c + endif +c + 21 continue +c + if ( nuel3d.ne.nbhe3d ) then + write (ulsort,texte(langue,9)) mess14(langue,3,9), nbhe3d + write (ulsort,texte(langue,10)) mess14(langue,3,9), nuel3d + codret = 2 + endif +c + endif +c + endif +c +c==== +c 3. transformations des triangles en pentaedres +c Convention MED des pentaedres : +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. tria -> pent ; codret', codret + write (ulsort,90002) 'nbpe3d', nbpe3d +#endif +c + if ( nbpe3d.ne.0 ) then +c + if ( codret.eq.0 ) then +c + do 31 , el = 1 , nbelem +c + if ( typele(el).eq.edtri3 ) then +c + nuel3d = nuel3d + 1 + do 311 , iaux = 1 , 3 + noee3d(nuel3d,iaux) = nu3dno(noeele(el,iaux)) + nbnoto - 1 + noee3d(nuel3d,iaux+3) = nu3dno(noeele(el,iaux)) + 311 continue + fame3d(nuel3d) = fameel(el) + type3d(nuel3d) = edpen6 +c + endif +c + 31 continue +c + if ( (nuel3d-nbhe3d).ne.nbpe3d ) then + write (ulsort,texte(langue,9)) mess14(langue,3,9), nbpe3d + write (ulsort,texte(langue,10)) mess14(langue,3,9), + > nuel3d-nbhe3d + codret = 3 + endif +c + endif +c + endif +c +c==== +c 4. creation des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. creation quadrangles ; codret', codret +#endif +c + if ( nbqu3d.ne.0 ) then +c +c 4.1. ==> transformations des segments en quadrangles de bord +c + if ( codret.eq.0 ) then +c + do 41 , el = 1 , nbelem +c + if ( typele(el).eq.edseg2 ) then + nuel3d = nuel3d + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nuel3d', nuel3d + write (ulsort,90015) 'noeele(',el,') = ', + > noeele(el,1), noeele(el,2) + write (ulsort,90015) 'nu3dno(noeele(',el,')) = ', + > nu3dno(noeele(el,1)), nu3dno(noeele(el,2)) +#endif +c + noee3d(nuel3d,1) = nu3dno(noeele(el,1)) + noee3d(nuel3d,2) = nu3dno(noeele(el,2)) + noee3d(nuel3d,3) = nu3dno(noeele(el,2)) + nbnoto - 1 + noee3d(nuel3d,4) = nu3dno(noeele(el,1)) + nbnoto - 1 + fame3d(nuel3d) = fameel(el) + type3d(nuel3d) = edqua4 + if ( nparrc.gt.0 ) then + tabaux(el) = nuel3d - nbhe3d + endif +c + endif +c + 41 continue +c + endif +c +c 4.2. ==> creation des quadrangles des faces inf et sup +c deux faces paralleles doivent tourner en sens inverse ... +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'inf', faminf + write (ulsort,texte(langue,7)) 'sup', famsup +#endif +c + do 42 , el = 1 , nbelem +c + if ( typele(el).eq.edqua4 ) then +c + nuel3d = nuel3d + 1 + noee3d(nuel3d,1) = nu3dno(noeele(el,4)) + noee3d(nuel3d,2) = nu3dno(noeele(el,3)) + noee3d(nuel3d,3) = nu3dno(noeele(el,2)) + noee3d(nuel3d,4) = nu3dno(noeele(el,1)) + fame3d(nuel3d) = faminf + type3d(nuel3d) = edqua4 +c + nuel3d = nuel3d + 1 + noee3d(nuel3d,1) = nu3dno(noeele(el,1)) + nbnoto - 1 + noee3d(nuel3d,2) = nu3dno(noeele(el,2)) + nbnoto - 1 + noee3d(nuel3d,3) = nu3dno(noeele(el,3)) + nbnoto - 1 + noee3d(nuel3d,4) = nu3dno(noeele(el,4)) + nbnoto - 1 + fame3d(nuel3d) = famsup + type3d(nuel3d) = edqua4 +c + endif +c + 42 continue +c + endif +c + if ( codret.eq.0 ) then +c + if ( (nuel3d-nbhe3d-nbpe3d).ne.(nbqu3d+nbtr3d) ) then + write (ulsort,texte(langue,9)) mess14(langue,3,8), nbqu3d+nbtr3d + write (ulsort,texte(langue,10)) + > mess14(langue,3,8), nuel3d-nbhe3d-nbpe3d + codret = 444 + endif +c + endif +c + endif +c +c==== +c 5. creation des triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. creation triangles ; codret', codret +#endif +c + if ( nbtr3d.ne.0 ) then +c +c 5.1. ==> creation des triangles des faces inf et sup +c deux faces paralleles doivent tourner en sens inverse ... +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'inf', faminf + write (ulsort,texte(langue,7)) 'sup', famsup +#endif +c + do 51 , el = 1 , nbelem +c + if ( typele(el).eq.edtri3 ) then +c + nuel3d = nuel3d + 1 + noee3d(nuel3d,1) = nu3dno(noeele(el,1)) + noee3d(nuel3d,2) = nu3dno(noeele(el,2)) + noee3d(nuel3d,3) = nu3dno(noeele(el,3)) + fame3d(nuel3d) = faminf + type3d(nuel3d) = edtri3 +c + nuel3d = nuel3d + 1 + noee3d(nuel3d,1) = nu3dno(noeele(el,3)) + nbnoto - 1 + noee3d(nuel3d,2) = nu3dno(noeele(el,2)) + nbnoto - 1 + noee3d(nuel3d,3) = nu3dno(noeele(el,1)) + nbnoto - 1 + fame3d(nuel3d) = famsup + type3d(nuel3d) = edtri3 +c + endif +c + 51 continue +c + endif +c + if ( codret.eq.0 ) then +c + if ( (nuel3d-nbhe3d-nbpe3d).ne.(nbqu3d+nbtr3d) ) then + write (ulsort,texte(langue,9)) mess14(langue,3,8), nbqu3d+nbtr3d + write (ulsort,texte(langue,10)) + > mess14(langue,3,8), nuel3d-nbhe3d-nbpe3d + codret = 555 + endif +c + endif +c + endif +c +c==== +c 6. transfert des recollements des segments vers les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. transfert ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 61 , iaux = 1 , nparrc +c + quarec(1,iaux) = tabaux(arerec(1,iaux)) + quarec(2,iaux) = tabaux(arerec(2,iaux)) +c + 61 continue +c + npqurc = nparrc + nparrc = 0 +c + endif +c +c==== +c 7. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. fin ; codret', codret + call dmflsh (iaux) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcma23.F b/src/tool/AP_Conversion/pcma23.F new file mode 100644 index 00000000..8cac3fce --- /dev/null +++ b/src/tool/AP_Conversion/pcma23.F @@ -0,0 +1,806 @@ + subroutine pcma23 ( nocmap, + > choixz, deltaz, nospec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - 2D vers 3D +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmap . e . char8 . nom de l'objet maillage de calcul n+1 . +c . choixz . e . 1 . choix sur le calcul de delta z : . +c . . . . 1 : coordonnees initiales (defaut) . +c . . . . 2 : valeur imposee . +c . . . . 3 : moyenne arithmetique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 4 : moyenne geometrique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 5 : ecart initial, divise par 2**nivsup . +c . deltaz . e . 1 . valeur de delta z si impose (choixz=1) . +c . nospec . es . char8 . objet memorisant les specificites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMA23' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envca1.h" +c +#include "nombno.h" +#include "nombar.h" +c +#include "nbutil.h" +c +c 0.3. ==> arguments +c + character*8 nocmap + character*8 nospec +c + integer choixz +c + double precision deltaz +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbele3, nbman3, nbmaa3, nbmaf3 + integer nbtr3d, nbqu3d, nbhe3d, nbpe3d + integer nbno3d +c + integer pfamen, pfamee, pnoeel, ptypel, pcoonc + integer pnuele, pnunoe + integer pinfpt, pinftl, pinftb + integer nbnomb, adnomb + integer lgpoin, lgtabl +c + integer ptrav1, ptrav2 + integer pfano3, pcono3 + integer pfame3, ptype3, pnoee3 + integer famaux(3) + integer nbpqt +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc +c + logical cforme +c + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*8 ntrav1, ntrav2 + character*8 nfano3, ncono3 + character*8 nfame3, ntype3, nnoee3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro +#endif +c + texte(1,4) = '(''. Passage du maillage 2D en 3D'')' +c + texte(2,4) = '(''. From 2D mesh to 3D'')' +c +#include "impr03.h" +c + write (ulsort,texte(langue,4)) +c +c==== +c 2. recuperation des donnees du maillage a modifier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. recuperation donnees ; codret', codret +#endif +c +c 2.1. ==> les noms des structures +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmap, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> les principales constantes +c + if ( codret.eq.0 ) then +c + call gmliat ( ncnoeu, 1, nbnoto, codre1 ) + call gmliat ( nccono, 1, nbelem, codre2 ) + call gmadoj ( ncnomb, adnomb, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncnomb) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMC', nompro +#endif + call utnbmc ( imem(adnomb), + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> les adresses +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 6006 + call utad11 ( iaux, ncnoeu, nccono, + > pcoonc, pfamen, jaux, jaux, + > ptypel, pfamee, pnoeel, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> les recollements pour le non conforme +c + if ( codret.eq.0 ) then +c + if ( maconf.eq.-1 .or. maconf.eq.0 ) then + cforme = .true. + else + cforme = .false. + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'cforme', cforme +#endif +c + if ( .not. cforme ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nospec) + call gmprsx (nompro,nospec//'.Tab1') + call gmprsx (nompro,nospec//'.Tab3') +#endif +c +c 2.4.1. ==> caracteristiques initiales +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD41', nompro +#endif + call utad41 ( nospec, + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > ulsort, langue, codret) +c + endif +c +c 2.4.2. ==> il faut allonger le tableau pour les quadrangles +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav2, 'entier ', nbarto, ptrav2, codre1 ) + call gmmod ( nospec//'.Tab3', adqurc, + > 2, 2, npqurc, nparrc, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + else +c + nparrc = 0 + npqurc = 0 +c + endif +c + endif +cgn write (ulsort,90002) 'nparrc', nparrc +cgn write (ulsort,90002) 'npqurc', npqurc +c +c==== +c 3. Les informations generales +c On enleve 3 informations : familles des faces inf et sup, +c famille du noeud supplementaire +c La longueur du tableau "Pointeur" evolue : - 3 +c Les nom et unite sont en char*16 alors que les numeros des +c familles seront codes sur des char*8 : +c . la longueur du tableau "Taille" evolue : - 3 +c . la longueur du tableau "Table" evolue : - 3 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. informations generales ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) 'Avant traitement de ncinfo' + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') + endif + call dmflsh (iaux) +#endif +c +c 3.1. ==> Caracteristiques de la structure +c + if ( codret.eq.0 ) then +c + call gmliat ( ncinfo, 1, lgpoin, codre1 ) + call gmliat ( ncinfo, 2, lgtabl, codre2 ) + call gmadoj ( ncinfo//'.Pointeur', pinfpt, iaux, codre3 ) + call gmadoj ( ncinfo//'.Table', pinftb, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 3.2. ==> Recuperation des numeros de familles des faces inf et sup et +c du noeud memorisant zinf et zsup +c + if ( codret.eq.0 ) then +c + nbpqt = lgpoin - 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpqt', nbpqt +#endif +c + do 32 , iaux = 1, nbpqt +c + jaux = pinftb+10*(iaux-1) +cgn write (ulsort,90064) iaux, '%'//smem(jaux)//'%' +c + if ( smem(jaux).eq.'SATURNE ' ) then +c + do 211 , kaux = 1 , 3 + jaux = jaux + 1 + read ( smem(jaux), '(i8)', err=32000, end=32000 ) famaux(kaux) +cgn write (ulsort,90002) 'famaux(kaux)', famaux(kaux) + 211 continue +c + goto 32 +c +32000 continue + codret = 1 +c + endif +c + 32 continue +c + endif +c +c 3.3. ==> Attributs et raccourcissement des tables +c Suppose que l'info sur SATURNE est a la fin ... +c + if ( codret.eq.0 ) then +c + iaux = lgpoin - 1 + call gmecat ( ncinfo, 1, iaux, codre1 ) + call gmmod ( ncinfo//'.Pointeur', + > pinfpt, lgpoin, iaux, 1, 1, codre2 ) + iaux = lgtabl - 10 + call gmecat ( ncinfo, 2, iaux, codre3 ) + call gmmod ( ncinfo//'.Taille', + > pinftl, lgtabl, iaux, 1, 1, codre4 ) + call gmmod ( ncinfo//'.Table', + > pinftb, lgtabl, iaux, 1, 1, codre5 ) + lgpoin = lgpoin - 1 + lgtabl = lgtabl - 10 +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) 'Apres traitement de ncinfo' + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') + endif +#endif +c +c==== +c 4. traitement des noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. traitement des noeuds ; codret', codret + call dmflsh(iaux) +#endif +c +c 4.1. ==> nombre de noeuds du futur maillage +c + if ( codret.eq.0 ) then +c + nbno3d = 2*(nbnoto-1) +c + endif +c +c 4.2. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbnoto, ptrav1, codre1 ) + call gmalot ( nfano3, 'entier ', nbno3d, pfano3, codre2 ) + iaux = nbno3d*3 + call gmalot ( ncono3, 'reel ', iaux , pcono3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 4.3. ==> traitement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMA21', nompro +cgn call gmprsx (nompro,ncnoeu//'.Coor') + call dmflsh(iaux) +#endif + call pcma21 ( choixz, deltaz, + > nbnoto, nbelem, imem(pfamen), rmem(pcoonc), + > famaux(3), nbno3d, + > imem(ptypel), imem(pnoeel), + > imem(ptrav1), imem(pfano3), rmem(pcono3), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro,ntrav1) + call gmprsx (nompro,ncono3) + call dmflsh(iaux) + endif +#endif +c +c==== +c 5. traitement des mailles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. traitement des mailles ; codret', codret +#endif +c +c 5.1. ==> preliminaires +c nombre de mailles du futur maillage : +c 1 quadrangle donne 1 hexaedre +c --> nbquad hexaedres +c 1 triangle donne 1 pentaedre +c --> nbtria pentaedres +c 1 segment donne un quadrangle lateral +c 1 quadrangle donne 1 quadrangle sur la face inferieure +c 1 quadrangle donne 1 quadrangle sur la face superieure +c --> nbsegm + 2*nbquad quadrangles +c + if ( codret.eq.0 ) then +c + nbtr3d = 0 + nbqu3d = 2*nbquad + nbsegm + nbhe3d = nbquad + nbpe3d = nbtria + nbele3 = nbhe3d + nbpe3d + nbqu3d + nbtr3d + if ( nbhe3d.eq.0 ) then + nbman3 = 6 + nbmaa3 = 9 + nbmaf3 = 5 + else + nbman3 = 8 + nbmaa3 = 12 + nbmaf3 = 6 + endif +c + endif +c +c 5.2. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + call gmalot ( nfame3, 'entier ', nbele3, pfame3, codre1 ) + call gmalot ( ntype3, 'entier ', nbele3, ptype3, codre2 ) + iaux = nbele3*nbman3 + call gmalot ( nnoee3, 'entier ', iaux , pnoee3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 5.3. ==> traitement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMA22', nompro +cgn call gmprsx (nompro,nccono//'.FamilMED') +cgn call gmprsx (nompro,nccono//'.Type') +cgn call gmprsx (nompro,nccono//'.Noeuds') +#endif +c + call pcma22 ( nbnoto, nbelem, + > nbtr3d, nbqu3d, nbhe3d, nbpe3d, nbele3, + > imem(pfamee), imem(ptypel), imem(pnoeel), + > imem(pfame3), imem(ptype3), imem(pnoee3), + > famaux(1), famaux(2), imem(ptrav1), + > nparrc, npqurc, + > imem(adarrc), imem(adqurc), imem(ptrav2), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro,nfame3) + call gmprsx (nompro,ntype3) + call gmprsx (nompro,nnoee3) + call dmflsh(iaux) + endif +#endif +c +c==== +c 6. Rangement dans la structure du maillage de calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Rangement dans structure ; codret',codret +#endif +c +c 6.1. ==> Le recollement +c + if ( .not. cforme ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( nospec, 1, nparrc, codre1 ) + call gmecat ( nospec, 3, npqurc, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +cgn call gmprsx (nompro,nospec) +cgn call gmprot (nompro,nospec//'.Tab1',1,2*nparrc) +cgn call gmprot (nompro,nospec//'.Tab3',1,2*npqurc) +c + endif +c + endif +c +c 6.2. ==> Les noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. Les noeuds ; codret',codret +#endif +c +c 6.2.1. ==> Suppression des structures obsoletes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - ncnoeu', ncnoeu) +#endif +c + call gmlboj ( ncnoeu//'.Coor', codre1 ) + call gmlboj ( ncnoeu//'.FamilMED', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.2.2. ==> Mise a jour +c + if ( codret.eq.0 ) then +c + call gmecat ( ncnoeu, 1, nbno3d, codre1 ) + call gmatoj ( ncnoeu//'.Coor', ncono3, codre2 ) + call gmatoj ( ncnoeu//'.FamilMED' , nfano3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.2.3. ==> Les numerotations externes +c + if ( codret.eq.0 ) then +c + call gmobal ( ncnoeu//'.NumeExte', codret ) + if ( codret.eq.2 ) then + call gmmod ( ncnoeu//'.NumeExte', + > pnunoe, nbnoto, nbno3d, 1, 1, codret ) + elseif ( codret.eq.0 ) then + call gmaloj ( ncnoeu//'.NumeExte', ' ', nbno3d, pnunoe, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + do 623 , iaux = 1 , nbno3d + imem(pnunoe-1+iaux) = iaux + 623 continue +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - ncnoeu', ncnoeu) +#endif +c + endif +c +c 6.3. ==> Les mailles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. Les mailles ; codret',codret +#endif +c +c 6.3.1. ==> Suppression des structures obsoletes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - nccono',nccono) +#endif +c + call gmlboj ( nccono//'.FamilMED', codre1 ) + call gmlboj ( nccono//'.Type', codre2 ) + call gmlboj ( nccono//'.Noeuds', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.3.2. ==> Mise a jour +c + if ( codret.eq.0 ) then +c + call gmatoj ( nccono//'.FamilMED', nfame3, codre1 ) + call gmatoj ( nccono//'.Type', ntype3, codre2 ) + call gmatoj ( nccono//'.Noeuds' , nnoee3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nccono, 1, nbele3, codre1 ) + call gmecat ( nccono, 2, nbman3, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.3.3. ==> Les numerotations externes +c + if ( codret.eq.0 ) then +c + call gmobal ( nccono//'.NumeExte', codret ) + if ( codret.eq.2 ) then + call gmmod ( nccono//'.NumeExte', + > pnuele, nbelem, nbele3, 1, 1, codret ) + elseif ( codret.eq.0 ) then + call gmaloj ( nccono//'.NumeExte', ' ', nbele3, pnuele, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + do 633 , iaux = 1 , nbele3 + imem(pnuele-1+iaux) = iaux + 633 continue +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - nccono',nccono) +#endif +c + endif +c +c 6.4. ==> Les generalites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.4. Les generalites ; codret',codret +#endif +c + if ( codret.eq.0 ) then +c + sdimca = 3 + call gmecat ( nocmap, 1, sdimca, codre1 ) + mdimca = 3 + call gmecat ( nocmap, 2, mdimca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - ncnomb', ncnomb) +#endif +c + imem(adnomb) = nbmaa3 + imem(adnomb+1) = nbmaf3 + imem(adnomb+3) = nbno3d + imem(adnomb+4) = nbele3 + imem(adnomb+5) = nbtr3d + nbqu3d + imem(adnomb+6) = nbhe3d + nbpe3d + imem(adnomb+12) = 0 + imem(adnomb+13) = nbtr3d + imem(adnomb+15) = 0 + imem(adnomb+16) = nbqu3d + imem(adnomb+17) = nbhe3d + imem(adnomb+18) = nbpe3d + imem(adnomb+41) = famaux(1) + imem(adnomb+48) = famaux(2) + imem(adnomb+49) = famaux(3) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - ncnomb', ncnomb) +#endif +c + nbelem = nbele3 + nbtria = nbtr3d + nbquad = nbqu3d + nbhexa = nbhe3d + nbpent = nbpe3d +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - nocmap', nocmap) +#endif +c + endif +c +c==== +c 7. menage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. menage ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + if ( .not. cforme ) then + call gmlboj ( ntrav2, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 8. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaa0.F b/src/tool/AP_Conversion/pcmaa0.F new file mode 100644 index 00000000..5ce6723b --- /dev/null +++ b/src/tool/AP_Conversion/pcmaa0.F @@ -0,0 +1,178 @@ + subroutine pcmaa0 ( rsarto, + > hetare, + > famare, cfaare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - Aretes +c - - -- - +c - phase 0 +c - +c ______________________________________________________________________ +c +c remarque : pcmaar et pcmaa0 sont des clones +c remarque : pcmaa0, pcmat0 et pcmaq0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . rsarto . s . 1 . nombre d'aretes actives et du calcul . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAA0' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer rsarto +c + integer hetare(nbarto) +c + integer cfaare(nctfar,nbfare), famare(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr06.h" +c +c==== +c 2. Decompte des aretes actives et du calcul +c==== +c + rsarto = 0 +c + do 21 , iaux = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,1), iaux + write (ulsort,texte(langue,12)) + > cotyel, cfaare(cotyel,famare(iaux)) +#endif +c + if ( cfaare(cotyel,famare(iaux)).ne.0 ) then +c + etat = mod( hetare(iaux) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetare(iaux), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + rsarto = nbarto + goto 22 +c + endif +c + endif +c + 21 continue +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,18)) mess14(langue,3,1), rsarto +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaar.F b/src/tool/AP_Conversion/pcmaar.F new file mode 100644 index 00000000..7fb9449a --- /dev/null +++ b/src/tool/AP_Conversion/pcmaar.F @@ -0,0 +1,294 @@ + subroutine pcmaar ( elemen, nbele0, + > somare, np2are, hetare, + > famare, cfaare, + > nnosca, narsca, narsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - ARetes +c - - -- -- +c ______________________________________________________________________ +c +c remarque : voir vcorie pour la definition des orientations +c remarque : pcmaar et pcmaa0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . narsca . s . rsarto . numero des aretes du calcul . +c . narsho . s . nbele0 . numero des aretes dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAAR' ) +c +#include "nblang.h" +#include "coftex.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer hetare(nbarto) +c + integer cfaare(nctfar,nbfare), famare(nbarto) +c + integer nnosca(rsnoto) + integer narsca(rsarto), narsho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete + integer etat + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr06.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'rsarto', rsarto + write (ulsort,90002) 'nbele0', nbele0 +#endif +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rsarto + narsca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + narsho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c a1 +c n1*-------------*n2 +c + do 31 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,1), larete + write (ulsort,texte(langue,12)) + > cotyel, cfaare(cotyel,famare(larete)) +#endif +c + if ( cfaare(cotyel,famare(larete)).ne.0 ) then +c + etat = mod( hetare(larete) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetare(larete), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + narsho(elemen) = larete + narsca(larete) = elemen +c + if ( cfaare(coorfa,famare(larete)).eq.1 ) then + noeele(elemen,1) = nnosca(somare(1,larete)) + noeele(elemen,2) = nnosca(somare(2,larete)) + else + noeele(elemen,1) = nnosca(somare(2,larete)) + noeele(elemen,2) = nnosca(somare(1,larete)) + endif +c + famele(elemen) = cfaare(cofamd,famare(larete)) + typele(elemen) = cfaare(cotyel,famare(larete)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + write (ulsort,90002) 'famare', famare(larete) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,2) + write (ulsort,90002) 'Famille MED',famele(elemen) + write (ulsort,90002) 'Type MED ',typele(elemen) + endif +#endif + endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + else +c a1 +c n1*------*------*n4 +c n2 +c + do 41 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,1), larete + write (ulsort,texte(langue,12)) + > cotyel, cfaare(cotyel,famare(larete)) +#endif +c + if ( cfaare(cotyel,famare(larete)).ne.0 ) then +c + etat = mod( hetare(larete) , 10) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetare(larete), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + narsho(elemen) = larete + narsca(larete) = elemen +c + if ( cfaare(coorfa,famare(larete)).eq.1 ) then + noeele(elemen,1) = nnosca(somare(1,larete)) + noeele(elemen,2) = nnosca(somare(2,larete)) + else + noeele(elemen,1) = nnosca(somare(2,larete)) + noeele(elemen,2) = nnosca(somare(1,larete)) + endif + noeele(elemen,3) = nnosca(np2are(larete)) +c + famele(elemen) = cfaare(cofamd,famare(larete)) + typele(elemen) = cfaare(cotyel,famare(larete)) + endif +c + endif +c + 41 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmac1.F b/src/tool/AP_Conversion/pcmac1.F new file mode 100644 index 00000000..381193c2 --- /dev/null +++ b/src/tool/AP_Conversion/pcmac1.F @@ -0,0 +1,795 @@ + subroutine pcmac1 ( nbele0, + > coonoe, hetnoe, ancnoe, trav1a, + > noempo, hetmpo, + > somare, np2are, hetare, + > aretri, hettri, nintri, + > arequa, hetqua, ninqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > ninhex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > famnoe, cfanoe, fammpo, cfampo, + > famare, cfaare, + > famtri, cfatri, famqua, cfaqua, + > famtet, cfatet, famhex, cfahex, + > fampyr, cfapyr, fampen, cfapen, + > nnosca, nnosho, nmpsca, nmpsho, + > narsca, narsho, + > ntrsca, ntrsho, nqusca, nqusho, + > ntesca, ntesho, nhesca, nhesho, + > npysca, npysho, npesca, npesho, + > dimcst, coocst, coonca, fameno, + > famele, noeele, typele, + > fmdeig, noeeig, + > noeord, deraff, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage Connectivite - phase 1 +c - - -- - - +c ______________________________________________________________________ +c +c remarque : on s'arrange pour que les mailles externes soient +c numerotees dans cet ordre : +c . les tetraedres +c . les triangles +c . les aretes +c . les mailles-points +c . les quadrangles +c . les hexaedres +c . les pyramides +c . les pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . hetmpo . e . nbmpto . historique de l'etat des mailles-points . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . ninhex . e . nbheto . noeud interne a l'hexaedre . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . + l : appartenance a l'equivalence l . +c . fammpo . e . nbmpto . famille des mailles-points . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfpe. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nnosca . s . rsnoto . numero des noeuds du code de calcul . +c . nnosho . s . rsnoac . numero des noeuds dans HOMARD . +c . nmpsca . s . rsmpto . numero des mailles-points du calcul . +c . nmpsho . s . rsmpac . numero des mailles-points dans HOMARD . +c . narsca . s . rsarto . numero des aretes du calcul . +c . narsho . s . rsarac . numero des aretes dans HOMARD . +c . ntrsca . s . rstrto . numero des triangles du calcul . +c . ntrsho . s . rstrac . numero des triangles dans HOMARD . +c . nqusca . s . rsquto . numero des quadrangles du calcul . +c . nqusho . s . rsquac . numero des quadrangles dans HOMARD . +c . ntesca . s . rsteto . numero des tetraedres du calcul . +c . ntesho . s . rsteac . numero des tetraedres dans HOMARD . +c . nhesho . s . reheac . numero des hexaedres dans HOMARD . +c . nhesca . s . rsheto . numero des hexaedres dans le calcul . +c . npysho . s . repyac . numero des pyramides dans HOMARD . +c . npysca . s . rspyto . numero des pyramides dans le calcul sortie . +c . npesho . s . repeac . numero des pentaedres dans HOMARD . +c . npesca . s . rspeto . numero des pentaedres dans le calcul . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . coonca . s . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . fameno . s . nbnoto . famille med des noeuds . +c . famele . s . nbele0 . famille med des elements . +c . noeele . s . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . s . nbele0 . type des elements . +c . noeord . e . 1 . vrai si les noeuds sont ordonnes . +c . . . . faux si sans importance . +c . noeeig . e .nbelig**. noeuds des elements . +c . fmdeig . e . nbelig . famille med des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAC1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +c +#include "nbfami.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "nombsr.h" +#include "nbutil.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer nbele0 + integer dimcst +c + double precision coocst(11) + double precision coonoe(nbnoto,sdim), coonca(nbnoto,sdimca) +c + integer hetnoe(nbnoto), ancnoe(nbnoto), trav1a(nbnoto) + integer noempo(nbmpto), hetmpo(nbmpto) + integer somare(2,nbarto), np2are(nbarto) + integer hetare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nintri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), ninqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto), ninhex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) +c + integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto) + integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer cfatet(nctfte,nbftet), famtet(nbteto) + integer cfahex(nctfhe,nbfhex), famhex(nbheto) + integer cfapyr(nctfpy,nbfpyr), fampyr(nbpyto) + integer cfapen(nctfpe,nbfpen), fampen(nbpeto) +c + integer nnosca(rsnoto), nnosho(rsnoac) + integer nmpsca(rsmpto), nmpsho(nbele0) + integer narsca(rsarto), narsho(nbele0) + integer ntrsca(rstrto), ntrsho(nbele0) + integer nqusca(rsquto), nqusho(nbele0) + integer ntesca(rsteto), ntesho(nbele0) + integer nhesca(rsheto), nhesho(nbele0) + integer npysca(rspyto), npysho(nbele0) + integer npesca(rspeto), npesho(nbele0) +c + integer fameno(nbnoto), famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) + integer fmdeig(nbelig) + integer noeeig(nbelig,*) +c + logical noeord + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer elemen + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de mailles calcule :'',i11)' + texte(1,5) = '(''Nombre de mailles estime :'',i11)' + texte(1,6) = '(''Elements hierarchiques :'',i2)' +c + texte(2,4) = '(''Computed number of meshes :'',i11)' + texte(2,5) = '(''Estimated number of meshes :'',i11)' + texte(2,6) = '(''Hierarchical elements :'',i2)' +c +#include "impr03.h" +c + nbquad = 0 + nbhexa = 0 + nbpent = 0 + nbpyra = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) hierar +#endif +c + codret = 0 +c +c==== +c 2. les noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMANO', nompro +#endif + call pcmano ( coonoe, hetnoe, + > famnoe, cfanoe, + > nnosca, nnosho, + > dimcst, coocst, sdimca, coonca, + > noeord, + > fameno, + > ulsort, langue, codret ) +c +c==== +c 3. les mailles +c on rappelle que la caracteristique numero 2 d'une maille +c est nulle si ce n'etait pas une maille du calcul. +c si c'est une maille de calcul, la caracteristique vaut le type +c correspondant a celui du code de calcul associe. +c +c remarque : on s'arrange pour que les mailles externes soient +c numerotees dans cet ordre : +c . les tetraedres +c . les triangles +c . les aretes +c . les mailles-points +c . les quadrangles +c . les hexaedres +c . les pyramides +c . les pentaedres +c Cela est indispensable pour les algorithmes de +c conversion de solution et pour la gestion des equivalences +c +c remarque : dans le cas general, on ne prend que les mailles actives. +c mais dans le cas hierarchique, on prend tous les niveaux. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. mailles ; codret', codret +#endif +c + elemen = 0 +c +c 3.1. ==> les tetraedres actifs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rsteto.eq.0 ) then +c + nbtetr = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMATE', nompro +#endif + call pcmate ( elemen, nbele0, + > somare, np2are, + > aretri, + > tritet, cotrte, aretet, + > hettet, famtet, cfatet, + > nnosca, ntesca, ntesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbtetr = elemen +c + endif +c + endif +c +c 3.2. ==> les mailles triangulaires : +c - triangles actifs en 2,5d +c - triangles actifs isoles en 3d, +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. triangles ; codret', codret + write (ulsort,90002) 'nbtrac', nbtrac +#endif +c + if ( codret.eq.0 ) then +c + if ( rstrto.eq.0 ) then +c + nbtria = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMATR', nompro +#endif + call pcmatr ( elemen, nbele0, + > somare, np2are, + > aretri, hettri, nintri, + > famtri, cfatri, + > nnosca, ntrsca, ntrsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbtria = elemen - nbtetr +c + endif +c + endif +c +c 3.3. ==> les poutres, c'est-a-dire les aretes isolees +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rsarto.eq.0 ) then +c + nbsegm = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAAR', nompro +#endif + call pcmaar ( elemen, nbele0, + > somare, np2are, hetare, + > famare, cfaare, + > nnosca, narsca, narsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbsegm = elemen - nbtetr - nbtria +c + endif +c + endif +c +c 3.4. ==> les mailles-points +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. mailles-points ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rsmpto.eq.0 ) then +c + nbmapo = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAMP', nompro +#endif + call pcmamp ( elemen, nbele0, + > noempo, hetmpo, + > fammpo, cfampo, + > nnosca, nmpsca, nmpsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbmapo = elemen - nbtetr - nbtria - nbsegm +c + endif +c + endif +c +c 3.5. ==> les elements quadrangulaires : +c - quadrangles actifs en 2,5d +c - quadrangles actifs isoles en 3d, +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. quadrangles ; codret', codret + write (ulsort,90002) 'nbquac', nbquac +#endif +c + if ( codret.eq.0 ) then +c + if ( rsquto.eq.0 ) then +c + nbquad = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAQU', nompro +#endif + call pcmaqu ( elemen, nbele0, + > somare, np2are, + > arequa, hetqua, ninqua, + > famqua, cfaqua, + > nnosca, nqusca, nqusho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbquad = elemen - nbtetr - nbtria - nbsegm - nbmapo +c + endif +c + endif +c +c 3.6. ==> les hexaedres actifs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rsheto.eq.0 ) then +c + nbhexa = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAHE', nompro +#endif + call pcmahe ( elemen, nbele0, + > somare, np2are, + > arequa, + > quahex, coquhe, arehex, + > hethex, ninhex, + > famhex, cfahex, + > nnosca, nhesca, nhesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbhexa = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad +c + endif +c + endif +c +c 3.7. ==> les pyramides actives +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7. pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rspyto.eq.0 ) then +c + nbpyra = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAPY', nompro +#endif + call pcmapy ( elemen, nbele0, + > somare, np2are, + > aretri, + > facpyr, cofapy, arepyr, + > hetpyr, fampyr, cfapyr, + > nnosca, npysca, npysho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbpyra = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad + > - nbhexa +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre de pyramides converties', nbpyra +#endif +c + endif +c + endif +c +c 3.8. ==> les pentaedres actifs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.8. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( rspeto.eq.0 ) then +c + nbpent = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAPE', nompro +#endif + call pcmape ( elemen, nbele0, + > somare, np2are, + > arequa, + > facpen, cofape, arepen, + > hetpen, fampen, cfapen, + > nnosca, npesca, npesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c + nbpent = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad + > - nbhexa - nbpyra +c + endif +c + endif +c +c=== +c 4. Les eventuelles mailles ignorees +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Elements ignores ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbelig.ne.0 ) then +c + nbpyra = nbpyra + nbelig +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre de pyramides', nbpyra +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAIG', nompro +#endif + call pcmaig ( nbele0, nbelig, + > fmdeig, noeeig, + > elemen, typele, famele, noeele, + > nnosca, ancnoe, trav1a, deraff, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. mise a jour +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. mise a jour ; codret', codret +#endif +c +c 5.1.==> nombres caracteristiques du maillage de calcul +c + if ( codret.eq.0 ) then +c + if ( nbhexa.ne.0 ) then + nbmaae = 12 + nbmafe = 6 + elseif ( nbpent.ne.0 ) then + nbmaae = 9 + nbmafe = 5 + elseif ( nbpyra.ne.0 ) then + nbmaae = 8 + nbmafe = 5 + elseif ( nbtetr.ne.0 ) then + nbmaae = 6 + nbmafe = 4 + elseif ( nbquad.ne.0 ) then + nbmaae = 4 + nbmafe = 1 + elseif ( nbtria.ne.0 ) then + nbmaae = 3 + nbmafe = 1 + else + nbmaae = 1 + nbmafe = 0 + endif +c + nbelem = nbmapo + nbsegm + + > nbtria + nbquad + + > nbtetr + nbhexa + nbpyra + nbpent +c + if ( elemen.ne.nbelem ) then + write (ulsort,texte(langue,4)) elemen + write (ulsort,texte(langue,5)) nbelem + write (ulsort,texte(langue,3)) + codret = 1 + endif +c + numael = nbelem + numano = nbnoto +c + nvoare = -1 + nvosom = -1 +c + endif +c +c 5.2. ==> nombres propres a la renumerotation des entites +c + if ( codret.eq.0 ) then +c + if ( nbmapo.ne.0 ) then + rsmpac = elemen + else + rsmpac = 0 + endif +c + if ( nbsegm.ne.0 ) then + rsarac = elemen + else + rsarac = 0 + endif +c + if ( nbtria.ne.0 ) then + rstrac = elemen + else + rstrac = 0 + endif +c + if ( nbquad.ne.0 ) then + rsquac = elemen + else + rsquac = 0 + endif +c + if ( nbteto.ne.0 ) then + rsteac = elemen + else + rsteac = 0 + endif +c + if ( nbheto.ne.0 ) then + rsheac = elemen + else + rsheac = 0 + endif +c + if ( nbpyto.ne.0 ) then + rspyac = elemen + else + rspyac = 0 + endif +c + if ( nbpeto.ne.0 ) then + rspeac = elemen + else + rspeac = 0 + endif +c + rseutc = elemen + if ( rsteac.eq.0 .and. rsheac.eq.0 .and. rspyac.eq.0 ) then + rsevca = nbtria + nbquad + rsevto = rstrto + rsquto + else + rsevca = nbtetr + nbhexa + nbpyra + nbpent + rsevto = rsteto + rsheto + rspyto + rspeto + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaco.F b/src/tool/AP_Conversion/pcmaco.F new file mode 100644 index 00000000..c115fb3b --- /dev/null +++ b/src/tool/AP_Conversion/pcmaco.F @@ -0,0 +1,2279 @@ + subroutine pcmaco ( modhom, + > nocmap, nomail, nomamd, lnomam, + > nospec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - COnnectivite +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . nocmap . s . char8 . nom de l'objet maillage de calcul iter. n+1. +c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . nomamd . e . char64 . nom med du maillage iteration n+1 . +c . lnomam . e . 1 . longueur de nomamd . +c . nospec . s . char8 . nom de l'objet memorisant les specificites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMACO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envca1.h" +#include "envada.h" +c +#include "nbutil.h" +#include "nombno.h" +#include "nombar.h" +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nombsr.h" +#include "nbfami.h" +#include "dicfen.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer modhom + integer lnomam +c + character*8 nocmap, nomail + character*64 nomamd + character*8 nospec +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer pcoono, adcocs, phetno, pancno + integer pnoemp, phetmp + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer paretr, phettr, ppertr, pfiltr, pnivtr, adnmtr + integer parequ, phetqu, pperqu, pfilqu, pnivqu, adnmqu + integer ptrite, pcotrt, parete, phette + integer pquahe, pcoquh, parehe, phethe, adnmhe + integer advotr, adpptr + integer advoqu, adppqu + integer pfacpy, pcofay, parepy, phetpy + integer pfacpe, pcofap, parepe, phetpe + integer ppovos, pvoiso + integer pposif, pfacar + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte, pcfate + integer pfamhe, pcfahe + integer pfampy, pcfapy + integer pfampe, pcfape + integer hfmdel, hnoeel + integer dimcst +c + integer adnbrp + integer adnocp, adnohp + integer admpcp, admphp + integer adarcp, adarhp + integer adtrcp, adtrhp + integer adtecp, adtehp + integer adqucp, adquhp + integer adhecp, adhehp + integer adpycp, adpyhp + integer adpecp, adpehp +c + integer adnomb + integer pfamen, pfamee, pnoeel, ptypel, pcoonc + integer pinfpt, pinftb + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc + integer lgtrc1, lgtrc2, lgtrc3 + integer lgtrc4, lgtrc5, lgtrc6, lgtrc7 + integer ptrav4 + integer nbanci, nbenrc, numead + integer adarra, adarrb + integer adtrra + integer adqura +c + integer iaux, jaux, kaux, laux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer nbele0, un + integer nonexm + integer nbpqt +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nhqufa + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*8 ntrav1, ntrav2, ntrav3, ntrav4 +c + character*8 heurus + character*9 dateus + character*32 saux32 +c + logical noeord + logical existe + logical deraff + logical cforme +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +cmdc ---------------- MAILLES DOUBLES DEBUT -------------- +cmd character*80 nomfic +cmd integer nbele1, nbtenw +cmd logical maildb +cmd integer adpoin, adtail, adtabl +cmd integer adnumf +cmd integer ptrav5 +cmd character*8 ntrav5 +cmdc ---------------- MAILLES DOUBLES FIN ---------------- +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' + texte(1,8) = + > '(5x,''Caracteristiques du maillage apres conversion :'',/)' +c + texte(2,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' + texte(2,8) = + > '(5x,''Characteristics of the mesh after conversion :'',/)' +c +#include "impr03.h" +c +#include "impr06.h" +c + un = 1 +c +c==== +c 2. recuperation des pointeurs +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. recuperation donnees ; codret', codret +#endif +c +c 2.1. ==> on alloue la future renumerotation +c remarque : on la supprime si elle existait ; cela arrive +c dans les cas de modifications de maillage +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.RenuMail', codre0 ) +c + if ( codre0.eq.1 ) then + call gmlboj ( nomail//'.RenuMail', codret ) + elseif ( codre0.ne.0 ) then + codret = 2 + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nomail//'.RenuMail', ' ', 0, iaux, codret ) +c + endif +c +c 2.2. ==> structure generale +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. ==> structure gale ; codret', codret + call dmflsh (iaux) +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nomail) + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +#include "mslve4.h" + endif +c + if ( codret.eq.0 ) then +c + if ( ( rafdef.eq.3 .or. rafdef.eq.4 ) .and. nbiter .gt.1 ) then + deraff = .true. + else + deraff = .false. + endif +c + if ( maconf.eq.-1 .or. maconf.eq.0 ) then + cforme = .true. + else + cforme = .false. + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'cforme', cforme +#endif +c + nonexm = 1 + if ( ( typcca.eq.36 ) .or. ( typcca.eq.56 ) ) then + nonexm = nonexm*2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nonexm', nonexm +#endif +c + endif +c +c 2.3. ==> tableaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. ==> tableaux ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + iaux = 42 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( deraff ) then + call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codre1 ) + call gmalot ( ntrav4, 'entier', nbnoto, ptrav4, codre2) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + endif +c + call gmliat ( nhnoeu, 2, dimcst, codre0 ) + codret = max ( abs(codre0), codret ) +c + if ( nbmpto.ne.0 ) then +c + iaux = 518 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + call utad02 ( iaux, nhmapo, + > phetmp, pnoemp, jaux, jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + iaux = 518 + if ( .not. cforme ) then + iaux = iaux*15 + endif + if ( degre.eq.2 ) then + iaux = iaux*13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( nbtrto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, jaux, jaux, + > adnmtr, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c + iaux = 37 + if ( nbquto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, pcfaqu, jaux, + > pnivqu, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbftet.ne.0 ) then +c +cgn write(ulsort,90002) 'nbtecf, nbteca', nbtecf, nbteca + iaux = 37 + if ( nbteto.ne.0 ) then + iaux = iaux*182 + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbfhex.ne.0 ) then +c + iaux = 37 + if ( nbheto.ne.0 ) then + iaux = iaux*182 + if ( mod(mailet,5).eq.0 ) then + iaux = iaux*19 + endif + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, pcoquh, jaux, + > adnmhe, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpyr.ne.0 ) then +c + iaux = 37 + if ( nbpyto.ne.0 ) then + iaux = iaux*182 + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux, jaux, + > pfampy, pcfapy, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpen.ne.0 ) then +c + iaux = 37 + if ( nbpeto.ne.0 ) then + iaux = iaux*182 + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + call gmliat ( nhsups, 2, iaux, codre1 ) + call gmliat ( nhsupe, 9, nbfmed, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + ngrouc = iaux / 10 +cgn print *,nompro,'nbfmed, ngrouc ',nbfmed, ngrouc +c + endif +c +c 2.4. ==> les voisinages des noeuds +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 + kaux = 0 + laux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > iaux, jaux, kaux, laux, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( nbteto.ne.0 ) then + iaux = iaux*5 + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*13 + endif + endif + if ( nbheto.ne.0 ) then + iaux = iaux*7 + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*17 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.5. ==> nombre d'equivalences +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. equivalences ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.eq.0 ) then + nbequi = 0 + else + call gmliat ( nhsups, 5, iaux, codret ) + if ( codret.eq.0 ) then + if ( mod(iaux,33).eq.0 ) then + nbequi = iaux / 33 + else + codret = 3 + endif + endif + endif +c + endif +c +c==== +c 3. Particularites des logiciels associes +c Il faut le faire maintenant, avant d'avoir converti le maillage +c du format HOMARD au format MED. En effet, ces programmes vont +c modifier/creer les familles med associes. Or cela est transfere au +c maillage de calcul par le programme pcmac1. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Particularites ; codret', codret + call dmflsh(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcca', typcca +#endif +c +c 3.1. ==> Creation des boites pour Athena +c + if ( typcca.eq.16 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Boites pour Athena ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhquad//'.Famille', nhqufa, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFAAT', nompro +#endif + call pcfaat ( typcca, + > nhsupe, nhsups, nhqufa, + > imem(phetar), imem(psomar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(pperqu), imem(pnivqu), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), pcfaqu, + > ulsort, langue, codret ) +c attention : il est normal que l'on passe pcfaqu et pas imem(pcfaqu) +c + endif +c + endif +c +c 3.2. ==> Elements a recoller pour le non conforme +c + if ( .not. cforme ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Recoller non conforme ; codret', codret + call dmflsh(iaux) +#endif +c +c 3.2.1. ==> Copie des tableaux des etats : les numeros vont etre +c modifies temporairement ; il faut pouvoir les restituer +c apres la conversion +c + if ( codret.eq.0 ) then +c + iaux = 0 + call gmcpal ( nharet//'.HistEtat', ntrav1, iaux, jaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c + call gmcpal ( nhtria//'.HistEtat', ntrav2, iaux, jaux, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c + call gmcpal ( nhquad//'.HistEtat', ntrav3, iaux, jaux, codret ) +c + endif +c + endif +c +c 3.2.2. ==> Recuperation du recollement initial +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.2. recollement initial ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03_ar', nompro +#endif + iaux = 462 + call utad03 ( iaux, nharet, + > nbanci, nbenrc, jaux, + > adarra, adarrb, + > ulsort, langue, codret ) +c + if ( nbtrto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03_tr', nompro +#endif + if ( nbtrri.eq.0 ) then + iaux = 5 + else + iaux = 35 + endif + call utad03 ( iaux, nhtria, + > jaux, jaux, numead, + > adtrra, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03_qu', nompro +#endif + if ( nbquri.eq.0 ) then + iaux = 5 + else + iaux = 35 + endif + call utad03 ( iaux, nhquad, + > jaux, jaux, numead, + > adqura, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2.3. ==> Creation de la structure de memorisation des recollements +c Remarque : on dimensionne surement trop grand car tout ne +c donne pas lieu a recollement, mais tant pis +c Remarque : on initialise a 0 pour la suite +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.3. creation structure ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL41', nompro +#endif + call utal41 ( typcca, nonexm, nbanci, nbenrc, + > nbarto, nbarde, + > nbtrri, nbtrde, + > nbquri, nbqude, + > nbpeac, nbpyac, + > nospec, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > lgtrc1, lgtrc2, lgtrc3, + > lgtrc4, lgtrc5, lgtrc6, lgtrc7, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'apres utal41' + write (ulsort,90002) 'lgtrc1', lgtrc1 + write (ulsort,90002) 'lgtrc2', lgtrc2 + write (ulsort,90002) 'lgtrc3', lgtrc3 + write (ulsort,90002) 'lgtrc4', lgtrc4 + write (ulsort,90002) 'lgtrc5', lgtrc5 + write (ulsort,90002) 'lgtrc6', lgtrc6 + write (ulsort,90002) 'lgtrc7', lgtrc7 +#endif +c + if ( codret.eq.0 ) then +c + jaux = adarrc + 2*lgtrc1 - 1 + do 3231 , iaux = adarrc, jaux + imem(iaux) = 0 + 3231 continue +c + jaux = adtrrc + 2*lgtrc2 - 1 + do 3232 , iaux = adtrrc, jaux + imem(iaux) = 0 + 3232 continue +c + jaux = adqurc + 2*lgtrc3 - 1 + do 3233 , iaux = adqurc, jaux + imem(iaux) = 0 + 3233 continue +c + jaux = adterc + 3*lgtrc4 - 1 + do 3234 , iaux = adterc, jaux + imem(iaux) = 0 + 3234 continue +c + jaux = adherc + 3*lgtrc5 - 1 + do 3235 , iaux = adherc, jaux + imem(iaux) = 0 + 3235 continue +c + jaux = adperc + 3*lgtrc6 - 1 + do 3236 , iaux = adperc, jaux + imem(iaux) = 0 + 3236 continue +c + jaux = adpyrc + 3*lgtrc7 - 1 + do 3237 , iaux = adpyrc, jaux + imem(iaux) = 0 + 3237 continue +c + endif +c +c 3.2.4. ==> Prise en compte du futur recollement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.4. futur recollement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAR0', nompro + call dmflsh(iaux) +#endif + call pcmar0 ( nonexm, + > imem(phetar), imem(pfilar), imem(pmerar), + > imem(pfamar), imem(pposif), imem(pfacar), + > imem(paretr), imem(phettr), imem(pnivtr), + > imem(pfamtr), imem(ppertr), imem(pfiltr), + > imem(parequ), imem(phetqu), imem(pnivqu), + > imem(pfamqu), imem(pperqu), imem(pfilqu), + > imem(phette), + > imem(phethe), + > imem(phetpy), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbanci, nbenrc, numead, + > imem(adarra), imem(adtrra), imem(adqura), + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > imem(adarrc), imem(adtrrc), imem(adqurc), + > imem(adterc), imem(adherc), + > imem(adperc), imem(adpyrc), + > ulsort, langue, codret ) +c + endif +c +c 3.2.5. ==> Redimensionnement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.5. Redimensionnement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'au debut de 3.2.5' + write (ulsort,90002) 'lgtrc1, nparrc', lgtrc1, nparrc + write (ulsort,90002) 'lgtrc2, nptrrc', lgtrc2, nptrrc + write (ulsort,90002) 'lgtrc3, npqurc', lgtrc3, npqurc + write (ulsort,90002) 'lgtrc4, npterc', lgtrc4, npterc + write (ulsort,90002) 'lgtrc5, npherc', lgtrc5, npherc + write (ulsort,90002) 'lgtrc6, nptrrc+npqurc', lgtrc6, nptrrc+npqurc + write (ulsort,90002) 'lgtrc7, nptrrc+npqurc', lgtrc7, nptrrc+npqurc +#endif +c + call gmecat ( nospec, 1, nparrc, codre1 ) + call gmmod ( nospec//'.Tab1', adarrc, + > 2, 2, lgtrc1, nparrc, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + call gmecat ( nospec, 2, nptrrc, codre1 ) + call gmmod ( nospec//'.Tab2', adtrrc, + > 2, 2, lgtrc2, nptrrc, codre2 ) + call gmecat ( nospec, 3, npqurc, codre3 ) + call gmmod ( nospec//'.Tab3', adqurc, + > 2, 2, lgtrc3, npqurc, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmecat ( nospec, 4, npterc, codre1 ) + call gmmod ( nospec//'.Tab4', adterc, + > 3, 3, lgtrc4, npterc, codre2 ) + call gmecat ( nospec, 5, npherc, codre3 ) + call gmmod ( nospec//'.Tab5', adherc, + > 3, 3, lgtrc5, npherc, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( nbpeac.gt.0 ) then + call gmecat ( nospec, 6, nptrrc+npqurc, codre1 ) + call gmmod ( nospec//'.Tab6', adperc, + > 3, 3, lgtrc6, nptrrc+npqurc, codre2 ) + else + codre1 = 0 + codre2 = 0 + endif + if ( nbpyac.gt.0 ) then + call gmecat ( nospec, 7, nptrrc+npqurc, codre3 ) + call gmmod ( nospec//'.Tab7', adpyrc, + > 3, 3, lgtrc7, nptrrc+npqurc, codre4 ) + else + codre3 = 0 + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +cgn call gmprsx (nompro,nospec) +cgn call gmprsx (nompro,nospec//'.Tab1') +cgn call gmprsx (nompro,nospec//'.Tab2') +cgn call gmprsx (nompro,nospec//'.Tab3') +cgn call gmprsx (nompro,nospec//'.Tab4') +cgn call gmprsx (nompro,nospec//'.Tab5') +cgn call gmprsx (nompro,nospec//'.Tab6') +cgn call gmprsx (nompro,nospec//'.Tab7') +c + endif +c + endif +c +c==== +c 4. preliminaires +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. preliminaires ; codret', codret + call dmflsh(iaux) +#endif +c +c 4.1. ==> nombres caracteristiques +c + if ( codret.eq.0 ) then +c + call gmliat ( nhelig, 1, nbelig, codret ) +c + endif +c +c 4.2. ==> on n'ordonne pas les noeuds +c +c noeord = .true. + noeord = .false. +c +c==== +c 5. Calcul du nombre d'entites pour le calcul. +c . Pour les noeuds, il y en a tout le temps et leur nombre +c est egal au nombre de noeuds. +c . Pour les aretes, les triangles ou les quadrangles, il est +c impossible d'avoir une estimation correcte a cause de la +c conformite qui fait apparaitre ou disparaitre des mailles. +c On appelle donc un programme qui fait le decompte. +c . Pour les mailles 3D, c'ets simple : il y a equivalence +c entre maille active et maille qui sera du calcul ensuite. +c Une fois ces estimations faites, on peut deduire le nombre +c total de mailles de calcul. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'au debut de 5. ; codret', codret +#endif +c +c 5.1. ==> estimation du nombre d'elements du maillage de calcul +c + nbele0 = nbelig +c +c 5.2. ==> les noeuds +c + rsnoac = nbnoto + rsnoto = nbnoto + rsnois = nbnois + rsnoei = nbnoei + rsnomp = nbnomp + rsnop1 = nbnop1 + rsnop2 = nbnop2 + rsnoim = nbnoim +c +c 5.3. ==> les mailles-points +c + if ( codret.eq.0 ) then +c + if ( nbmpto.eq.0 ) then + rsmpto = 0 + else + rsmpto = nbmpto + endif +c + nbele0 = nbele0 + rsmpto +c + endif +c +c 5.4. ==> les aretes +c + if ( codret.eq.0 ) then +c + if ( nbarac.eq.0 ) then + rsarto = 0 + elseif ( mod(nonexm,2).eq.0 ) then + rsarto = 0 + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAA0', nompro +#endif + call pcmaa0 ( rsarto, + > imem(phetar), + > imem(pfamar), imem(pcfaar), + > ulsort, langue, codret ) + endif +c + nbele0 = nbele0 + rsarto +c + endif +c +c 5.5. ==> les triangles +c + if ( codret.eq.0 ) then +c + if ( nbtrac.eq.0 ) then + rstrto = 0 + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAT0', nompro +#endif + call pcmat0 ( rstrto, + > imem(phettr), + > imem(pfamtr), imem(pcfatr), + > ulsort, langue, codret ) + endif +c + nbele0 = nbele0 + rstrto +c + endif +c +c 5.6. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbquac.eq.0 ) then + rsquto = 0 + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAQ0', nompro +#endif + call pcmaq0 ( rsquto, + > imem(phetqu), + > imem(pfamqu), imem(pcfaqu), + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'rsquto', rsquto +#endif + endif +c + nbele0 = nbele0 + rsquto +c + endif +c +c 5.8. ==> les tetraedres +c + if ( codret.eq.0 ) then +c + if ( nbteac.eq.0 ) then + rsteto = 0 + else + rsteto = nbteto + endif +c + nbele0 = nbele0 + rsteto +c + endif +c +c 5.9. ==> les hexaedres +c + if ( codret.eq.0 ) then +c + if ( nbheac.eq.0 ) then + rsheto = 0 + else + rsheto = nbheto + endif +c + nbele0 = nbele0 + rsheto +c + endif +c +c 5.10. ==> les pyramides +c + if ( codret.eq.0 ) then +c + if ( nbpyac.eq.0 ) then + rspyto = 0 + else + rspyto = nbpyto + endif +c + nbele0 = nbele0 + rspyto +c + endif +c +c 5.11. ==> les pentaedres +c + if ( codret.eq.0 ) then +c + if ( nbpeac.eq.0 ) then + rspeto = 0 + else + rspeto = nbpeto + endif +c + nbele0 = nbele0 + rspeto +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,18)) mess14(langue,3,13), nbele0 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'apres les 5.3.x ; codret', codret + call dmflsh(iaux) +#endif +c +c==== +c 6. allocation des tableaux pour le maillage de sortie +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. allocation des tableaux ; codret', codret +#endif +c +c 6.1. ==> allocation de l'objet de tete +c remarque : pour le moment, ncfron n'est pas alloue +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sdimca, mdimca', sdimca, mdimca + write (ulsort,90002) 'nbnoto, nctfno, nbele0, nbmane', + > nbnoto, nctfno, nbele0, nbmane + write (ulsort,texte(langue,3)) 'UTACMA', nompro +#endif + call utacma ( nocmap, iaux, typcca, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnoto, nctfno, nbele0, nbmane, jaux, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> tableaux de correspondance entre les numerotations +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'au debut de 6.2 ; codret', codret +#endif +c +c 6.2.1 ==> les noeuds +c + if ( codret.eq.0 ) then +c + iaux = -1 + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_no', nompro +#endif + call utre01 ( iaux, kaux, + > norenu, rsnoac, rsnoto, + > adnohp, adnocp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.2. ==> les mailles-points +c + if ( codret.eq.0 ) then +c + iaux = 0 + if ( rsmpto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_mp', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rsmpto, + > admphp, admpcp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.3. ==> les aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_ar', nompro +#endif + iaux = 1 + if ( rsarto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 + call utre01 ( iaux, kaux, norenu, jaux, rsarto, + > adarhp, adarcp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.4. ==> les triangles +c + if ( codret.eq.0 ) then +c + iaux = 2 + if ( rstrto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_tr', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rstrto, + > adtrhp, adtrcp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.5. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + iaux = 4 + if ( rsquto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_qu', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rsquto, + > adquhp, adqucp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.6. ==> les tetraedres +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( rsteto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_te', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rsteto, + > adtehp, adtecp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.7. ==> les hexaedres +c + if ( codret.eq.0 ) then +c + iaux = 6 + if ( rsheto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_he', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rsheto, + > adhehp, adhecp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.8. ==> les pyramides +c + if ( codret.eq.0 ) then +c + iaux = 5 + if ( rspyto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_py', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rspyto, + > adpyhp, adpycp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.9. ==> les pentaedres +c + if ( codret.eq.0 ) then +c + iaux = 7 + if ( rspeto.eq.0 ) then + jaux = 0 + else + jaux = nbele0 + endif + kaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_pe', nompro +#endif + call utre01 ( iaux, kaux, norenu, jaux, rspeto, + > adpehp, adpecp, laux, + > ulsort, langue, codret) +c + endif +c +c 6.2.10. ==> les nombres +c + if ( codret.eq.0 ) then +c + iaux = 25 + call gmecat ( norenu, 19, iaux, codre1 ) + call gmaloj ( norenu//'.Nombres', ' ', iaux, adnbrp, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'apres les 6.2.x ; codret', codret + call dmflsh(iaux) +#endif +c +c 6.3. ==> structure de donnees de type externe : on prend large pour +c le nombre de mailles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. structure externe ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbnoto * sdimca + call gmaloj ( ncnoeu//'.Coor', ' ', iaux, pcoonc, codre1 ) + call gmaloj ( ncnoeu//'.FamilMED', ' ', nbnoto, pfamen, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + call gmecat ( ncnoeu, 3, dimcst, codre1 ) + call gmcpoj ( nhnoeu//'.CoorCons', ncnoeu//'.CoorCons', codre2 ) + call gmadoj ( nhnoeu//'.CoorCons', adcocs, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmaloj ( nccono//'.FamilMED', ' ', nbele0, pfamee, codre1 ) + iaux = nbele0*nbmane + call gmaloj ( nccono//'.Noeuds', ' ', iaux , pnoeel, codre2 ) + call gmaloj ( nccono//'.Type', ' ', nbele0, ptypel, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.4. ==> transfert des mailles ignorees +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.4. ==> transfert ignores ; codret', codret + write (ulsort,90002) 'nbelig', nbelig + call dmflsh(iaux) +#endif +c + if ( nbelig.ne.0 ) then +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro, nhelig ) +cgn call gmprsx (nompro, nhelig//'.ConnNoeu' ) +cgn call gmprsx (nompro, nhelig//'.FamilMED' ) +c + call gmadoj ( nhelig//'.ConnNoeu', hnoeel, iaux, codre1 ) + call gmadoj ( nhelig//'.FamilMED', hfmdel, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINEI', nompro +#endif + call utinei ( modhom, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c==== +c 7. impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. impressions ; codret', codret + call dmflsh(iaux) +#endif +cgn call gmprsx (nompro, nhnofa//'.EntiFamm') +cgn call gmprsx (nompro, nhmpfa//'.EntiFamm') +cgn call gmprsx (nompro, nharfa//'.EntiFamm') +cgn call gmprsx (nompro, nhtrfa//'.EntiFamm') +cgn call gmprsx (nompro, nhqufa//'.EntiFamm') +cgn call gmprsx (nompro, nhtefa//'.EntiFamm') +cgn call gmmess(6) +cgn call gmprsx (nompro, nhtrfa//'.Codes') +cgn call gmprsx (nompro, nhqufa//'.Codes') +cgn ulsort = 6 +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif + call utecfe ( iaux, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +c +#endif +c +c==== +c 8. conversion vraie +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. conversion vraie ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAC1', nompro +#endif + call pcmac1 ( nbele0, + > rmem(pcoono), imem(phetno), imem(pancno), imem(ptrav4), + > imem(pnoemp), imem(phetmp), + > imem(psomar), imem(pnp2ar), imem(phetar), + > imem(paretr), imem(phettr), imem(adnmtr), + > imem(parequ), imem(phetqu), imem(adnmqu), + > imem(ptrite), imem(pcotrt), imem(parete), imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), imem(phethe), + > imem(adnmhe), + > imem(pfacpy), imem(pcofay), imem(parepy), imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), imem(phetpe), + > imem(pfamno), imem(pcfano), imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), imem(pfampe), imem(pcfape), + > imem(adnocp), imem(adnohp), imem(admpcp), imem(admphp), + > imem(adarcp), imem(adarhp), + > imem(adtrcp), imem(adtrhp), imem(adqucp), imem(adquhp), + > imem(adtecp), imem(adtehp), imem(adhecp), imem(adhehp), + > imem(adpycp), imem(adpyhp), imem(adpecp), imem(adpehp), + > dimcst, rmem(adcocs), rmem(pcoonc), imem(pfamen), + > imem(pfamee), imem(pnoeel), imem(ptypel), + > imem(hfmdel), imem(hnoeel), + > noeord, deraff, + > ulsort, langue, codret ) +c + endif +c +c==== +c 9. finitions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. finitions ; codret', codret + call dmflsh(iaux) +#endif +c +c 9.1. ==> maintenant que l'on connait le vrai nombre de mailles au sens +c du calcul, on raccourcit eventuellement les tableaux +c +c 9.1.1. ==> les eventuelles mailles-points +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.1. mailles-points ; codret', codret + write (ulsort,90002) 'nbmpto', nbmpto + write (ulsort,90002) 'rsmpac', rsmpac + call dmflsh(iaux) +#endif +c + if ( rsmpto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_mp', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rsmpto, rsmpac, rsmpto, + > admphp, admpcp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.2. ==> les aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.2. aretes ; codret', codret + write (ulsort,90002) 'nbarto', nbarto + call dmflsh(iaux) +#endif +c + if ( rsarto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_ar', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rsarto, rsarac, rsarto, + > adarhp, adarcp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.3. ==> les eventuels triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.3. triangles ; codret', codret + write (ulsort,90002) 'nbele0', nbele0 + write (ulsort,90002) 'nbtrto', nbtrto + call dmflsh(iaux) +#endif +c + if ( rstrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_tr', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rstrto, rstrac, rstrto, + > adtrhp, adtrcp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.4. ==> les eventuels quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.4. quadrangles ; codret', codret + write (ulsort,90002) 'nbele0', nbele0 + write (ulsort,90002) 'rsquac', rsquac + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'rsquto', rsquto + call dmflsh(iaux) +#endif +c + if ( rsquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_qu', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rsquto, rsquac, rsquto, + > adquhp, adqucp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.5. ==> les eventuels tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.5. tetraedres ; codret', codret + write (ulsort,90002) 'nbteto', nbteto + call dmflsh(iaux) +#endif +c + if ( rsteto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 3 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_te', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rsteto, rsteac, rsteto, + > adtehp, adtecp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.6. ==> les eventuelles pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.6. pyramides ; codret', codret + write (ulsort,90002) 'nbpyto', nbpyto + call dmflsh(iaux) +#endif +c + if ( rspyto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 5 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_py', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rspyto, rspyac, rspyto, + > adpyhp, adpycp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.7. ==> les eventuels hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.7. hexaedres ; codret', codret + write (ulsort,90002) 'nbheto', nbheto + call dmflsh(iaux) +#endif +c + if ( rsheto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 6 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_he', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rsheto, rsheac, rsheto, + > adhehp, adhecp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.8. ==> les eventuels pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.8. pentaedres ; codret', codret + write (ulsort,90002) 'nbpeto', nbpeto + call dmflsh(iaux) +#endif +c + if ( rspeto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 7 + jaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_pe', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > nbele0, rspeto, rspeac, rspeto, + > adpehp, adpecp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.1.9. ==> les descriptions des mailles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.1.9. mailles ; codret', codret + write (ulsort,90002) 'nbele0, nbelem, nbmane', + > nbele0,nbelem,nbmane + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + call gmmod ( nccono//'.FamilMED', + > pfamee, nbele0, nbelem, un, un, codre1 ) + call gmmod ( nccono//'.Type', + > ptypel, nbele0, nbelem, un, un, codre2 ) + call gmmod ( nccono//'.Noeuds', + > pnoeel, nbele0, nbelem, nbmane, nbmane, codre3 ) + call gmecat ( nccono, 1, nbelem, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +cgn call gmprsx (nompro//' - 8.1.9',nccono) +cgn call gmprsx (nompro//' - 8.1.9',nccono//'.Type') +cgn call gmprsx (nompro//' - 8.1.9',nccono//'.Noeuds') +c +c 9.2. ==> les caracteristiques du maillage de calcul +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2. carac. mail de calcul ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adnbrp) = rsnois + imem(adnbrp+1) = rsnoei + imem(adnbrp+2) = rsnomp + imem(adnbrp+3) = rsnop1 + imem(adnbrp+4) = rsnop2 + imem(adnbrp+5) = rsnoim + imem(adnbrp+6) = rseutc + imem(adnbrp+7) = rsevca + imem(adnbrp+8) = rsevto + imem(adnbrp+9) = nbelem + imem(adnbrp+10) = nbmaae + imem(adnbrp+11) = nbmafe + imem(adnbrp+12) = nbmane + imem(adnbrp+13) = nbmapo + imem(adnbrp+14) = nbsegm + imem(adnbrp+15) = nbtetr + imem(adnbrp+16) = nbtria + imem(adnbrp+17) = nbquad + imem(adnbrp+18) = numael + imem(adnbrp+19) = numano + imem(adnbrp+20) = nvoare + imem(adnbrp+21) = nvosom + imem(adnbrp+22) = nbhexa + imem(adnbrp+23) = nbpyra + imem(adnbrp+24) = nbpent +c + endif +c +c 9.3. ==> Les nombres +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +cgn print *,nbmaae, nbmafe, nbmnei, numano, numael +cgn print *,nbmapo,nbsegm,nbtria,nbtetr +cgn print *,nbelig,nbquad,nbhexa,nbpent,nbpyra +c + if ( codret.eq.0 ) then +c + imem(adnomb) = nbmaae + imem(adnomb+1) = nbmafe + imem(adnomb+2) = nbmnei + imem(adnomb+3) = numano + imem(adnomb+4) = numael + imem(adnomb+5) = nbtria + nbquad + imem(adnomb+6) = nbtetr + nbhexa + nbpent + nbpyra + imem(adnomb+11) = nbmapo + imem(adnomb+12) = nbsegm + imem(adnomb+13) = nbtria + imem(adnomb+14) = nbtetr + imem(adnomb+15) = nbelig + imem(adnomb+16) = nbquad + imem(adnomb+17) = nbhexa + imem(adnomb+18) = nbpent + imem(adnomb+19) = nbpyra +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnomb ) +#endif +c + endif +c +c 9.4. ==> date et heure +c + if ( codret.eq.0 ) then +c + call utdhus ( dateus, heurus ) +c + endif +c +cmdc ---------------- MAILLES DOUBLES DEBUT -------------- +cmdc +cmdc 3.4.1. ==> Lecture du numero de la couche en cours +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd nomfic = 'nrc.dat' +cmd inquire ( file = nomfic, exist = maildb ) +cmdc +cmd endif +cmdc +cmd if ( maildb ) then +cmdc +cmd nbele0 = nbelem +cmd nbele1 = nbele0 + nbtetr +cmdcgn write(ulsort,90002) 'nbele0', nbele0 +cmdcgn write(ulsort,90002) 'nbele1', nbele1 +cmdcgn write(ulsort,90002) 'nbfmed', nbfmed +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre1 ) +cmd call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre2 ) +cmd call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre3 ) +cmd call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre4 ) +cmdc +cmd codre0 = min ( codre1, codre2, codre3, codre4 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2, codre3, codre4 ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd iaux = 3*nbfmed +cmd call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codret ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmmod ( nccono//'.FamilMED', +cmd > pfamee, nbele0, nbele1, un, un, codre1 ) +cmd call gmmod ( nccono//'.Type', +cmd > ptypel, nbele0, nbele1, un, un, codre2 ) +cmd call gmmod ( nccono//'.Noeuds', +cmd > pnoeel, nbele0, nbele1, nbmane, nbmane, codre3 ) +cmd call gmecat ( nccono, 1, nbelem, codre4 ) +cmdc +cmd codre0 = min ( codre1, codre2, codre3, codre4 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2, codre3, codre4 ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd#ifdef _DEBUG_HOMARD_ +cmd write (ulsort,texte(langue,3)) 'PCMMEN', nompro +cmd#endif +cmd call pcmmen ( nbele0, nbele1, nbtenw, +cmd > imem(pnoeel), imem(pfamee), imem(ptypel), +cmd > imem(adnumf), +cmd > imem(adpoin), imem(adtail), smem(adtabl), +cmd > imem(ptrav5), imem(ptrav5+2*nbfmed), +cmd > ulsort, langue, codret ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd nbtetr = nbtetr + nbtenw +cmd nbelem = nbele0 + nbtenw +cmdc +cmd call gmmod ( nccono//'.FamilMED', +cmd > pfamee, nbele1, nbelem, un, un, codre1 ) +cmd call gmmod ( nccono//'.Type', +cmd > ptypel, nbele1, nbelem, un, un, codre2 ) +cmd call gmmod ( nccono//'.Noeuds', +cmd > pnoeel, nbele1, nbelem, nbmane, nbmane, codre3 ) +cmd call gmecat ( nccono, 1, nbelem, codre4 ) +cmdc +cmd codre0 = min ( codre1, codre2, codre3, codre4 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2, codre3, codre4 ) +cmdc +cmd imem(adnbrp+15) = nbtetr +cmd imem(adnomb+6) = nbtetr + nbhexa + nbpent + nbpyra +cmd imem(adnomb+14) = nbtetr +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmlboj ( ntrav5, codret ) +cmdc +cmd endif +cmdc +cmd endif +cmdc ---------------- MAILLES DOUBLES FIN ---------------- +c +c==== +c 10. impression des nombres d'entites du maillage de calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. impression ; codret', codret + call dmflsh(iaux) +#endif + if ( codret.eq.0 ) then +c + iaux = 0 + if ( langue.eq.1 ) then +c 12345678901234567890123456789012 + saux32 = 'apres conversion ' + else + saux32 = 'after the conversion ' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINMA', nompro +#endif + call utinma ( iaux, saux32, + > sdimca, mdimca, degre, + > nbnoto, nbnop1, nbnop2, nbnoim, + > nbnois, nbnomp, + > nbnoei, nbelem, + > nbmapo, nbsegm, nbtria, nbquad, + > nbtetr, nbhexa, nbpyra, nbpent, + > nbelig, + > nbmane, nbmaae, nbmafe, + > ulsort, langue, codret) +c + endif +c +c==== +c 11. sauvegarde des informations generales, au sens du module de +c calcul associe +c on peut faire des attachements car le maillage homard n'est +c jamais detruit. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. sauvegarde ; codret', codret + call dmflsh(iaux) +#endif +c +c 11.1. ==> a-t-on defini des informations en externe ? +c + if ( codret.eq.0 ) then +c + call gmobal ( nhsupe//'.Tab7', codret ) +c + if ( codret.eq.0 ) then + existe = .false. + elseif ( codret.eq.2 ) then + codret = 0 + existe = .true. + else + codret = 2 + endif +c + endif +c +c 11.2. ==> copie des differents attributs +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11.2. copie des attributs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( existe ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 7, iaux , codre1 ) + call gmliat ( nhsups, 3, jaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( ncinfo, 1, iaux , codre1 ) + call gmecat ( ncinfo, 2, jaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif + + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + call gmprsx (nompro//' 11.2', ncinfo ) + call gmprsx (nompro//' 11.2', ncinfo//'.Pointeur' ) + call gmprsx (nompro//' 11.2', ncinfo//'.Taille' ) + call gmprsx (nompro//' 11.2', ncinfo//'.Table' ) +c + endif +#endif +c +c 11.3. ==> copie des differentes branches +c attention : il faut faire des copies et non pas des +c attachements car le contenu est modifie ensuite dans +c certains cas +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11.3. copie des branches ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( existe ) then +c + if ( codret.eq.0 ) then +c + call gmcpoj ( nhsupe//'.Tab7', + > ncinfo//'.Pointeur', codre1 ) + call gmcpoj ( nhsupe//'.Tab8', + > ncinfo//'.Taille', codre2 ) + call gmcpoj ( nhsups//'.Tab3', + > ncinfo//'.Table', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( mod(typcca-6,10).eq.0 ) then +c + call gmadoj ( ncinfo//'.Pointeur', pinfpt, iaux, codre1 ) + call gmadoj ( ncinfo//'.Table' , pinftb, iaux, codre2 ) + call gmliat ( ncinfo, 1, iaux, codre3 ) + nbpqt = iaux - 1 +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 11.4. ==> changement du nom du maillage +c + if ( codret.eq.0 ) then +c + do 1114 , iaux = 1, nbpqt +c + jaux = pinftb + 10*(iaux-1) +cgn write (ulsort,90064) jaux, '%'//smem(jaux)//'%' +c +c 2.1. Repere et noms des coordonnees +c + if ( smem(jaux).eq.'NOMAMD ' ) then +c + call utchs8 ( nomamd, lnomam, smem(jaux+1), + > ulsort, langue, codret ) +c + endif +c + 1114 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + call gmprsx (nompro, ncinfo ) + call gmprsx (nompro, ncinfo//'.Pointeur' ) + call gmprsx (nompro, ncinfo//'.Taille' ) + call gmprsx (nompro, ncinfo//'.Table' ) +c + endif +#endif +c + endif +c + endif +c +c==== +c 12. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. Menage ; codret', codret +#endif +c +c 12.1. ==> Structure dediee au deraffinement +c + if ( codret.eq.0 ) then +c + if ( deraff ) then +c + call gmlboj ( ntrav4, codret ) +c + endif +c + endif +c +c 12.2. ==> Recuperation des sauvegardes dans le cas non conforme +c + if ( .not. cforme ) then +c +c 12.2.1. ==> Suppression des mailles temporaires dans les +c renumerotations +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro,nospec//'.Tab1') +cgn call gmprsx (nompro,nospec//'.Tab3') +cgn call gmprsx (nompro,nospec//'.Tab5') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAR1', nompro +#endif + call pcmar1 ( imem(adarcp), + > imem(adtrcp), imem(adqucp), + > imem(adtecp), imem(adhecp), + > imem(adpecp), imem(adpycp), + > nparrc, nptrrc, npqurc, + > imem(adarrc), imem(adtrrc), imem(adqurc), + > imem(adterc), imem(adherc), + > imem(adperc), imem(adpyrc), + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx (nompro,nospec) +cgn call gmprsx (nompro,nospec//'.Tab1') +cgn call gmprsx (nompro,nospec//'.Tab2') +cgn call gmprsx (nompro,nospec//'.Tab3') +cgn call gmprsx (nompro,nospec//'.Tab4') +cgn call gmprsx (nompro,nospec//'.Tab5') +cgn call gmprsx (nompro,nospec//'.Tab6') +cgn call gmprsx (nompro,nospec//'.Tab7') +c +c 12.2.2. ==> Recopie des historiques et familles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12.2.2. Copie hist/fami - codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmcpoj ( ntrav1, nharet//'.HistEtat', codre1 ) + call gmlboj ( ntrav1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( nbtrto.ne.0 ) then +c + call gmcpoj ( ntrav2, nhtria//'.HistEtat', codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( nbquto.ne.0 ) then +c + call gmcpoj ( ntrav3, nhquad//'.HistEtat', codre1 ) + call gmlboj ( ntrav3, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c==== +c 13. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '13. la fin ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + call gmprsx ( nompro , nhnoeu ) + if ( nbmapo.gt.0 ) then + call gmprsx ( nompro , nhmapo ) + endif + call gmprsx ( nompro , nharet ) + if ( nbtrto.gt.0 ) then + call gmprsx ( nompro , nhtria ) + endif + if ( nbquto.gt.0 ) then + call gmprsx ( nompro , nhquad ) + endif + if ( nbteto.gt.0 ) then + call gmprsx ( nompro , nhtetr ) + endif + if ( nbheto.gt.0 ) then + call gmprsx ( nompro , nhhexa ) + endif + if ( nbpyto.gt.0 ) then + call gmprsx ( nompro , nhpyra ) + endif + if ( nbpeto.gt.0 ) then + call gmprsx ( nompro , nhpent ) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmafa.F b/src/tool/AP_Conversion/pcmafa.F new file mode 100644 index 00000000..4f368d4d --- /dev/null +++ b/src/tool/AP_Conversion/pcmafa.F @@ -0,0 +1,858 @@ + subroutine pcmafa ( nocmap, nohmap, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - FAmilles +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmap . e . char8 . nom de l'objet maillage de calcul iter. n+1. +c . nohmap . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nbutil.h" +#include "nombsr.h" +#include "nbfami.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nocmap, nohmap +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c + integer adhono, admpho, adhoar, adhotr, adhoqu + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte, pcfate + integer pfamhe, pcfahe + integer pfampy, pcfapy + integer pfampe, pcfape + integer adeqpo, adeqin + integer adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe + integer nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn +c + integer ptypel +c + integer rvnoac, adnohp, rvnoto, adnocp + integer rvmpac, admphp, rvmpto, admpcp + integer rvarac, adarhp, rvarto, adarcp + integer rvtrac, adtrhp, rvtrto, adtrcp + integer rvquac, adquhp, rvquto, adqucp + integer rvteac, adtehp, rvteto, adtecp + integer rvheac, adhehp, rvheto, adhecp + integer rvpyac, adpyhp, rvpyto, adpycp + integer rvpeac, adpehp, rvpeto, adpecp +c + integer adnomb +c + integer iaux, jaux + integer iaux1, iaux2, iaux3, iaux4, iaux5, iaux6, iaux7,iaux8 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8, codre9 + integer codre0 +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nhnofa, nhmpfa, nharfa, nhtrfa, nhqufa + character*8 nhtefa, nhhefa, nhpyfa, nhpefa + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' +c + texte(2,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' +c +#include "impr03.h" +c +c==== +c 2. structure generale +c==== +c +c 2.1. ==> Nom des structures +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nohmap, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> Verification du type de calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Verification ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +#include "mslve4.h" + endif +#endif +c +c 2.3. ==> Nom des structures des familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. structures familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhnoeu//'.Famille', nhnofa, codre1 ) + call gmnomc ( nhmapo//'.Famille', nhmpfa, codre2 ) + call gmnomc ( nharet//'.Famille', nharfa, codre3 ) + call gmnomc ( nhtria//'.Famille', nhtrfa, codre4 ) + call gmnomc ( nhquad//'.Famille', nhqufa, codre5 ) + call gmnomc ( nhtetr//'.Famille', nhtefa, codre6 ) + call gmnomc ( nhhexa//'.Famille', nhhefa, codre7 ) + call gmnomc ( nhpyra//'.Famille', nhpyfa, codre8 ) + call gmnomc ( nhpent//'.Famille', nhpefa, codre9 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) +c + endif +c +c==== +c 3. Recuperation des pointeurs +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recup. des pointeurs ; codret', codret +#endif +c +c 3.1.==> tableaux +c + if ( codret.eq.0 ) then +c + iaux = 7 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > jaux, + > pfamno, pcfano, jaux, + > jaux, jaux, adhono, jaux, + > ulsort, langue, codret ) +c + if ( rsmpto.ne.0 ) then +c + iaux = 259 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + call utad02 ( iaux, nhmapo, + > jaux, jaux, jaux , jaux, + > pfammp, pcfamp, jaux, + > jaux , jaux, jaux, + > jaux , admpho, jaux, + > ulsort, langue, codret ) +c + endif +c + iaux = 259 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > jaux, jaux, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux , jaux, jaux, + > jaux , adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( rstrto.ne.0 ) then + iaux = iaux*7 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, jaux, + > pfamtr, pcfatr, jaux, + > jaux , jaux, jaux, + > jaux , adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c + iaux = 37 + if ( rsquto.ne.0 ) then + iaux = iaux*7 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux , jaux, jaux, + > jaux , adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbftet.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 37 + if ( rsteto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhtetr, + > jaux, jaux, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfhex.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 37 + if ( rsheto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhhexa, + > jaux, jaux, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpyr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 37 + if ( rspyto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhpyra, + > jaux, jaux, jaux, jaux, + > pfampy, pcfapy, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpen.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 37 + if ( rspeto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhpent, + > jaux, jaux, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2. ==> homologues +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. homologues ; codret', codret +#endif +c +c 3.3. ==> tableaux de renumerotation +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. renumerotation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > rvnoac, rvnoto, adnohp, adnocp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_mp', nompro +#endif + iaux = 0 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvmpac, rvmpto, admphp, admpcp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + iaux = 1 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvarac, rvarto, adarhp, adarcp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvtrac, rvtrto, adtrhp, adtrcp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_te', nompro +#endif + iaux = 3 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvteac, rvteto, adtehp, adtecp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvquac, rvquto, adquhp, adqucp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_py', nompro +#endif + iaux = 5 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvpyac, rvpyto, adpyhp, adpycp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_he', nompro +#endif + iaux = 6 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvheac, rvheto, adhehp, adhecp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro +#endif + iaux = 7 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rvpeac, rvpeto, adpehp, adpecp, + > ulsort, langue, codret) +c + endif +c +c 3.4. ==> maillage de calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. maillage de calcul ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call utnomc ( nocmap, + > iaux1, iaux2, + > iaux3, iaux4, iaux5, iaux6, iaux7, + > iaux8, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 7 + call utad11 ( iaux, ncnoeu, nccono, + > jaux, jaux, jaux, jaux, + > ptypel, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ +c 3.5. ==> impression +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif + call utecfe ( iaux, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 5. Les equivalences +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Les equivalences ; codret', codret +#endif +c + if ( homolo.ne.0 ) then +c +c 5.1. ==> estimation de la longueur des listes +c c'est une estimation car on ne fait pas de difference +c entre les vrais et les faux homolgues de l'axe +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ1', nompro +#endif + call pcceq1 ( imem(pcfano), imem(pfamno), imem(adnohp), + > imem(pcfamp), imem(pfammp), imem(admphp), + > imem(pcfaar), imem(pfamar), imem(adarhp), + > imem(pcfatr), imem(pfamtr), imem(adtrhp), + > imem(pcfaqu), imem(pfamqu), imem(adquhp), + > imem(ptypel), + > ulsort, langue, codret ) +c + endif +c +c 5.2. ==> allocation des nouveaux tableaux +c + if ( codret.eq.0 ) then +c + nbeqte = 0 + nbeqhe = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTACME', nompro +#endif + call utacme ( ncequi, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe, + > adeqpo, adeqin, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> creation des listes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCEQ3', nompro +#endif + call pcceq3 ( imem(pcfano), imem(pfamno), + > imem(adnohp), imem(adnocp), + > imem(pcfamp), imem(pfammp), + > imem(admphp), imem(admpcp), + > imem(pcfaar), imem(pfamar), + > imem(adarhp), imem(adarcp), + > imem(pcfatr), imem(pfamtr), + > imem(adtrhp), imem(adtrcp), + > imem(pcfaqu), imem(pfamqu), + > imem(adquhp), imem(adqucp), + > imem(ptypel), + > imem(adhono), imem(admpho), + > imem(adhoar), imem(adhotr), imem(adhoqu), + > imem(adeqpo), + > imem(adeqno), imem(adeqmp), + > imem(adeqar), imem(adeqtr), imem(adeqqu), + > nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn, + > ulsort, langue, codret ) +c + endif +c +c 5.4. ==> modification des longueurs des tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD07', nompro +#endif + call utad07 ( ncequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. sauvegarde des informations sur les familles, au sens +c du module de calcul associe +c on peut faire des attachements car le maillage homard n'est +c jamais detruit. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. sauvegarde familles ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsupe ) + call gmprsx (nompro, nhsupe//'.Tab3' ) + call gmprsx (nompro, nhsupe//'.Tab4' ) + call gmprsx (nompro, nhsupe//'.Tab5' ) + call gmprsx (nompro, nhsupe//'.Tab6' ) + call gmprsx (nompro, nhsupe//'.Tab9' ) + call gmprsx (nompro, nhsups ) + call gmprsx (nompro, nhsups//'.Tab2' ) + call gmprsx (nompro, nhsups//'.Tab4' ) +#endif +c +c 6.1. ==> Allocations +c + if ( codret.eq.0 ) then +c + call gmaloj ( ncfami//'.Groupe' , ' ', 0, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 6.2. ==> Attributs +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. Attributs lecture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 5, iaux3, codre1 ) + call gmliat ( nhsups, 2, iaux4, codre2 ) + call gmliat ( nhsupe, 9, nbfmed, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. Attributs ecriture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + ngrouc = iaux4/10 + call gmecat ( ncfami//'.Groupe', 1, iaux3, codre1 ) + call gmecat ( ncfami//'.Groupe', 2, iaux4, codre2 ) + call gmecat ( ncfami, 1, nbfmed, codre3 ) + call gmecat ( ncfami, 2, ngrouc, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 6.3. ==> Attachements +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. ==> Attachements ; codret', codret + write (ulsort,90002) 'nbfmed', nbfmed + write (ulsort,90002) 'ngrouc', ngrouc +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfmed.ne.0 ) then +c + if ( ngrouc.gt.0 ) then +c + call gmatoj ( ncfami//'.Groupe.Pointeur', + > nhsupe//'.Tab5', codre1 ) + call gmatoj ( ncfami//'.Groupe.Taille', + > nhsupe//'.Tab6', codre2 ) + call gmatoj ( ncfami//'.Groupe.Table', + > nhsups//'.Tab2', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +cgn write (ulsort,*) codre1, codre2, codre3 +c + endif +c + call gmatoj ( ncfami//'.Numero', + > nhsupe//'.Tab9', codre1 ) + call gmatoj ( ncfami//'.Nom', + > nhsups//'.Tab4', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +cgn write (ulsort,*) codre1, codre2 +c + endif +c + endif +c +c==== +c 7. sauvegarde des informations sur les equivalences, au sens +c du module de calcul associe +c on peut faire des attachements car le maillage homard n'est +c jamais detruit. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. sauvegarde equivalences ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsups//'.Tab5' ) +#endif +c + call gmobal ( ncequi//'.InfoGene', codret ) +c + if ( codret.eq.2 ) then + codret = 0 + call gmlboj ( ncequi//'.InfoGene', codret ) + elseif ( codret.ne.0 ) then + codret = 2 + endif +c + if ( codret.eq.0 ) then + call gmatoj ( ncequi//'.InfoGene', + > nhsups//'.Tab5', codret ) + endif +c + endif +c + endif +c +c==== +c 8. Les nombres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Les nombres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +cgn print *,nbfmed, ngrouc +cgn print *,nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu +c + if ( codret.eq.0 ) then +c + imem(adnomb+21) = nbfmed +cgn imem(adnomb+22) = nattrc + imem(adnomb+23) = ngrouc + imem(adnomb+30) = nbequi + imem(adnomb+31) = nbeqno + imem(adnomb+32) = nbeqmp + imem(adnomb+33) = nbeqar + imem(adnomb+34) = nbeqtr + imem(adnomb+35) = nbeqqu +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnomb ) + call dmflsh (iaux) +#endif +c + endif +c +c==== +c 9. la fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmahe.F b/src/tool/AP_Conversion/pcmahe.F new file mode 100644 index 00000000..d88e03ff --- /dev/null +++ b/src/tool/AP_Conversion/pcmahe.F @@ -0,0 +1,537 @@ + subroutine pcmahe ( elemen, nbele0, + > somare, np2are, + > arequa, + > quahex, coquhe, arehex, + > hethex, ninhex, + > famhex, cfahex, + > nnosca, nhesca, nhesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - HExaedres +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . ninhex . e . nbheto . noeud interne a l'hexaedre . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . nhesca . s . rsheto . numero des hexaedres dans le calcul . +c . nhesho . s . nbele0 . numero des hexaedres dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAHE' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto), ninhex(nbheto) +c + integer cfahex(nctfhe,nbfhex), famhex(nbheto) +c + integer nnosca(rsnoto) + integer nhesca(rsheto), nhesho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lehexa, lehex0 + integer etat + integer iaux + integer listar(12), listso(20), nomiar(12) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbhecf, nbheca =', nbhecf, nbheca +#endif +c +#include "impr03.h" +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rsheto + nhesca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + nhesho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c 1 4 +c -------------------- +c / /. +c / / . +c / / . +c / / . +c 2 -------------------- 3 . +c . . . +c . . . +c . 5 . . 8 +c . . / +c . . / +c . . / +c . ./ +c -------------------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (1-->2,1-->5,1-->4) est direct +c + + do 31 , lehex0 = 1 , nbheto +c + lehexa = lehex0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa +#endif +c + etat = mod(hethex(lehexa),1000) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,14)) elemen + endif +#endif + nhesho(elemen) = lehexa + nhesca(lehexa) = elemen +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASHE', nompro +#endif + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c Attention : utashe donne la numerotation dans la convention homard +c il faut permuter les sommets 5/6 et 7/8 pour obtenir +c la numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(2)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,6) = nnosca(listso(5)) + noeele(elemen,5) = nnosca(listso(6)) + noeele(elemen,8) = nnosca(listso(7)) + noeele(elemen,7) = nnosca(listso(8)) +c + famele(elemen) = cfahex(cofamd,famhex(lehexa)) + typele(elemen) = cfahex(cotyel,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ +cgn if ( glop.ne.0 ) then + write (ulsort,90002) 'famhex', famhex(lehexa) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,8) + write (ulsort,90002) 'Famille MED',famele(elemen) + write (ulsort,90002) 'Type MED ',typele(elemen) +cgn endif +#endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + elseif ( mod(mailet,5).gt.0 ) then +c +c 1 4 +c ---------12--------- +c / /. +c 9/ 11. +c / / . +c / 17 / . +c 2 ---------10---------3 20 +c . . . +c . . . +c . 5 16 . . 8 +c 18. .19 / +c . 13 . /15 +c . . / +c . ./ +c ---------14--------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (1-->2,1-->5,1-->4) est direct +c +c Au sens homard au sens MED +c arete 1 de s1 a s2 | de s1 a s2 +c arete 2 de s1 a s4 | de s1 a s4 +c arete 3 de s2 a s3 | de s2 a s3 +c arete 4 de s3 a s4 | de s3 a s4 +c arete 5 de s1 a s6 | de s1 a s5 +c arete 6 de s2 a s5 | de s2 a s6 +c arete 7 de s4 a s7 | de s4 a s8 +c arete 8 de s3 a s8 | de s3 a s7 +c arete 9 de s5 a s6 | de s6 a s5 +c arete 10 de s6 a s7 | de s5 a s8 +c arete 11 de s5 a s8 | de s6 a s7 +c arete 12 de s7 a s8 | de s8 a s7 +c Tableau de travail nomiar : +c nomiar(i) contient le numero local au sens MED du noeud porte +c par l'arete de numero local i au sens homard +c + nomiar( 1) = 9 + nomiar( 2) = 12 + nomiar( 3) = 10 + nomiar( 4) = 11 + nomiar( 5) = 17 + nomiar( 6) = 18 + nomiar( 7) = 20 + nomiar( 8) = 19 + nomiar( 9) = 13 + nomiar(10) = 16 + nomiar(11) = 14 + nomiar(12) = 15 +c + do 41 , lehex0 = 1 , nbheto +c + lehexa = lehex0 +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa +#endif +c + etat = mod(hethex(lehexa),1000) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,14)) elemen + endif +#endif + nhesho(elemen) = lehexa + nhesca(lehexa) = elemen +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASHE', nompro +#endif + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c Attention : utashe donne la numerotation dans la convention homard +c il faut permuter les sommets 5/6 et 7/8pour obtenir la +c numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(2)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,6) = nnosca(listso(5)) + noeele(elemen,5) = nnosca(listso(6)) + noeele(elemen,8) = nnosca(listso(7)) + noeele(elemen,7) = nnosca(listso(8)) +c +c Les noeuds au milieu des aretes +c + do 411 , iaux = 1 , 12 + noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux))) + 411 continue +c +c Les noeuds internes +c + if ( mod(mailet,5).eq.0 ) then + noeele(elemen,27) = nnosca(ninhex(lehexa)) + endif +c + famele(elemen) = cfahex(cofamd,famhex(lehexa)) + typele(elemen) = cfahex(cotyel,famhex(lehexa)) +c + endif +c + 41 continue +c +c +c==== +c 4. Conversion en quadratique etendu +c Similaire au quadratique a part les noeuds de 21 a 27 +c==== +c + else +c +c 1 4 +c ---------12--------- +c / /. +c 9/ 11. +c / / . +c / 17 / . +c 2 ---------10---------3 20 +c . . . +c . . . +c . 5 16 . . 8 +c 18. .19 / +c . 13 . /15 +c . . / +c . ./ +c ---------14--------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (1-->2,1-->5,1-->4) est direct +c +c Au sens homard au sens MED +c arete 1 de s1 a s2 | de s1 a s2 +c arete 2 de s1 a s4 | de s1 a s4 +c arete 3 de s2 a s3 | de s2 a s3 +c arete 4 de s3 a s4 | de s3 a s4 +c arete 5 de s1 a s6 | de s1 a s5 +c arete 6 de s2 a s5 | de s2 a s6 +c arete 7 de s4 a s7 | de s4 a s8 +c arete 8 de s3 a s8 | de s3 a s7 +c arete 9 de s5 a s6 | de s6 a s5 +c arete 10 de s6 a s7 | de s5 a s8 +c arete 11 de s5 a s8 | de s6 a s7 +c arete 12 de s7 a s8 | de s8 a s7 +c Tableau de travail nomiar : +c nomiar(i) contient le numero local au sens MED du noeud porte +c par l'arete de numero local i au sens homard +c + nomiar( 1) = 9 + nomiar( 2) = 12 + nomiar( 3) = 10 + nomiar( 4) = 11 + nomiar( 5) = 17 + nomiar( 6) = 18 + nomiar( 7) = 20 + nomiar( 8) = 19 + nomiar( 9) = 13 + nomiar(10) = 16 + nomiar(11) = 14 + nomiar(12) = 15 +c + do 51 , lehex0 = 1 , nbheto +c + lehexa = lehex0 +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa +#endif +c + etat = mod(hethex(lehexa),1000) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,14)) elemen + endif +#endif + nhesho(elemen) = lehexa + nhesca(lehexa) = elemen +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASHE', nompro +#endif + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c Attention : utashe donne la numerotation dans la convention homard +c il faut permuter les sommets 5/6 et 7/8pour obtenir la +c numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(2)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,6) = nnosca(listso(5)) + noeele(elemen,5) = nnosca(listso(6)) + noeele(elemen,8) = nnosca(listso(7)) + noeele(elemen,7) = nnosca(listso(8)) +c +c Les noeuds au milieu des aretes +c + do 512 , iaux = 1 , 12 + noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux))) + 512 continue +c +c Les noeuds internes +c + noeele(elemen,27) = nnosca(ninhex(lehexa)) +c + famele(elemen) = cfahex(cofamd,famhex(lehexa)) + typele(elemen) = cfahex(cotyel,famhex(lehexa)) +c + endif +c + 51 continue +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaig.F b/src/tool/AP_Conversion/pcmaig.F new file mode 100644 index 00000000..93cc723f --- /dev/null +++ b/src/tool/AP_Conversion/pcmaig.F @@ -0,0 +1,199 @@ + subroutine pcmaig ( nbele0, nbelig, + > coueig, noeeig, + > elemen, typele, fameel, noeele, + > nnosca, ancnoe, trav1a, deraff, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . nbelig . e . 1 . nombre d'elements elimines . +c . noeeig . s .nbelig**. noeuds des elements . +c . coueig . s . nbelig . famille med des elements . +c . elemen . es . 1 . numero de l'element en cours . +c . noeele . es . nbele0 . noeuds des elements . +c . . .*nbmane . . +c . typele . es . nbele0 . type des elements . +c . fameel . es . nbele0 . famille med des elements . +c . nnosca . e . * . numero des noeuds dans le calcul . +c . ancnoe . e . nbnoto . ancien numero de noeud si deraffinement . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAIG' ) +c +#include "nblang.h" +#include "referx.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "meddc0.h" +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer nbele0, nbelig + integer coueig(nbelig) + integer noeeig(nbelig,*) + integer elemen, typele(nbele0), fameel(nbele0) + integer noeele(nbele0,nbmane) + integer nnosca(*), ancnoe(*), trav1a(*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer noeud, typeig + integer nbnoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'deraff = ',deraff + write (ulsort,*) 'nbele0, nbmane = ', nbele0,nbmane +#endif +c +c==== +c 2. s'il y a eu du deraffinement, il faut construire la table qui faitc +c passer de l'ancien au nouveau numero de noeud HOMARD. Cela permet +c de trouver le bon numero pour la connectivite. +c remarque : cela aurait pu etre fait dans cmdcno, mais on prefere +c le mettre ici pour ne pas polluer la phase d'adaptation avec des +c informations sur les elemenst exotiques. +c==== +c + if ( deraff ) then +c + do 21 , noeud = 1 , nbnoto + if ( ancnoe(noeud).gt.0 ) then + trav1a(ancnoe(noeud)) = noeud + endif + 21 continue +c + endif +c +c==== +c 3. on passe en revue chaque maille. +c quand c'est un element qui doit etre ignore on memorise son +c nombre de noeuds et on transfere sa description dans la structure +c HOMARD +c==== +c + if ( degre.eq.1 ) then + typeig = edpyr5 + nbnoel = 5 + else + typeig = edpy13 + nbnoel = 13 + endif +c + do 31 , iaux = 1 , nbelig +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) 'Element ',iaux +#endif +c + elemen = elemen + 1 + typele(elemen) = typeig + fameel(elemen) = coueig(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==> elemen = ',elemen + write (ulsort,*) ' noeeig : ', + > (noeeig(iaux,noeud),noeud=1,nbnoel) +#endif +c + if ( deraff ) then + do 311 , noeud = 1 , nbnoel + noeele(elemen,noeud) = trav1a(nnosca(noeeig(iaux,noeud))) + 311 continue + else + do 312 , noeud = 1 , nbnoel + noeele(elemen,noeud) = nnosca(noeeig(iaux,noeud)) + 312 continue + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' noeele : ', + > (noeele(elemen,noeud),noeud=1,nbnoel) +#endif +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmail.F b/src/tool/AP_Conversion/pcmail.F new file mode 100644 index 00000000..b5a5211d --- /dev/null +++ b/src/tool/AP_Conversion/pcmail.F @@ -0,0 +1,227 @@ + subroutine pcmail ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAILlage +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAIL' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux + integer lnomam +c + character*6 saux + character*8 typobs, nocmap, nohmap + character*64 nomamd +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONVERSION DU MAILLAGE'')' + texte(1,5) = '(29(''=''),/)' +c + texte(2,4) = '(/,a6,'' MESH CONVERSION'')' + texte(2,5) = '(22(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. les structures de base +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> le nom MED du maillage final +c + if ( mod(taopti(11)-6,10).eq.0 ) then +c + typobs = mccnmp + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) +c + else +c + lnomam = 0 +c + endif +c + endif +c +c 2.2. ==> le maillage homard a l'iteration n+1 +c + if ( codret.eq.0 ) then +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + taopts(4) = nohmap + endif +c +c==== +c 3. conversion vraie et archivage du nom du maillage +c==== +c +c 3.1. ==> conversion vraie des connectivites +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMACO', nompro + call dmflsh (iaux) +#endif + call pcmaco ( taopti(4), + > nocmap, taopts(4), nomamd, lnomam, + > taopts(20), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + taopts(2) = nocmap + endif +c +c 3.2. ==> les familles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAFA', nompro + call dmflsh(iaux) +#endif + call pcmafa ( nocmap, taopts(4), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AP_Conversion/pcmamp.F b/src/tool/AP_Conversion/pcmamp.F new file mode 100644 index 00000000..ce44d342 --- /dev/null +++ b/src/tool/AP_Conversion/pcmamp.F @@ -0,0 +1,201 @@ + subroutine pcmamp ( elemen, nbele0, + > noempo, hetmpo, + > fammpo, cfampo, + > nnosca, nmpsca, nmpsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - MaillePoint +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . hetmpo . e . nbmpto . historique de l'etat des mailles-points . +c . fammpo . e . nbmpto . famille des mailles-points . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . + l : appartenance a l'equivalence l . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . nmpsca . s . rsmpto . numero des mailles-points du calcul . +c . nmpsho . s . rsmpac . numero des mailles-points dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMATE' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombmp.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer noempo(nbmpto), hetmpo(nbmpto) +c + integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto) +c + integer nnosca(rsnoto) + integer nmpsca(rsmpto), nmpsho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + if ( nbmpto.gt.0 ) then +c + do 21 , iaux = 1 , nbmpto + nmpsca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + nmpsho(iaux) = 0 + 22 continue +c + endif +c +c==== +c 3. Conversion +c==== +c + do 31 , iaux = 1 , nbmpto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,0), iaux + write (ulsort,texte(langue,12)) + > cotyel, cfampo(cotyel,fammpo(iaux)) +#endif +c + if ( cfampo(cotyel,fammpo(iaux)).ne.0 ) then +c + etat = mod( hetmpo(iaux) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetmpo(iaux), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + nmpsho(elemen) = iaux + nmpsca(iaux) = elemen + noeele(elemen,1) = nnosca(noempo(iaux)) + famele(elemen) = cfampo(cofamd,fammpo(iaux)) + typele(elemen) = cfampo(cotyel,fammpo(iaux)) + endif +c + endif +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmanc.F b/src/tool/AP_Conversion/pcmanc.F new file mode 100644 index 00000000..ecd9696f --- /dev/null +++ b/src/tool/AP_Conversion/pcmanc.F @@ -0,0 +1,227 @@ + subroutine pcmanc ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - Non Conforme +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . e . lgoptr . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMANC' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux + integer nonexm +c + character*6 saux + character*7 saux07 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( taopti(11).eq.26 .or. + > taopti(11).eq.36 ) then + saux07 = 'SATURNE' + elseif ( taopti(11).eq.46 .or. + > taopti(11).eq.56 ) then + saux07 = 'NEPTUNE' + elseif ( taopti(11).eq.46 .or. + > taopti(11).eq.76 ) then + saux07 = 'CARMEL ' + else + saux07 = 'NON CFM' + endif +c + texte(1,4) = '(/,a6,1x,'''//saux07//' - COMPLEMENTS'')' + texte(1,5) = '(28(''=''),/)' +c + texte(2,4) = '(/,a6,1x,'''//saux07//' - ADDITIONAL OPERATIONS'')' + texte(2,5) = '(38(''=''),/)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. Passage du maillage 2D au maillage 3D pour un maillage extrude +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. 2D -> 3D ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(39).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMA23', nompro +#endif + call pcma23 ( taopts(2), + > taopti(40), taoptr(4), taopts(20), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Les recollements par equivalence +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recollements ; codret', codret +#endif +c + if ( taopti(30).eq.-2 .or. + > taopti(30).eq.1 .or. + > taopti(30).eq.2 .or. + > taopti(30).eq.3 ) then +c + if ( codret.eq.0 ) then +c + nonexm = 1 + if ( ( taopti(11).eq.36 ) .or. ( taopti(11).eq.56 ) ) then + nonexm = nonexm*2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nonexm', nonexm +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMARC', nompro +#endif + call pcmarc ( taopts(2), taopts(20), + > nonexm, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AP_Conversion/pcmano.F b/src/tool/AP_Conversion/pcmano.F new file mode 100644 index 00000000..40805303 --- /dev/null +++ b/src/tool/AP_Conversion/pcmano.F @@ -0,0 +1,405 @@ + subroutine pcmano ( coonoe, hetnoe, + > famnoe, cfanoe, + > nnosca, nnosho, + > dimcst, coocst, sdimca, coonca, + > noeord, + > fameno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - NOeud +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . famnoe . e . nbnoto . famille des noeuds . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . + l : appartenance a l'equivalence l . +c . nnosca . s . rsnoto . numero des noeuds du code de calcul . +c . nnosho . s . rsnoac . numero des noeuds dans HOMARD . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . sdimca . e . 1 . dimension de l'espace de calcul . +c . coonca . s . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . noeord . e . 1 . vrai si les noeuds sont ordonnes . +c . . . . faux si sans importance . +c . fameno . s . nbnoto . famille med des noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMANO' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombsr.h" +#include "impr02.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer dimcst, sdimca +c + double precision coocst(11) + double precision coonoe(nbnoto,sdim), coonca(nbnoto,sdimca) +c + integer hetnoe(nbnoto) + integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto) + integer nnosca(rsnoto), nnosho(rsnoac) + integer fameno(nbnoto) +c + logical noeord +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lenoeu, lenolo + integer etat + integer iaux, jaux, kaux, laux, maux +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds '',a2,'' calcule :'',i10)' + texte(1,5) = '(''Nombre de noeuds '',a2,'' estime :'',i10)' + texte(1,6) = '(''Coordonnee constante incorrecte :'',i7)' + texte(1,10) = '(''Les deux doivent etre egaux ...'')' +c + texte(2,4) = '(''Computed number of '',a2,'' nodes :'',i10)' + texte(2,5) = '(''Estimated number of '',a2,'' nodes :'',i10)' + texte(2,6) = '(''Constant coordinate is wrong :'',i7)' + texte(2,10) = '(''Both numbers oUGht to be equal ...'')' +c +#include "impr06.h" +c + codret = 0 +c +c==== +c 2. noeuds +c==== +c +c 2.1. ==> renumerotation eventuelle des noeuds pour placer les +c noeuds dans l'ordre suivant : +c . noeuds isoles +c . noeuds d'elements ignores +c . noeuds uniquement support de maille-point +c . noeuds p1 +c . noeuds p2 +c sinon, pas de changement de renumerotation +cgn write(6,*) 'noeord = ',noeord +cgn write(6,*) 'nbnois, nbnoei, nbnomp, nbnop1, nbnoto = ', +cgn >nbnois, nbnoei, nbnomp, nbnop1, nbnoto +c + if ( noeord ) then +c + iaux = 0 + jaux = nbnois + kaux = jaux + nbnoei + laux = kaux + nbnomp + maux = laux + nbnop1 +c + do 211 , lenoeu = 1 , nbnoto +c +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,2,-1), lenoeu + endif +#endif + if ( hetnoe(lenoeu).eq.0) then + iaux = iaux + 1 + nnosho(iaux) = lenoeu + nnosca(lenoeu) = iaux + else + etat = mod ( hetnoe(lenoeu), 10 ) + if ( etat.eq.7 ) then + jaux = jaux + 1 + nnosho(jaux) = lenoeu + nnosca(lenoeu) = jaux + elseif ( etat.eq.3 ) then + kaux = kaux + 1 + nnosho(kaux) = lenoeu + nnosca(lenoeu) = kaux + elseif ( etat.eq.1 ) then + laux = laux + 1 + nnosho(laux) = lenoeu + nnosca(lenoeu) = laux + elseif ( etat.eq.2 ) then + maux = maux + 1 + nnosho(maux) = lenoeu + nnosca(lenoeu) = maux + else + codret = codret + 1 + endif + endif + 211 continue +c + if ( iaux.ne.nbnois ) then + write(ulsort,texte(langue,4)) 'is', iaux + write(ulsort,texte(langue,5)) 'is', nbnois + write(ulsort,texte(langue,10)) + codret = 1 + endif +c + if ( kaux-nbnois.ne.nbnoei ) then + write(ulsort,texte(langue,4)) 'IG', jaux-nbnois + write(ulsort,texte(langue,5)) 'IG', nbnoei + write(ulsort,texte(langue,10)) + codret = 1 + endif +c + if ( kaux-nbnois-nbnoei.ne.nbnomp ) then + write(ulsort,texte(langue,4)) 'MP', jaux-nbnois-nbnoei + write(ulsort,texte(langue,5)) 'MP', nbnomp + write(ulsort,texte(langue,10)) + codret = 1 + endif +c + if ( laux-nbnois-nbnoei-nbnomp.ne.nbnop1 ) then + write(ulsort,texte(langue,4)) 'P1', kaux-nbnois-nbnoei-nbnomp + write(ulsort,texte(langue,5)) 'P1', nbnop1 + write(ulsort,texte(langue,10)) + codret = 1 + endif +c + if ( maux-nbnois-nbnoei-nbnomp-nbnop1.ne.nbnop2 ) then + write(ulsort,texte(langue,4)) 'P2', + > laux-nbnois-nbnoei-nbnomp-nbnop1 + write(ulsort,texte(langue,5)) 'P2', nbnop2 + write(ulsort,texte(langue,10)) + codret = 1 + endif +c + else +c + do 212 , lenoeu = 1 , nbnoto +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,2,-1), lenoeu + endif +#endif + nnosho(lenoeu) = lenoeu + nnosca(lenoeu) = lenoeu + 212 continue +CGN nnosho(28) = 30 +CGN nnosca(28) = 30 +CGN nnosho(30) = 28 +CGN nnosca(30) = 28 +CGN nnosho(29) = 31 +CGN nnosca(29) = 31 +CGN nnosho(31) = 29 +CGN nnosca(31) = 29 +CGN nnosho(40) = 46 +CGN nnosca(40) = 46 +CGN nnosho(46) = 40 +CGN nnosca(46) = 40 +CGN nnosho(41) = 47 +CGN nnosca(41) = 47 +CGN nnosho(47) = 41 +CGN nnosca(47) = 41 +CGN nnosho(42) = 48 +CGN nnosca(42) = 48 +CGN nnosho(48) = 42 +CGN nnosca(48) = 42 +c + endif +c +CGN do 219 , lenoeu = 1 , nbnoto +CGN write(6,5555) lenoeu, nnosho(lenoeu), nnosca(lenoeu) +CGN 219 continue +CGN 5555 format(3i4) +c +c 2.2. ==> les coordonnees +c + if ( sdim.eq.1 ) then +c + do 221 , lenoeu = 1 , nbnoto + lenolo = nnosho(lenoeu) + coonca(lenoeu,1) = coonoe(lenolo,1) + 221 continue +c + elseif ( sdim.eq.2 ) then +c + if ( dimcst.eq.0 .or. dimcst.eq.3 ) then + iaux = 1 + jaux = 2 + elseif ( dimcst.eq.1 ) then + iaux = 2 + jaux = 3 + elseif ( dimcst.eq.2 ) then + iaux = 1 + jaux = 3 + else + write (ulsort,texte(langue,6)) dimcst + codret = 1 + endif +c + if ( codret.eq.0 ) then +c + do 222 , lenoeu = 1 , nbnoto + lenolo = nnosho(lenoeu) + coonca(lenoeu,iaux) = coonoe(lenolo,1) + coonca(lenoeu,jaux) = coonoe(lenolo,2) + 222 continue +c + if ( dimcst.ne.0 ) then + do 2221 , lenoeu = 1 , nbnoto + coonca(lenoeu,dimcst) = coocst(1) + 2221 continue + endif +c + endif +c + else +c + do 223 , lenoeu = 1 , nbnoto +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,2,-1), lenoeu + endif +#endif + lenolo = nnosho(lenoeu) + coonca(lenoeu,1) = coonoe(lenolo,1) + coonca(lenoeu,2) = coonoe(lenolo,2) + coonca(lenoeu,3) = coonoe(lenolo,3) + 223 continue +c + endif +c +c==== +c 3. la famille des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. la famille des noeuds ; codret = ', codret +#endif +c + do 31, lenoeu = 1, rsnoto +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,2,-1), lenoeu + write (ulsort,*) 'nnosho(lenoeu) =', nnosho(lenoeu) + write (ulsort,*) 'famnoe =', famnoe(nnosho(lenoeu)) +c write (ulsort,texte(langue,16)) cofamd + endif +#endif + fameno(lenoeu) = cfanoe(cofamd,famnoe(nnosho(lenoeu))) + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmape.F b/src/tool/AP_Conversion/pcmape.F new file mode 100644 index 00000000..957a20dd --- /dev/null +++ b/src/tool/AP_Conversion/pcmape.F @@ -0,0 +1,389 @@ + subroutine pcmape ( elemen, nbele0, + > somare, np2are, + > arequa, + > facpen, cofape, arepen, + > hetpen, fampen, cfapen, + > nnosca, npesca, npesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Coperight EDF 1997, 1998, 1999, 2002 +c ______________________________________________________________________ +c +c +c aPres adaptation - Conversion - MAillage connectivite - PEntaedres +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfhe. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type d'pentaedres . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . npesca . s . rspeto . numero des pentaedres dans le calcul . +c . npesho . s . nbele0 . numero des pentaedres dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAPE' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) +c + integer cfapen(nctfpe,nbfpen), fampen(nbpeto) +c + integer nnosca(rsnoto) + integer npesca(rspeto), npesho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lepent, lepen0 + integer etat + integer iaux + integer listar(9), listso(15), nomiar(9) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbpecf, nbpeca =', nbpecf, nbpeca +#endif +c +#include "impr03.h" +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rspeto + npesca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + npesho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c S3 a9 S6 +c x------------------------------------------x +c . . +c . . . . +c a3 . a6 . +c . . . . +c . . +c . .a1 . .a4 +c . . +c S2. . a8 S5. . +c x------------------------------------------x +c . . . . +c . . +c a2 . . a5 . . +c x------------------------------------------x +c S1 a7 S4 +c La face f1 est le triangle (S1,S2,S3). +c La face f2 est le triangle (S4,S6,S5). +c La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2. +c + do 31 , lepen0 = 1 , nbpeto +c + lepent = lepen0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,7), lepent +#endif +c + etat = mod( hetpen(lepent) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,14)) elemen + endif +#endif + npesho(elemen) = lepent + npesca(lepent) = elemen +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c Attention : utaspe donne la numerotation dans la convention homard +c il faut permuter les sommets 2/3 et 5/6 pour obtenir +c la numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(3)) + noeele(elemen,3) = nnosca(listso(2)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,5) = nnosca(listso(6)) + noeele(elemen,6) = nnosca(listso(5)) +c + famele(elemen) = cfapen(cofamd,fampen(lepent)) + typele(elemen) = cfapen(cotyel,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) 'fampen', fampen(lepent) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,6) + write (ulsort,90002) 'Famille MED',famele(elemen) + write (ulsort,90002) 'Type MED ',typele(elemen) + endif +#endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + else +c +c S3 a9/N14 S6 +c x------------------------------------------x +c . . +c . . . . +c a3 . a6 . +c N8. . N11. . +c . . +c . .a1 . .a4 +c . N7 . N10 +c S2. . a8/N15 S5. . +c x------------------------------------------x +c . . . . +c . N12 . +c a2 . . a5 . . +c N9 x------------------------------------------x +c S1 a7/N13 S4 +c La face f1 est le triangle (S1,S2,S3). +c La face f2 est le triangle (S4,S6,S5). +c La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2. +c +c Au sens homard au sens MED +c arete 1 de s1 a s3 | de s1 a s2 +c arete 2 de s1 a s2 | de s1 a s3 +c arete 3 de s2 a s3 | de s2 a s3 +c arete 4 de s4 a s6 | de s4 a s5 +c arete 5 de s4 a s5 | de s4 a s6 +c arete 6 de s5 a s6 | de s5 a s6 +c arete 7 de s1 a s4 | de s1 a s4 +c arete 8 de s2 a s5 | de s3 a s6 +c arete 9 de s3 a s6 | de s2 a s5 +c Tableau de travail nomiar : +c nomiar(i) contient le numero local au sens MED du noeud porte +c par l'arete de numero local i au sens homard +c + nomiar( 1) = 7 + nomiar( 2) = 9 + nomiar( 3) = 8 + nomiar( 4) = 10 + nomiar( 5) = 12 + nomiar( 6) = 11 + nomiar( 7) = 13 + nomiar( 8) = 15 + nomiar( 9) = 14 +c + do 41 , lepen0 = 1 , nbpeto +c + lepent = lepen0 +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,7), lepent +#endif +c + etat = mod( hetpen(lepent) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,14)) elemen + endif +#endif + npesho(elemen) = lepent + npesca(lepent) = elemen +cgn write (ulsort,555) 'tria', (facpen(lepent,iaux),iaux=1,2) +cgn write (ulsort,555) 'quad',facpen(lepent,3),cofape(lepent,3) +cgn write (ulsort,555) '-> ',(arequa(facpen(lepent,3),iaux),iaux=1,4) +cgn write (ulsort,555) 'quad',facpen(lepent,4),cofape(lepent,4) +cgn write (ulsort,555) '-> ',(arequa(facpen(lepent,4),iaux),iaux=1,4) +cgn write (ulsort,555) 'quad',facpen(lepent,5),cofape(lepent,5) +cgn write (ulsort,555) '-> ',(arequa(facpen(lepent,5),iaux),iaux=1,4) +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c Attention : utaspe donne la numerotation dans la convention homard +c il faut permuter les sommets 2/3 et 5/6 pour obtenir +c la numerotation dans la convention med +c +cgn write (ulsort,555) 'listso',(listso(iaux),iaux=1,6) + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(3)) + noeele(elemen,3) = nnosca(listso(2)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,5) = nnosca(listso(6)) + noeele(elemen,6) = nnosca(listso(5)) +cgn write (ulsort,555) '--> so',(noeele(elemen,iaux),iaux=1,6) +c +c Les noeuds au milieu des aretes +c + do 411 , iaux = 1 , 9 + noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux))) + 411 continue +cgn write (ulsort,555) 'p2',(noeele(elemen,nomiar(iaux)),iaux=1,9) +c +cgn 555 format(a,10i3) + famele(elemen) = cfapen(cofamd,fampen(lepent)) + typele(elemen) = cfapen(cotyel,fampen(lepent)) +c + endif +c + 41 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmapy.F b/src/tool/AP_Conversion/pcmapy.F new file mode 100644 index 00000000..89f37756 --- /dev/null +++ b/src/tool/AP_Conversion/pcmapy.F @@ -0,0 +1,385 @@ + subroutine pcmapy ( elemen, nbele0, + > somare, np2are, + > aretri, + > facpyr, cofapy, arepyr, + > hetpyr, fampyr, cfapyr, + > nnosca, npysca, npysho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - PYramides +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfhe. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type d'pyramides . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . npysca . s . rspyto . numero des pyramides dans le calcul sortie . +c . npysho . s . nbele0 . numero des pyramides dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAPY' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) +c + integer cfapyr(nctfpy,nbfpyr), fampyr(nbpyto) +c + integer nnosca(rsnoto) + integer npysca(rspyto), npysho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lapyra, lapyr0 + integer etat + integer iaux + integer listar(8), listso(13), nomiar(8) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbpycf, nbpyca', nbpycf, nbpyca + write(ulsort,90002) 'nbele0, nbmane', nbele0, nbmane + write(ulsort,90002) 'degre', degre +cgn write(ulsort,*) cfapyr +#endif +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rspyto + npysca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + npysho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c S5 +c x +c . . . . +c . . . . +c . . . . +c . . . . +c . . x . . +c . . . S2 . . +c . . . . . +c . . . . +c . . . . . +c . . . . . +c . . . . . +c S1 . . . . +c x . . . . +c . . . +c x--------------------------------------------------------x +c S4 S3 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c + do 31 , lapyr0 = 1 , nbpyto +c + lapyra = lapyr0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,5), lapyra +#endif +c + etat = mod( hetpyr(lapyra) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + npysho(elemen) = lapyra + npysca(lapyra) = elemen +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASPY', nompro +#endif + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +cgn write (ulsort,90002) 'listar', (listar(iaux),iaux = 1 , 8) +cgn write (ulsort,90002) 'listso', (listso(iaux),iaux = 1 , 5) +c +c Attention : utaspy donne la numerotation dans la convention homard +c il faut permuter les sommets 2/4 pour obtenir +c la numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(4)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(2)) + noeele(elemen,5) = nnosca(listso(5)) +c + famele(elemen) = cfapyr(cofamd,fampyr(lapyra)) + typele(elemen) = cfapyr(cotyel,fampyr(lapyra)) +c +#ifdef _DEBUG_HOMARD_ + if ( noeele(elemen,1).ne.-54117 ) then + write (ulsort,*) 'fampyr = ', fampyr(lapyra) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,5) + write (ulsort,*) 'Famille MED = ',famele(elemen), + > ', Type MED = ',typele(elemen) + endif +#endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + else +c +c S5 +c x +c . . . . +c . . . . +c . . N11 . +c . . . . +c . . x . . +c N10. . . S2 . .N12 +c . . . . . +c . . . . +c . . .N13 . . +c . . . N7 . . +c . . N6 . . . +c S1 . . . . +c x . . . . +c . . . +c N9 x--------------------------------------------------------x +c S4 N8 S3 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c +c Au sens homard au sens MED +c arete 1 de s1 a s5 | de s1 a s5 +c arete 2 de s2 a s5 | de s4 a s5 +c arete 3 de s3 a s5 | de s3 a s5 +c arete 4 de s4 a s5 | de s2 a s5 +c arete 5 de s1 a s2 | de s1 a s4 +c arete 6 de s2 a s3 | de s4 a s3 +c arete 7 de s3 a s4 | de s3 a s2 +c arete 8 de s4 a s1 | de s2 a s1 +c Tableau de travail nomiar : +c nomiar(i) contient le numero local au sens MED du noeud porte +c par l'arete de numero local i au sens homard +c + nomiar( 1) = 10 + nomiar( 2) = 13 + nomiar( 3) = 12 + nomiar( 4) = 11 + nomiar( 5) = 9 + nomiar( 6) = 8 + nomiar( 7) = 7 + nomiar( 8) = 6 +c + do 41 , lapyr0 = 1 , nbpyto +c + lapyra = lapyr0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,5), lapyra +#endif +c + etat = mod( hetpyr(lapyra) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + npysho(elemen) = lapyra + npysca(lapyra) = elemen +c +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASPY', nompro +#endif + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +cgn write (ulsort,90002) 'listar', (listar(iaux),iaux = 1 , 8) +cgn write (ulsort,90002) 'listso', (listso(iaux),iaux = 1 , 5) +c +c Attention : utaspy donne la numerotation dans la convention homard +c il faut permuter les sommets 2/4 pour obtenir la +c numerotation dans la convention med +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(4)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(2)) + noeele(elemen,5) = nnosca(listso(5)) +c +c Les noeuds au milieu des aretes +c + do 411 , iaux = 1 , 8 + noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux))) + 411 continue +c + famele(elemen) = cfapyr(cofamd,fampyr(lapyra)) + typele(elemen) = cfapyr(cotyel,fampyr(lapyra)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-601 ) then + write (ulsort,*) 'fampyr = ', fampyr(lapyra) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,13) + write (ulsort,*) 'Famille MED = ',famele(elemen), + > ', Type MED = ',typele(elemen) + endif +#endif +c + endif +c + 41 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaq0.F b/src/tool/AP_Conversion/pcmaq0.F new file mode 100644 index 00000000..65913613 --- /dev/null +++ b/src/tool/AP_Conversion/pcmaq0.F @@ -0,0 +1,175 @@ + subroutine pcmaq0 ( rsquto, + > hetqua, + > famqua, cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - +c - - -- +c QUadrangles - phase 0 +c - - +c ______________________________________________________________________ +c +c remarque : pcmaqu et pcmaq0 sont des clones +c remarque : pcmaa0, pcmat0 et pcmaq0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . rsquto . es . 1 . nombre de quadrangles actifs et du calcul . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAQ0' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombqu.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer rsquto +c + integer hetqua(nbquto) +c + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr06.h" +c +c==== +c 2. Decompte des quadrangles actifs et du calcul +c==== +c + rsquto = 0 +c + do 21 , iaux = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,4), iaux + write (ulsort,texte(langue,12)) + > cotyel, cfaqua(cotyel,famqua(iaux)) +#endif +c + if ( cfaqua(cotyel,famqua(iaux)).ne.0 ) then +c + etat = mod( hetqua(iaux) , 100 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetqua(iaux), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + rsquto = nbquto + goto 22 +c + endif +c + endif +c + 21 continue +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,18)) mess14(langue,3,4), rsquto +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmaqu.F b/src/tool/AP_Conversion/pcmaqu.F new file mode 100644 index 00000000..f7cb2cb1 --- /dev/null +++ b/src/tool/AP_Conversion/pcmaqu.F @@ -0,0 +1,419 @@ + subroutine pcmaqu ( elemen, nbele0, + > somare, np2are, + > arequa, hetqua, ninqua, + > famqua, cfaqua, + > nnosca, nqusca, nqusho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - +c - - -- +c QUadrangles +c -- +c ______________________________________________________________________ +c +c remarque : pcmaqu et pcmaq0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . nqusca . s . rsquto . numero des quadrangles du calcul . +c . nqusho . s . nbele0 . numero des quadrangles dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAQU' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombqu.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer arequa(nbquto,4), hetqua(nbquto), ninqua(nbquto) +c + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) +c + integer nnosca(rsnoto) + integer nqusca(rsquto), nqusho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lequad + integer etat + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rsquto + nqusca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + nqusho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c s1 s4 sa4a1 a4 sa3a4 +c ._________. ._________. +c . . . . +c . . . . +c MED : . . HOMARD : a1. .a3 +c . . . . +c ._________. ._________. +c s2 s3 sa1a2 a2 sa2a3 +c +c + do 31 , lequad = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,4), lequad + write (ulsort,texte(langue,12)) + > cotyel, cfaqua(cotyel,famqua(lequad)) +#endif +c + if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then +c + etat = mod( hetqua(lequad) , 100 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetqua(lequad), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 3.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + nqusho(elemen) = lequad + nqusca(lequad) = elemen +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +c 3.2. ==> recherche des numeros des sommets +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOQU', nompro +#endif + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c 3.3. ==> archivage +c + noeele(elemen,1) = nnosca(sa4a1) + noeele(elemen,2) = nnosca(sa1a2) + noeele(elemen,3) = nnosca(sa2a3) + noeele(elemen,4) = nnosca(sa3a4) +c + famele(elemen) = cfaqua(cofamd,famqua(lequad)) + typele(elemen) = cfaqua(cotyel,famqua(lequad)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + write (ulsort,90002) 'famqua', famqua(lequad) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,4) + write (ulsort,90002) 'Famille MED',famele(elemen) + write (ulsort,90002) 'Type MED ',typele(elemen) + endif +#endif +c + endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + elseif ( mod(mailet,3).ne.0 ) then +c +c s1 s8 s4 sa4a1 a4 sa3a4 +c .____*____. .____*____. +c . . . n4 . +c . . . . +c MED : s5 * * s7 HOMARD : a1*n1 n3*a3 +c . . . n2 . +c .____*____. .____*____. +c s2 s6 s3 sa1a2 a2 sa2a3 +c + do 41 , lequad = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,4), lequad + write (ulsort,texte(langue,12)) + > cotyel, cfaqua(cotyel,famqua(lequad)) +#endif +c + if ( cfaqua(cotyel,famqua(lequad)).ge.1 ) then +c + etat = mod( hetqua(lequad) , 100 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetqua(lequad), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 4.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + nqusho(elemen) = lequad + nqusca(lequad) = elemen +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +c 4.2. ==> recherche des numeros des sommets +c les aretes a1 et a3 se coupent sur le premier sommet de a1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOQU', nompro +#endif + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c 4.3. ==> archivage +c + noeele(elemen,1) = nnosca(sa4a1) + noeele(elemen,2) = nnosca(sa1a2) + noeele(elemen,3) = nnosca(sa2a3) + noeele(elemen,4) = nnosca(sa3a4) + noeele(elemen,5) = nnosca(np2are(a1)) + noeele(elemen,6) = nnosca(np2are(a2)) + noeele(elemen,7) = nnosca(np2are(a3)) + noeele(elemen,8) = nnosca(np2are(a4)) +c + famele(elemen) = cfaqua(cofamd,famqua(lequad)) + typele(elemen) = cfaqua(cotyel,famqua(lequad)) +c + endif +c + endif +c + 41 continue +c +c==== +c 5. Conversion en quadratique etendu +c Similaire au quadratique a part le 9-eme noeud +c==== +c + else +c +c s1 s8 s4 sa4a1 a4 sa3a4 +c .____*____. .____*____. +c . . . n4 . +c . . . . +c MED : s5 * s9 * s7 HOMARD : a1*n1 NIM n3*a3 +c . . . n2 . +c .____*____. .____*____. +c s2 s6 s3 sa1a2 a2 sa2a3 +c + do 51 , lequad = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,4), lequad + write (ulsort,texte(langue,12)) + > cotyel, cfaqua(cotyel,famqua(lequad)) +#endif +c + if ( cfaqua(cotyel,famqua(lequad)).ge.1 ) then +c + etat = mod( hetqua(lequad) , 100 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hetqua(lequad), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 5.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + nqusho(elemen) = lequad + nqusca(lequad) = elemen +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +c 5.2. ==> recherche des numeros des sommets +c les aretes a1 et a3 se coupent sur le premier sommet de a1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOQU', nompro +#endif + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c 5.3. ==> archivage +c + noeele(elemen,1) = nnosca(sa4a1) + noeele(elemen,2) = nnosca(sa1a2) + noeele(elemen,3) = nnosca(sa2a3) + noeele(elemen,4) = nnosca(sa3a4) + noeele(elemen,5) = nnosca(np2are(a1)) + noeele(elemen,6) = nnosca(np2are(a2)) + noeele(elemen,7) = nnosca(np2are(a3)) + noeele(elemen,8) = nnosca(np2are(a4)) + noeele(elemen,9) = nnosca(ninqua(lequad)) +c + famele(elemen) = cfaqua(cofamd,famqua(lequad)) + typele(elemen) = cfaqua(cotyel,famqua(lequad)) +c + endif +c + endif +c + 51 continue +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +cgn print 1789, (nqusca(iaux),iaux=1,rsquto) +cgn 1789 format(10i4) +c + end diff --git a/src/tool/AP_Conversion/pcmar0.F b/src/tool/AP_Conversion/pcmar0.F new file mode 100644 index 00000000..f975350c --- /dev/null +++ b/src/tool/AP_Conversion/pcmar0.F @@ -0,0 +1,360 @@ + subroutine pcmar0 ( nonexm, + > hetare, filare, merare, + > famare, posifa, facare, + > aretri, hettri, nivtri, + > famtri, pertri, filtri, + > arequa, hetqua, nivqua, + > famqua, perqua, filqua, + > hettet, + > hethex, + > hetpyr, + > voltri, pypetr, + > volqua, pypequ, + > nbanci, nbenrc, numead, + > arreca, trreca, qureca, + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > arerec, trirec, quarec, + > tetrec, hexrec, penrec, pyrrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - Recollements - phase 0 +c - - -- - - +c Reperage des faces de raccordement non conforme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nonexm . e . 1 . non exportation de mailles . +c . . . . 1 : on exporte toutes les mailles . +c . . . . 2x : les segments ne sont pas exportes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . fille ainee de chaque arete . +c . merare . e . nbarto . mere de chaque arete . +c . famare . es . nbarto . famille des aretes . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . famtri . es . nbtrto . famille des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . filtri . e . nbtrto . fils des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . famqua . es . nbquto . famille des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbanci . e . 1 . nombre de non conformites initiales . +c . nbenrc . e . 1 . nombre d'entites par recollement unitaire . +c . numead . e . 1 . numero de la mere adoptive . +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . nparrc . s . 1 . nombre de paires d'aretes a recoller . +c . nptrrc . s . 1 . nombre de paires de triangles a recoller . +c . npqurc . s . 1 . nombre de paires de quadrangles a recoller . +c . npterc . s . 1 . nombre de paires de tetraedres recolles . +c . npherc . s . 1 . nombre de paires d'hexaedres recolles . +c . npperc . s . 1 . nombre de paires de pentaedres recolles . +c . nppyrc . s . 1 . nombre de paires de pyramides recollees . +c . arerec . s . 2*x . paires des aretes a recoller . +c . trirec . s . 2*x . paires des triangles a recoller . +c . quarec . s . 2*x . paires des quadrangles a recoller . +c . tetrec . s . 3*x . paires des tetra. voisins faces a recoller . +c . hexrec . s . 3*x . paires des hexa. voisins faces a recoller . +c . penrec . s . 3*x . paires des penta. voisins faces a recoller . +c . pyrrec . s . 3*x . paires des pyram. voisines faces a recoller. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAR0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nonexm +c + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer famare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer famtri(nbtrto), pertri(nbtrto), filtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer famqua(nbquto), perqua(nbquto),filqua(nbquto) + integer hettet(nbteto) + integer hethex(nbheto) + integer hetpyr(nbpyto) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer nbanci, nbenrc, numead + integer arreca(nbenrc*nbanci) + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer trreca(nbtrri) + integer qureca(nbquri) + integer arerec(2,*), trirec(2,*), quarec(2,*) + integer tetrec(3,*), hexrec(3,*), penrec(3,*), pyrrec(3,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''On ne devrait pas passer dans '',a)' + texte(1,5) = '(''Examen du '',a,''numero '',i10)' + texte(1,6) = + > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)' + texte(1,8) = + > '(''.. Modification de la famille du '',a,''numero '',i10)' + texte(1,9) = + > '(''.. Modification de l''''etat du '',a,''numero '',i10)' + texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)' + texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))' + texte(1,12) = '(''. de fils :'',2i10))' + texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)' +c + texte(2,4) = '(a,'' should not be called.'')' + texte(2,5) = '(''Examination of '',a,'',# '',i10)' + texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)' + texte(2,8) = + > '(''.. Modification of the family of '',a,'',# '',i10)' + texte(2,9) = + > '(''.. Modification of the state of '',a,'',# '',i10)' + texte(2,10) = '(5x,''==> old :'',i5,'', new :'',i5)' + texte(2,11) = '(''Number of non-conformal situations :'',i10))' + texte(2,12) = '(''. with sons :'',2i10))' + texte(2,13) = '(''. State for '',a,''# '',i10,'' :'',i10)' +c +#include "impr03.h" +c + codret = 0 +c + nparrc = 0 + nptrrc = 0 + npqurc = 0 + npterc = 0 + npherc = 0 + npperc = 0 + nppyrc = 0 +c +c==== +c 2. Les aretes +c==== +c + if ( mod(nonexm,2).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAR2', nompro +#endif + call pcmar2 ( hetare, filare, merare, + > famare, posifa, facare, + > aretri, hettri, nivtri, + > voltri, + > arequa, hetqua, nivqua, + > nbanci, nbenrc, + > arreca, + > nparrc, arerec, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Les triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAR3_tr', nompro +#endif + call pcmar3 ( iaux, numead, + > nbtrto, nbteto, nbftri, + > hettri, nivtri, + > famtri, pertri, filtri, + > hettet, hetpyr, + > voltri, pypetr, + > nbtrri, trreca, + > nptrrc, trirec, + > npterc, tetrec, npperc, penrec, nppyrc, pyrrec, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Les quadrangles ; codret', codret +#endif +c + if ( nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAR3_qu', nompro +#endif + call pcmar3 ( iaux, numead, + > nbquto, nbheto, nbfqua, + > hetqua, nivqua, + > famqua, perqua, filqua, + > hethex, hetpyr, + > volqua, pypequ, + > nbquri, qureca, + > npqurc, quarec, + > npherc, hexrec, npperc, penrec, nppyrc, pyrrec, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. Bilan +c==== +#ifdef _DEBUG_HOMARD_ +c + if ( codret.eq.0 ) then +c + if ( mod(nonexm,2).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc + endif + write (ulsort,texte(langue,6)) mess14(langue,3,2), nptrrc + write (ulsort,texte(langue,6)) mess14(langue,3,4), npqurc + write (ulsort,*) ' ' +c + endif +#endif +c +c==== +c 6. la fin +c==== +c +cgn iaux = 12274 +cgn write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux +cgn write (ulsort,*) 'etat = ',hettri(iaux), +cgn > ', famille = ',famtri(iaux) +cgn iaux = 31599 +cgn write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux +cgn write (ulsort,*) 'etat = ',hettri(iaux), +cgn > ', famille = ',famtri(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. la fin ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmar1.F b/src/tool/AP_Conversion/pcmar1.F new file mode 100644 index 00000000..0da474d6 --- /dev/null +++ b/src/tool/AP_Conversion/pcmar1.F @@ -0,0 +1,226 @@ + subroutine pcmar1 ( narsca, + > ntrsca, nqusca, + > ntesca, nhesca, npesca, npysca, + > nparrc, nptrrc, npqurc, + > arerec, trirec, quarec, + > tetrec, hexrec, penrec, pyrrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - Recollements - phase 1 +c - - -- - - +c Passage des listes de recollements des numerotations HOMARD +c aux numerotations du calcul +c Mise a jour des renumerotations +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . narsca . e . rsarto . numero des aretes du calcul . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . ntesca . e . rsteto . numero des tetraedres du calcul . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul . +c . npesca . e . rspeto . numero des pentaedres dans le calcul . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . nparrc . e . 1 . nombre de paires d'aretes a recoller . +c . nptrrc . e . 1 . nombre de paires de triangles a recoller . +c . npqurc . e . 1 . nombre de paires de quadrangles a recoller . +c . arerec . es .2*nbarto. paires des aretes a recoller . +c . trirec . es . 2* x . paires des triangles a recoller . +c . quarec . es . 2* x . paires des quadrangles a recoller . +c . tetrec . es . 3*x . paires des tetra. voisins faces a recoller . +c . hexrec . es . 3*x . paires des hexa. voisins faces a recoller . +c . penrec . es . 3*x . paires des penta. voisins faces a recoller . +c . pyrrec . es . 3*x . paires des pyram. voisines faces a recoller. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAR1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombsr.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer narsca(rsarto) + integer ntrsca(rstrto), nqusca(rsquto) + integer ntesca(rsteto), nhesca(rsheto) + integer npysca(rspyto), npesca(rspeto) + integer nparrc, nptrrc, npqurc + integer arerec(2,*), trirec(2,*), quarec(2,*) + integer tetrec(3,*), hexrec(3,*), penrec(3,*), pyrrec(3,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nparrc', nparrc + write (ulsort,90002) 'nptrrc', nptrrc + write (ulsort,90002) 'npqurc', npqurc +#endif +c + codret = 0 +c +c==== +c 2. Changement de numerotation dans les listes d'entites a recoller +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> les aretes +c + do 21 , iaux = 1 , nparrc +c + arerec(1,iaux) = narsca(arerec(1,iaux)) + arerec(2,iaux) = narsca(arerec(2,iaux)) +c + 21 continue +c +c 2.2. ==> les triangles +c + do 22 , iaux = 1 , nptrrc +c + trirec(1,iaux) = ntrsca(trirec(1,iaux)) + trirec(2,iaux) = ntrsca(trirec(2,iaux)) +c + 22 continue +c +c 2.3. ==> les quadrangles +c + do 23 , iaux = 1 , npqurc +c + quarec(1,iaux) = nqusca(quarec(1,iaux)) + quarec(2,iaux) = nqusca(quarec(2,iaux)) +c + 23 continue +c +c 2.4. ==> les tetraedres +c + do 24 , iaux = 1 , nptrrc +c + tetrec(1,iaux) = ntesca(tetrec(1,iaux)) + tetrec(2,iaux) = ntesca(tetrec(2,iaux)) + tetrec(3,iaux) = ntrsca(tetrec(3,iaux)) +c + 24 continue +c +c 2.5. ==> les hexaedres +c + do 25 , iaux = 1 , npqurc +c + hexrec(1,iaux) = nhesca(hexrec(1,iaux)) + hexrec(2,iaux) = nhesca(hexrec(2,iaux)) + hexrec(3,iaux) = nqusca(hexrec(3,iaux)) +c + 25 continue +c +c 2.6. ==> les pentaedres +c + if ( rspeto.gt.0 ) then +c + do 26 , iaux = 1 , nptrrc+npqurc +c + penrec(1,iaux) = npesca(penrec(1,iaux)) + penrec(2,iaux) = npesca(penrec(2,iaux)) +c + 26 continue +c + endif +c +c 2.7. ==> les pyramides +c + if ( rspyto.gt.0 ) then +c + do 27 , iaux = 1 , nptrrc+npqurc +c + pyrrec(1,iaux) = npysca(pyrrec(1,iaux)) + pyrrec(2,iaux) = npysca(pyrrec(2,iaux)) +c + 27 continue +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmar2.F b/src/tool/AP_Conversion/pcmar2.F new file mode 100644 index 00000000..6c3531a1 --- /dev/null +++ b/src/tool/AP_Conversion/pcmar2.F @@ -0,0 +1,536 @@ + subroutine pcmar2 ( hetare, filare, merare, + > famare, posifa, facare, + > aretri, hettri, nivtri, + > voltri, + > arequa, hetqua, nivqua, + > nbanci, nbenrc, + > arreca, + > nparrc, arerec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - Recollements - phase 2 +c - - -- - - +c Reperage des aretes de raccordement non conforme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . fille ainee de chaque arete . +c . merare . e . nbarto . mere de chaque arete . +c . famare . es . nbarto . famille des aretes . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . nbanci . e . 1 . nombre de non conformites initiales . +c . nbenrc . e . 1 . nombre d'entites par recollement unitaire . +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . nparrc . s . 1 . nombre de paires d'aretes a recoller . +c . arerec . s .2*nbarto. paires des aretes a recoller . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAR2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer famare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer nbanci, nbenrc + integer arreca(nbenrc*nbanci) + integer nparrc + integer arerec(2,nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer kdeb , kfin + integer nbar2d, nbar3d + integer larete, lareta + integer adelre +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + character*8 noelre +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''On ne devrait pas passer dans '',a)' + texte(1,5) = '(''Examen du '',a,''numero '',i10)' + texte(1,6) = + > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)' + texte(1,8) = + > '(''.. Modification de la famille du '',a,''numero '',i10)' + texte(1,9) = + > '(''.. Modification de l''''etat du '',a,''numero '',i10)' + texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)' + texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))' + texte(1,12) = '(''. de fils :'',2i10))' + texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)' + texte(1,14) = '(2x,''Apres la phase de limites de zone :'')' + texte(1,15) = '(2x,''Apres les non conformites initiales :'')' + texte(1,19) = '(''. Famille du '',a,''numero '',i10,'' :'',i10)' + texte(1,20) = '(''Impossible d''''avoir des groupes internes'')' +c + texte(2,4) = '(a,'' should not be called.'')' + texte(2,5) = '(''Examination of '',a,'',# '',i10)' + texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)' + texte(2,8) = + > '(''.. Modification of the family of '',a,'',# '',i10)' + texte(2,9) = + > '(''.. Modification of the state of '',a,'',# '',i10)' + texte(2,10) = '(5x,''==> old :'',i5,'', new :'',i5)' + texte(2,11) = '(''Number of non-conformal situations :'',i10))' + texte(2,12) = '(''. with sons :'',2i10))' + texte(2,13) = '(''. State for '',a,''# '',i10,'' :'',i10)' + texte(2,14) = '(2x,''After zone limit analysis :'')' + texte(2,15) = '(2x,''After initial non conforming :'')' + texte(2,19) = '(''. Family for '',a,''# '',i10,'' :'',i10)' + texte(2,20) = '(''Impossible d''''avoir des groupes internes'')' +c +#include "impr03.h" +c + codret = 0 +c + nparrc = 0 +c +c==== +c 2. recherche des aretes a la limite entre deux zones de +c raffinement de niveau different, sans tenir compte du +c bord exterieur +c==== +c + if ( codret.eq.0 ) then +c + call gmalot ( noelre, 'entier ', nbarto, adelre, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOAR', nompro +#endif + iaux = 3 + call utboar ( iaux, + > nbarto, nbtrto, nbquto, nbteto, nbfaar, + > hetare, filare, + > posifa, facare, + > aretri, hettri, voltri, + > arequa, hetqua, + > nbar2d, nbar3d, imem(adelre), + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx (nompro,noelre) +c==== +c 3. examen des aretes en fonction de la limite de zone +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. examen des aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 31 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-7 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,1), larete + write (ulsort,90002) 'borare', imem(adelre-1+larete) + endif +#endif +c + iaux = imem(adelre-1+larete) +c +c 3.1. ==> L'arete est a la limite entre 2 zones de niveaux de +c raffinement differents. Si elle est active, on doit lui +c attribuer la famille supplementaire ainsi qu'a son aieule +c + if ( iaux.eq.1 ) then +c + if ( mod(hetare(larete),10).eq.0 ) then +c +c 3.1.1. ==> L'arete est a modifier +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), larete + write (ulsort,texte(langue,10)) famare(larete), nbfare + endif +#endif + famare(larete) = nbfare +c +c 3.1.2. ==> Reperage de l'aieule qui borde 2 surfaces +c on cherche l'ascendant le plus ancien qui se trouve +c en limite de zone +c + lareta = merare(larete) +c + 32 continue +cgn write(ulsort,90002) '... lareta', lareta +c + if ( imem(adelre-1+lareta).eq.1 ) then + lareta = merare(lareta) + goto 32 + endif +cgn write(ulsort,90112) 'famare', lareta, famare(lareta) +c +c 3.1.3. ==> Cet aieul doit faire partie du maillage de calcul. Pour +c cela, sa famille doit valoir la famille supplementaire et +c il doit passer actif. +C Remarque : il se peut que la famille d'une telle arete soit +c deja la famille supplementaire. Il ne faut pas +c filtrer la-dessus car sinon on ne mettra pas son +c etat a 0 ; or cela est indispensable pour +c etre detectee en tant qu'element de calcul. +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), lareta + write (ulsort,texte(langue,10)) famare(lareta), nbfare + endif +#endif + famare(lareta) = nbfare +c + if ( mod(hetare(lareta),10).ne.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,1), lareta + write (ulsort,texte(langue,10)) hetare(lareta), 0 + endif +#endif + hetare(lareta) = 0 + endif +c + nparrc = nparrc + 1 + arerec(1,nparrc) = lareta + arerec(2,nparrc) = larete +c + endif +c + else +c +c 3.2. ==> L'arete est interne au domaine. Si elle est de la famille +c supplementaire, on doit la ramener a la famille libre +c Remarque : bug possible si des elements internes ont ete +c mis dans des groupes au depart ... +c + if ( famare(larete).eq.nbfare ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), larete + write (ulsort,texte(langue,10)) famare(larete), 1 + endif +#endif + famare(larete) = 1 +c +c +#ifdef _DEBUG_HOMARD_ + elseif ( famare(larete).ne.1 ) then +c + write (ulsort,texte(langue,19)) + > mess14(langue,1,1), larete , famare(larete) + write (ulsort,texte(langue,20)) +ccc codret = 12 +#endif +c + endif +c + endif +c + 31 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,14)) + write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc + write (ulsort,*) ' ' + endif +#endif +c +c==== +c 4. chaque arete de la non conformite initiale doit devenir +c un element si elle apparait +c on va s'interesser aux aretes recouvrantes qui sont +c decoupees en 2 et dont aucune des faces voisines n'est +c decoupee ; cela correspond en effet a la situation semblable +c au depart. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. non conf initiale ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) nbanci + write (ulsort,90002) 'nbenrc', nbenrc +#endif +c + if ( nbanci.gt.0 ) then +c + if ( codret.eq.0 ) then +c + jaux = nbanci*nbenrc +c + do 41 , iaux = 1 , jaux +c + larete = arreca(iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,1), larete + endif +#endif +c + if ( mod(hetare(larete),10).eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,12)) filare(larete), filare(larete)+1 + write (ulsort,texte(langue,13)) + > mess14(langue,1,1), filare(larete) , hetare(filare(larete)) + write (ulsort,texte(langue,13)) + > mess14(langue,1,1), filare(larete)+1, hetare(filare(larete)+1) + endif +#endif +c +c 4.1. ==> Si on a deja traite cette arete, on passe a la suite +c + do 411 , kaux = nparrc, 1, -1 +c + if ( arerec(1,kaux).eq.larete .or. + > arerec(2,kaux).eq.larete ) then + goto 41 + endif +c + 411 continue +c +c 4.2. ==> Si une de ses faces voisines est decoupee, on passe +c a la suite +c + kdeb = posifa(larete-1)+1 + kfin = posifa(larete) + do 412 , kaux = kdeb , kfin +c + laux = facare(kaux) + if ( laux.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,2), laux + write (ulsort,texte(langue,13)) + > mess14(langue,1,2), laux, hettri(laux) + endif +#endif + if ( mod(hettri(laux),10).ne.0 ) then + goto 41 + endif + else + laux = -laux +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,4), laux + write (ulsort,texte(langue,13)) + > mess14(langue,1,4), laux, hetqua(laux) + endif +#endif + if ( mod(hetqua(laux),100).ne.0 ) then + goto 41 + endif + endif +c +c + 412 continue +c +c 4.3. ==> L'arete mere est a modifier +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), larete + write (ulsort,texte(langue,10)) famare(larete), nbfare + write (ulsort,texte(langue,10)) hetare(larete), 0 + endif +#endif +c + famare(larete) = nbfare + hetare(larete) = 0 +c +c 4.4. ==> Ses filles sont a modifier +c + do 414 , lareta = filare(larete), filare(larete)+1 +c + if ( famare(lareta).ne.nbfare ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), lareta + write (ulsort,texte(langue,10)) famare(lareta), nbfare + endif +#endif + famare(lareta) = nbfare +c + if ( mod(hetare(lareta),10).ne.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,1), lareta + write (ulsort,texte(langue,10)) hetare(lareta), 0 + endif +#endif + hetare(lareta) = 0 + endif +c + endif +c + nparrc = nparrc + 1 + arerec(1,nparrc) = lareta + arerec(2,nparrc) = larete +c + 414 continue +c + endif +c + 41 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,15)) + write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc + write (ulsort,*) ' ' + endif +#endif +c +c==== +c 5. Bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Bilan ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( noelre, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmar3.F b/src/tool/AP_Conversion/pcmar3.F new file mode 100644 index 00000000..606b12a1 --- /dev/null +++ b/src/tool/AP_Conversion/pcmar3.F @@ -0,0 +1,740 @@ + subroutine pcmar3 ( typenh, numead, + > nbfato, nbvoto, nbffac, + > hetfac, nivfac, + > famfac, perfac, filfac, + > hetvol, hetpyr, + > volfac, pypefa, + > nbfari, fareca, + > npfarc, facrec, + > npvorc, volrec, + > npperc, penrec, nppyrc, pyrrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - Recollements - phase 3 +c - - -- - - +c Reperage des faces de raccordement non conforme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . numead . e . 1 . numero de la mere adoptive . +c . nbfato . e . 1 . nombre de faces total . +c . nbvoto . e . 1 . nombre de volumes total . +c . nbffac . e . 1 . nombre de familles de faces . +c . nivfac . e . nbfato . niveau des faces . +c . hetfac . e . nbfato . historique de l'etat des faces . +c . famfac . es . nbfato . famille des faces . +c . perfac . e . nbfato . pere des faces . +c . perfac . e . nbfato . filles des faces . +c . hetvol . e . nbvoto . historique de l'etat des volumes . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . volfac . e .2*nbfato. numeros des 2 volumes par face . +c . . . . volfac(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre/tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypefa(1/2,j). +c . pypefa . e .2*lgpype. pypefa(1,j) = numero de la pyramide voisine. +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . . . . pypefa(2,j) = numero du pentaedre voisin . +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . npfarc . s . 1 . nombre de paires de faces a recoller . +c . facrec . s . 2*x . paires des faces a recoller . +c . npvorc . s . 1 . nombre de paires de volumes a recoller . +c . volrec . s . 3*x . paires des volumes voisins faces a recoller. +c . npperc . s . 1 . nombre de paires de pentaedres a recoller . +c . penrec . s . 3*x . paires des penta. voisins faces a recoller . +c . nppyrc . s . 1 . nombre de paires de pyramides a recoller . +c . pyrrec . s . 3*x . paires des pyram. voisines faces a recoller. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAR3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, numead + integer nbfato, nbvoto, nbffac + integer hetfac(nbfato), nivfac(nbfato) + integer famfac(nbfato), perfac(nbfato), filfac(nbfato) + integer hetvol(*), hetpyr(*) + integer volfac(2,nbfato), pypefa(2,*) + integer nbfari + integer fareca(nbfari) + integer npfarc, facrec(2,*) + integer npvorc, volrec(3,*) + integer npperc, penrec(3,*) + integer nppyrc, pyrrec(3,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer laface, lafaci + integer facbis, face + integer nbfa2d, nbfabo, nbfav2, nbfav3, nbfav4, nbfanc + integer tybofa + integer mhistf, mhistv + integer levolu, typvol +c + integer adelre +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + character*8 noelre +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''On ne devrait pas passer dans '',a)' + texte(1,5) = '(''Examen du '',a,''numero '',i10)' + texte(1,6) = + > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)' + texte(1,8) = + > '(''.. Modification de la famille du '',a,''numero '',i10)' + texte(1,9) = + > '(''.. Modification de l''''etat du '',a,''numero '',i10)' + texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)' + texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))' + texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)' + texte(1,14) = '(2x,''Apres la phase de limites de zone :'')' + texte(1,15) = '(2x,''Apres les non conformites initiales :'')' + texte(1,19) = '(''. Famille du '',a,''numero '',i10,'' :'',i10)' + texte(1,20) = '(''. Niveau du '',a,'' numero '',i10,'' :'',i10)' +c + texte(2,4) = '(a,'' should not be called.'')' + texte(2,5) = '(''Examination of '',a,'',#'',i10)' + texte(2,6) = '(2x,''Number of pairs of '',a,''to glue:'',i10)' + texte(2,8) = + > '(''.. Modification of the family of '',a,'',#'',i10)' + texte(2,9) = + > '(''.. Modification of the state of '',a,'',#'',i10)' + texte(2,10) = '(5x,''==> old:'',i5,'', new:'',i5)' + texte(2,11) = '(''Number of non-conformal situations:'',i10))' + texte(2,13) = '(''. State for '',a,''#'',i10,'':'',i10)' + texte(2,14) = '(2x,''After zone limit analysis:'')' + texte(2,15) = '(2x,''After initial non conforming:'')' + texte(2,19) = '(''. Family for '',a,''#'',i10,'':'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. recherche des faces a la limite entre deux zones de +c raffinement de niveau different, sans tenir compte du +c bord exterieur +c -1 : face non classee +c 0 : face bidimensionnelle +c 1 : face au bord d'un seul volume +c 2 : face entre 2 volumes actifs +c 3 : face entre 2 volumes dont 1 seul actif +c 4 : face entre 2 volumes inactifs +c 5 : face de non conformite +c==== +c + if ( codret.eq.0 ) then +c + call gmalot ( noelre, 'entier ', nbfato, adelre, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOFA', nompro +#endif + call utbofa ( typenh, numead, + > nbfato, nbvoto, + > nivfac, filfac, perfac, + > hetvol, hetpyr, + > volfac, pypefa, + > imem(adelre), nbfa2d, nbfabo, + > nbfav2, nbfav3, nbfav4, nbfanc, + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx (nompro,noelre) +c==== +c 3. examen des faces en limite de zone +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. faces limite de zone ; codret', codret +cgn write (ulsort,90002) 'nbffac = ', nbffac +cgn write (ulsort,*) filfac(5) + call dmflsh (iaux) +#endif +c + if ( typenh.eq.2 ) then + mhistf = 10 + mhistv = 100 + else + mhistf = 100 + mhistv = 1000 + endif +c + if ( codret.eq.0 ) then +c + do 31 , laface = 1 , nbfato +c +#ifdef _DEBUG_HOMARD_ + if ( laface.eq.0 )then + glop=1 + write (ulsort,*) '===========================================' + else + glop=0 + endif + if ( glop.eq.1 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,typenh), laface + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), laface , hetfac(laface) + write (ulsort,texte(langue,19)) + > mess14(langue,1,typenh), laface , famfac(laface) + write (ulsort,texte(langue,20)) + > mess14(langue,1,typenh), laface , nivfac(laface) + write (ulsort,90112) 'filfac',laface,filfac(laface) + write (ulsort,90112) 'perfac',laface,perfac(laface) + endif +#endif +c + tybofa = imem(adelre-1+laface) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'type de bord', tybofa + endif +#endif +c +c 3.1. ==> La face est a la limite entre 2 zones de niveaux de +c raffinement differents. Si elle est active, on doit lui +c attribuer la famille supplementaire ainsi qu'a son aieule +c + if ( tybofa.eq.5 ) then +cgn write (ulsort,90002) 'etat/famille : ',hetfac(laface),famfac(laface) +c + if ( mod(hetfac(laface),mhistf).eq.0 ) then +c +c 3.1.1. ==> la face est a modifier +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) 'face limite de zone' + write (ulsort,texte(langue,8)) mess14(langue,1,typenh), laface + write (ulsort,texte(langue,10)) famfac(laface), nbffac + endif +#endif + famfac(laface) = nbffac +c +c 3.1.2. ==> On cherche l'ascendant le plus ancien qui se trouve aussi +c en limite de zone +c + facbis = perfac(laface) +c + 32 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write(ulsort,90002) '... facbis', facbis + write(ulsort,90015) '... bord de', + > facbis,'=',imem(adelre-1+facbis) + endif +#endif +c + if ( imem(adelre-1+facbis).eq.5 ) then + if ( perfac(facbis).gt.0 ) then + facbis = perfac(facbis) + goto 32 + endif + endif +c +c 3.1.3. ==> Cet aieul doit faire partie du maillage de calcul +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,typenh),facbis + write (ulsort,texte(langue,10)) famfac(facbis), nbffac + endif +#endif +c +c 3.1.3.1. ==> La famille doit valoir la famille supplementaire pour +c que la maille appartienne au maillage de calcul +C Remarque : il se peut que la famille d'une telle face soit +c deja la famille supplementaire. Il ne faut pas +c filtrer la-dessus car sinon on ne mettra pas son +c etat a 0 ; or cela est indispensable pour +c etre detectee en tant qu'element de calcul. +c + famfac(facbis) = nbffac +c +c 3.1.3.2. ==> La maille doit etre active +c + if ( mod(hetfac(facbis),mhistf).ne.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,typenh), facbis + write (ulsort,texte(langue,10)) hetfac(facbis), 0 + endif +#endif + hetfac(facbis) = 0 + endif +c +c 3.1.3.3. ==> Enregistrement de la nouvelle paire +c +#ifdef _DEBUG_HOMARD_ +cc if ( glop.eq.1 ) then + write (ulsort,*) 'enregistrement ',npfarc+1, + > ' pour ',facbis,' et ',laface +cc endif +#endif +c + npfarc = npfarc + 1 + facrec(1,npfarc) = facbis + facrec(2,npfarc) = laface +c +c 3.1.3.4. ==> Enregistrement des volumes voisins +c + npvorc = npvorc + 1 + do 3134 , iaux = 1 , 2 +c + if ( iaux.eq.1 ) then + face = facbis + else + face = laface + endif +c +c lequel des deux voisins ? +c + do 31341 , jaux = 1 , 2 +c + kaux = volfac(jaux,face) +#ifdef _DEBUG_HOMARD_ +cc if ( glop.eq.1 ) then + write (ulsort,90122) 'volfac', jaux, face, kaux + if ( kaux.gt.0 ) then + write (ulsort,90002) 'd''etat', hetvol(kaux) + endif +cc endif +#endif +c Le volume est tetra ou hexa + if ( kaux.gt.0 ) then + if ( mod(hetvol(kaux),mhistv).eq.0 ) then + levolu = kaux + typvol = 1 + goto 31342 + endif + endif +c +31341 continue +c +31342 continue +c +c enregistrement du voisin +c +#ifdef _DEBUG_HOMARD_ +cc if ( glop.eq.1 ) then + write (ulsort,90002) 'volume et type', levolu, typvol +cc endif +#endif +c + if ( typvol.eq.1 ) then + volrec(iaux,npvorc) = levolu + volrec(3,npvorc) = facbis + endif +c + 3134 continue +c + endif +c + elseif ( tybofa.eq.2 .or. tybofa.eq.4 ) then +c +c 3.2. ==> La face est interne au domaine. +c . Si elle borde deux volumes actifs ou deux volumes inactifs +c et qu'elle est de la famille supplementaire, on doit la +c ramener a la famille libre +c Remarque : bug possible si des elements internes ont ete +c mis dans des groupes au depart ... +c + if ( famfac(laface).eq.nbffac ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) 'face interne au domaine' + write (ulsort,texte(langue,8)) mess14(langue,1,typenh), laface + write (ulsort,texte(langue,10)) famfac(laface), 1 + endif +#endif + famfac(laface) = 1 +c +#ifdef _DEBUG_HOMARD_ + elseif ( famfac(laface).ne.1 ) then +c + write (ulsort,texte(langue,19)) + > mess14(langue,1,typenh), laface , famfac(laface) + write (ulsort,texte(langue,20)) + > mess14(langue,1,typenh), laface , nivfac(laface) + codret = 12 + goto 310 +#endif +c + endif +c + endif +c + 31 continue +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,typenh), npfarc + if ( npfarc.gt.0 ) then + jaux = 1 + laface = facrec(1,1) +cgn print *,'laface = ', laface +cgn print *,'adelre-1+laface = ', adelre-1+laface + write (ulsort,90002) 'face', laface, imem(adelre-1+laface) + do 3100 , iaux = 1 , npfarc + if ( imem(adelre-1+laface).ne.3 ) then + stop + elseif ( imem(adelre-1+facrec(2,iaux)).ne.5 ) then + stop + endif + write (ulsort,*)' ',imem(adelre-1+facrec(2,iaux)) + if ( jaux.eq.2 .or. jaux.eq.3 .or. jaux.eq.4 ) then + if ( laface.ne.facrec(1,iaux) ) then + write (ulsort,*) jaux + write (ulsort,*) facrec(2,iaux) + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), laface , hetfac(laface) + write (ulsort,texte(langue,19)) + > mess14(langue,1,typenh), laface , famfac(laface) + write (ulsort,texte(langue,20)) + > mess14(langue,1,typenh), laface , nivfac(laface) + write (ulsort,90002) 'fils', filfac(laface) + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), filfac(laface), hetfac(filfac(laface)) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+1,hetfac(filfac(laface)+1) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+2,hetfac(filfac(laface)+2) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+3,hetfac(filfac(laface)+3) + stop + endif + elseif ( jaux.eq.5 ) then + if ( laface.eq.facrec(1,iaux) ) then + write (ulsort,*) '5' + write (ulsort,texte(langue,19)) + > mess14(langue,1,typenh), laface , famfac(laface) + write (ulsort,texte(langue,20)) + > mess14(langue,1,typenh), laface , nivfac(laface) + stop + endif + jaux = 1 + laface = facrec(1,iaux) + write (ulsort,*)imem(adelre-1+laface) + endif + jaux = jaux + 1 + 3100 continue + endif +c + do 3101 , laface = 1 , nbfato + if ( imem(adelre-1+laface).eq.3 ) then + do 3102 , iaux = 1 , npfarc + if ( laface.eq.facrec(1,iaux) ) then + goto 3101 + endif + 3102 continue + elseif ( imem(adelre-1+laface).eq.5 ) then + do 3103 , iaux = 1 , npfarc + if ( laface.eq.facrec(2,iaux) ) then + goto 3101 + endif + 3103 continue + else + goto 3101 + endif + write (ulsort,*) jaux + write (ulsort,*) facrec(1,iaux), facrec(2,iaux) + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), laface , hetfac(laface) + write (ulsort,texte(langue,19)) + > mess14(langue,1,typenh), laface , famfac(laface) + write (ulsort,texte(langue,20)) + > mess14(langue,1,typenh), laface , nivfac(laface) + write (ulsort,90002) 'fils', filfac(laface) + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), filfac(laface), hetfac(filfac(laface)) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+1,hetfac(filfac(laface)+1) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+2,hetfac(filfac(laface)+2) + write (ulsort,texte(langue,13)) + >mess14(langue,1,typenh),filfac(laface)+3,hetfac(filfac(laface)+3) + stop + 3101 continue +#endif +c +#ifdef _DEBUG_HOMARD_ + 310 continue +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,14)) + write (ulsort,texte(langue,6)) mess14(langue,3,typenh), npfarc + write (ulsort,*) ' ' + endif +#endif +c +#ifdef _DEBUG_HOMARD_ +cgn do 300 , laface = 1 , nbfato + do 300 , laface = 1 , -nbfato + if ( famfac(laface).ne.1 ) then + if ( imem(adelre-1+laface).eq.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,typenh), laface + write (ulsort,90002) 'etat ',hetfac(laface) + write (ulsort,90002) 'pere ',perfac(laface) + write (ulsort,90002) 'famille',famfac(laface) + write (ulsort,90002) 'bord ',imem(adelre-1+laface) + call dmflsh(iaux) + endif + endif + 300 continue + laface = 12279 + do 3010 , laface = 1 , nbfato + if ( famfac(laface).eq.nbffac ) then + write (ulsort,texte(langue,5)) mess14(langue,1,typenh), laface + write (ulsort,*) 'etat = ',hetfac(laface), + < ', pere = ',perfac(laface), + < ', bord = ',imem(adelre-1+laface) + endif + 3010 continue + call dmflsh(iaux) + write (ulsort,*) ' ' + do 3020 , laface = 1 , -nbfato + if ( famfac(laface).ge.2 .and. famfac(laface).le.7) then + write (ulsort,texte(langue,5)) mess14(langue,1,typenh), laface + write (ulsort,*) 'etat = ',hetfac(laface), + > ', pere = ',perfac(laface), + > ', bord = ',imem(adelre-1+laface) + endif + 3020 continue + call dmflsh(iaux) +#endif +c +c==== +c 4. chaque face de la non conformite initiale doit devenir +c un element si elle apparait +c on va s'interesser aux faces recouvrantes qui sont +c decoupees en 4 et dont l'element voisin n'est pas decoupe ; +c cela correspond en effet a la situation semblable au depart. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. conformite initiale ; codret', codret + call dmflsh(iaux) + write (ulsort,texte(langue,11)) nbfari +#endif +c + if ( nbfari.gt.0 ) then +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nbfari +c + laface = fareca(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,4), laface + write (ulsort,*) filfac(laface) +#endif +c + if ( mod(hetfac(laface),mhistf).eq.4 ) then +c +c 4.1. ==> Si on a deja traite cette face, on passe a la suite +c + do 411 , kaux = npfarc, 1, -1 +c + if ( facrec(1,kaux).eq.laface .or. + > facrec(2,kaux).eq.laface ) then + goto 41 + endif +c + 411 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) + > mess14(langue,1,typenh), laface , hetfac(laface) +#endif +c +c 4.2. ==> Si son volume voisin est decoupe, on passe a la suite +c + kaux = volfac(1,laface) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) + > mess14(langue,1,9), kaux , hetvol(kaux) +#endif + if ( kaux.gt.0 ) then + if ( mod(hetvol(kaux),100).ne.0 ) then + goto 41 + endif + else + kaux = -kaux + if ( pypefa(1,kaux).ne.0 ) then + if ( mod(hetpyr(pypefa(1,kaux)),100).ne.0 ) then + goto 41 + endif + endif + if ( pypefa(2,kaux).ne.0 ) then + codret = 1793 + endif + endif +c +c 4.3. ==> La face mere est a modifier +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,typenh), laface + write (ulsort,texte(langue,10)) famfac(laface), nbffac + write (ulsort,texte(langue,10)) hetfac(laface), 0 +#endif +c + famfac(laface) = nbffac + hetfac(laface) = 0 +c +c 4.4. ==> Ses filles sont a modifier +c + do 414 , lafaci = filfac(laface), filfac(laface)+3 +c + if ( famfac(lafaci).ne.nbffac ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) + > mess14(langue,1,typenh), lafaci + write (ulsort,texte(langue,10)) famfac(lafaci), nbffac +#endif + famfac(lafaci) = nbffac +c + if ( mod(hetfac(lafaci),mhistf).ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) + > mess14(langue,1,typenh), lafaci + write (ulsort,texte(langue,10)) hetfac(lafaci), 0 +#endif + hetfac(lafaci) = 0 + endif +c + endif +c + npfarc = npfarc + 1 + facrec(1,npfarc) = lafaci + facrec(2,npfarc) = laface +c + 414 continue +c + endif +c + 41 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,15)) + write (ulsort,texte(langue,6)) mess14(langue,3,typenh), npfarc + write (ulsort,*) ' ' + endif +#endif +c +c==== +c 5. Bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Bilan ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( noelre, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmarc.F b/src/tool/AP_Conversion/pcmarc.F new file mode 100644 index 00000000..3d93a43a --- /dev/null +++ b/src/tool/AP_Conversion/pcmarc.F @@ -0,0 +1,489 @@ + subroutine pcmarc ( nocmap, nospec, + > nonexm, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de MAillage - ReCollements +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmap . e . char8 . nom de l'objet maillage de calcul iter.n+1 . +c . nospec . e . char8 . nom de l'objet memorisant les specificites . +c . nonexm . e . 1 . non exportation de mailles . +c . . . . 1 : on exporte toutes les mailles . +c . . . . 2x : les segments ne sont pas exportes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMARC' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +#include "impr02.h" +c +#include "envca1.h" +c +#include "nbutil.h" +c +c 0.3. ==> arguments +c + character*8 nocmap + character*8 nospec +c + integer nonexm +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc +c + integer nbnomb, adnomb + integer un +c + integer adeqpo, adeqin + integer adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + character*64 saux64 + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''. Creation de l''''equivalence pour le recollement'')' + texte(1,6) = + > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)' +c + texte(2,4) = '(''. Creation of equivalence for glue'')' + texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)' +c +#include "impr03.h" +c + write (ulsort,texte(langue,4)) +c + un = 1 +c +c==== +c 2. recuperation des donnees du maillage a modifier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. recuperation donnees ; codret', codret +#endif +c +c 2.1. ==> les noms des structures +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmap, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> les recollements +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nospec) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD41', nompro +#endif + call utad41 ( nospec, + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > ulsort, langue, codret) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nospec//'.Tab1') + call gmprsx (nompro, nospec//'.Tab2') + call gmprsx (nompro, nospec//'.Tab3') + call gmprsx (nompro, nospec//'.Tab5') +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(nonexm,2).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc + endif + if ( nbtria.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,2), nptrrc + endif + if ( nbquad.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,4), npqurc + endif + if ( nbtetr.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,3), npterc + endif + if ( nbhexa.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,6), npherc + endif + write (ulsort,*) ' ' +c + endif +c +c==== +c 3. la structure generale des equivalences +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Struct gale des equiv ; codret', codret +#endif +c + if ( nparrc.ne.0 .or. nptrrc.ne.0 .or. npqurc.ne.0 ) then +c +c 3.1. ==> Les nombres +c + if ( codret.eq.0 ) then +c + nbequi = nbequi + 1 + nbeqar = nbeqar + nparrc + nbeqtr = nbeqtr + nptrrc + nbeqqu = nbeqqu + npqurc + nbeqte = nptrrc + nbeqhe = npqurc +c + endif +c +c 3.2. ==> Si aucune equivalence n'existe, on en cree une +c + if ( homolo.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTACME', nompro +#endif + call utacme ( ncequi, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe, + > adeqpo, adeqin, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +cgn call gmprsx ( nompro, ncequi ) +cgn call gmprsx ( nompro, ncequi//'.Quadr' ) +cgn call gmprsx ( nompro, ncequi//'.Hexae' ) +c + endif +c + else +c +c 3.3. ==> Si des equivalences existent, on enrichit +c + if ( codret.eq.0 ) then +c + call gmecat ( ncequi, 1, nbequi, codre1 ) + call gmecat ( ncequi, 4, nbeqar, codre2 ) + call gmecat ( ncequi, 5, nbeqtr, codre3 ) + call gmecat ( ncequi, 6, nbeqqu, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + iaux = 5*(nbequi-1) + jaux = 5*nbequi + call gmmod ( ncequi//'.Pointeur', + > adeqpo, iaux, jaux, un, un, codre1 ) + iaux = 33*(nbequi-1) + jaux = 33*nbequi + call gmmod ( ncequi//'.InfoGene', + > adeqin, iaux, jaux, un, un, codre2 ) + iaux = 2*(nbeqar-nparrc) + jaux = 2*nbeqar + call gmmod ( ncequi//'.Arete', + > adeqar, iaux, jaux, un, un, codre3 ) + iaux = 2*(nbeqtr-nptrrc) + jaux = 2*nbeqtr + call gmmod ( ncequi//'.Trian', + > adeqtr, iaux, jaux, un, un, codre4 ) + iaux = 2*(nbeqqu-npqurc) + jaux = 2*nbeqqu + call gmmod ( ncequi//'.Quadr', + > adeqqu, iaux, jaux, un, un, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncequi) + call gmprsx (nompro,ncequi//'.Pointeur') + call gmprsx (nompro,ncequi//'.InfoGene') + call gmprsx (nompro,ncequi//'.Arete') + call gmprsx (nompro,ncequi//'.Trian') + call gmprsx (nompro,ncequi//'.Quadr') +#endif +c + endif +c +c==== +c 4. Remplissage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Remplissage ; codret', codret +#endif +c + if ( nparrc.ne.0 .or. nptrrc.ne.0 .or. npqurc.ne.0 ) then +c +c 4.1. ==> Les pointeurs +c + if ( codret.eq.0 ) then +c + iaux = adeqpo + 5*nbequi + imem(iaux-5) = 0 + imem(iaux-4) = 0 + imem(iaux-3) = nparrc + imem(iaux-2) = nptrrc + imem(iaux-1) = npqurc +c + endif +c +c 4.2. ==> Les informations generales +c + if ( codret.eq.0 ) then +c + saux64 = blan64 + saux64(1:31) = 'MAILLES_A_RECOLLER_APRES_HOMARD' +c 12345678901234567890123456789012 + iaux = 64 + jaux = adeqin + 33*(nbequi-1) + call utchs8 ( saux64, iaux, smem(jaux), + > ulsort, langue, codret ) +c 1234567890123456789012345678901234567890 + sau200( 1: 40) = 'Cette equivalence decrit les mailles a r' + sau200( 41: 80) = 'ecoller. Dans chaque correspondance, le ' + sau200( 81:120) = 'premier numero est celui de la maille co' + sau200(121:160) = 'upee ; le second numero est celui d''une ' + sau200(161:200) = 'des petites mailles en regard. ' +c + iaux = 200 + jaux = adeqin + 33*(nbequi-1) + 8 + call utchs8 ( sau200, iaux, smem(jaux), + > ulsort, langue, codret ) +c + endif +c +c 4.3. ==> Les aretes +c + if ( codret.eq.0 ) then +c + jaux = adeqar + 2*(nbeqar-nparrc) + kaux = 2*nparrc - 1 + do 43 , iaux = 0 , kaux + imem(jaux+iaux) = imem(adarrc+iaux) + 43 continue +c + endif +c +c 4.4. ==> Les triangles +c + if ( codret.eq.0 ) then +c + jaux = adeqtr + 2*(nbeqtr-nptrrc) + kaux = 2*nptrrc - 1 + do 44 , iaux = 0 , kaux + imem(jaux+iaux) = imem(adtrrc+iaux) + 44 continue +c + endif +c +c 4.5. ==> Les quadrangles +c + if ( codret.eq.0 ) then +c + jaux = adeqqu + 2*(nbeqqu-npqurc) + kaux = 2*npqurc - 1 + do 45 , iaux = 0 , kaux + imem(jaux+iaux) = imem(adqurc+iaux) + 45 continue +c + endif +c +c 4.6. ==> Les tetraedres +c + if ( codret.eq.0 ) then +c + jaux = adeqte + kaux = 2*nptrrc - 1 + do 46 , iaux = 0 , kaux + imem(jaux+iaux) = imem(adterc+iaux) + 46 continue +c + endif +c +c 4.7. ==> Les hexaedres +c + if ( codret.eq.0 ) then +c + jaux = adeqhe + kaux = 2*npqurc - 1 + do 47 , iaux = 0 , kaux + imem(jaux+iaux) = imem(adherc+iaux) + 47 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncequi) + call gmprsx (nompro,ncequi//'.Pointeur') + call gmprsx (nompro,ncequi//'.InfoGene') + call gmprsx (nompro,ncequi//'.Arete') + call gmprsx (nompro,ncequi//'.Trian') + call gmprsx (nompro,ncequi//'.Quadr') + call gmprsx (nompro,ncequi//'.Tetra') + call gmprsx (nompro,ncequi//'.Hexae') +#endif +c + endif +c +c==== +c 5. Les nombres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Les nombres ; codret', codret +#endif +c + if ( nparrc.ne.0 .or. nptrrc.ne.0 .or. npqurc.ne.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +cgn print *,nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu +c + if ( codret.eq.0 ) then +c + imem(adnomb+30) = nbequi + imem(adnomb+31) = nbeqno + imem(adnomb+32) = nbeqmp + imem(adnomb+33) = nbeqar + imem(adnomb+34) = nbeqtr + imem(adnomb+35) = nbeqqu +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnomb ) + call dmflsh (iaux) +#endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmat0.F b/src/tool/AP_Conversion/pcmat0.F new file mode 100644 index 00000000..0eff2a61 --- /dev/null +++ b/src/tool/AP_Conversion/pcmat0.F @@ -0,0 +1,172 @@ + subroutine pcmat0 ( rstrto, + > hettri, + > famtri, cfatri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - Triangles +c - - -- - +c - phase 0 +c - +c ______________________________________________________________________ +c +c remarque : pcmatr et pcmat0 sont des clones +c remarque : pcmaa0, pcmat0 et pcmaq0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . rstrto . s . 1 . nombre de triangles actifs et du calcul . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMAT0' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombtr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer rstrto +c + integer hettri(nbtrto) +c + integer cfatri(nctftr,nbftri), famtri(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr06.h" +c +c==== +c 2. Decompte des triangles actifs et du calcul +c==== +c + rstrto = 0 +c + do 21 , iaux = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,2), iaux + write (ulsort,texte(langue,12)) + > cotyel, cfatri(cotyel,famtri(iaux)) +#endif +c + if ( cfatri(cotyel,famtri(iaux)).ne.0 ) then +c + etat = mod( hettri(iaux) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hettri(iaux), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + rstrto = nbtrto + goto 22 +c + endif +c + endif +c + 21 continue +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,18)) mess14(langue,3,2), rstrto +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmate.F b/src/tool/AP_Conversion/pcmate.F new file mode 100644 index 00000000..37d2a4a0 --- /dev/null +++ b/src/tool/AP_Conversion/pcmate.F @@ -0,0 +1,316 @@ + subroutine pcmate ( elemen, nbele0, + > somare, np2are, + > aretri, + > tritet, cotrte, aretet, + > hettet, famtet, cfatet, + > nnosca, ntesca, ntesho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - TEtraedres +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . . . . + l : appartenance a l'equivalence l . +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . ntesca . s . rsteto . numero des tetraedres du calcul . +c . ntesho . s . nbele0 . numero des tetraedres dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMATE' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) +c + integer cfatet(nctfte,nbftet), famtet(nbteto) +c + integer nnosca(rsnoto) + integer ntesca(rsteto), ntesho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer letetr, letet0 + integer etat + integer iaux + integer listar(6), listso(4) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbtecf, nbteca =', nbtecf, nbteca +#endif +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rsteto + ntesca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + ntesho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a3 +c . . . +c . . . +c a1 . a2 . . n4 +c . . * +c . . . . +c . a4 . . . a6 +c . . . . +c . . .. +c . . . +c *..................................* +c n2 a5 n3 +c + do 31 , letet0 = 1 , nbteto +c + letetr = letet0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,3), letetr +#endif +c + etat = mod( hettet(letetr) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen + write (ulsort,*) 'triangles',(tritet(letetr,iaux),iaux=1,4) +#endif + ntesho(elemen) = letetr + ntesca(letetr) = elemen +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) "sommets", listso +#endif +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(2)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(4)) + famele(elemen) = cfatet(cofamd,famtet(letetr)) + typele(elemen) = cfatet(cotyel,famtet(letetr)) +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + else +c +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a3 +c . . *n8 +c . . . +c a1 . a2 * . n4 +c n5* n7. * +c . . . . +c . a5 . . . a6 +c . *n9 . *n10 +c . . .. +c . . . +c *................*.................* +c n2 a4 n6 n3 +c +c + do 41 , letet0 = 1 , nbteto +c + letetr = letet0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,3), letetr +#endif +c + etat = mod( hettet(letetr) , 100 ) +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen + write (ulsort,*) 'triangles',(tritet(letetr,iaux),iaux=1,3) +#endif + ntesho(elemen) = letetr + ntesca(letetr) = elemen +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) "sommets", listso +#endif +c + noeele(elemen,1) = nnosca(listso(1)) + noeele(elemen,2) = nnosca(listso(2)) + noeele(elemen,3) = nnosca(listso(3)) + noeele(elemen,4) = nnosca(listso(4)) + noeele(elemen,5) = nnosca(np2are(listar(1))) + noeele(elemen,6) = nnosca(np2are(listar(4))) + noeele(elemen,7) = nnosca(np2are(listar(2))) + noeele(elemen,8) = nnosca(np2are(listar(3))) + noeele(elemen,9) = nnosca(np2are(listar(5))) + noeele(elemen,10) = nnosca(np2are(listar(6))) +cgn write (ulsort,*) (noeele(elemen,iaux),iaux=5,10) + famele(elemen) = cfatet(cofamd,famtet(letetr)) + typele(elemen) = cfatet(cotyel,famtet(letetr)) +c + endif +c + 41 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmatr.F b/src/tool/AP_Conversion/pcmatr.F new file mode 100644 index 00000000..d6a30b38 --- /dev/null +++ b/src/tool/AP_Conversion/pcmatr.F @@ -0,0 +1,441 @@ + subroutine pcmatr ( elemen, nbele0, + > somare, np2are, + > aretri, hettri, nintri, + > famtri, cfatri, + > nnosca, ntrsca, ntrsho, + > famele, noeele, typele, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion - MAillage connectivite - TRiangles +c - - -- -- +c ______________________________________________________________________ +c +c remarque : pcmatr et pcmat0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . elemen . es . 1 . numero du dernier element cree . +c . nbele0 . e . 1 . estimation du nombre d'elements . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . nnosca . e . rsnoto . numero des noeuds du code de calcul . +c . ntrsca . s . rstrto . numero des triangles du calcul . +c . ntrsho . s . nbele0 . numero des triangles dans HOMARD . +c . famele . es . nbele0 . famille med des elements . +c . noeele . es . nbele0 . noeuds des elements . +c . . . *nbmane. . +c . typele . es . nbele0 . type des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMATR' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +c +#include "nbfami.h" +#include "nombar.h" +#include "nombtr.h" +c +#include "nombsr.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer elemen + integer nbele0 +c + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nintri(nbtrto) +c + integer cfatri(nctftr,nbftri), famtri(nbtrto) +c + integer nnosca(rsnoto) + integer ntrsca(rstrto), ntrsho(nbele0) +c + integer famele(nbele0), noeele(nbele0,nbmane) + integer typele(nbele0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer letria + integer etat + integer a1, a2, a3 + integer sa3a1, sa1a2, sa2a3 + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr06.h" +c +c==== +c 2. initialisations des renumerotations +c==== +c + do 21 , iaux = 1 , rstrto + ntrsca(iaux) = 0 + 21 continue +c + do 22 , iaux = 1 , nbele0 + ntrsho(iaux) = 0 + 22 continue +c +c==== +c 3. Conversion en lineaire +c==== +c + if ( degre.eq.1 ) then +c +c sa2a3 +c * +c . . +c . . +c HOMARD . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1*---------------*sa1a2 +c a1 +c +c s3 +c * +c / \ +c / \ +c code de calcul : / \ +c / \ +c /_________\ +c s1 s2 +c +c + do 31 , letria = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,2), letria + write (ulsort,*) '. Famille : ', famtri(letria) + write (ulsort,texte(langue,12)) + > cotyel, cfatri(cotyel,famtri(letria)) +#endif +c + if ( cfatri(cotyel,famtri(letria)).ne.0 ) then +c + etat = mod( hettri(letria) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hettri(letria), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 3.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + ntrsho(elemen) = letria + ntrsca(letria) = elemen +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +c 3.2. ==> recherche des numeros des sommets +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOTR', nompro +#endif + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c +c 3.3. ==> archivage +c + noeele(elemen,1) = nnosca(sa2a3) + noeele(elemen,2) = nnosca(sa3a1) + noeele(elemen,3) = nnosca(sa1a2) +c + famele(elemen) = cfatri(cofamd,famtri(letria)) + typele(elemen) = cfatri(cotyel,famtri(letria)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + write (ulsort,90002) 'famtri', famtri(letria) + write (ulsort,texte(langue,14)) elemen + write (ulsort,texte(langue,15)) + > (noeele(elemen,iaux),iaux=1,3) + write (ulsort,90002) 'Famille MED',famele(elemen) + write (ulsort,90002) 'Type MED ',typele(elemen) + endif +#endif + endif +c + endif +c + 31 continue +c +c==== +c 4. Conversion en quadratique +c==== +c + elseif ( mod(mailet,2).ne.0 ) then +c +c sa2a3 +c * +c . . +c . . +c HOMARD . . +c a3 *n3 n2. a2 +c . . +c . . +c . n1 . +c sa3a1*-------*-------*sa1a2 +c a1 +c +c s3 +c * +c / \ +c / \ +c MED : s6 * *s5 +c / \ +c /____*____\ +c s1 s4 s2 +c + do 41 , letria = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,2), letria + write (ulsort,texte(langue,12)) + > cotyel, cfatri(cotyel,famtri(letria)) +#endif +c + if ( cfatri(cotyel,famtri(letria)).ge.1 ) then +c + etat = mod( hettri(letria) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hettri(letria), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 4.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + ntrsho(elemen) = letria + ntrsca(letria) = elemen +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +c 4.2. ==> recherche des numeros des sommets +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOTR', nompro +#endif + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c +c 4.3. ==> archivage +c + noeele(elemen,1) = nnosca(sa2a3) + noeele(elemen,2) = nnosca(sa3a1) + noeele(elemen,3) = nnosca(sa1a2) + noeele(elemen,4) = nnosca(np2are(a3)) + noeele(elemen,5) = nnosca(np2are(a1)) + noeele(elemen,6) = nnosca(np2are(a2)) +c + famele(elemen) = cfatri(cofamd,famtri(letria)) + typele(elemen) = cfatri(cotyel,famtri(letria)) +c + endif +c + endif +c + 41 continue +c +c==== +c 5. Conversion en quadratique etendu +c Similaire au quadratique a part le 7-eme noeud +c==== +c + else +c +c sa2a3 +c * +c . . +c . . +c HOMARD . . +c a3 *n3 n2. a2 +c . nin . +c . . +c . n1 . +c sa3a1*-------*-------*sa1a2 +c a1 +c +c s3 +c * +c / \ +c / \ +c MED : s6 . .s5 +c / s7 \ +c /____.____\ +c s1 s4 s2 +c + do 51 , letria = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,2,2), letria + write (ulsort,texte(langue,12)) + > cotyel, cfatri(cotyel,famtri(letria)) +#endif +c + if ( cfatri(cotyel,famtri(letria)).ge.1 ) then +c + etat = mod( hettri(letria) , 10 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) hettri(letria), etat +#endif +c + if ( etat.eq.0 .or. hierar.ne.0 ) then +c +c 5.1. ==> generalites +c + elemen = elemen + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) elemen +#endif + ntrsho(elemen) = letria + ntrsca(letria) = elemen +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +c 5.2. ==> recherche des numeros des sommets +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOTR', nompro +#endif + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c +c 5.3. ==> archivage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'noeud interne', nintri(letria) +#endif + noeele(elemen,1) = nnosca(sa2a3) + noeele(elemen,2) = nnosca(sa3a1) + noeele(elemen,3) = nnosca(sa1a2) + noeele(elemen,4) = nnosca(np2are(a3)) + noeele(elemen,5) = nnosca(np2are(a1)) + noeele(elemen,6) = nnosca(np2are(a2)) + noeele(elemen,7) = nnosca(nintri(letria)) +c + famele(elemen) = cfatri(cofamd,famtri(letria)) + typele(elemen) = cfatri(cotyel,famtri(letria)) +c + endif +c + endif +c + 51 continue +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmex0.F b/src/tool/AP_Conversion/pcmex0.F new file mode 100644 index 00000000..cda64cfe --- /dev/null +++ b/src/tool/AP_Conversion/pcmex0.F @@ -0,0 +1,264 @@ + subroutine pcmex0 ( indnoe, indare, nouvno, nouvar, + > coocst, + > hetnoe, coonoe, arenoe, + > famnoe, cfanoe, + > hetare, somare, + > filare, merare, + > famare, + > entxno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage EXtrude - phase 0 +c - - - -- - +c Duplication des noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . nouvno . e . 1 . nouveau nombre de noeuds . +c . nouvar . e . 1 . nouveau nombre d'aretes . +c . coocst . es . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . . . . 0 pour les noeuds isoles . +c . . . . 1 pour les sommets . +c . . . . 2 pour les noeuds milieux . +c . . . . 3 pour les noeuds support de maille-point . +c . . . . 4 pour les noeuds internes aux mailles . +c . . . . 7 pour les noeuds n'appartenant qu'a des . +c . . . . elements ignores . +c . coonoe . es . nouvno . coordonnees des noeuds . +c . . . * sdim . . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . si extrusion : . +c . . . . 2 : famille du noeud extrude . +c . . . . 3 : famille de l'arete perpendiculaire . +c . . . . 4 : position du noeud . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . fille ainee de chaque arete . +c . merare . es . nouvar . mere de chaque arete . +c . famare . es . nouvar . famille des aretes . +c . entxno . s .2*nouvno. entites liees a l'extrusion du noeud . +c . . . . 1 : le noeud . +c . . . . 2 : l'arete perpendiculaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMEX0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "cofexn.h" +#include "dicfen.h" +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare, nouvno, nouvar +c + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno), cfanoe(nctfno,nbfnoe) + integer somare(2,nouvar) + integer hetare(nouvar), filare(nouvar), merare(nouvar) + integer famare(nouvar) +c + integer entxno(2,nbnoto) +c + double precision coocst(11) + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer iaux1, iaux2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,5) = '(''Nombre de noeuds :'',i10)' + texte(1,6) = '(''==> epaisseur maximale = '',g13.5)' + texte(1,7) = '(''==> coordonnee '',a3,'' ='',g13.5)' +c + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,5) = '(''Number of nodes:'',i10)' + texte(2,6) = '(''==> maximal thickness:'',g13.5)' + texte(2,7) = '(''==> '',a3,'' coordinate:'',g13.5)' +c +#include "impr03.h" +c + codret = 0 +c + if ( maextr.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + elseif ( maextr.eq.2 ) then + iaux1 = 1 + iaux2 = 3 + elseif ( maextr.eq.3 ) then + iaux1 = 1 + iaux2 = 2 + else + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) nbnoto + write (ulsort,90002) 'maextr', maextr + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + write (ulsort,texte(langue,6)) coocst(11) + write (ulsort,texte(langue,7)) 'inf', coocst(4) + write (ulsort,texte(langue,7)) 'sup', coocst(7) + endif +#endif +c +c==== +c 2. parcours des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nouvno', nouvno + write (ulsort,90002) 'nouvar', nouvar +#endif +c + do 20 , iaux = 1 , nbnoto +c +c 2.1. ===> Creation du nouveau noeud +c + indnoe = indnoe + 1 + coonoe(indnoe,iaux1) = coonoe(iaux,iaux1) + coonoe(indnoe,iaux2) = coonoe(iaux,iaux2) + coonoe(indnoe,maextr) = coocst(7) +c + hetnoe(indnoe) = 51 + arenoe(indnoe) = 0 + famnoe(indnoe) = cfanoe(cofxnt,famnoe(iaux)) +c +c 2.2. ===> Creation de l'arete joignant ces deux noeuds +c + indare = indare + 1 + somare(1,indare) = iaux + somare(2,indare) = indnoe + hetare(indare) = 50 + filare(indare) = 0 + merare(indare) = 0 + famare(indare) = cfanoe(cofxnx,famnoe(iaux)) +c +c 2.3. ===> Retablissement des coordonnes du noeud courant +c + coonoe(iaux,maextr) = coocst(4) +c +c 2.4. ===> Memorisation de l'extrusion du noeud +c + entxno(1,iaux) = indnoe + entxno(2,iaux) = indare +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indare', indare + do 2221 , iaux = 1 , nbnoto + write (ulsort,90112) 'entxno',iaux,entxno(1,iaux), entxno(2,iaux) + 2221 continue +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmex1.F b/src/tool/AP_Conversion/pcmex1.F new file mode 100644 index 00000000..837cbd6a --- /dev/null +++ b/src/tool/AP_Conversion/pcmex1.F @@ -0,0 +1,384 @@ + subroutine pcmex1 ( indare, indqua, nouvno, nouvar, nouvqu, + > coonoe, + > hetare, somare, + > filare, merare, + > famare, cfaare, + > hetqua, arequa, + > filqua, perqua, nivqua, + > famqua, cfaqua, + > entxno, entxar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage EXtrude - phase 1 +c - - - -- - +c Duplication des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indare . es . 1 . indice de la derniere arete creee . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . nouvno . e . 1 . nouveau nombre de noeuds . +c . nouvar . e . 1 . nouveau nombre d'aretes . +c . nouvqu . e . 1 . nouveau nombre de quadrangles . +c . coonoe . e . nouvno . coordonnees des noeuds . +c . . . * sdim . . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . fille ainee de chaque arete . +c . merare . es . nouvar . mere de chaque arete . +c . famare . es . nouvar . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . si extrusion : . +c . . . . 8 : famille de l'arete extrudee . +c . . . . 9 : famille du quadrangle perpendiculaire. +c . . . . 10 : position de l'arete . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 7 : sens de la 1ere compos. de la normale. +c . . . . 8 : sens de la 2eme compos. de la normale. +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . entxno . e .2*nbnoto. entites liees a l'extrusion du noeud . +c . . . . 1 : le noeud . +c . . . . 2 : l'arete perpendiculaire . +c . entxar . s .2*nbarto. entites liees a l'extrusion de l'arete . +c . . . . 1 : l'arete . +c . . . . 2 : le quadrangle perpendiculaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMEX1' ) +c +#include "nblang.h" +#include "cofexa.h" +#include "cofexq.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "envca1.h" +#include "dicfen.h" +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer indare, indqua, nouvno, nouvar, nouvqu +c + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar) + integer famare(nouvar), cfaare(nctfar,nbfare) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu) + integer famqua(nouvqu), cfaqua(nctfqu,nbfqua) +c + integer entxno(2,nbnoto) + integer entxar(2,nbarto) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer iaux1, iaux2 + integer larete + integer coor12(2) + integer etat +c + double precision daux + double precision vn(3), normal(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre d''''aretes actives :'',i10)' +c + texte(2,4) = '(''Number of active edges:'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbarac + write (ulsort,90002) 'maconf', maconf +#endif +c +c==== +c 2. caracterisation de l'extrusion +c==== +c + if ( maextr.eq.1 ) then + coor12(1) = 2 + coor12(2) = 3 + elseif ( maextr.eq.2 ) then + coor12(1) = 1 + coor12(2) = 3 + elseif ( maextr.eq.3 ) then + coor12(1) = 1 + coor12(2) = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'maextr', maextr + endif +#endif +c +c==== +c 3. parcours des aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'nouvar', nouvar + write (ulsort,90002) 'nouvqu', nouvqu +#endif +c + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + etat = 0 + else + etat = 10 + endif +c + do 30 , larete = 1 , nbarto +c + if ( mod(hetare(larete),10).le.etat ) then +c +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,*) ' ' +cgn write (ulsort,90012) +cgn > '.. Famille de l''arete de base', larete, famare(larete) +cgn write (ulsort,90022) '.... caract.', +cgn > (cfaare(iaux,famare(larete)),iaux=1,nctfar) +cgn endif +c +c 3.1. ===> Creation de la nouvelle arete +c 3.1.1. ==> Noeuds extrudes depuis les extremites de l'arete +c + iaux1 = entxno(1,somare(1,larete)) + iaux2 = entxno(1,somare(2,larete)) +c +c 3.1.2. ==> Creation +c + indare = indare + 1 +c + somare(1,indare) = min(iaux1,iaux2) + somare(2,indare) = max(iaux1,iaux2) + hetare(indare) = 50 + filare(indare) = 0 + merare(indare) = 0 + famare(indare) = cfaare(cofxat,famare(larete)) +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90015) '.... ==> Creation de l''arete', indare, +cgn > ' entre',somare(1,indare),somare(2,indare) +cgn endif +c +c 3.2. ===> Creation du quadrangle joignant ces deux aretes +c 3.2.1. ==> Aretes partant des extremites de l'arete +c + iaux1 = entxno(2,somare(1,larete)) + iaux2 = entxno(2,somare(2,larete)) +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90012) '.... Aretes perp a l''arete', +cgn > larete, iaux1, iaux2 +cgn endif +c +c 3.2.2. ==> Creation +c + indqua = indqua + 1 +c + hetqua(indqua) = 5500 + filqua(indqua) = 0 + perqua(indqua) = 0 + nivqua(indqua) = 0 + famqua(indqua) = cfaare(cofxax,famare(larete)) +c + arequa(indqua,1) = larete + arequa(indqua,2) = iaux1 + arequa(indqua,3) = indare + arequa(indqua,4) = iaux2 +c +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90002) '.... ==> Creation du quad', indqua +cgn write (ulsort,90002) '.... Aretes', arequa(indqua,1), +cgn >arequa(indqua,2) , arequa(indqua,3), arequa(indqua,4) +cgn write (ulsort,90002) '... Familles homard et med', +cgn > famqua(indqua), cfaqua(cofamd,famqua(indqua)) +cgn endif +c +c 3.2.3. ==> Controle de l'orientation +c 3.2.3.1. ==> Normale voulue +c + iaux1 = cfaqua(cofxqt,famqua(indqua)) + iaux2 = cfaqua(cofxqx,famqua(indqua)) + vn(maextr) = 0.d0 + vn(coor12(1)) = dble(iaux1) + vn(coor12(2)) = dble(iaux2) +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90004) '... Normale voulue', vn +cgn endif +c +c 3.2.3.2. ==> Calcul du vecteur normal +c + call utnqua ( indqua, normal, + > nouvno, nouvqu, + > coonoe, somare, arequa ) +c +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90004) '... Vecteur normal', normal +cgn endif +c +c 3.2.3.3. ==> Produit scalaire +c + daux = vn(1)*normal(1) + vn(2)*normal(2) + vn(3)*normal(3) +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90004) '... ==> produit scalaire', daux +cgn endif +c +c 3.2.3.4. ==> Reorientation eventuelle +c + if ( daux.lt.-0.5d0 ) then +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,*) '... reorientation' +cgn endif + iaux1 = arequa(indqua,2) + arequa(indqua,2) = arequa(indqua,4) + arequa(indqua,4) = iaux1 +cgn if ( larete.le.2 .or. larete.eq.53 ) then +cgn write (ulsort,90002) '.... Aretes', arequa(indqua,1), +cgn >arequa(indqua,2) , arequa(indqua,3), arequa(indqua,4) +cgn endif + endif +c +c 3.3. ===> Memorisation de l'extrusion de l'arete +c + entxar(1,larete) = indare + entxar(2,larete) = indqua +c +#ifdef _DEBUG_HOMARD_ + else +cgn if ( larete.le.2 .or. larete.eq.53 ) then + write (ulsort,90012) '.. Fille de', larete, filare(larete) +cgn endif +#endif + endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indqua', indqua + do 2221 , iaux = 1 , nbarto + write (ulsort,90112) 'entxar',iaux,entxar(1,iaux), entxar(2,iaux) + 2221 continue +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmex2.F b/src/tool/AP_Conversion/pcmex2.F new file mode 100644 index 00000000..921a6eeb --- /dev/null +++ b/src/tool/AP_Conversion/pcmex2.F @@ -0,0 +1,481 @@ + subroutine pcmex2 ( indtri, indpen, + > nouvar, nouvtr, nouvqu, nouvpe, + > hettri, aretri, + > filtri, pertri, nivtri, + > famtri, cfatri, pentri, + > arequa, nivqua, + > famqua, cfaqua, + > hetpen, facpen, cofape, + > filpen, perpen, + > fampen, + > somare, + > entxar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage EXtrude - phase 2 +c - - - -- - +c Duplication des triangles et creation des pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . nouvar . e . 1 . nouveau nombre d'aretes . +c . nouvtr . e . 1 . nouveau nombre de triangles . +c . nouvqu . e . 1 . nouveau nombre de quadrangles . +c . nouvpe . e . 1 . nouveau nombre de pentaedres . +c . hettri . es . nouvtr . historitre de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . si extrusion : . +c . . . . 5 : famille du triangle extrude . +c . . . . 6 : famille du pent. perpendiculaire . +c . . . . 7 : code du triangle dans le pentaedre . +c . . . . 8 : position du triangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . pentri . s . nbtrto . pentaedre sur un triangle de la face avant . +c . arequa . es .nouvqu*4. numeros des 4 aretes des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 7 : sens de la 1ere compos. de la normale. +c . . . . 8 : sens de la 2eme compos. de la normale. +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . hetpen . es . nouvpe . historique de l'etat des pentaedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. code des faces des pentaedres . +c . filpen . es . nouvpe . premier fils des pentaedres . +c . perpen . e . nouvpe . pere des pentaedres . +c . fampen . es . nouvpe . famille des pentaedres . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . entxar . e .2*nbarto. entites liees a l'extrusion de l'arete . +c . . . . 1 : l'arete . +c . . . . 2 : le quadrangle perpendiculaire . +c . . . . 3 : la 2eme arete de ce quadrangle . +c . ulsort . e . 1 . numero d'unite logitre de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMEX2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "cofext.h" +#include "cofexq.h" +#include "dicfen.h" +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer indtri, indpen + integer nouvar, nouvtr, nouvqu, nouvpe +c + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr) + integer famtri(nouvtr), cfatri(nctftr,nbftri) + integer pentri(nouvtr) + integer arequa(nouvqu,4), nivqua(nouvqu) + integer famqua(nouvqu), cfaqua(nctfqu,nbfqua) + integer hetpen(nouvpe) + integer facpen(nouvpe,5), cofape(nouvpe,5) + integer filpen(nouvpe), perpen(nouvpe) + integer fampen(nouvpe) +c + integer somare(2,nouvar) + integer entxar(2,nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letria + integer atrba1, atrba2, atrba3 + integer atrex1, atrex2, atrex3 + integer arepen(9) + integer sompe1, sompe2, sompe3 +c + logical oripos, oripox +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de triangles actifs :'',i10)' +c + texte(2,4) = '(''Number of active triangles:'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbtrac +#endif +c +c==== +c 2. parcours des triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'nouvtr', nouvtr + write (ulsort,90002) 'nouvpe', nouvpe +#endif +c + do 20 , letria = 1 , nbtrto +c + if ( mod(hettri(letria),10).eq.0 ) then +c +cgn write (ulsort,*) ' ' +cgn write (ulsort,90012) '.. Aretes du triangle de base', +cgn > letria, aretri(letria,1), +cgn > aretri(letria,2), aretri(letria,3) +cgn write (ulsort,90002) '.... Famille', famtri(letria) +cgn write (ulsort,90002) '.... codes', +cgn > (cfatri(iaux,famtri(letria)),iaux=1,nctftr) +c +c 2.1. ==> Orientations +c oripo. est vrai si le triangle entre dans le volume +c 2.1.1. ==> Orientation du triangle de base +c + if ( cfatri(cofxto,famtri(letria)).le.3 ) then + oripos = .True. + else + oripos = .False. + endif +cgn write (ulsort,99001) '.. La base entre dans le volume', oripos +c +c 2.1.2. ==> Orientation du triangle extrude +c + if ( cfatri(cofxto,cfatri(cofxtt,famtri(letria))).le.3 ) then + oripox = .True. + else + oripox = .False. + endif +cgn write (ulsort,99001) '.. L''extru entre dans le volume', oripox +c +c 2.2. ===> Creation du nouveau triangle +c 2.2.1. ==> Aretes extrudees en tant que bord du triangle +c + atrex1 = entxar(1,aretri(letria,1)) + atrex2 = entxar(1,aretri(letria,2)) + atrex3 = entxar(1,aretri(letria,3)) +c +c 2.2.2. ==> Creation +c Attention a garder la meme orientation qu'au depart +c + indtri = indtri + 1 +c + aretri(indtri,1) = atrex1 + if ( ( oripos .and. .not. oripox ) .or. + > ( .not. oripos .and. oripox ) ) then + aretri(indtri,2) = atrex2 + aretri(indtri,3) = atrex3 + else + aretri(indtri,2) = atrex3 + aretri(indtri,3) = atrex2 + endif +cgn write (ulsort,90012) '.. Aretes du triangle extrude', +cgn > indtri, aretri(indtri,1), +cgn > aretri(indtri,2), aretri(indtri,3) + hettri(indtri) = 50 + filtri(indtri) = 0 + pertri(indtri) = 0 + nivtri(indtri) = nivtri(letria) + famtri(indtri) = cfatri(cofxtt,famtri(letria)) +cgn write (ulsort,90012) '.. Famille du triangle translate', +cgn > indtri, famtri(indtri) +c +c 2.3. ===> Creation du volume joignant ces deux triangles +c face 1 : on postule : +c - c'est le triangle a la base de l'extrusion +c - sa 1ere arete est la 1ere du pentaedre +c - il est positionne avec la meme orientation qu'au +c depart +c On en deduit le code : +c . si l'orientation est positive, code 1 : (a1, a2, a3) +c . si l'orientation est negative, code 4 : (a1, a3, a2) +c face 2 : c'est le triangle qui est l'extrusion de la face 1. +c Ses aretes sont les extrudees des aretes de la face 1 : +c 1ere arete = extrusion de a1 = a4 +c On en deduit le code : +c . si la face 1 entre et la face 2 sort ou si la face 1 +c sort et la face 2 entre : +c 2eme arete = extrusion de a2 = a5 +c 3eme arete = extrusion de a3 = a6 +c donc code 1 +c . sinon, code 4 +c face 3 : c'est le quadrangle qui est l'extrusion de l'arete 1 +c du pentaedre. +c 1ere arete = a1 = 1ere arete du triangle de base +c 2eme arete = celle qui part du 1er sommet de a1 +c 3eme arete = extrusion de a1 = a4 = 1ere arete +c du triangle extrude +c 4eme arete = celle qui part du 2nd sommet de a1 +c . si le 1er sommet de a1 est sommet de a2, la 2eme +c arete du quadrangle est a7 ; +c la face est (a1,a7,a4,a9) donc code 5 +c . sinon, la 2eme arete du quadrangle est a9 ; +c la face est (a1,a9,a4,a7) donc code 1 +c face 4 : c'est le quadrangle qui est l'extrusion de l'arete 2 +c du pentaedre. +c 1ere arete = a2 +c 2eme arete = celle qui part du 1er sommet de a2 +c 3eme arete = extrusion de a2 = a5 +c 4eme arete = celle qui part du 2nd sommet de a2 +c . si l'orientation est positive : +c a2 = 2eme arete du triangle de base +c . sinon : +c a2 = 3eme arete du triangle de base +c . si le 1er sommet de a2 est sommet de a3, la 2eme +c arete du quadrangle est a8 ; +c la face est (a2,a8,a5,a7) donc code 5 +c . sinon, la face est (a2,a7,a5,a8) donc code 1 +c face 5 : c'est le quadrangle qui est l'extrusion de l'arete 3 +c de la face 1. +c 1ere arete = a3 +c 2eme arete = celle qui part du 1er sommet de a3 +c 3eme arete = extrusion de a3 = a6 +c 4eme arete = celle qui part du 2nd sommet de a3 +c . si l'orientation est positive : +c a3 = 3eme arete du triangle +c . sinon : +c a3 = 2eme arete du triangle de base +c . si le 1er sommet de a3 est sommet de a1, la 2eme +c arete du quadrangle est a9 ; +c la face est (a3,a9,a6,a8) donc code 5 +c . sinon, la face est (a3,a8,a6,a9) donc code 1 +c +c 2.3.1. ==> Triangle de base +c + atrba1 = aretri(letria,1) + atrba2 = aretri(letria,2) + atrba3 = aretri(letria,3) +c +cgn write (ulsort,90002) '.... Fac ext', +cgn > entxar(2,atrba1), entxar(2,atrba2), entxar(2,atrba3) +c +c 2.3.2. ==> Les aretes et les sommets du pentaedre +c + arepen(1) = atrba1 + if ( oripos ) then + arepen(2) = atrba2 + arepen(3) = atrba3 + else + arepen(2) = atrba3 + arepen(3) = atrba2 + endif +cgn write (ulsort,90002) '.... Ar. Pen', +cgn > arepen(1), arepen(2), arepen(3) +c + call utsotr ( somare, arepen(1), arepen(2), arepen(3), + > sompe1, sompe2, sompe3 ) +cgn write (ulsort,90002) '.... So. Pen', sompe1, sompe2, sompe3 +c +c 2.3.3. ==> Creation du pentaedre +c + indpen = indpen + 1 +cgn write (ulsort,90002) '.... pentaedre ', indpen +c +c 2.3.3.1. ==> Face 1 : la base +c + facpen(indpen,1) = letria + if ( oripos ) then + cofape(indpen,1) = 1 + else + cofape(indpen,1) = 4 + endif +cgn write (ulsort,90012) '.... code de la face 1', +cgn > facpen(indpen,1), cofape(indpen,1) +c +c 2.3.3.2. ==> Face 2 : le triangle extrude +c + facpen(indpen,2) = indtri + if ( ( oripos .and. .not. oripox ) .or. + > ( .not. oripos .and. oripox ) ) then + cofape(indpen,2) = 1 + else + cofape(indpen,2) = 4 + endif +cgn write (ulsort,90012) '.... code de la face 2', +cgn > facpen(indpen,2), cofape(indpen,2) +c +c 2.3.3.3. ==> Face 3 : le quadrangle construit sur la 1ere arete +c + facpen(indpen,3) = entxar(2,arepen(1)) + iaux = somare(1,arequa(facpen(indpen,3),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(facpen(indpen,3),2),iaux + if ( iaux.eq.sompe1 ) then + cofape(indpen,3) = 5 + else + cofape(indpen,3) = 1 + endif + nivqua(facpen(indpen,3)) = nivtri(letria) +cgn write (ulsort,90012) '.... code de la face 3', +cgn > facpen(indpen,3),cofape(indpen,3) +c +c 2.3.3.4. ==> Face 4 : le quadrangle construit sur la 2eme arete +c + facpen(indpen,4) = entxar(2,arepen(2)) + iaux = somare(1,arequa(facpen(indpen,4),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(facpen(indpen,4),2),iaux + if ( iaux.eq.sompe2 ) then + cofape(indpen,4) = 5 + else + cofape(indpen,4) = 1 + endif + nivqua(facpen(indpen,4)) = nivtri(letria) +cgn write (ulsort,90012) '.... code de la face 4', +cgn > facpen(indpen,4),cofape(indpen,4) +c +c 2.3.3.5. ==> Face 5 : le quadrangle construit sur la 3eme arete +c + facpen(indpen,5) = entxar(2,arepen(3)) + iaux = somare(1,arequa(facpen(indpen,5),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(facpen(indpen,5),2),iaux + if ( iaux.eq.sompe3 ) then + cofape(indpen,5) = 5 + else + cofape(indpen,5) = 1 + endif + nivqua(facpen(indpen,5)) = nivtri(letria) +cgn write (ulsort,90012) '.... code de la face 5', +cgn > facpen(indpen,5),cofape(indpen,5) +c +c 2.3.3.6. ==> Caracteristiques generales +c +cgn write (ulsort,90002) '.... Faces',(facpen(indpen,iaux),iaux=1,5) +cgn write (ulsort,90002) '.... Codes',(cofape(indpen,iaux),iaux=1,5) + hetpen(indpen) = 5500 + filpen(indpen) = 0 + perpen(indpen) = 0 + fampen(indpen) = cfatri(cofxtx,famtri(letria)) +cgn write (ulsort,90002) '.... Famille',fampen(indpen) +c + endif +c +c 2.3.4. ==> Correspondances +c + if ( mod(hettri(letria),10).eq.0 ) then +c + pentri(letria) = indpen + pentri(indtri) = 0 +c + else +c + pentri(letria) = 0 +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indpen', indpen +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmex3.F b/src/tool/AP_Conversion/pcmex3.F new file mode 100644 index 00000000..83ce462a --- /dev/null +++ b/src/tool/AP_Conversion/pcmex3.F @@ -0,0 +1,513 @@ + subroutine pcmex3 ( indqua, indhex, nouvar, nouvqu, nouvhe, + > hetqua, arequa, + > filqua, perqua, nivqua, + > famqua, cfaqua, hexqua, + > quahex, coquhe, + > hethex, filhex, perhex, + > famhex, + > somare, + > entxar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage EXtrude - phase 3 +c - - - -- - +c Duplication des quadrangles et creation des hexaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . nouvar . e . 1 . nouveau nombre d'aretes . +c . nouvqu . e . 1 . nouveau nombre de quadrangles . +c . nouvhe . e . 1 . nouveau nombre d'hexaedres . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 7 : sens de la 1ere compos. de la normale. +c . . . . 8 : sens de la 2eme compos. de la normale. +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . hexqua . s . nbquto . hexaedre sur un quadrangle de la face avant. +c . quahex . e .nouvhe*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhe*6. codes des 6 quadrangles des hexaedres . +c . hethex . e . nouvhe . historique de l'etat des hexaedres . +c . filhex . e . nouvhe . premier fils des hexaedres . +c . perhex . e . nouvhe . pere des hexaedres . +c . . . . si perhex(i) > 0 : numero de l'hexaedre . +c . . . . si perhex(i) < 0 : -numero dans pthepe . +c . famhex . e . nouvhe . famille des hexaedres . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . entxar . e .2*nbarto. entites liees a l'extrusion de l'arete . +c . . . . 1 : l'arete . +c . . . . 2 : le quadrangle perpendiculaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMEX3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "cofexq.h" +#include "dicfen.h" +#include "nombar.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer indqua, indhex, nouvar, nouvqu, nouvhe +c + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu) + integer famqua(nouvqu), cfaqua(nctfqu,nbfqua) + integer hexqua(nouvqu) + integer quahex(nouvhe,6), coquhe(nouvhe,6) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer famhex(nouvhe) +c + integer somare(2,nouvar) + integer entxar(2,nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad + integer aquba1, aquba2, aquba3, aquba4 + integer aquex1, aquex2, aquex3, aquex4 + integer arehex(12) + integer somhe1, somhe2, somhe3, somhe4 +c + logical oripos, oripox +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de quadrangles actifs :'',i10)' +c + texte(2,4) = '(''Number of active quadrangles:'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbquac +#endif +c +c==== +c 2. parcours des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'nouvqu', nouvqu + write (ulsort,90002) 'nouvhe', nouvhe +cgn write (ulsort,*) 'entxar' +cgn do 2222 , iaux = 1 , nbarto +cgn write (ulsort,90112) 'entxar',iaux,entxar(1,iaux),entxar(2,iaux) +cgn 2222 continue +#endif +c + do 20 , lequad = 1 , nbquto +c + if ( mod(hetqua(lequad),100).eq.0 ) then +c +cgn write (ulsort,*) ' ' +cgn write (ulsort,90012) '.. Aretes du quadrangle de base', +cgn > lequad, arequa(lequad,1), +cgn > arequa(lequad,2), arequa(lequad,3), arequa(lequad,4) +cgn write (ulsort,90002) '.... Famille', famqua(lequad) +cgn write (ulsort,90005) '.... codes', +cgn > (cfaqua(iaux,famqua(lequad)),iaux=1,nctfqu) +c +c 2.1. ==> Orientations +c oripo. est vrai si le quadrangle entre dans le volume +c 2.1.1. ==> Orientation du quadrangle de base +c + if ( cfaqua(cofxqo,famqua(lequad)).le.4 ) then + oripos = .True. + else + oripos = .False. + endif +cgn write (ulsort,99001) '.. La base entre dans le volume', oripos +c +c 2.1.2. ==> Orientation du quadrangle extrude +c + if ( cfaqua(cofxqo,cfaqua(cofxqt,famqua(lequad))).le.4 ) then + oripox = .True. + else + oripox = .False. + endif +cgn write (ulsort,99001) '.. L''extru entre dans le volume', oripox +c +c 2.2. ===> Creation du nouveau quadrangle +c 2.2.1. ==> Aretes extrudees en tant que bord du quadrangle +c + aquex1 = entxar(1,arequa(lequad,1)) + aquex2 = entxar(1,arequa(lequad,2)) + aquex3 = entxar(1,arequa(lequad,3)) + aquex4 = entxar(1,arequa(lequad,4)) +c +c 2.2.2. ==> Creation +c Attention a garder la meme orientation qu'au depart +c + indqua = indqua + 1 +c + arequa(indqua,1) = aquex1 + arequa(indqua,3) = aquex3 + if ( ( oripos .and. .not. oripox ) .or. + > ( .not. oripos .and. oripox ) ) then + arequa(indqua,2) = aquex2 + arequa(indqua,4) = aquex4 + else + arequa(indqua,2) = aquex4 + arequa(indqua,4) = aquex2 + endif +cgn write (ulsort,90012) '.. Aretes du quadrangle extrude', +cgn > indqua, aquex1, aquex2, aquex3, aquex4 + hetqua(indqua) = 5500 + filqua(indqua) = 0 + perqua(indqua) = 0 + nivqua(indqua) = nivqua(lequad) + famqua(indqua) = cfaqua(cofxqt,famqua(lequad)) +cgn write (ulsort,90012) '.. Famille du quadrangle translate', +cgn > indqua, famqua(indqua) +c +c 2.3. ===> Creation du volume joignant ces deux quadrangles +c face 1 : on postule : +c - c'est le quadrangle a la base de de l'extrusion +c - sa 1ere arete est la 1ere de l'hexaedre +c - il est positionne avec la meme orientation qu'au +c depart +c On en deduit le code : +c . si l'orientation est positive, code 1 : (a1,a2,a4,a3) +c . si l'orientation est negative, code 5 : (a1,a3,a4,a2) +c face 2 : c'est le quadrangle qui est l'extrusion de l'arete 1 +c de l'hexaedre. +c 1ere arete = a1 = 1ere arete du quadrangle de base +c 2eme arete = celle qui part d'un sommet de a1 +c 3eme arete = extrusion de a1 = a9 +c (= 1ere arete du quadrangle extrude) +c 4eme arete = celle qui part de l'autre sommet de a1 +c . si le 1er sommet de la 2eme arete du quadrangle est +c le premier sommet de l'hexaedre, cette arete est a5 ; +c la face est (a1,a5,a9,a6) donc code 5 +c . sinon, la face est (a1,a6,a9,a5) donc code 1 +c face 3 : c'est le quadrangle qui est l'extrusion de l'arete 2 +c de l'hexaedre. +c 1ere arete = a2 +c 2eme arete = celle qui part d'un sommet de a2 +c 3eme arete = extrusion de a2 = a10 +c 4eme arete = celle qui part de l'autre sommet de a2 +c . si l'orientation est positive : +c a2 = 2eme arete du quadrangle de base +c . sinon : +c a2 = 4eme arete du quadrangle de base +c . si le 1er sommet de la 2eme arete du quadrangle est +c le 4eme sommet de l'hexaedre, cette arete est a7 ; +c la face est (a2,a7,a10,a5) donc code 5 +c . sinon, la face est (a2,a5,a10,a7) donc code 1 +c face 4 : c'est le quadrangle qui est l'extrusion de l'arete 3 +c de l'hexaedre. +c 1ere arete = a3 +c 2eme arete = celle qui part d'un sommet de a3 +c 3eme arete = extrusion de a3 = a11 +c 4eme arete = celle qui part de l'autre sommet de a3 +c . si l'orientation est positive : +c a3 = 4eme arete du quadrangle de base +c . sinon : +c a3 = 2eme arete du quadrangle de base +c . si le 1er sommet de la 2eme arete du quadrangle est +c le 2eme sommet de l'hexaedre, cette arete est a6 ; +c la face est (a3,a6,a11,a8) donc code 5 +c . sinon, la face est (a3,a8,a11,a6) donc code 1 +c face 5 : c'est le quadrangle qui est l'extrusion de l'arete 4 +c de l'hexaedre. +c 1ere arete = a4 = 3eme arete du quadrangle de base +c 2eme arete = celle qui part d'un sommet de a4 +c 3eme arete = extrusion de a4 = a12 +c 4eme arete = celle qui part de l'autre sommet de a4 +c . si le 1er sommet de la 2eme arete du quadrangle est +c le 3eme sommet de l'hexaedre, cette arete est a8 ; +c la face est (a4,a8,a12,a7) donc code 5 +c . sinon, la face est (a4,a7,a12,a8) donc code 1 +c face 6 : c'est le quadrangle qui est l'extrusion de la face 1. +c Ses aretes sont les extrudees des aretes de la face 1 : +c 1ere arete = extrusion de a1 = a9 +c 3eme arete = extrusion de a4 = a12 +c Ce quadrangle etant une translation du quadrangle de +c base, son code est le symetrique de celui de la face 1. +c On en deduit le code : +c . si la face 1 entre et la face 2 sort ou si la face 1 +c sort et la face 2 entre : +c 2eme arete = extrusion de a2 = a10 +c 4eme arete = extrusion de a3 = a11 +c donc code 1 +c . sinon, code 5 +c +c 2.3.1. ==> Quadrangle de base +c + aquba1 = arequa(lequad,1) + aquba2 = arequa(lequad,2) + aquba3 = arequa(lequad,3) + aquba4 = arequa(lequad,4) +c +cgn write (ulsort,90002) '.... Fac ext', +cgn > entxar(2,aquba1), entxar(2,aquba2), +cgn > entxar(2,aquba3), entxar(2,aquba4) +c +c 2.3.2. ==> Les aretes et les sommets de l'hexaedre +c + arehex(1) = aquba1 + if ( oripos ) then + arehex(2) = aquba2 + arehex(3) = aquba4 + arehex(4) = aquba3 + else + arehex(2) = aquba4 + arehex(3) = aquba2 + arehex(4) = aquba3 + endif +cgn write (ulsort,90002) '.... Ar. Hex', +cgn > arehex(1), arehex(2), arehex(3), arehex(4) +c + call utsoqu ( somare, arehex(1),arehex(2),arehex(4),arehex(3), + > somhe1, somhe4, somhe3, somhe2 ) +cgn write (ulsort,90002) '.... So. Hex',somhe1,somhe2,somhe3,somhe4 +c +c 2.3.3. ==> Creation de l'hexaedre +c Remarque : on en profite pour ajuster les niveaux des +c faces laterales +c + indhex = indhex + 1 +cgn write (ulsort,90002) '.... hexaedre ', indhex +c +c 2.3.3.1. ==> Face 1 : la base +c + quahex(indhex,1) = lequad + if ( oripos ) then + coquhe(indhex,1) = 1 + else + coquhe(indhex,1) = 5 + endif +cgn write (ulsort,90012) '.... code de la face 1',quahex(indhex,1), +cgn > coquhe(indhex,1) +c +c 2.3.3.2. ==> Face 2 : le quadrangle construit sur la 1ere arete +c + quahex(indhex,2) = entxar(2,arehex(1)) +cgn write (ulsort,90012) '.. Aretes de la face 2 de numero', +cgn > quahex(indhex,2), +cgn > arequa(quahex(indhex,2),1),arequa(quahex(indhex,2),2), +cgn > arequa(quahex(indhex,2),3),arequa(quahex(indhex,2),4) + iaux = somare(1,arequa(quahex(indhex,2),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(quahex(indhex,2),2),iaux + if ( iaux.eq.somhe1 ) then + coquhe(indhex,2) = 5 + else + coquhe(indhex,2) = 1 + endif + nivqua(quahex(indhex,2)) = nivqua(lequad) +cgn write (ulsort,90012) '.... code de la face 2', +cgn > quahex(indhex,2), coquhe(indhex,2) +c +c 2.3.3.3. ==> Face 3 : le quadrangle construit sur la 2eme arete +c + quahex(indhex,3) = entxar(2,arehex(2)) +cgn write (ulsort,90012) '.. Aretes de la face 3 de numero', +cgn > quahex(indhex,3), +cgn > arequa(quahex(indhex,3),1),arequa(quahex(indhex,3),2), +cgn > arequa(quahex(indhex,3),3),arequa(quahex(indhex,3),4) + iaux = somare(1,arequa(quahex(indhex,3),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(quahex(indhex,3),2),iaux + if ( iaux.eq.somhe4 ) then + coquhe(indhex,3) = 5 + else + coquhe(indhex,3) = 1 + endif + nivqua(quahex(indhex,3)) = nivqua(lequad) +cgn write (ulsort,90012) '.... code de la face 3', +cgn > quahex(indhex,3), coquhe(indhex,3) +c +c 2.3.3.4. ==> Face 4 : le quadrangle construit sur la 3eme arete +c + quahex(indhex,4) = entxar(2,arehex(3)) +cgn write (ulsort,90012) '.. Aretes de la face 4 de numero', +cgn > quahex(indhex,4), +cgn > arequa(quahex(indhex,4),1),arequa(quahex(indhex,4),2), +cgn > arequa(quahex(indhex,4),3),arequa(quahex(indhex,4),4) + iaux = somare(1,arequa(quahex(indhex,4),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(quahex(indhex,4),2),iaux + if ( iaux.eq.somhe2 ) then + coquhe(indhex,4) = 5 + else + coquhe(indhex,4) = 1 + endif + nivqua(quahex(indhex,4)) = nivqua(lequad) +cgn write (ulsort,90012) '.... code de la face 4', +cgn > quahex(indhex,4), coquhe(indhex,4) +c +c 2.3.3.5. ==> Face 5 : le quadrangle construit sur la 4eme arete +c + quahex(indhex,5) = entxar(2,arehex(4)) +cgn write (ulsort,90012) '.. Aretes de la face 5 de numero', +cgn > quahex(indhex,5), +cgn > arequa(quahex(indhex,5),1),arequa(quahex(indhex,5),2), +cgn > arequa(quahex(indhex,5),3),arequa(quahex(indhex,5),4) + iaux = somare(1,arequa(quahex(indhex,5),2)) +cgn write (ulsort,90012) '.... 1er som de l''arete', +cgn > arequa(quahex(indhex,5),2),iaux + if ( iaux.eq.somhe3 ) then + coquhe(indhex,5) = 5 + else + coquhe(indhex,5) = 1 + endif + nivqua(quahex(indhex,5)) = nivqua(lequad) +cgn write (ulsort,90012) '.... code de la face 5', +cgn > quahex(indhex,5), coquhe(indhex,5) +c +c 2.3.3.6. ==> Face 6 : le quadrangle extrude +c + quahex(indhex,6) = indqua + if ( ( oripos .and. .not. oripox ) .or. + > ( .not. oripos .and. oripox ) ) then + coquhe(indhex,6) = 1 + else + coquhe(indhex,6) = 5 + endif +cgn write (ulsort,90012) '.... code de la face 6', +cgn > quahex(indhex,6), coquhe(indhex,6) +c +c 2.3.3.7. ==> Caracteristiques generales +c + hethex(indhex) = 555000 + filhex(indhex) = 0 + perhex(indhex) = 0 + famhex(indhex) = cfaqua(cofxqx,famqua(lequad)) +cgn write (ulsort,90002) '.... Faces',(quahex(indhex,iaux),iaux=1,6) +cgn write (ulsort,90002) '.... Codes',(coquhe(indhex,iaux),iaux=1,6) +cgn write (ulsort,90002) '.... Famille',famhex(indhex) +c + endif +c +c 2.3.4. ==> Correspondances +c + if ( mod(hetqua(lequad),100).eq.0 ) then +c + hexqua(lequad) = indhex + hexqua(indqua) = 0 +c + else +c + hexqua(lequad) = 0 +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indqua', indqua + write (ulsort,90002) 'indhex', indhex +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmext.F b/src/tool/AP_Conversion/pcmext.F new file mode 100644 index 00000000..716236d6 --- /dev/null +++ b/src/tool/AP_Conversion/pcmext.F @@ -0,0 +1,981 @@ + subroutine pcmext ( lgopti, taopti, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage EXTrude +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMEXT' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux, kaux, laux + integer tbiaux(1) + integer codre1, codre2 + integer codre0 + integer ptrav1, ptrav2 + integer pcoono, pareno, phetno, adcocs + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer paretr, phettr, pfiltr, ppertr, pnivtr, adpetr, adnmtr + integer parequ, phetqu, pfilqu, pperqu, pnivqu, adhequ, adnmqu + integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche + integer adnmhe + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe + integer pposif, pfacar + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte + integer pfamhe, pcfahe + integer pfampe, pcfape + integer pfampy + integer pancqu + integer panctr + integer pancar + integer pancno + integer adhono, adhoar, adhotr, adhoqu + integer indnoe, indare, indtri, indqua + integer indhex, indpen + integer option, optio2 +c + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpyan, nbpyno + integer nbpean, nbpeno + integer voarno, vofaar, vovoar, vovofa +c + character*6 saux + character*8 typobs + character*8 nomail + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2 + character*9 saux09 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( taopti(11).eq.26 ) then + saux09 = 'SATURNE ' + elseif ( taopti(11).eq.46 ) then + saux09 = 'NEPTUNE ' + else + if ( langue.eq.1 ) then + saux09 = 'EXTRUSION' + else + saux09 = 'EXTRUSION' + endif + endif +c + texte(1,4) = + > '(/,a6,1x,'''//saux09//' - PASSAGE DU MAILLAGE 2D EN 3D'')' + texte(1,5) = '(47(''=''),/)' +c + texte(2,4) = '(/,a6,1x,'''//saux09//' - FROM 2D MESH TO 3D'')' + texte(2,5) = '(37(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. les structures de base +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. structures de base ; codret', codret +#endif +c +c 2.1. ==> Le maillage homard a l'iteration n+1 +c + if ( codret.eq.0 ) then +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) +c + endif +c +c 2.2. ==> structure generale +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. structure gale ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +cgn call gmprot ( nompro, nharet//'.Famille.EntiFamm',1,26) +cgn call gmprot ( nompro, nharet//'.Famille.EntiFamm',27,118) +c +c==== +c 3. (re)allocation des tableaux avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reallocation ; codret', codret +#endif +c +c 3.1. ==> Nombres ancien/nouveau +c + if ( codret.eq.0 ) then +c +c les noeuds sont dupliques +c Remarque : on suppose du P1 simple + indnoe = nbnoto + nbnoan = nbnoto + nbnono = 2*nbnoto +c +c . si conforme : les aretes actives sont dupliquees +c . si non conforme : toutes les aretes sont dupliquees +c . A chaque noeud, on en construit une + indare = nbarto + nbaran = nbarto + nbarno = nbarto + nbnoto + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + nbarno = nbarno + nbarac + else + nbarno = nbarno + nbarto + endif +c +c . Les triangles actifs sont dupliques + indtri = nbtrto + nbtran = nbtrto + nbtrno = nbtrto + nbtrac +c +c . Les quadrangles actif sont dupliques +c . si conforme : a chaque arete active, on en construit un +c . si non conforme : a chaque arete, on en construit un + indqua = nbquto + nbquan = nbquto + nbquno = nbquto + nbquac + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + nbquno = nbquno + nbarac + else + nbquno = nbquno + nbarto + endif +c + nbtean = 0 + nbteno = 0 +c +c . Chaque quadrangle actif du maillage 2D produit un hexaedre + indhex = 0 + nbhean = 0 + nbheno = nbquac +c +c . Chaque triangle actif du maillage 2D produit un pentaedre + indpen = 0 + nbpean = 0 + nbpeno = nbtrac +c + nbpyan = 0 + nbpyno = 0 +c + endif +c +c 3.2. ==> noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. ==> noeuds, codret', codret + write (ulsort,90002) 'nbnoan', nbnoan + write (ulsort,90002) 'nbnono', nbnono +#endif +c + if ( codret.eq.0 ) then +c + iaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + call utad05 ( iaux, jaux, nhnoeu, + > nbnoan, nbnono, sdim, + > phetno, + > pfamno, + > pcoono, pareno, adhono, pancno, + > ulsort, langue, codret ) +c + call gmecat ( nhnoeu, 1, nbnono, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 3.3. ==> Les entites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. ==> entites, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + option = 0 + optio2 = 1 + iaux = 0 + if ( nbquan.eq.0 ) then + kaux = 0 + laux = 0 + else + kaux = nbquan + laux = nbquno + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD98', nompro +#endif + call utad98 ( nomail, option, optio2, + > nbaran, nbarno, + > nbtran, nbtrno, + > kaux, laux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > phetar, psomar, pfilar, pmerar, pancar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, panctr, + > pnivtr, adpetr, adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pancqu, + > pnivqu, adhequ, adnmqu, adhoqu, + > phette, ptrite, pcotrt, parete, + > pfilte, pperte, pancte, + > phethe, pquahe, pcoquh, parehe, + > pfilhe, pperhe, panche, adnmhe, + > phetpy, pfacpy, pcofay, parepy, + > pfilpy, pperpy, pancpy, + > phetpe, pfacpe, pcofap, parepe, + > pfilpe, pperpe, pancpe, + > pfamar, pfamtr, pfamqu, + > pfamte, pfamhe, pfampy, pfampe, + > ulsort, langue, codret ) +c +c 3.5. ==> Allocations pour les quadrangles, s'il n'y en avait pas +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. quadrangles ; codret', codret + write (ulsort,90002) 'nbquno', nbquno +#endif + if ( nbquan.eq.0 ) then +c + iaux = 4 + jaux = 2 + call utad08 ( iaux, jaux, nhquad, + > ulsort, langue, codret ) +c + iaux = 4 + jaux = 2310 + if ( mod(mailet,5).eq.0 ) then + jaux = jaux*19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro +#endif + call utal02 ( iaux, jaux, + > nhquad, nbquno, kaux, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, laux, + > pnivqu, laux, laux, + > adnmqu, laux, laux, + > ulsort, langue, codret ) +c + endif +c +c 3.6. ==> Allocations pour les hexaedres, s'il y en aura +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. hexaedres ; codret', codret + write (ulsort,90002) 'nbheno', nbheno +#endif + if ( nbheno.ne.0 ) then +c + iaux = 6 + jaux = 2730 + if ( mod(mailet,5).eq.0 ) then + jaux = jaux*19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_he', nompro +#endif + call utal02 ( iaux, jaux, + > nhhexa, nbheno, kaux, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, laux, + > laux, pcoquh, laux, + > adnmhe, laux, laux, + > ulsort, langue, codret ) +c + endif +c +c 3.7. ==> Allocations pour les pentaedres, s'il y en aura +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7. pentaedres ; codret', codret + write (ulsort,90002) 'nbpeno', nbpeno +#endif + if ( nbpeno.ne.0 ) then +c +c + iaux = 7 + jaux = 2730 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_pe', nompro +#endif + call utal02 ( iaux, jaux, + > nhpent, nbpeno, kaux, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, laux, + > laux, pcofap, laux, + > laux, laux, laux, + > ulsort, langue, codret ) +c + endif +c +c 3.8. ==> Rearrangement des coordonnees +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.8. coordonnees ; codret', codret +#endif +c +c 3.8.1. ==> Dimension du tableau des coordonnees +c + if ( codret.eq.0 ) then +c + call gmmod ( nhnoeu//'.Coor', + > pcoono, nbnono, nbnono, 2, 3, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 3.8.2. ==> Si l'extrusion a lieu selon X, on decale +c les coordonnees Y et Z +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(39)', taopti(39) +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(39).eq.1 ) then +c + jaux = pcoono - 1 + kaux = pcoono - 1 + nbnono + laux = pcoono - 1 + 2*nbnono + do 382 , iaux = 1 , nbnoto + rmem(laux+iaux) = rmem(kaux+iaux) + rmem(kaux+iaux) = rmem(jaux+iaux) + 382 continue +c +c 3.8.3. ==> Si l'extrusion a lieu selon Y, on decale la coordonnee Z +c + elseif ( taopti(39).eq.2 ) then +c + jaux = pcoono - 1 + nbnono + kaux = pcoono - 1 + 2*nbnono + do 383 , iaux = 1 , nbnoto + rmem(kaux+iaux) = rmem(jaux+iaux) + 383 continue +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ('coor des noeuds :', nhnoeu//'.Coor') +#endif +c + endif +c +c==== +c 4. Adresses pour les familles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 133 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > jaux, jaux, jaux, adcocs, + > ulsort, langue, codret ) +c + if ( nbfmpo.ne.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + call utad02 ( iaux, nhmapo, + > jaux, jaux, jaux, jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > jaux, jaux, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( nbtrno.ne.0 ) then + iaux = iaux*7 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, jaux, + > pfamtr, pcfatr, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c + iaux = 37 + if ( nbquno.ne.0 ) then + iaux = iaux*7 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfhex.ne.0 ) then +c + iaux = 37 + if ( nbheno.ne.0 ) then + iaux = iaux*7 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > jaux, jaux, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpen.ne.0 ) then +c + iaux = 37 + if ( nbpeno.ne.0 ) then + iaux = iaux*7 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > jaux, jaux, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 1 + call utecfe ( iaux, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > tbiaux, tbiaux, + > imem(pfamhe), imem(pcfahe), + > tbiaux, tbiaux, + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 5. Tableaux de travail +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Tableaux de travail ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2*nbnoto + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + iaux = 2*nbarto + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 6. Duplication des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Duplication des noeuds ; codret', codret + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indare', indare +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMEX0', nompro +#endif + call pcmex0 ( indnoe, indare, nbnono, nbarno, + > rmem(adcocs), + > imem(phetno), rmem(pcoono), imem(pareno), + > imem(pfamno), imem(pcfano), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), + > imem(pfamar), + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - noeuds :', nhnoeu) + call gmprsx ('coor des noeuds :', nhnoeu//'.Coor') + call gmprsx ('famille des noeuds :', nhnoeu//'.Famille.EntiFamm') + call gmprsx (nompro//' - extrusion noeuds :', ntrav1) + call gmprsx (nompro//' - aretes :', nharet) + call gmprsx (nompro//' - somare :', nharet//'.ConnDesc') + call gmprsx ('famille des aretes :', nharet//'.Famille.EntiFamm') +#endif +c + endif +c +c==== +c 7. Duplication des aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Duplication des aretes ; codret', codret + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indqua', indqua +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMEX1', nompro +#endif + call pcmex1 ( indare, indqua, nbnono, nbarno, nbquno, + > rmem(pcoono), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), + > imem(pfamar), imem(pcfaar), + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrav1), imem(ptrav2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - aretes :', nharet) + call gmprsx (nompro//' - somare :', nharet//'.ConnDesc') + call gmprsx ('famille des aretes :', nharet//'.Famille.EntiFamm') + call gmprsx (nompro//' - extrusion aretes :', ntrav2) + call gmprsx (nompro//' - quad :', nhquad) + call gmprsx (nompro//' - arequa :', nhquad//'.ConnDesc') + call gmprsx ('famille des quad :', nhquad//'.Famille.EntiFamm') +#endif +c + endif +c +c==== +c 8. Duplication des triangles actifs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Duplication des tria ; codret', codret + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indpen', indpen + write (ulsort,90002) 'nbtrac', nbtrac +#endif +c + if ( nbtrac.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMEX2', nompro +#endif + call pcmex2 ( indtri, indpen, + > nbarno, nbtrno, nbquno, nbpeno, + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(pfamtr), imem(pcfatr), imem(adpetr), + > imem(parequ), imem(pnivqu), + > imem(pfamqu), imem(pcfaqu), + > imem(phetpe), imem(pfacpe), imem(pcofap), + > imem(pfilpe), imem(pperpe), + > imem(pfampe), + > imem(psomar), + > imem(ptrav2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro//' - tria :', nhtria) +cgn call gmprsx (nompro//' - aretri :', nhtria//'.ConnDesc') +cgn call gmprsx ('famille des tria :', nhtria//'.Famille.EntiFamm') +cgn call gmprsx (nompro//' - pent :', nhpent) + call gmprsx (nompro//' - facpen :', nhpent//'.ConnDesc') + call gmprsx (nompro//' - cofape :', nhpent//'.InfoSupp') + call gmprsx ('famille des pent :', nhpent//'.Famille.EntiFamm') +#endif +c + endif +c + endif +c +c==== +c 9. Duplication des quadrangles actifs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. Duplication des quad ; codret', codret + write (ulsort,90002) 'indqua', indqua + write (ulsort,90002) 'indhex', indhex + write (ulsort,90002) 'nbquac', nbquac +#endif +c + if ( nbquac.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMEX3', nompro +#endif + call pcmex3 ( indqua, indhex, nbarno, nbquno, nbheno, + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(pfamqu), imem(pcfaqu), imem(adhequ), + > imem(pquahe), imem(pcoquh), + > imem(phethe), imem(pfilhe), imem(pperhe), + > imem(pfamhe), + > imem(psomar), + > imem(ptrav2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro//' - quad :', nhquad) + call gmprsx (nompro//' - arequa :', nhquad//'.ConnDesc') + call gmprsx ('famille des quad :', nhquad//'.Famille.EntiFamm') +cgn call gmprsx (nompro//' - hexa :', nhhexa) + call gmprsx (nompro//' - quahex :', nhhexa//'.ConnDesc') + call gmprsx (nompro//' - coquhe :', nhhexa//'.InfoSupp') + call gmprsx ('famille des hexa :', nhhexa//'.Famille.EntiFamm') +#endif +c + endif +c + endif +c +c==== +c 10. mise a jour avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. mise a jour ; codret', codret +#endif +c +c 10.1 ==> Controle +c + if ( codret.eq.0 ) then +c + if ( indnoe.ne.nbnono ) then + codret = 811 + elseif ( indare.ne.nbarno ) then + codret = 812 + elseif ( indtri.ne.nbtrno ) then + codret = 813 + elseif ( indqua.ne.nbquno ) then + codret = 814 + elseif ( indhex.ne.nbheno ) then + codret = 815 + elseif ( indpen.ne.nbpeno ) then + codret = 816 + endif +c + if ( codret.ne.0 ) then +c + write (ulsort,90002) 'indnoe, nbnono', indnoe, nbnono + write (ulsort,90002) 'indare, nbarno', indare, nbarno + write (ulsort,90002) 'indtri, nbtrno', indtri, nbtrno + write (ulsort,90002) 'indqua, nbquno', indqua, nbquno + write (ulsort,90002) 'indhex, nbheno', indhex, nbheno + write (ulsort,90002) 'indpen, nbpeno', indpen, nbpeno +c + endif +c + endif +c +c 10.2 ==> Nombres +c + if ( codret.eq.0 ) then +c + nbpeac = nbpeno + nbpema = nbpeno + nbpepe = nbpeno + nbpecf = nbpeno + nbpeto = nbpeno +c + nbheac = nbheno + nbhema = nbheno + nbhepe = nbheno + nbhecf = nbheno + nbheto = nbheno +c + nbquac = nbquno + nbqupe = 2*nbqupe + nbquto = nbquno +c + nbtrac = nbtrno + nbtrpe = 2*nbtrpe + nbtrto = nbtrno +c + nbarac = 2*nbarac + nbnoto + nbarma = 2*nbarma + nbnoma + nbarpe = 2*nbarpe + nbnoma + nbarto = nbarno +c +c nbnop1 = nbnore - nbp2re - nbimre - nbnomp - nbnoei - nbnois +c nbnop2 = nbp2re +c nbnoim = nbimre + nbnoma = 2*nbnoma + nbnoto = nbnono +c + sdim = 3 + call gmecat ( nomail, 1, sdim, codre1 ) + mdim = 3 + call gmecat ( nomail, 2, mdim, codre1 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 11. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 10. mise a jour des voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. voisinages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + voarno = -1 + vofaar = 2 + vovoar = -1 + vovofa = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > iaux, iaux, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 13. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcmmen.F b/src/tool/AP_Conversion/pcmmen.F new file mode 100644 index 00000000..61772544 --- /dev/null +++ b/src/tool/AP_Conversion/pcmmen.F @@ -0,0 +1,353 @@ + subroutine pcmmen ( nbmaid, nbmaif, nbmanw, + > noeele, fameel, typele, + > numfam, + > grfmpo, grfmtl, grfmtb, + > nrofam, tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Maillage - MENage +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbmaid . e . 1 . nombre de mailles au debut . +c . nbmaif . e . 1 . estimation du nombre de mailles a la fin . +c . nbmanw . s . 1 . nombre de nouvelles mailles . +c . noeele . es . nbmaif . noeuds des elements . +c . . .*nbmane . . +c . fameel . es . nbmaif . famille med des elements . +c . typele . es . nbmaif . type des elements pour le code de calcul . +c . nrofam . a .2*nbfmed. auxiliaire . +c . tbiaux . a . nbfmed . auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCMMEN' ) +c +#include "consts.h" +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nbutil.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbmaid, nbmaif, nbmanw + integer noeele(nbmaif,nbmane) + integer fameel(nbmaif), typele(nbmaif) + integer numfam(nbfmed), grfmpo(0:nbfmed), grfmtl(*) + integer nrofam(2,nbfmed), tbiaux(nbfmed) +c + character*8 grfmtb(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbfami + integer numf, numfb + integer lamail, nbnoma +c + integer nrocou +c + character*80 nomgro + character*80 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Groupe : '',a)' + texte(1,5) = '(''Famille a dupliquer :'',i10)' + texte(1,6) = '(''Famille resultat de la duplication :'',i10)' +c + texte(2,4) = '(''Group: '',a)' + texte(2,5) = '(''Family to duplicate :'',i10)' + texte(2,6) = '(''Family after the duplication:'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Lecture du numero de la couche en cours +c==== +c + nomfic = 'nrc.dat' + jaux = 7 +c + call guoufs ( nomfic, jaux, kaux, codret ) +c + if ( codret.eq.0 ) then +c + read (kaux,*) nrocou + call gufefi ( nomfic, jaux, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrocou', nrocou +#endif +c +c==== +c 3. On passe en revue chaque famille +c Pour une couche donnee, on a nbfami familles de mailles +c concernees. +c La creation des mailles du futur groupe R_xx_b equivaut a +c dupliquer les mailles du groupe ROCHE_20 et de tous les groupes +c CAV_20, CAV_19, ..., CAV_(xx+1) +c Pour chacune de ces situations : +c nrofam(1,n) = numero de la famille d'un maille a dupliquer +c nrofam(2,n) = numero de la famille du maille duplique +c Remarque : on suppose qu'il n'y a qu'une famille par groupe +c==== +c +c 3.1. ==> Famille du groupe 'ROCHE_20' +c + nomgro = blan80 + nomgro(1:8) = 'ROCHE_20' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbiaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c + nrofam(1,1) = tbiaux(1) +c +c 3.2. ==> Famille du groupe 'R_20_b' +c + if ( codret.eq.0 ) then +c + nomgro = blan80 + nomgro(1:6) = 'R_20_b' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbiaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c + nrofam(2,1) = tbiaux(1) +c + endif +c +c 3.3. ==> Familles des groupes 'CAV_xx' et 'CAV_xx_b' +c + nbfami = 1 +c + do 33 , iaux = 20, nrocou+1, -1 +c + nbfami = nbfami + 1 +c +c 3.3.1. ==> Familles des groupes 'CAV_xx' +c + if ( codret.eq.0 ) then +c + nomgro = blan80 + nomgro(1:6) = 'CAV_00' + if ( iaux.le.9) then + write(nomgro(6:6),'(i1)') iaux + else + write(nomgro(5:6),'(i2)') iaux + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbiaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c + nrofam(1,nbfami) = tbiaux(1) +c + endif +c +c 3.3.2. ==> Familles des groupes 'CAV_xx_b' +c + if ( codret.eq.0 ) then +c + nomgro(7:8) = '_b' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbiaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c + nrofam(2,nbfami) = tbiaux(1) +c + endif +c + 33 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbfami', nbfami + write(ulsort,91020) (nrofam(1,iaux),iaux=1,nbfami) + write(ulsort,91020) (nrofam(2,iaux),iaux=1,nbfami) +#endif +c +c==== +c 4. on passe en revue chaque famille a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmaid', nbmaid +#endif +c + if ( codret.eq.0 ) then +c + jaux = nbmaid +c + do 41 , iaux = 1 , nbfami +c +c 4.1. ==> Le numero de la famille a dupliquer +c Le numero de la famille des mailles apres duplication +c + numf = nrofam(1,iaux) + numfb = nrofam(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) numf + write (ulsort,texte(langue,6)) numfb +#endif +c +c 4.2. ==> On parcourt toutes les mailles +c + do 42 , lamail = 1 , nbmaid +c +cgn write (ulsort,texte(langue,6)) fameel(lamail), typele(lamail) +c +c la famille de la maille est-elle celle a retenir ? + if ( fameel(lamail).eq.numf ) then +c +c On duplique +c +c numero de la nouvelle maille + jaux = jaux + 1 +c +cgn write(ulsort,90002) 'lamail/jaux', lamail,jaux +cgn if ( jaux.eq.nbmaid + 1 .or. jaux.eq.nbmaif ) then +cgn write(ulsort,90015) 'noeele(', lamail,')', +cgn >(noeele(lamail,kaux), kaux = 1 , nbmane) +cgn endif + nbnoma = mednnm(typele(lamail)) + do 412 , kaux = 1 , nbnoma + noeele(jaux,kaux) = noeele(lamail,kaux) + 412 continue + fameel(jaux) = numfb + typele(jaux) = typele(lamail) +c + endif +c + 42 continue +c + 41 continue +cgn write (ulsort,texte(langue,1)) 'Sortie', nompro +cgn write(ulsort,90015) nompro//'noeele(',nbmaid + 1,')', +cgn >(noeele(nbmaid + 1,iaux), iaux = 1 , nbmane) +cgn write(ulsort,90015) nompro//'noeele(', nbmaif,')', +cgn >(noeele(nbmaif,iaux), iaux = 1 , nbmane) +c +c nombre de nouvelles mailles + nbmanw = jaux - nbmaid +c + endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmanw', nbmanw +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs0he.F b/src/tool/AP_Conversion/pcs0he.F new file mode 100644 index 00000000..deceb330 --- /dev/null +++ b/src/tool/AP_Conversion/pcs0he.F @@ -0,0 +1,290 @@ + subroutine pcs0he ( lehexa, profho, + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > afaire, listar, listso, listno, + > bindec, typdec, etanp1, + > nbarcp, tbarcp, areint, noeumi ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - phase 0 +c - +c decoupage des HExaedres +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a examiner . +c . profho . e . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . listar . s . 12 . liste des aretes de l'hexaedre . +c . listso . s . 8 . liste des sommets de l'hexaedre . +c . listno . s . 12 . liste des noeuds de l'hexaedre . +c . bindec . s . 1 . code binaire du decoupage . +c . typdec . s . 1 . type de decoupage . +c . etanp1 . s . 1 . etat de l'hexaedre a l'iteration N+1 . +c . noeumi . s . 1 . numero du noeud milieu . +c . nbarcp . s . 1 . nombre d'aretes coupees . +c . tbarcp . s . 12 . 1/0 pour chaque arete coupee ou non . +c . areint . s . * . numeros globaux des aretes internes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer profho(nbnoto) + integer hethex(nbheto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer filhex(nbheto) + integer fhpyte(2,nbheco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer listar(12), listso(8), listno(12) + integer bindec, typdec, etanp1 + integer nbarcp, tbarcp(12), areint(*) + integer noeumi +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux +c +c etan = ETAt de l'hexaedre a l'iteration N +c + integer etan +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur de l'hexaedre, donc quand il y a une arete interne +c==== +c + etanp1 = mod(hethex(lehexa),1000) + etan = (hethex(lehexa)-etanp1) / 1000 + bindec = chbiet(etanp1) +c +c type de decoupage +c + typdec = chtn2i(bindec) +#ifdef _DEBUG_HOMARD_ + write(*,90001) 'etats de l''hexa', lehexa,etan,etanp1 + write(*,90002) 'bindec', bindec + write(*,90002) 'nb sommet', chnp1(bindec) + write(*,90015) 'typdec', chtn2i(bindec), ' ==> ', typdec +#endif +c +c . cas du decoupage en 8 : +c on elimine le cas de l'hexaedre qui etait coupe en 8 et +c qui le reste : rien ne change +c + if ( ( etanp1.eq.8 ) .and. ( etanp1.eq.etan ) ) then + typdec = 1 + endif +c +c==== +c 2. Caracteristiques de l'hexaedre +c==== +c + if ( typdec.gt.1 ) then +c +c 2.1. ==> reperage des 6 aretes de l'hexaedre +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +cgn write(*,90002) 'listar 1- 6', (listar(iaux),iaux=1,6) +cgn write(*,90002) 'listar 7-12', (listar(iaux),iaux=7,12) +c +c 2.2. ==> recuperation des 8 noeuds sommets +c + call utsohe ( somare, listar, listso ) +cgn write(*,90002) 'listso sommets', (listso(iaux),iaux=1,8) +c +c 2.3. ==> recuperation des 12 noeuds +c + do 23 , iaux = 1 , 12 + listno(iaux) = np2are(listar(iaux)) + 23 continue +cgn write(*,90002) 'listno 1- 6', (listno(iaux),iaux=1,6) +cgn write(*,90002) 'listno 7-12', (listno(iaux),iaux=7,12) +c + endif +c +c==== +c 3. on verifie que le champ est present sur tous les noeuds +c de l'hexaedre +c==== +c + if ( typdec.gt.1 ) then +c + afaire = .true. + do 311 , iaux = 1 , 8 +cgn write (*,90015)'profho(',listso(iaux),') =',profho(listso(iaux)) + if ( profho(listso(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 311 continue + do 312 , iaux = 1 , 12 +cgn write (*,90015)'profho(',listno(iaux),') =',profho(listno(iaux)) + if ( profho(listno(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 312 continue +c + 32 continue +c + else +c + afaire = .false. +c + endif +cgn write (*,99001) 'afaire', afaire +c +c==== +c 4. Recuperation des numeros locaux des aretes coupees +c==== +c + if ( afaire ) then +c + call utbide ( bindec, nbarcp, tbarcp ) +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'nb d''aretes coupees', nbarcp + write (*,91010) (tbarcp(iaux),iaux=1,nbarcp) +#endif +c + endif +c +c==== +c 5. Recuperation des numeros globaux des aretes internes +c==== +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de UTHCAI par PCS0HE' +#endif + call uthcai ( lehexa, bindec, + > aretri, + > arequa, + > quahex, coquhe, arehex, + > filhex, fhpyte, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > areint ) +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'aretes internes', + > (areint(iaux),iaux=1,chnar(bindec)) +#endif +c + endif +c +c==== +c 6. Recuperation du noeud milieu +c==== +c + if ( afaire ) then +c +c 6.1. ==> Cas ou un noeud est cree au centre de l'hexaedre +c + if ( mod(typdec,2).eq.0 ) then +c + iaux = lehexa + call utnmhe ( iaux, noeumi, + > somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, filhex, fhpyte, + > facpyr, cofapy, arepyr ) +c +c 6.2. ==> Cas ou un noeud est cree sur l'arete qui joint les milieux +c de deux faces opposees +c + elseif ( mod(typdec,17).eq.0 ) then +c +cgn write (*,90002) 'Arete interne', areint(1) + noeumi = np2are(areint(1)) +c + endif +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'noeud central', noeumi +#endif +c + endif +cgn write(*,*) 'on sort de pcs0he' +c + end diff --git a/src/tool/AP_Conversion/pcs0pe.F b/src/tool/AP_Conversion/pcs0pe.F new file mode 100644 index 00000000..f9ad32af --- /dev/null +++ b/src/tool/AP_Conversion/pcs0pe.F @@ -0,0 +1,247 @@ + subroutine pcs0pe ( lepent, profho, + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > afaire, listar, listno, typdec, etanp1, + > noeumi ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - phase 0 +c - +c decoupage des PEntaedres +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a examiner . +c . profho . e . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . listar . s . 9 . liste des aretes du pentaedre . +c . listno . s . 15 . liste des noeuds du pentaedre . +c . typdec . s . 1 . type de decoupage . +c . etanp1 . s . 1 . etat du pentaedre a l'iteration N+1 . +c . noeumi . s . 1 . numero du noeud milieu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lepent + integer profho(nbnoto) + integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) + integer listar(9), listno(15) + integer typdec, etanp1 + integer noeumi +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux +c +c etan = ETAt du pentaedre a l'iteration N +c + integer etan +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur du pentaedre, donc quand il y a une arete interne +c==== +c + etanp1 = mod(hetpen(lepent),100) + etan = (hetpen(lepent)-etanp1) / 100 +cgn write(1,90001) 'etats du penta', lepent,etan,etanp1 +cgn write(1,90002) 'faces', (facpen(lepent,iaux),iaux=1,5) +cgn write(1,90002) 'codes', (cofape(lepent,iaux),iaux=1,5) +c +c type de decoupage +c + typdec = 1 +c . l'eventuel noeud central +c decoupage selon 2 aretes tria/tria +c decoupage selon 1 face triangulaire + if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then + typdec = typdec*2 + endif +c +c . d'un milieu de faces a un autre (en 8) + if ( ( etanp1.eq.80 ) .and. ( etanp1.ne.etan ) ) then + typdec = typdec*3 + endif +c +c . du centre aux milieux d'aretes +c decoupage selon 2 aretes tria/tria +c decoupage selon 1 face triangulaire + if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then + typdec = typdec*5 + endif +c +c . du centre aux sommets +c decoupage selon 2 aretes tria/tria +c decoupage selon 1 face triangulaire + if ( ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then + typdec = typdec*7 + endif +c +c . d'un milieu d'arete a un autre (aretes tria+quad) + if ( etanp1.ge.21 .and. etanp1.le.26 ) then + typdec = typdec*11 + endif +c +c . d'un milieu d'arete a un sommet (selon 1 arete tria) + if ( etanp1.ge. 1 .and. etanp1.le. 6 ) then + typdec = typdec*13 + endif +c +c . d'un milieu de face a un sommet (selon 1 face quad) + if ( etanp1.ge.43 .and. etanp1.le.45 ) then + typdec = typdec*17 + endif +c +cgn write(1,90002) 'typdec',typdec +c +c==== +c 2. Caracteristiques du pentaedre +c==== +c + if ( typdec.gt.1 ) then +c +c 2.1. ==> reperage des 9 aretes du pentaedre +c + call utarpe ( lepent, + > nbquto, nbpeto, + > arequa, facpen, cofape, + > listar ) +cgn write(1,90002) 'listar', listar +c +c 2.2. ==> recuperation des 6 noeuds sommets +c + call utsope ( somare, listar, listno ) +cgn write(1,90002) 'listno sommets', (listno(iaux),iaux=1,6)) +c +c 2.3. ==> recuperation des 9 noeuds milieux +c + do 23 , iaux = 1 , 9 + listno(6+iaux) = np2are(listar(iaux)) + 23 continue +cgn write(1,90002) 'listno milieux', (listno(iaux),iaux=7,15)) +c + endif +c +c==== +c 3. on verifie que le champ est present sur tous les noeuds +c du pentaedre +c==== +c + if ( typdec.gt.1 ) then +c + afaire = .true. + do 31 , iaux = 1 , 15 + if ( profho(listno(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 31 continue +c + 32 continue +c + else +c + afaire = .false. +c + endif +cgn write(1,*) 'afaire', afaire +c +c==== +c 4. S'il faudra interpoler avec l'eventuel noeud central : +c==== +c + if ( afaire ) then +c + if ( mod(typdec,2).eq.0 .or. + > mod(typdec,5).eq.0 .or. + > mod(typdec,7).eq.0 ) then +c + iaux = lepent + call utnmpe ( iaux, noeumi, + > somare, aretri, arequa, + > tritet, cotrte, + > facpen, cofape, filpen, fppyte, + > facpyr, cofapy ) +c + endif +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs0qu.F b/src/tool/AP_Conversion/pcs0qu.F new file mode 100644 index 00000000..3f317e8f --- /dev/null +++ b/src/tool/AP_Conversion/pcs0qu.F @@ -0,0 +1,191 @@ + subroutine pcs0qu ( lequad, profho, + > hetqua, arequa, + > somare, np2are, + > afaire, listar, listno, typdec, etanp1 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - phase 0 +c - +c decoupage des QUadrangles +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a examiner . +c . profho . e . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . listar . s . 4 . liste des aretes du quadrangle . +c . listno . s . 8 . liste des noeuds du quadrangle . +c . typdec . s . 1 . type de decoupage . +c . etanp1 . s . 1 . etat de l'hexaedre a l'iteration N+1 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer lequad + integer profho(nbnoto) + integer hetqua(nbquto), arequa(nbquto,4) + integer somare(2,nbarto), np2are(nbarto) + integer listar(4), listno(8) + integer typdec, etanp1 +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c +c etan = ETAt du quadrangle a l'iteration N +c + integer etan +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur du quadrangle : +c . au centre pour un decoupage standard +c . sur des milieux d'aretes internes pour un decoupage standard +c ou de conformite +c==== +c + etanp1 = mod(hetqua(lequad),100) + etan = (hetqua(lequad)-etanp1) / 100 +c +c type de decoupage : +c 4 : en 4 standard +c 21, 22 : en 2 quadrangles selon les aretes 1/3 ou 2/4 +c 31, 32, 33 ou 34 : en 3 triangles selon l'arete 1, 2, 3 ou 4 +c 41, 42, 43 ou 44 : en 3 quadrangles selon les aretes 1/2, +c 2/3, 3/4 ou 4/1 +c + if ( ( etanp1.eq.4 ) .and. + > ( etan.eq.0 .or. + > etan.eq.21 .or. etan.eq.22 .or. + > etan.eq.31 .or. etan.eq.32 .or. + > etan.eq.33 .or. etan.eq.34 .or. + > etan.eq.41 .or. etan.eq.42 .or. + > etan.eq.43 .or. etan.eq.44 ) ) then + typdec = 4 +c + elseif ( etanp1.eq.21 .or. etanp1.eq.22 .or. + > etanp1.eq.31 .or. etanp1.eq.32 .or. + > etanp1.eq.33 .or. etanp1.eq.34 .or. + > etanp1.eq.41 .or. etanp1.eq.42 .or. + > etanp1.eq.43 .or. etanp1.eq.44 ) then + typdec = etanp1 +c + else + typdec = 0 +c + endif +c +c==== +c 2. Caracteristiques du quadrangle +c==== +c + if ( typdec.ne.0 ) then +cgn write(6,*) 'lequad,etan,etanp1=',lequad,etan,etanp1 +cgn write(6,*) 'typdec =', typdec +c +c 2.1. ==> reperage des 4 aretes du quadrangle +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + listar(1) = a1 + listar(2) = a2 + listar(3) = a3 + listar(4) = a4 +c +c 2.2. ==> recuperation des 4 noeuds sommets +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + listno(1) = sa1a2 + listno(2) = sa2a3 + listno(3) = sa3a4 + listno(4) = sa4a1 +c +c 2.3. ==> recuperation des 4 noeuds milieux +c + listno(5) = np2are(a1) + listno(6) = np2are(a2) + listno(7) = np2are(a3) + listno(8) = np2are(a4) +c + endif +c +c==== +c 3. on verifie que le champ est present sur tous les noeuds +c du quadrangle +c==== +c + if ( typdec.ne.0 ) then +c + afaire = .true. + do 31 , iaux = 1 , 8 + if ( profho(listno(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 31 continue +c + 32 continue +c + else +c + afaire = .false. +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs0te.F b/src/tool/AP_Conversion/pcs0te.F new file mode 100644 index 00000000..b750fff1 --- /dev/null +++ b/src/tool/AP_Conversion/pcs0te.F @@ -0,0 +1,225 @@ + subroutine pcs0te ( letetr, profho, + > tritet, cotrte, aretet, + > hettet, filtet, + > aretri, + > somare, np2are, + > afaire, listar, listno, adiag ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - phase 0 +c - +c decoupage des TEtraedres +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . tetraedre a examiner . +c . profho . e . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . listar . s . 6 . liste des aretes du tetraedre . +c . listno . s . 10 . liste des noeuds du tetraedre . +c . adiag . s . 1 . arete diagonale si interpolation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer letetr + integer profho(nbnoto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto), filtet(nbteto) + integer aretri(nbtrto,3) + integer somare(2,nbarto), np2are(nbarto) + integer listar(6), listno(10) + integer adiag +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux + integer typdec + integer t16ff1, t25ff1, t34ff1, td16a2, td25a1, td34a1 + integer fd16n4, fd25n4, fd34n5, fd16s3, fd25s2, fd34s2 +c +c etan = ETAt du tetraedre a l'iteration N +c etanp1 = ETAt du tetraedre a l'iteration N+1 +c + integer etan, etanp1 +c ______________________________________________________________________ +c +c==== +c 1. les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur du tetraedre, donc quand il y a une diagonale. +c==== +c + etanp1 = mod( hettet(letetr), 100 ) + etan = (hettet(letetr)-etanp1) / 100 +c +c type de decoupage +c 8 : en 8 standard +c 45, 46, 47 : en 4 par 2 fois 2 selon l'arete 5, 6, 7 +c + if ( ( etanp1.eq.85 .or. etanp1.eq.86 .or. etanp1.eq.87 ) .and. + > ( etan.ne.etanp1 ) ) then + typdec = 8 +c + elseif ( + > etanp1.eq.45 .or. etanp1.eq.46 .or. etanp1.eq.47 ) then + typdec = etanp1 +c + else + typdec = 0 +c + endif +c +c==== +c 2. Caracteristiques du tetraedre +c==== +c + if ( typdec.ne.0 ) then +c +c 2.1. ==> reperage des aretes et des sommets du tetraedre +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listno ) +c +c 2.2. ==> recuperation des 6 noeuds milieux +c + do 22 , iaux = 1 , 6 + listno(4+iaux) = np2are(listar(iaux)) + 22 continue +c + endif +c +c==== +c 3. on verifie que le champ est present sur tous les noeuds +c du tetraedre +c==== +c + if ( typdec.ne.0 ) then +c + afaire = .true. + do 31 , iaux = 1 , 10 + if ( profho(listno(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 31 continue +c + 32 continue +c + else +c + afaire = .false. +c + endif +c +c==== +c 4. S'il faudra interpoler, on cherche la diagonale +c==== +c + if ( afaire ) then +c +c 4.1. ==> le tetraedre vient d'etre decoupee en 8 par (1,6) +c + if ( etanp1.eq.85 ) then +c + t16ff1 = filtet(letetr) + 4 + fd16n4 = tritet(t16ff1,3) + adiag = aretri(fd16n4,1) +c +c 4.2. ==> le tetraedre vient d'etre decoupee en 8 par (2,5) +c + elseif ( etanp1.eq.86 ) then +c + t25ff1 = filtet(letetr) + 4 + fd25n4 = tritet(t25ff1,2) + adiag = aretri(fd25n4,1) +c +c 4.3. ==> le tetraedre vient d'etre decoupee en 8 par (3,4) +c + elseif ( etanp1.eq.87 ) then +c + t34ff1 = filtet(letetr) + 4 + fd34n5 = tritet(t34ff1,2) + adiag = aretri(fd34n5,2) +c +c 4.4. ==> le tetraedre vient d'etre decoupee en 4 par (1,6) +c + elseif ( etanp1.eq.45 ) then +c + td16a2 = filtet(letetr) + fd16s3 = tritet(td16a2,1) + adiag = aretri(fd16s3,2) +c +c 4.5. ==> le tetraedre vient d'etre decoupee en 4 par (2,5) +c + elseif ( etanp1.eq.46 ) then +c + td25a1 = filtet(letetr) + fd25s2 = tritet(td25a1,1) + adiag = aretri(fd25s2,3) +c +c 4.6. ==> le tetraedre vient d'etre decoupee en 4 par (3,4) +c + elseif ( etanp1.eq.47 ) then +c + td34a1 = filtet(letetr) + fd34s2 = tritet(td34a1,1) + adiag = aretri(fd34s2,3) +c + endif +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs0tr.F b/src/tool/AP_Conversion/pcs0tr.F new file mode 100644 index 00000000..e249bd33 --- /dev/null +++ b/src/tool/AP_Conversion/pcs0tr.F @@ -0,0 +1,173 @@ + subroutine pcs0tr ( letria, profho, + > hettri, aretri, + > somare, np2are, + > afaire, listno, typdec ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - phase 0 +c - +c decoupage des TRiangles +c -- +c ______________________________________________________________________ +c remarque : pcs0tr et pcs3tr sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . triangle a examiner . +c . profho . e . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . listno . s . 6 . liste des noeuds du triangle . +c . typdec . s . 1 . type de decoupage . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer letria + integer profho(nbnoto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer somare(2,nbarto), np2are(nbarto) + integer listno(6) + integer typdec +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux + integer as1s2, as2s3, as1s3 + integer s1, s2, s3 +c +c etan = ETAt du triangle a l'iteration N +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etan, etanp1 +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. Quel decoupage +c==== +c + etanp1 = mod(hettri(letria),10) + etan = (hettri(letria)-etanp1) / 10 +c +c type de decoupage +c 4 : en 4 standard +c 6, 7, 8 : en 4 avec basculement de l'arete typdec-5 +c 1, 2, 3 : en 2 selon l'arete typdec +c + if ( ( etanp1.eq.4 ) .and. + > ( etan.eq.0 .or. etan.eq.1 .or. + > etan.eq.2 .or. etan.eq.3 ) ) then + typdec = 4 +c + elseif ( + > ( etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) .and. + > ( etan.eq.0 .or. etan.eq.1 .or. + > etan.eq.2 .or. etan.eq.3 ) ) then + typdec = etanp1 +c + elseif ( etanp1.eq.1 .or. etanp1.eq.2 .or. etanp1.eq.3 ) then + typdec = etanp1 +c + else + typdec = 0 +c + endif +c +c==== +c 2. Caracteristiques du triangle +c==== +c + if ( typdec.ne.0 ) then +c +c 2.1. ==> reperage des 3 aretes du triangle decoupe +c + as2s3 = aretri(letria,1) + as1s3 = aretri(letria,2) + as1s2 = aretri(letria,3) +c +c 2.2. ==> recuperation des 3 noeuds sommets +c + call utsotr ( somare, as2s3, as1s3, as1s2, s3, s1, s2 ) +c + listno(1) = s1 + listno(2) = s2 + listno(3) = s3 +c +c 2.3. ==> recuperation des 3 noeuds milieux +c + listno(4) = np2are(as2s3) + listno(5) = np2are(as1s3) + listno(6) = np2are(as1s2) +c + endif +c +c==== +c 3. on verifie que le champ est present sur tous les noeuds +c du triangle +c==== +c + if ( typdec.ne.0 ) then +c + afaire = .true. + do 31 , iaux = 1 , 6 + if ( profho(listno(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif + 31 continue +c + 32 continue +c + else +c + afaire = .false. +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs1ar.F b/src/tool/AP_Conversion/pcs1ar.F new file mode 100644 index 00000000..93cf3ad1 --- /dev/null +++ b/src/tool/AP_Conversion/pcs1ar.F @@ -0,0 +1,176 @@ + subroutine pcs1ar ( nbfop1, profho, + > hetare, somare, filare, + > vap1ho ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p1 sur les noeuds lors du decoupage des ARetes +c - -- +c remarque : pcs1ar et pcsmar sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop1 . e . 1 . nombre de fonctions P1 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . vap1ho . es . nbfop1*. variables p1 numerotation homard . +c . . . nbnoto . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer nbfop1 + integer profho(nbnoto) + integer hetare(nbarto), somare(2,nbarto), filare(nbarto) +c + double precision vap1ho(nbfop1,*) +c +c 0.4. ==> variables locales +c + integer larete, nuv, s1, s2, sm +c +cgn double precision TTT(2) +cgn integer lglist +cgn parameter ( lglist = 15) +cgn integer listno(lglist) +c ______________________________________________________________________ +c +c==== +c 1. interpolation p1 pour les aretes qui viennent d'etre decoupees +c==== +c +cgn listno( 1) = 16358 +cgn listno( 2) = 14604 +cgn listno( 3) = 16395 +cgn listno( 4) = 17054 +cgn listno( 5) = 16394 +cgn listno( 6) = 17072 +cgn listno( 7) = 22390 +cgn listno( 8) = 22395 +cgn listno( 9) = 22414 +cgn listno(10) = 22393 +cgn listno(11) = 22418 +cgn listno(12) = 22415 +cgn listno(13) = 22417 +cgn listno(14) = 25003 +cgn listno(15) = 25006 +cgn ttt(1) = 1.d4 +cgn ttt(2) = -1.d4 +cgn print *,'Avant passage dans PCS1AR' +cgn do 888 , nuv=1,6 +cgn s1 = listno(nuv) +cgn print 1786,s1,vap1ho(nbfop1,s1) +cgn ttt(1)=min(ttt(1),vap1ho(nbfop1,s1)) +cgn ttt(2)=max(ttt(2),vap1ho(nbfop1,s1)) +cgn 888 continue +cgn print *,'minimum sur les 6 noeuds ',ttt(1) +cgn print *,'maximum sur les 6 noeuds ',ttt(2) +cgn write(*,*) 'nbfop1 =', nbfop1 +c + if ( nbfop1.ne.0 ) then +c + do 1000, larete = 1, nbarto +c +cgn if ( larete.eq.34918 .or. larete.eq.32464 ) then +cgn print 1789,larete,hetare(larete) +cgn print 1788,somare(1,larete),somare(2,larete) +cgn endif +cgn 1789 format('Arete ',i6,' ==> etat = ',i3) +cgn 1788 format('Sommet 1 : ',i6,' ; Sommet 2 : ',i6) +cgn 1787 format('Sommet milieu : ',i6) +cgn 1786 format('Valeur sur le sommet ',i6,' : ',g14.5) +c + if ( hetare(larete).eq.2 ) then +c +c recuperation des sommets de l'arete +c + s1 = somare(1,larete) + s2 = somare(2,larete) +cgn write(*,1784) s1, profho(s1) +cgn write(*,1784) s2, profho(s2) +cgn 1784 format('Noeud',i3,' :',i2) +c + if ( profho(s1).eq.1 .and. profho(s2).eq.1 ) then +c +c recuperation du nouveau noeud sommet +c + sm = somare(2,filare(larete)) + profho(sm) = 1 +cgn write(*,1784) sm, profho(sm) +cgn if ( larete.eq.34918 .or. larete.eq.32464 ) then +cgn print 1787,sm +cgn print 1786,s1,vap1ho(nbfop1,s1) +cgn print 1786,s2,vap1ho(nbfop1,s2) +cgn endif +c +c interpolation : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 11, nuv = 1, nbfop1 +c + vap1ho(nuv,sm) = unsde + > * ( vap1ho(nuv,s1) + vap1ho(nuv,s2) ) +c + 11 continue +c + endif +c + endif +c + 1000 continue +cgn print 1786,22414,vap1ho(nbfop1,22414) +cgn print 1786,22390,vap1ho(nbfop1,22390) +cgn ttt(1) = 1.d4 +cgn ttt(2) = -1.d4 +cgn print *,'Apres passage dans PCS1AR' +cgn do 889 , nuv=1,13 +cgn s1 = listno(nuv) +cgn print 1786,s1,vap1ho(nbfop1,s1) +cgn ttt(1)=min(ttt(1),vap1ho(nbfop1,s1)) +cgn ttt(2)=max(ttt(2),vap1ho(nbfop1,s1)) +cgn 889 continue +cgn print *,'minimum sur les 13 noeuds ',ttt(1) +cgn print *,'maximum sur les 13 noeuds ',ttt(2) +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs1he.F b/src/tool/AP_Conversion/pcs1he.F new file mode 100644 index 00000000..57b8c2d1 --- /dev/null +++ b/src/tool/AP_Conversion/pcs1he.F @@ -0,0 +1,187 @@ + subroutine pcs1he ( nbfop1, profho, + > somare, + > aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > filhex, hethex, fhpyte, + > facpyr, cofapy, arepyr, + > vap1ho ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p1 sur les noeuds lors du decoupage des HExaedres +c - -- +c remarque : on devrait optimiser cela car si l'hexaedre etait dans +c un etat de decoupage avec presence de noeud central, on +c recalcule une valeur qui est deja presente +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop1 . e . 1 . nombre de fonctions P1 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . vap1ho . es . nbfop1*. variables p1 numerotation homard . +c . . . nbnoto . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer nbfop1 + integer profho(nbnoto) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer filhex(nbheto), hethex(nbheto) + integer fhpyte(2,nbheco) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + double precision vap1ho(nbfop1,*) +c +c 0.4. ==> variables locales +c + integer lehexa, lehex0 + integer listar(12), listso(8) + integer etahex + integer sm, nuv + integer iaux +c + double precision daux +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. interpolation p1 pour les hexaedres qui viennent d'etre decoupes +c avec creation d'un noeud central. Ce noeud est au barycentre +c des 8 sommets de l'hexaedre pere. Donc on prend la moyenne de la +c fonction sur ces 8 noeuds. +c==== +c + if ( nbfop1.ne.0 ) then +c + do 10 , lehex0 = 1, nbheto +c + lehexa = lehex0 +c + etahex = mod(hethex(lehexa),1000) +cgn write(6,90015) 'hexa',lehexa,' => etat, binaire, chnp1', +cgn > hethex(lehexa), chbiet(etahex), chnp1(chbiet(etahex)) +cgn write(6,*) (quahex(lehexa,iaux),iaux=1,6) +cgn write(6,*) (coquhe(lehexa,iaux),iaux=1,6) +c + if ( chnp1(chbiet(etahex)).gt.0 ) then +c +c les aretes et les sommets de l'hexaedre +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +cgn write(6,*) listso +c +c tous les sommets doivent etre dans le profil +c + do 102 , iaux = 1 , 8 + if ( profho(listso(iaux)).ne.1 ) then + goto 10 + endif + 102 continue +c +c recherche du noeud central +c + iaux = lehexa + call utnmhe ( iaux, sm, + > somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, filhex, fhpyte, + > facpyr, cofapy, arepyr ) +cgn write(6,*) 'sm', sm +c +c le noeud central est a ajouter dans le profil +c + profho(sm) = 1 +c +c interpolation = 1/8 (u1+u2+u3...u8) +c + do 103 , nuv = 1, nbfop1 +c + daux = 0.d0 + do 1031 , iaux = 1 , 8 + daux = daux + vap1ho(nuv,listso(iaux)) + 1031 continue + vap1ho(nuv,sm) = unshu * daux +c + 103 continue +c + endif +c + 10 continue +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs1pe.F b/src/tool/AP_Conversion/pcs1pe.F new file mode 100644 index 00000000..8926824d --- /dev/null +++ b/src/tool/AP_Conversion/pcs1pe.F @@ -0,0 +1,186 @@ + subroutine pcs1pe ( nbfop1, profho, + > somare, + > aretri, arequa, + > tritet, cotrte, + > facpen, cofape, arepen, + > filpen, hetpen, fppyte, + > facpyr, cofapy, arepyr, + > vap1ho ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p1 sur les noeuds lors du decoupage des PEntaedres +c - -- +c remarque : on devrait optimiser cela car si le pentaedre etait dans +c un etat de decoupage avec presence de noeud central, on +c recalcule une valeur qui est deja presente +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop1 . e . 1 . nombre de fonctions P1 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . vap1ho . es . nbfop1*. variables p1 numerotation homard . +c . . . nbnoto . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracte.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbfop1 + integer profho(nbnoto) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto), filpen(nbpeto) + integer fppyte(2,nbpeco) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + double precision vap1ho(nbfop1,*) +c +c 0.4. ==> variables locales +c + integer lepent, lepen0 + integer listar(9), listso(6) + integer etapen + integer sm, nuv + integer iaux +c + double precision daux +c ______________________________________________________________________ +c +c==== +c 1. interpolation p1 pour les pentaedres qui viennent d'etre decoupes +c avec creation d'un noeud central. Ce noeud est au barycentre +c des 6 sommets du pentaedre pere. Donc on prend la moyenne de la +c fonction sur ces 6 noeuds. +c==== +c + if ( nbfop1.ne.0 ) then +c + do 10 , lepen0 = 1, nbpeto +c + lepent = lepen0 +c + etapen = mod(hetpen(lepent),100) +cgn if ( etapen.gt.0 .and. etapen.ne.80 ) then +cgn write(6,*) lepent,hetpen(lepent) +cgn endif +cgn write(6,*) lepent,hetpen(lepent) +cgn write(6,*) (facpen(lepent,iaux),iaux=1,5) +cgn write(6,*) (cofape(lepent,iaux),iaux=1,5) +c + if ( ( etapen.ge.31 .and. etapen.le.36 ) .or. + > ( etapen.ge.51 .and. etapen.le.52 ) ) then +cgn write(6,*) lepent,hetpen(lepent) +c +c les aretes et les sommets du pentaedre +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +cgn write(6,*) listso +c +c tous les noeuds doivent etre dans le profil +c + do 101 , iaux = 1 , 6 + if ( profho(listso(iaux)).ne.1 ) then + goto 10 + endif + 101 continue +c +c recherche du noeud central +c + iaux = lepent + call utnmpe ( iaux, sm, + > somare, aretri, arequa, + > tritet, cotrte, + > facpen, cofape, filpen, fppyte, + > facpyr, cofapy ) +c +c le noeud central est a ajouter dans le profil +c + profho(sm) = 1 +c +c interpolation = 1/6 (u1+u2+u3...u6) +c + do 102 , nuv = 1, nbfop1 +c + daux = 0.d0 + do 103 , iaux = 1 , 6 + daux = daux + vap1ho(nuv,listso(iaux)) + 103 continue + vap1ho(nuv,sm) = unssix * daux +c + 102 continue +c + endif +c + 10 continue +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs1qu.F b/src/tool/AP_Conversion/pcs1qu.F new file mode 100644 index 00000000..a5f34b41 --- /dev/null +++ b/src/tool/AP_Conversion/pcs1qu.F @@ -0,0 +1,205 @@ + subroutine pcs1qu ( nbfop1, profho, + > somare, + > hetqua, arequa, filqua, + > vap1ho ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p1 sur les noeuds lors du decoupage des QUadrangles +c - -- +c remarque : on devrait optimiser cela car si le quadrangle etait dans +c un etat de decoupage avec presence de noeud central, on +c recalcule une valeur qui est deja presente +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop1 . e . 1 . nombre de fonctions P1 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . vap1ho . es . nbfop1*. variables p1 numerotation homard . +c . . . nbnoto . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbfop1 + integer profho(nbnoto) + integer somare(2,nbarto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) +c + double precision vap1ho(nbfop1,*) +c +c 0.4. ==> variables locales +c + integer lequad + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer sm, nuv + integer iaux +c +cgn double precision TTT(2) +cgn integer lglist +cgn parameter ( lglist = 15) +cgn integer listno(lglist) +c ______________________________________________________________________ +c +c==== +c 1. interpolation p1 pour les quadrangles qui viennent d'etre decoupes +c on a une valeur a mettre sur le noeud central. Ce noeud est +c au barycentre des 4 sommets du quadrangle pere. Donc on prend la +c moyenne de la fonction sur ces 4 noeuds. +c==== +cgn listno( 1) = 16358 +cgn listno( 2) = 14604 +cgn listno( 3) = 16395 +cgn listno( 4) = 17054 +cgn listno( 5) = 16394 +cgn listno( 6) = 17072 +cgn listno( 7) = 22390 +cgn listno( 8) = 22395 +cgn listno( 9) = 22414 +cgn listno(10) = 22393 +cgn listno(11) = 22418 +cgn listno(12) = 22415 +cgn listno(13) = 22417 +cgn listno(14) = 25003 +cgn listno(15) = 25006 +cgn ttt(1) = 1.d4 +cgn ttt(2) = -1.d4 +cgn print *,'Avant passage dans PCS1QU' +cgn do 888 , nuv=1,13 +cgn sm = listno(nuv) +cgn print 1786,sm,vap1ho(nbfop1,sm) +cgn ttt(1)=min(ttt(1),vap1ho(nbfop1,sm)) +cgn ttt(2)=max(ttt(2),vap1ho(nbfop1,sm)) +cgn 888 continue +cgn print *,'minimum sur les 13 noeuds ',ttt(1) +cgn print *,'maximum sur les 13 noeuds ',ttt(2) +c + if ( nbfop1.ne.0 ) then +c + do 10 , lequad = 1, nbquto +c +cgn if ( lequad.eq.17127 .or. lequad.eq.17198 ) then +cgn print 1789,lequad,hetqua(lequad) +cgn print 1788,arequa(lequad,1),arequa(lequad,2), +cgn >arequa(lequad,3),arequa(lequad,4) +cgn endif +cgn 1789 format('Quadrangle ',i6,' ==> etat = ',i3) +cgn 1788 format('Arete 1 : ',i6,' ; Arete 2 : ',i6, +cgn > ,' ; Arete 3 : ',i6,' ; Arete 4 : ',i6) +cgn 1787 format('Sommet milieu : ',i6) +cgn 1786 format('Valeur sur le sommet ',i6,' : ',g14.5) +c + iaux = mod(hetqua(lequad),100) + if ( iaux.eq.4 .or. ( iaux.ge.41 .and. iaux.le.44 ) ) then +c +c les aretes et les sommets du quadrangle +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c tous les noeuds doivent etre dans le profil +c + if ( profho(sa1a2).eq.1 .and. profho(sa2a3).eq.1 .and. + > profho(sa3a4).eq.1 .and. profho(sa4a1).eq.1 ) then +c +c recherche du noeud central +c + iaux = lequad + call utnmqu ( iaux, sm, + > somare, arequa, filqua ) +c +c le noeud central est a ajouter dans le profil +c + profho(sm) = 1 +c +cgn if ( lequad.eq.17127 .or. lequad.eq.17198 ) then +cgn print 1787,sm +cgn print 1786,sa1a2,vap1ho(nbfop1,sa1a2) +cgn print 1786,sa2a3,vap1ho(nbfop1,sa2a3) +cgn print 1786,sa3a4,vap1ho(nbfop1,sa3a4) +cgn print 1786,sa4a1,vap1ho(nbfop1,sa4a1) +cgn endif +c +c interpolation = 1/4 (u1+u2+u3+u4) +c + do 101 , nuv = 1, nbfop1 +c + vap1ho(nuv,sm) = unsqu * ( vap1ho(nuv,sa1a2) + > + vap1ho(nuv,sa2a3) + > + vap1ho(nuv,sa3a4) + > + vap1ho(nuv,sa4a1) ) +c + 101 continue +c + endif +c + endif +c + 10 continue +c +cgn print 1786,25003,vap1ho(nbfop1,25003) +cgn print 1786,25006,vap1ho(nbfop1,25006) +cgn ttt(1) = 1.d4 +cgn ttt(2) = -1.d4 +cgn print *,'Apres passage dans PCS1QU' +cgn do 889 , nuv=1,15 +cgn sm = listno(nuv) +cgn print 1786,sm,vap1ho(nbfop1,sm) +cgn ttt(1)=min(ttt(1),vap1ho(nbfop1,sm)) +cgn ttt(2)=max(ttt(2),vap1ho(nbfop1,sm)) +cgn 889 continue +cgn print *,'minimum sur les 15 noeuds ',ttt(1) +cgn print *,'maximum sur les 15 noeuds ',ttt(2) +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcs2ar.F b/src/tool/AP_Conversion/pcs2ar.F new file mode 100644 index 00000000..b79b87fa --- /dev/null +++ b/src/tool/AP_Conversion/pcs2ar.F @@ -0,0 +1,135 @@ + subroutine pcs2ar ( nbfop2, profho, vap2ho, + > hetare, somare, np2are, filare ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds lors du decoupage des ARetes +c - -- +c remarque : pcs2ar et pcsiar sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables iso-p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer filare(nbarto) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer larete, a1, a2, sm, s1, s2, m1, m2, nuv +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. interpolation pour les aretes qui viennent d'etre decoupees +c==== +c + do 10 , larete = 1, nbarto +c +cgn write(1,90001) 'Arete', larete, hetare(larete) + if ( hetare(larete).eq.2 ) then +c +c recuperation des aretes filles +c + a1 = filare(larete) + a2 = a1 + 1 +c +c recuperation des sommets de l'arete +c + s1 = somare(1,larete) + s2 = somare(2,larete) +cgn write(1,90001) '. profil sommet 1', s1, profho(s1) +cgn write(1,90001) '. profil sommet 2', s2, profho(s2) +c +c recuperation du noeud milieu de l'arete +c + sm = np2are(larete) +cgn write(1,90001) '. profil milieu', sm, profho(sm) +c + if ( profho(s1).eq.1 .and. profho(s2).eq.1 .and. + > profho(sm).eq.1 ) then +c +c recuperation des noeuds milieux des aretes filles +c + m1 = np2are(a1) + m2 = np2are(a2) +cgn write(1,90002) '. Noeuds milieux filles', m1, m2 + profho(m1) = 1 + profho(m2) = 1 +c +c interpolation p2 a : +c +c interpolee (ui,i=1,3) = 3/8 u1 - 1/8 u2 + 3/4 u3 +c + do 11, nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = trshu * vap2ho(nuv,s1) + > - unshu * vap2ho(nuv,s2) + > + trsqu * vap2ho(nuv,sm) + vap2ho(nuv,m2) = trshu * vap2ho(nuv,s2) + > - unshu * vap2ho(nuv,s1) + > + trsqu * vap2ho(nuv,sm) +c + 11 continue +c + endif +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2h1.F b/src/tool/AP_Conversion/pcs2h1.F new file mode 100644 index 00000000..93dc2f1d --- /dev/null +++ b/src/tool/AP_Conversion/pcs2h1.F @@ -0,0 +1,428 @@ + subroutine pcs2h1 ( nbfop2, profho, vap2ho, + > somare, np2are, + > hetqua, arequa, filqua, + > quahex, + > lehexa, listso, listno, + > nbarhi, areint, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Hexaedres - 1 +c - - - +c Du noeud central au milieu des faces +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . lehexa . e . 1 . hexaedre a traiter . +c . listso . e . 8 . liste des sommets de l'hexaedre . +c . listno . e . 12 . liste des noeuds de l'hexaedre . +c . nbarhi . e . 1 . nombre d'aretes internes . +c . areint . e . * . numeros globaux des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c + character*6 nompro + parameter ( nompro = 'PCS2H1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer quahex(nbhecf,6) + integer lehexa + integer listso(8), listno(12) + integer nbarhi, areint(nbarhi) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nuface, laface, larete + integer listns(20) + integer sm, nuv + integer iaux1, iaux2, iaux3, iaux4 +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +#include "impr01.h" +c +#include "impr03.h" +c ______________________________________________________________________ +c +cgn write (ulsort,texte(langue,1)) 'Entree', nompro +#ifdef _DEBUG_HOMARD_ + if ( lehexa.eq.2) then + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listno 1-8', (listno(iaux),iaux=1,8) + write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12) + endif +#endif +c On passe en revue toutes les faces coupees +c + do 10 , nuface = 1 , 6 +c + laface = quahex(lehexa,nuface) +cgn if ( lehexa.eq.2) then +cgn write (ulsort,90002) 'nuface, laface, etat', +cgn > nuface,laface,hetqua(laface) +cgn endif +cgn write (ulsort,*) 'Dans pcs2h1, nuface =',nuface +cgn write (ulsort,*) 'Dans pcs2h1, laface =',laface +cgn write (ulsort,*) 'Dans pcs2h1, etat =',hetqua(laface) +c + if ( ( mod(hetqua(laface),100).eq.4 ) .or. + > ( mod(hetqua(laface),100).ge.41 .and. + > mod(hetqua(laface),100).le.44 ) .or. + > ( mod(hetqua(laface),100).eq.99 ) ) then +c +c==== +c 1. Les sommets de la face +c==== +c + if ( nuface.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 3 + iaux4 = 4 + elseif ( nuface.eq.2 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 5 + iaux4 = 6 + elseif ( nuface.eq.3 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 6 + iaux4 = 7 + elseif ( nuface.eq.4 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 8 + elseif ( nuface.eq.5 ) then + iaux1 = 3 + iaux2 = 4 + iaux3 = 7 + iaux4 = 8 + elseif ( nuface.eq.6 ) then + iaux1 = 5 + iaux2 = 6 + iaux3 = 7 + iaux4 = 8 + endif +c + listns(1) = listso(iaux1) + listns(2) = listso(iaux2) + listns(3) = listso(iaux3) + listns(4) = listso(iaux4) +c +c==== +c 2. Les sommets de la face opposee +c==== +c + if ( nuface.eq.1 ) then + iaux1 = 5 + iaux2 = 6 + iaux3 = 7 + iaux4 = 8 + elseif ( nuface.eq.2 ) then + iaux1 = 3 + iaux2 = 4 + iaux3 = 7 + iaux4 = 8 + elseif ( nuface.eq.3 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 8 + elseif ( nuface.eq.4 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 6 + iaux4 = 7 + elseif ( nuface.eq.5 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 5 + iaux4 = 6 + elseif ( nuface.eq.6 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 3 + iaux4 = 4 + endif +c + listns(5) = listso(iaux1) + listns(6) = listso(iaux2) + listns(7) = listso(iaux3) + listns(8) = listso(iaux4) +c +c==== +c 3. Les noeuds de la face +c==== +c + if ( nuface.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 3 + iaux4 = 4 + elseif ( nuface.eq.2 ) then + iaux1 = 1 + iaux2 = 5 + iaux3 = 6 + iaux4 = 9 + elseif ( nuface.eq.3 ) then + iaux1 = 2 + iaux2 = 5 + iaux3 = 10 + iaux4 = 7 + elseif ( nuface.eq.4 ) then + iaux1 = 3 + iaux2 = 8 + iaux3 = 11 + iaux4 = 6 + elseif ( nuface.eq.5 ) then + iaux1 = 4 + iaux2 = 7 + iaux3 = 12 + iaux4 = 8 + elseif ( nuface.eq.6 ) then + iaux1 = 9 + iaux2 = 10 + iaux3 = 11 + iaux4 = 12 + endif +c + listns( 9) = listno(iaux1) + listns(10) = listno(iaux2) + listns(11) = listno(iaux3) + listns(12) = listno(iaux4) +c +c==== +c 4. Les noeuds milieux intermediaires +c==== +c + if ( nuface.eq.1 .or. nuface.eq.6 ) then + iaux1 = 5 + iaux2 = 6 + iaux3 = 7 + iaux4 = 8 + elseif ( nuface.eq.2 .or. nuface.eq.5 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 11 + iaux4 = 10 + elseif ( nuface.eq.3 .or. nuface.eq.4 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 12 + iaux4 = 9 + endif +c + listns(13) = listno(iaux1) + listns(14) = listno(iaux2) + listns(15) = listno(iaux3) + listns(16) = listno(iaux4) +c +c==== +c 5. Les noeuds de la face opposee +c==== +c + if ( nuface.eq.1 ) then + iaux1 = 9 + iaux2 = 10 + iaux3 = 11 + iaux4 = 12 + elseif ( nuface.eq.2 ) then + iaux1 = 4 + iaux2 = 7 + iaux3 = 12 + iaux4 = 8 + elseif ( nuface.eq.3 ) then + iaux1 = 3 + iaux2 = 8 + iaux3 = 11 + iaux4 = 6 + elseif ( nuface.eq.4 ) then + iaux1 = 2 + iaux2 = 5 + iaux3 = 10 + iaux4 = 7 + elseif ( nuface.eq.5 ) then + iaux1 = 1 + iaux2 = 5 + iaux3 = 6 + iaux4 = 9 + elseif ( nuface.eq.6 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 3 + iaux4 = 4 + endif +c + listns(17) = listno(iaux1) + listns(18) = listno(iaux2) + listns(19) = listno(iaux3) + listns(20) = listno(iaux4) +c +c==== +c 6. L'arete concernee et donc le noeud au milieu +c==== +c 6.1. ==> Le noeud au milieu de la face +c + call utnmqu ( laface, jaux, + > somare, arequa, filqua ) +cgn write (ulsort,90002) 'noeud au milieu de la face', jaux +c +c 6.2. ==> L'arete concernee : celle des aretes internes qui demarre +c sur le milieu de la face +c +cgn write (ulsort,90002) 'nbarhi', nbarhi + do 62 , iaux = 1 , nbarhi + larete = areint(iaux) +cgn write (ulsort,90002) 'larete', larete,somare(1,larete),somare(2,larete) + if ( somare(1,larete).eq.jaux ) then + sm = np2are(larete) + goto 620 + endif + 62 continue + write(ulsort,*) nompro//' - aucune arete interne ne correspond ?' + codret = 62 +c + 620 continue +c +c==== +c 7. Interpolation +c==== +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'sm', sm + profho(sm) = 1 +c +cgn write (ulsort,90002) 'listns 1- 8',(listns(jaux),jaux=1,8) +cgn write (ulsort,90002) 'listns 9-16',(listns(jaux),jaux=9,16) +cgn write (ulsort,90002) 'listns 17-20',(listns(jaux),jaux=17,20) +c + do 71, nuv = 1 , nbfop2 +cgn do 711 , jaux =1 ,20 +cgn write (ulsort,90014) listns(jaux), vap2ho(nuv,listns(jaux)) +cgn 711 continue +c + vap2ho(nuv,sm) = - nfstr2 * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) + > + vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) ) + > - cqstr2 * ( vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) + > + vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) ) + > + trshu * ( vap2ho(nuv,listns(9)) + > + vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) ) + > + trssz * ( vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) + > + vap2ho(nuv,listns(16)) ) + > + unshu * ( vap2ho(nuv,listns(17)) + > + vap2ho(nuv,listns(18)) + > + vap2ho(nuv,listns(19)) + > + vap2ho(nuv,listns(20)) ) +c +cgn write (ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 71 continue +c + endif +c + endif +c + 10 continue +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2h2.F b/src/tool/AP_Conversion/pcs2h2.F new file mode 100644 index 00000000..e6a2a8b5 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2h2.F @@ -0,0 +1,567 @@ + subroutine pcs2h2 ( nbfop2, profho, vap2ho, + > somare, np2are, + > listso, listno, + > tbarcp, nbarhi, areint, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage Hexaedres - 2 +c - - - +c Du centre aux milieux d'aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . listso . e . 8 . liste des sommets de l'hexaedre . +c . listno . e . 12 . liste des noeuds de l'hexaedre . +c . tbarcp . e . 12 . 1/0 pour chaque arete coupee ou non . +c . nbarhi . e . 1 . nombre d'aretes internes . +c . areint . e . * . numeros globaux des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c + character*6 nompro + parameter ( nompro = 'PCS2H2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer listso(8), listno(12) + integer tbarcp(12), nbarhi, areint(nbarhi) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +cgn integer jaux + integer larete + integer listns(20) + integer sm, nuv + integer nuloar +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c ______________________________________________________________________ +c +#include "impr01.h" +c +#include "impr03.h" +c +cgn write (ulsort,texte(langue,1)) 'Entree', nompro +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listno 1-8', (listno(iaux),iaux=1,8) + write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12) + write (ulsort,90002) 'tbarcp 1-8', (tbarcp(iaux),iaux=1,8) + write (ulsort,90002) 'tbarcp 9-12', (tbarcp(iaux),iaux=9,12) +#endif +c On passe en revue toutes les aretes coupees +c + do 10 , nuloar = 1 , 12 +c + if ( tbarcp(nuloar).eq.1 ) then +c +c==== +c 1. Reperage des sommets et des noeuds +c==== +c le milieu de l'arete coupee + listns( 9) = listno(nuloar) +c le milieu de l'arete opposee + listns(20) = listno(13-nuloar) +c +c 1.1. ==> Arete 1 +c + if ( nuloar.eq.1 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(1) + listns( 2) = listso(2) +c les autres sommets + listns( 3) = listso(3) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(6) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(7) + listns( 8) = listso(8) +c les milieux des aretes proches + listns(10) = listno( 2) + listns(11) = listno( 3) + listns(12) = listno( 5) + listns(13) = listno( 6) +c les milieux des aretes paralleles + listns(14) = listno( 4) + listns(15) = listno( 9) +c les milieux des aretes moins proches + listns(16) = listno( 7) + listns(17) = listno( 8) + listns(18) = listno(10) + listns(19) = listno(11) +c +c 1.2. ==> Arete 2 +c + elseif ( nuloar.eq.2 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(1) + listns( 2) = listso(4) +c les autres sommets + listns( 3) = listso(2) + listns( 4) = listso(3) + listns( 5) = listso(6) + listns( 6) = listso(7) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(5) + listns( 8) = listso(8) +c les milieux des aretes proches + listns(10) = listno( 1) + listns(11) = listno( 4) + listns(12) = listno( 5) + listns(13) = listno( 7) +c les milieux des aretes paralleles + listns(14) = listno( 3) + listns(15) = listno(10) +c les milieux des aretes moins proches + listns(16) = listno( 6) + listns(17) = listno( 8) + listns(18) = listno( 9) + listns(19) = listno(12) +c +c 1.3. ==> Arete 3 +c + elseif ( nuloar.eq.3 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(2) + listns( 2) = listso(3) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(6) + listns( 8) = listso(7) +c les milieux des aretes proches + listns(10) = listno( 1) + listns(11) = listno( 4) + listns(12) = listno( 6) + listns(13) = listno( 8) +c les milieux des aretes paralleles + listns(14) = listno( 2) + listns(15) = listno(11) +c les milieux des aretes moins proches + listns(16) = listno( 5) + listns(17) = listno( 7) + listns(18) = listno( 9) + listns(19) = listno(12) +c +c 1.2. ==> Arete 4 +c + elseif ( nuloar.eq.4 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(3) + listns( 2) = listso(4) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(2) + listns( 5) = listso(7) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(5) + listns( 8) = listso(6) +c les milieux des aretes proches + listns(10) = listno( 2) + listns(11) = listno( 3) + listns(12) = listno( 7) + listns(13) = listno( 8) +c les milieux des aretes paralleles + listns(14) = listno( 1) + listns(15) = listno(12) +c les milieux des aretes moins proches + listns(16) = listno( 5) + listns(17) = listno( 6) + listns(18) = listno(10) + listns(19) = listno(11) +c +c 1.5. ==> Arete 5 +c + elseif ( nuloar.eq.5 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(1) + listns( 2) = listso(6) +c les autres sommets + listns( 3) = listso(2) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(7) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(3) + listns( 8) = listso(8) +c les milieux des aretes proches + listns(10) = listno( 1) + listns(11) = listno( 2) + listns(12) = listno( 9) + listns(13) = listno(10) +c les milieux des aretes paralleles + listns(14) = listno( 6) + listns(15) = listno( 7) +c les milieux des aretes moins proches + listns(16) = listno( 3) + listns(17) = listno( 4) + listns(18) = listno(11) + listns(19) = listno(12) +c +c 1.6. ==> Arete 6 +c + elseif ( nuloar.eq.6 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(2) + listns( 2) = listso(5) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(3) + listns( 5) = listso(6) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(4) + listns( 8) = listso(7) +c les milieux des aretes proches + listns(10) = listno( 1) + listns(11) = listno( 3) + listns(12) = listno( 9) + listns(13) = listno(11) +c les milieux des aretes paralleles + listns(14) = listno( 5) + listns(15) = listno( 8) +c les milieux des aretes moins proches + listns(16) = listno( 2) + listns(17) = listno( 4) + listns(18) = listno(10) + listns(19) = listno(12) +c +c 1.7. ==> Arete 7 +c + elseif ( nuloar.eq.7 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(4) + listns( 2) = listso(7) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(3) + listns( 5) = listso(6) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(2) + listns( 8) = listso(5) +c les milieux des aretes proches + listns(10) = listno( 2) + listns(11) = listno( 4) + listns(12) = listno(10) + listns(13) = listno(12) +c les milieux des aretes paralleles + listns(14) = listno( 5) + listns(15) = listno( 8) +c les milieux des aretes moins proches + listns(16) = listno( 1) + listns(17) = listno( 3) + listns(18) = listno( 9) + listns(19) = listno(11) +c +c 1.8. ==> Arete 8 +c + elseif ( nuloar.eq.8 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(3) + listns( 2) = listso(8) +c les autres sommets + listns( 3) = listso(2) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(7) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(1) + listns( 8) = listso(6) +c les milieux des aretes proches + listns(10) = listno( 3) + listns(11) = listno( 4) + listns(12) = listno(11) + listns(13) = listno(12) +c les milieux des aretes paralleles + listns(14) = listno( 6) + listns(15) = listno( 7) +c les milieux des aretes moins proches + listns(16) = listno( 1) + listns(17) = listno( 2) + listns(18) = listno( 9) + listns(19) = listno(10) +c +c 1.9. ==> Arete 9 +c + elseif ( nuloar.eq.9 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(5) + listns( 2) = listso(6) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(2) + listns( 5) = listso(7) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(3) + listns( 8) = listso(4) +c les milieux des aretes proches + listns(10) = listno( 5) + listns(11) = listno( 6) + listns(12) = listno(10) + listns(13) = listno(11) +c les milieux des aretes paralleles + listns(14) = listno( 1) + listns(15) = listno(12) +c les milieux des aretes moins proches + listns(16) = listno( 2) + listns(17) = listno( 3) + listns(18) = listno( 7) + listns(19) = listno( 8) +c +c 1.10. ==> Arete 10 +c + elseif ( nuloar.eq.10 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(6) + listns( 2) = listso(7) +c les autres sommets + listns( 3) = listso(1) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(8) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(2) + listns( 8) = listso(3) +c les milieux des aretes proches + listns(10) = listno( 5) + listns(11) = listno( 7) + listns(12) = listno( 9) + listns(13) = listno(12) +c les milieux des aretes paralleles + listns(14) = listno( 2) + listns(15) = listno(11) +c les milieux des aretes moins proches + listns(16) = listno( 1) + listns(17) = listno( 4) + listns(18) = listno( 6) + listns(19) = listno( 8) +c +c 1.11. ==> Arete 11 +c + elseif ( nuloar.eq.11 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(5) + listns( 2) = listso(8) +c les autres sommets + listns( 3) = listso(2) + listns( 4) = listso(3) + listns( 5) = listso(6) + listns( 6) = listso(7) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(1) + listns( 8) = listso(4) +c les milieux des aretes proches + listns(10) = listno( 6) + listns(11) = listno( 8) + listns(12) = listno( 9) + listns(13) = listno(12) +c les milieux des aretes paralleles + listns(14) = listno( 3) + listns(15) = listno(10) +c les milieux des aretes moins proches + listns(16) = listno( 1) + listns(17) = listno( 4) + listns(18) = listno( 5) + listns(19) = listno( 7) +c +c 1.12. ==> Arete 12 +c + elseif ( nuloar.eq.12 ) then +c +c les sommets de l'arete coupee + listns( 1) = listso(7) + listns( 2) = listso(8) +c les autres sommets + listns( 3) = listso(3) + listns( 4) = listso(4) + listns( 5) = listso(5) + listns( 6) = listso(6) +c les sommets de l'arete opposee a l'arete coupee + listns( 7) = listso(1) + listns( 8) = listso(2) +c les milieux des aretes proches + listns(10) = listno( 7) + listns(11) = listno( 8) + listns(12) = listno(10) + listns(13) = listno(11) +c les milieux des aretes paralleles + listns(14) = listno( 4) + listns(15) = listno( 9) +c les milieux des aretes moins proches + listns(16) = listno( 2) + listns(17) = listno( 3) + listns(18) = listno( 5) + listns(19) = listno( 6) +c + endif +c +c==== +c 2. L'arete concernee : celle des aretes internes qui demarrent +c sur le milieu de l'arete coupee +c==== +c + do 22 , iaux = 1 , nbarhi + larete = areint(iaux) + if ( somare(1,larete).eq.listns( 9) ) then + sm = np2are(larete) + goto 220 + endif + 22 continue + write(ulsort,*) nompro//' - aucune arete interne ne correspond ?' + codret = 22 +c + 220 continue +c +c==== +c 3. Calcul +c==== +c + if ( codret.eq.0 ) then +c + profho(sm) = 1 +c + do 31, nuv = 1 , nbfop2 +cgn do 311 , jaux =1 ,20 +cgn write(*,90014) listns(jaux), vap2ho(nuv,listns(jaux)) +cgn 311 continue +c + vap2ho(nuv,sm) = - nfstr2 * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) ) + > - trssz * ( vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) + > + vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) ) + > - trstr2 * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) ) + > + nessz * vap2ho(nuv,listns(9)) + > + nfstr2 * ( vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) + > + vap2ho(nuv,listns(13)) ) + > + trssz * ( vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) ) + > + trstr2 * ( vap2ho(nuv,listns(16)) + > + vap2ho(nuv,listns(17)) + > + vap2ho(nuv,listns(18)) + > + vap2ho(nuv,listns(19)) ) + > + unssz * vap2ho(nuv,listns(20)) +c +cgn write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 31 continue +c + endif +c + endif +c + 10 continue +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2h3.F b/src/tool/AP_Conversion/pcs2h3.F new file mode 100644 index 00000000..027699f8 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2h3.F @@ -0,0 +1,411 @@ + subroutine pcs2h3 ( nbfop2, profho, vap2ho, + > somare, np2are, + > listso, listno, + > nbarhi, areint, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2/iso-p2 sur les noeuds - decoupage Hexaedres - 3 +c - - - +c Du centre aux sommets (selon 2 ou 3 aretes) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . listso . e . 8 . Liste des sommets ordonnes de l'hexaedre . +c . listno . e . 12 . Liste des noeuds ordonnees de l'hexaedre . +c . nbarhi . e . 1 . nombre d'aretes internes . +c . areint . e . * . numeros globaux des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracti.h" +#include "fractj.h" +c + character*6 nompro + parameter ( nompro = 'PCS2H3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer listso(8), listno(12) + integer nbarhi, areint(nbarhi) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +cgn integer jaux + integer nusomm, larete + integer listns(20) + integer sm, nuv + integer iaux1, iaux2, iaux3, iaux4, iaux5, iaux6 +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c ______________________________________________________________________ +c +#include "impr01.h" +c +#include "impr03.h" +c +cgn write (ulsort,texte(langue,1)) 'Entree', nompro +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listno 1-8', (listno(iaux),iaux=1,8) + write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12) +#endif +c +c On passe en revue tous les sommets +c Ils sont parcourus dans l'ordre de leur numerotation de reference +c + do 10 , nusomm = 1 , 8 +cgn write(6,*) 'Dans pcs2h3, nusomm =',nusomm +c +c==== +c 1. Le sommet dont on part et ses plus proches voisins +c==== +c + iaux1 = nusomm + if ( nusomm.eq.1 ) then + iaux2 = 2 + iaux3 = 4 + iaux4 = 6 + elseif ( nusomm.eq.2 ) then + iaux2 = 1 + iaux3 = 3 + iaux4 = 5 + elseif ( nusomm.eq.3 ) then + iaux2 = 2 + iaux3 = 4 + iaux4 = 8 + elseif ( nusomm.eq.4 ) then + iaux2 = 1 + iaux3 = 3 + iaux4 = 7 + elseif ( nusomm.eq.5 ) then + iaux2 = 2 + iaux3 = 6 + iaux4 = 8 + elseif ( nusomm.eq.6 ) then + iaux2 = 1 + iaux3 = 5 + iaux4 = 7 + elseif ( nusomm.eq.7 ) then + iaux2 = 4 + iaux3 = 6 + iaux4 = 8 + else + iaux2 = 3 + iaux3 = 5 + iaux4 = 7 + endif +c + listns(1) = listso(iaux1) + listns(2) = listso(iaux2) + listns(3) = listso(iaux3) + listns(4) = listso(iaux4) +c +c==== +c 2. Le sommet oppose et ses plus proches voisins +c==== +c + iaux1 = 9-nusomm + if ( nusomm.eq.1 ) then + iaux2 = 3 + iaux3 = 5 + iaux4 = 7 + elseif ( nusomm.eq.2 ) then + iaux2 = 4 + iaux3 = 6 + iaux4 = 8 + elseif ( nusomm.eq.3 ) then + iaux2 = 1 + iaux3 = 5 + iaux4 = 7 + elseif ( nusomm.eq.4 ) then + iaux2 = 2 + iaux3 = 6 + iaux4 = 8 + elseif ( nusomm.eq.5 ) then + iaux2 = 1 + iaux3 = 3 + iaux4 = 7 + elseif ( nusomm.eq.6 ) then + iaux2 = 2 + iaux3 = 4 + iaux4 = 8 + elseif ( nusomm.eq.7 ) then + iaux2 = 1 + iaux3 = 3 + iaux4 = 5 + else + iaux2 = 2 + iaux3 = 4 + iaux4 = 6 + endif +c + listns(8) = listso(iaux1) + listns(5) = listso(iaux2) + listns(6) = listso(iaux3) + listns(7) = listso(iaux4) +c +c==== +c 3. Les noeuds milieux les plus proches +c==== +c + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 5 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 3 + iaux3 = 6 + elseif ( nusomm.eq.3 ) then + iaux1 = 3 + iaux2 = 4 + iaux3 = 8 + elseif ( nusomm.eq.4 ) then + iaux1 = 2 + iaux2 = 4 + iaux3 = 7 + elseif ( nusomm.eq.5 ) then + iaux1 = 6 + iaux2 = 9 + iaux3 = 11 + elseif ( nusomm.eq.6 ) then + iaux1 = 5 + iaux2 = 9 + iaux3 = 10 + elseif ( nusomm.eq.7 ) then + iaux1 = 7 + iaux2 = 10 + iaux3 = 12 + else + iaux1 = 8 + iaux2 = 11 + iaux3 = 12 + endif +c + listns( 9) = listno(iaux1) + listns(10) = listno(iaux2) + listns(11) = listno(iaux3) +c +c==== +c 4. Les noeuds milieux intermediaires +c==== +c + if ( nusomm.eq.1 .or. nusomm.eq.8 ) then + iaux1 = 3 + iaux2 = 6 + iaux3 = 9 + iaux4 = 10 + iaux5 = 7 + iaux6 = 4 + elseif ( nusomm.eq.2 .or. nusomm.eq.7 ) then + iaux1 = 2 + iaux2 = 4 + iaux3 = 8 + iaux4 = 11 + iaux5 = 9 + iaux6 = 5 + elseif ( nusomm.eq.3 .or. nusomm.eq.6) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 7 + iaux4 = 12 + iaux5 = 11 + iaux6 = 6 + else + iaux1 = 1 + iaux2 = 3 + iaux3 = 8 + iaux4 = 12 + iaux5 = 10 + iaux6 = 5 + endif +c + listns(12) = listno(iaux1) + listns(13) = listno(iaux2) + listns(14) = listno(iaux3) + listns(15) = listno(iaux4) + listns(16) = listno(iaux5) + listns(17) = listno(iaux6) +c +c==== +c 5. Les noeuds milieux les plus eloignes +c==== +c + if ( nusomm.eq.1 ) then + iaux1 = 8 + iaux2 = 11 + iaux3 = 12 + elseif ( nusomm.eq.2 ) then + iaux1 = 7 + iaux2 = 10 + iaux3 = 12 + elseif ( nusomm.eq.3 ) then + iaux1 = 5 + iaux2 = 9 + iaux3 = 10 + elseif ( nusomm.eq.4 ) then + iaux1 = 6 + iaux2 = 9 + iaux3 = 11 + elseif ( nusomm.eq.5 ) then + iaux1 = 2 + iaux2 = 4 + iaux3 = 7 + elseif ( nusomm.eq.6 ) then + iaux1 = 3 + iaux2 = 4 + iaux3 = 8 + elseif ( nusomm.eq.7 ) then + iaux1 = 1 + iaux2 = 3 + iaux3 = 6 + else + iaux1 = 1 + iaux2 = 2 + iaux3 = 5 + endif +c + listns(18) = listno(iaux1) + listns(19) = listno(iaux2) + listns(20) = listno(iaux3) +c +c==== +c 6. L'arete concernee : celle des aretes internes qui demarrent +c sur le sommet en cours +c==== +c + do 62 , iaux = 1 , nbarhi + larete = areint(iaux) + if ( somare(1,larete).eq.listns(1) ) then + sm = np2are(larete) + goto 620 + endif + 62 continue + write(ulsort,*) nompro//' - aucune arete interne ne correspond ?' + codret = 62 +c + 620 continue +c +c==== +c 7. Interpolation +c==== +c + if ( codret.eq.0 ) then +c + profho(sm) = 1 +c + do 71, nuv = 1 , nbfop2 +cgn do 711 , jaux =1 ,20 +cgn write(*,90014) listns(jaux), vap2ho(nuv,listns(jaux)) +cgn 711 continue +c + vap2ho(nuv,sm) = - v7s128 * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) + > + vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) ) + > - qzs128 * ( vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) + > + vap2ho(nuv,listns(7)) ) + > - ses128 * vap2ho(nuv,listns(8)) + > + v7st64 * ( vap2ho(nuv,listns(9)) + > + vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) ) + > + nfst64 * ( vap2ho(nuv,listns(12)) + > + vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) + > + vap2ho(nuv,listns(16)) + > + vap2ho(nuv,listns(17)) ) + > + trst64 * ( vap2ho(nuv,listns(18)) + > + vap2ho(nuv,listns(19)) + > + vap2ho(nuv,listns(20)) ) +c +cgn write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 71 continue +c + endif +c + 10 continue +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2h4.F b/src/tool/AP_Conversion/pcs2h4.F new file mode 100644 index 00000000..b17886d9 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2h4.F @@ -0,0 +1,306 @@ + subroutine pcs2h4 ( nbfop2, profho, vap2ho, + > somare, np2are, + > listso, listar, + > areint, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage Hexaedres - 4 +c - - - +c D'un milieu d'arete a un sommet (selon 1 arete) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . areint . e . * . numeros globaux des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCS2H4' ) +c +#include "nblang.h" +c +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer listso(8), listar(12) + integer areint(*) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer larete + integer listns(20) + integer sm(2), nuv + integer iaux1(2), iaux2(2), iaux3(2), iaux4(2) + integer jaux1(2), jaux2(2), jaux3(2), jaux4(2) + integer kaux1(2), kaux2(2), kaux3(2), kaux4(2) + integer laux1(2), laux2(2), laux3(2), laux4(2) + integer maux1, maux2, maux3, maux4 + integer perm12(2) +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data perm12 / 2, 1 / +c +#include "impr03.h" +c ______________________________________________________________________ +c +#include "impr01.h" +c +cgn write (ulsort,texte(langue,1)) 'Entree', nompro +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso +#endif +c +c Deux aretes partent du milieu de l'arete coupee vers un des deux +c sommets de l'arete opposee. On a donc deux interpolations a faire. +c Ce sont les indices 1 et 2 des tableaux iauxi. +c +cgn write (ulsort,*) 'la', nuarlo,'-eme arete est coupee' +c +c==== +c 1. Les sommets de la face qui contient le sommet +c iaux1 : le sommet de l'arete coupee +c iaux2/3 : les deux autres sommets +c iaux4 : le sommet oppose +c==== +c +c f1 : F3 + iaux1(1) = 1 + iaux2(1) = 4 + iaux3(1) = 6 + iaux4(1) = 7 +c f2 : F4 + iaux1(2) = 2 + iaux2(2) = 3 + iaux3(2) = 5 + iaux4(2) = 8 +c +c==== +c 2. Les noeuds de la face du cote du sommet oppose +c kaux1/2 : les milieux des aretes vers l'arete coupee +c kaux3/4 : les milieux des aretes vers le sommet oppose +c==== +c +c f1 : F3 + kaux1(1) = 2 + kaux2(1) = 5 + kaux3(1) = 7 + kaux4(1) = 10 +c f2 : F4 + kaux1(2) = 3 + kaux2(2) = 6 + kaux3(2) = 8 + kaux4(2) = 11 +c +c==== +c 3. Les noeuds et sommets de la face opposee : +c . jauxi a le meme role que iauxi +c . lauxi a le meme role que kauxi +c==== +c + do 31 , iaux = 1 , 2 +c + jaux1(iaux) = iaux1(perm12(iaux)) + jaux2(iaux) = iaux2(perm12(iaux)) + jaux3(iaux) = iaux3(perm12(iaux)) + jaux4(iaux) = iaux4(perm12(iaux)) +c + laux1(iaux) = kaux1(perm12(iaux)) + laux2(iaux) = kaux2(perm12(iaux)) + laux3(iaux) = kaux3(perm12(iaux)) + laux4(iaux) = kaux4(perm12(iaux)) +c + 31 continue +c +c==== +c 4. Les noeuds milieux intermediaires +c maux1 : le milieu de l'arete coupee +c maux2/3 : les milieux des aretes paralleles a l'arete coupee +c maux4 : le milieu de l'arete oppose +c==== +c + maux1 = 1 + maux2 = 4 + maux3 = 9 + maux4 = 12 +c +c==== +c 5. L'arete concernee : celle des deux aretes internes qui demarrent +c sur le sommet oppose +c==== +c + larete = areint(1) + if ( somare(1,larete).eq.listso(iaux4(1)) ) then + sm(1) = np2are(larete) + sm(2) = np2are(areint(2)) + else + sm(1) = np2are(areint(2)) + sm(2) = np2are(larete) + endif +c +c==== +c 7. Interpolation +c==== +c + if ( codret.eq.0 ) then +c + do 70 , iaux = 1 , 2 +c + profho(sm(iaux)) = 1 +cgn write (ulsort,*) 'sm =',sm(iaux) +c + listns( 1) = listso(iaux1(iaux)) + listns( 2) = listso(iaux2(iaux)) + listns( 3) = listso(iaux3(iaux)) + listns( 4) = listso(iaux4(iaux)) + listns( 5) = listso(jaux1(iaux)) + listns( 6) = listso(jaux2(iaux)) + listns( 7) = listso(jaux3(iaux)) + listns( 8) = listso(jaux4(iaux)) + listns( 9) = np2are(listar(kaux1(iaux))) + listns(10) = np2are(listar(kaux2(iaux))) + listns(11) = np2are(listar(kaux3(iaux))) + listns(12) = np2are(listar(kaux4(iaux))) + listns(13) = np2are(listar(laux1(iaux))) + listns(14) = np2are(listar(laux2(iaux))) + listns(15) = np2are(listar(laux3(iaux))) + listns(16) = np2are(listar(laux4(iaux))) + listns(17) = np2are(listar(maux1)) + listns(18) = np2are(listar(maux2)) + listns(19) = np2are(listar(maux3)) + listns(20) = np2are(listar(maux4)) +cgn write (ulsort,90002) 'listns 1- 8',(listns(jaux),jaux=1,8) +cgn write (ulsort,90002) 'listns 9-16',(listns(jaux),jaux=9,16) +cgn write (ulsort,90002) 'listns 17-20',(listns(jaux),jaux=17,20) +cgn write (ulsort,*) listar(kaux1(iaux)), +cgn > listar(kaux2(iaux)), +cgn > listar(kaux3(iaux)), +cgn > listar(kaux4(iaux)) +cgn write (ulsort,*) listar(laux1(iaux)), +cgn > listar(laux2(iaux)), +cgn > listar(laux3(iaux)), +cgn > listar(laux4(iaux)) +c + do 71, nuv = 1 , nbfop2 + +c +cgn do 711 , jaux =1 ,20 +cgn write (ulsort,90014) listns(jaux), vap2ho(nuv,listns(jaux)) +cgn 711 continue + vap2ho(nuv,sm(iaux)) = + > - nfstr2 * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) + > + vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) ) + > - cqstr2 * ( vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) + > + vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) ) + > + trshu * ( vap2ho(nuv,listns(9)) + > + vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) ) + > + unshu * ( vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) + > + vap2ho(nuv,listns(16)) ) + > + trssz * ( vap2ho(nuv,listns(17)) + > + vap2ho(nuv,listns(18)) + > + vap2ho(nuv,listns(19)) + > + vap2ho(nuv,listns(20)) ) +c +cgn write (ulsort,*) 'vap2ho(nuv,',sm(iaux),') =',vap2ho(nuv,sm(iaux)) + 71 continue +c + 70 continue +c + endif +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2h5.F b/src/tool/AP_Conversion/pcs2h5.F new file mode 100644 index 00000000..77e72798 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2h5.F @@ -0,0 +1,641 @@ + subroutine pcs2h5 ( nbfop2, profho, vap2ho, + > somare, np2are, + > hetqua, + > quahex, + > lehexa, listso, listno, + > areint, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage Hexaedres - 5 +c - - - +c D'un milieu de face a un sommet (par face) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . lehexa . e . 1 . hexaedre a traiter . +c . listso . e . 8 . liste des sommets de l'hexaedre . +c . listno . e . 12 . liste des noeuds de l'hexaedre . +c . areint . e . * . numeros globaux des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c + character*6 nompro + parameter ( nompro = 'PCS2H5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer hetqua(nbquto) + integer quahex(nbhecf,6) + integer lehexa + integer listso(8), listno(12) + integer areint(4) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nuface, etahex + integer nusomm, laface, larete + integer listns(20) + integer sm, nuv + integer iaux1, iaux2, iaux3, iaux4 +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +#include "impr03.h" +c ______________________________________________________________________ +c +#include "impr01.h" +c +cgn write (ulsort,texte(langue,1)) 'Entree', nompro +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listno 1-8', (listno(iaux),iaux=1,8) + write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12) +#endif +c +c==== +c 0. Reperage de la face coupees +c==== +c + do 11 , nuface = 1 , 6 +c + laface = quahex(lehexa,nuface) + if ( mod(hetqua(laface),100).eq.4 ) then + etahex = 40 + nuface + endif +c + 11 continue +c + if ( etahex.lt.41 .or. etahex.gt.46 ) then + write(ulsort,*) 'Pb. Dans pcs2h5, etahex =',etahex + codret = 11 + endif +c +c On passe en revue tous les sommets +c Ils sont parcourus dans l'ordre des aretes a1, a2, a3 et a4 de +c la pyramide de base. +c + do 10 , nusomm = 1 , 4 +cgn write(6,*) 'Dans pcs2h5, nusomm =',nusomm +c +c==== +c 1. Les 2 sommets les plus proches et les 2 les plus eloignes +c Remarques : +c . L'un des sommets les plus proches est celui ou aboutit l'arete +c du noeud milieu a interpoler (iaux1) +c . L'autre sommet le plus proche est la 2nde extremite de l'arete +c de l'hexaedre qui relie ce sommet a la face coupee (iaux2) +c . Les sommets eloignes sont deduits par la regle : +c somme des numeros locaux de deux sommets opposes = 9 +c==== +c + if ( etahex.eq.41 ) then + if ( nusomm.eq.1 ) then + iaux1 = 6 + iaux2 = 1 + elseif ( nusomm.eq.2 ) then + iaux1 = 5 + iaux2 = 2 + elseif ( nusomm.eq.3 ) then + iaux1 = 8 + iaux2 = 3 + else + iaux1 = 7 + iaux2 = 4 + endif + elseif ( etahex.eq.42 ) then + if ( nusomm.eq.1 ) then + iaux1 = 3 + iaux2 = 2 + elseif ( nusomm.eq.2 ) then + iaux1 = 4 + iaux2 = 1 + elseif ( nusomm.eq.3 ) then + iaux1 = 7 + iaux2 = 6 + else + iaux1 = 8 + iaux2 = 5 + endif + elseif ( etahex.eq.43 ) then + if ( nusomm.eq.1 ) then + iaux1 = 2 + iaux2 = 1 + elseif ( nusomm.eq.2 ) then + iaux1 = 3 + iaux2 = 4 + elseif ( nusomm.eq.3 ) then + iaux1 = 8 + iaux2 = 7 + else + iaux1 = 5 + iaux2 = 6 + endif + elseif ( etahex.eq.44 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + elseif ( nusomm.eq.2 ) then + iaux1 = 6 + iaux2 = 5 + elseif ( nusomm.eq.3 ) then + iaux1 = 7 + iaux2 = 8 + else + iaux1 = 4 + iaux2 = 3 + endif + elseif ( etahex.eq.45 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + elseif ( nusomm.eq.2 ) then + iaux1 = 2 + iaux2 = 3 + elseif ( nusomm.eq.3 ) then + iaux1 = 5 + iaux2 = 8 + else + iaux1 = 6 + iaux2 = 7 + endif + else + if ( nusomm.eq.1 ) then + iaux1 = 2 + iaux2 = 5 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 6 + elseif ( nusomm.eq.3 ) then + iaux1 = 4 + iaux2 = 7 + else + iaux1 = 3 + iaux2 = 8 + endif + endif +c + listns(1) = listso(iaux1) + listns(2) = listso(iaux2) + listns(7) = listso(9-iaux1) + listns(8) = listso(9-iaux2) +c +c==== +c 2. Les sommets intermediaires +c Il suffit d'en noter 2 sur la meme arete de l'hexaedre, les deux +c autres sont deduits par la regle : +c somme des numeros locaux de deux sommets opposes = 9 +c==== +c + if ( etahex.eq.41 ) then + if ( nusomm.eq.1 .or. nusomm.eq.3 ) then + iaux1 = 2 + iaux2 = 5 + else + iaux1 = 1 + iaux2 = 6 + endif + elseif ( etahex.eq.42 ) then + if ( nusomm.eq.1 .or. nusomm.eq.3 ) then + iaux1 = 1 + iaux2 = 4 + else + iaux1 = 2 + iaux2 = 3 + endif + elseif ( etahex.eq.43 .or. etahex.eq.44 ) then + if ( nusomm.eq.1 .or. nusomm.eq.3 ) then + iaux1 = 3 + iaux2 = 4 + else + iaux1 = 1 + iaux2 = 2 + endif + elseif ( etahex.eq.45 ) then + if ( nusomm.eq.1 .or. nusomm.eq.3 ) then + iaux1 = 2 + iaux2 = 3 + else + iaux1 = 1 + iaux2 = 4 + endif + else + if ( nusomm.eq.1 .or. nusomm.eq.3 ) then + iaux1 = 1 + iaux2 = 6 + else + iaux1 = 2 + iaux2 = 5 + endif + endif +c + listns(3) = listso(iaux1) + listns(4) = listso(iaux2) + listns(5) = listso(9-iaux1) + listns(6) = listso(9-iaux2) +c +c==== +c 3. Le noeud le plus proche, le plus eloigne et les 2 coplanaires +c dans un plan parallelle a la face coupee +c Remarques : +c . Le noeud le plus proche est celui au milieu de l'arete +c de l'hexaedre qui relie ce sommet a la face coupee (iaux1) +c . Le noeud eloigne est deduit par la regle : +c somme des numeros locaux de deux noeuds opposes = 13 +c . Le dernier noeud est deduit par la regle : +c somme des numeros locaux de deux noeuds opposes = 13 +c==== +c + if ( etahex.eq.41 ) then + if ( nusomm.eq.1 ) then + iaux1 = 5 + iaux2 = 6 + elseif ( nusomm.eq.2 ) then + iaux1 = 6 + iaux2 = 5 + elseif ( nusomm.eq.3 ) then + iaux1 = 8 + iaux2 = 6 + else + iaux1 = 7 + iaux2 = 5 + endif + elseif ( etahex.eq.42 ) then + if ( nusomm.eq.1 ) then + iaux1 = 3 + iaux2 = 2 + elseif ( nusomm.eq.2 ) then + iaux1 = 2 + iaux2 = 3 + elseif ( nusomm.eq.3 ) then + iaux1 = 10 + iaux2 = 2 + else + iaux1 = 11 + iaux2 = 3 + endif + elseif ( etahex.eq.43 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + elseif ( nusomm.eq.2 ) then + iaux1 = 4 + iaux2 = 1 + elseif ( nusomm.eq.3 ) then + iaux1 = 12 + iaux2 = 4 + else + iaux1 = 9 + iaux2 = 1 + endif + elseif ( etahex.eq.44 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + elseif ( nusomm.eq.2 ) then + iaux1 = 9 + iaux2 = 1 + elseif ( nusomm.eq.3 ) then + iaux1 = 12 + iaux2 = 4 + else + iaux1 = 4 + iaux2 = 1 + endif + elseif ( etahex.eq.45 ) then + if ( nusomm.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + elseif ( nusomm.eq.2 ) then + iaux1 = 3 + iaux2 = 2 + elseif ( nusomm.eq.3 ) then + iaux1 = 11 + iaux2 = 3 + else + iaux1 = 10 + iaux2 = 2 + endif + else + if ( nusomm.eq.1 ) then + iaux1 = 6 + iaux2 = 5 + elseif ( nusomm.eq.2 ) then + iaux1 = 5 + iaux2 = 6 + elseif ( nusomm.eq.3 ) then + iaux1 = 7 + iaux2 = 5 + else + iaux1 = 8 + iaux2 = 6 + endif + endif +c + listns( 9) = listno(iaux1) + listns(20) = listno(13-iaux1) + listns(18) = listno(iaux2) + listns(19) = listno(13-iaux2) +c +c==== +c 4. Les 4 noeuds intermediaires les plus proches +c et les 4 noeuds intermediaires les plus eloignes +c==== +c + if ( etahex.eq.41 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 9 + iaux4 = 10 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 3 + iaux3 = 9 + iaux4 = 11 + elseif ( nusomm.eq.3 ) then + iaux1 = 3 + iaux2 = 4 + iaux3 = 11 + iaux4 = 12 + else + iaux1 = 2 + iaux2 = 4 + iaux3 = 10 + iaux4 = 12 + endif + elseif ( etahex.eq.42 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 6 + iaux4 = 8 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 5 + iaux4 = 7 + elseif ( nusomm.eq.3 ) then + iaux1 = 5 + iaux2 = 7 + iaux3 = 9 + iaux4 = 12 + else + iaux1 = 6 + iaux2 = 8 + iaux3 = 9 + iaux4 = 12 + endif + elseif ( etahex.eq.43 ) then + if ( nusomm.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 6 + elseif ( nusomm.eq.2 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 7 + iaux4 = 8 + elseif ( nusomm.eq.3 ) then + iaux1 = 7 + iaux2 = 8 + iaux3 = 10 + iaux4 = 11 + else + iaux1 = 5 + iaux2 = 6 + iaux3 = 10 + iaux4 = 11 + endif + elseif ( etahex.eq.44 ) then + if ( nusomm.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 6 + elseif ( nusomm.eq.2 ) then + iaux1 = 5 + iaux2 = 6 + iaux3 = 10 + iaux4 = 11 + elseif ( nusomm.eq.3 ) then + iaux1 = 7 + iaux2 = 8 + iaux3 = 10 + iaux4 = 11 + else + iaux1 = 2 + iaux2 = 3 + iaux3 = 7 + iaux4 = 8 + endif + elseif ( etahex.eq.45 ) then + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + iaux3 = 5 + iaux4 = 7 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 6 + iaux3 = 4 + iaux4 = 8 + elseif ( nusomm.eq.3 ) then + iaux1 = 6 + iaux2 = 8 + iaux3 = 9 + iaux4 = 12 + else + iaux1 = 5 + iaux2 = 7 + iaux3 = 9 + iaux4 = 12 + endif + else + if ( nusomm.eq.1 ) then + iaux1 = 1 + iaux2 = 3 + iaux3 = 9 + iaux4 = 11 + elseif ( nusomm.eq.2 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 9 + iaux4 = 10 + elseif ( nusomm.eq.3 ) then + iaux1 = 2 + iaux2 = 4 + iaux3 = 10 + iaux4 = 12 + else + iaux1 = 3 + iaux2 = 4 + iaux3 = 11 + iaux4 = 12 + endif + endif +c + listns(10) = listno(iaux1) + listns(11) = listno(iaux2) + listns(12) = listno(iaux3) + listns(13) = listno(iaux4) +c + listns(14) = listno(13-iaux1) + listns(15) = listno(13-iaux2) + listns(16) = listno(13-iaux3) + listns(17) = listno(13-iaux4) +c +c==== +c 5. L'arete concernee : celle des aretes internes qui demarrent +c ou finissent sur le sommet en cours +c==== +c +cgn write (ulsort,90002) 'listns(1)', listns(1) + do 62 , iaux = 1 , 4 + larete = areint(iaux) + if ( ( somare(1,larete).eq.listns(1) ) .or. + > ( somare(2,larete).eq.listns(1) ) ) then + sm = np2are(larete) + goto 620 + endif + 62 continue + write(ulsort,*) nompro//' - aucune arete interne ne correspond ?' + codret = 62 +c + 620 continue +c +c==== +c 7. Interpolation +c==== +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'sm', sm + profho(sm) = 1 +c +cgn write (ulsort,90002) 'listns 1- 8',(listns(jaux),jaux=1,8) +cgn write (ulsort,90002) 'listns 9-16',(listns(jaux),jaux=9,16) +cgn write (ulsort,90002) 'listns 17-20',(listns(jaux),jaux=17,20) +c + do 71, nuv = 1 , nbfop2 +cgn do 711 , jaux =1 ,20 +cgn write (ulsort,90014) listns(jaux), vap2ho(nuv,listns(jaux)) +cgn 711 continue +c + vap2ho(nuv,sm) = - nfstr2 * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) ) + > - trssz * ( vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) + > + vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) ) + > - trstr2 * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) ) + > + nessz * vap2ho(nuv,listns(9)) + > + nfstr2 * ( vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) + > + vap2ho(nuv,listns(13)) ) + > + trstr2 * ( vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) + > + vap2ho(nuv,listns(16)) + > + vap2ho(nuv,listns(17)) ) + > + trssz * ( vap2ho(nuv,listns(18)) + > + vap2ho(nuv,listns(19)) ) + > + unssz * vap2ho(nuv,listns(20)) +c +cgn write (ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 71 continue +c + endif +c + 10 continue +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2he.F b/src/tool/AP_Conversion/pcs2he.F new file mode 100644 index 00000000..57dc2de6 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2he.F @@ -0,0 +1,340 @@ + subroutine pcs2he ( nbfop2, profho, vap2ho, + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > hetqua, arequa, filqua, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des HExaedres +c - -- +c remarque : on devrait optimiser cela car si l'hexaedre etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2he et pcsihe sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p1 numerotation homard . +c . . . nbnoto . . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCS2HE' ) +c +#include "nblang.h" +c +#include "fractc.h" +#include "fract0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +c +#include "hexcf0.h" +#include "hexcf3.h" +#include "ope002.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer hethex(nbheto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer filhex(nbheto) + integer fhpyte(2,nbheco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lehexa + integer bindec, typdec, etanp1 + integer sm, nuv + integer nbarcp, tbarcp(12), areint(20) +c + integer listar(12), listso(8), listno(12) +c + logical afaire +c + double precision daux +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr01.h" +#include "impr03.h" +c + do 10 , lehexa = 1, nbheto +c +c==== +c 1. recherche des caracteristiques des interpolations a faire +c==== +c + iaux = lehexa +#ifdef _DEBUG_HOMARD_ + if ( lehexa.eq.-158) then + write (ulsort,90002) 'hexaedre', lehexa + endif +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS0HE', nompro +#endif + call pcs0he ( iaux, profho, + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > afaire, listar, listso, listno, + > bindec, typdec, etanp1, + > nbarcp, tbarcp, areint, sm ) +#ifdef _DEBUG_HOMARD_ + if ( lehexa.eq.-158) then + write (ulsort,99001) 'afaire', afaire + write (ulsort,90002) 'typdec', typdec + write (ulsort,90002) 'listar 1- 6', (listar(iaux),iaux=1,6) + write (ulsort,90002) 'listar 7-12', (listar(iaux),iaux=7,12) + endif +#endif +c + if ( afaire ) then +c +#include "hexcf4.h" +c +c==== +c 2. L'eventuel noeud central +c==== +c + if ( ( mod(typdec,2).eq.0 ) .or. + > ( mod(typdec,17).eq.0 ) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'noeud central', sm +#endif +c + profho(sm) = 1 +c +c formule p2 : +c interpolation = -1/4(u1+...+u8) +1/4(u9+...+u12) +c + do 22 , nuv = 1, nbfop2 +c + daux = 0.d0 + do 221 , iaux = 1 , 8 + daux = daux - vap2ho(nuv,listso(iaux)) + 221 continue + do 222 , iaux = 1 , 12 + daux = daux + vap2ho(nuv,np2are(listar(iaux))) + 222 continue + vap2ho(nuv,sm) = unsqu * daux +cgn write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) +c + 22 continue +c + endif +c +c==== +c 3. Du noeud central au milieu des faces +c==== +c + if ( mod(typdec,3).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2H1', nompro +#endif + call pcs2h1 ( nbfop2, profho, vap2ho, + > somare, np2are, + > hetqua, arequa, filqua, + > quahex, + > lehexa, listso, listno, + > chnar(bindec), areint, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Du noeud central aux milieux d'aretes +c==== +c + if ( mod(typdec,5).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2H2', nompro +#endif + call pcs2h2 ( nbfop2, profho, vap2ho, + > somare, np2are, + > listso, listno, + > tbarcp, chnar(bindec), areint, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Du noeud central aux sommets +c==== +c + if ( mod(typdec,7).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2H3', nompro +#endif + call pcs2h3 ( nbfop2, profho, vap2ho, + > somare, np2are, + > listso, listno, + > chnar(bindec), areint, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. D'un milieu d'arete a un sommet (selon 1 arete) +c==== +c + if ( mod(typdec,11).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2H4', nompro + write (ulsort,90002) 'chperm(bindec)', chperm(bindec) +#endif + call pcs2h4 ( nbfop2, profho, vap2ho, + > somare, np2are, + > hepers(1,chperm(bindec)), + > hepera(1,chperm(bindec)), + > areint, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. D'un milieu de face a un sommet (par face) +c==== +c + if ( mod(typdec,13).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2H5', nompro +#endif + call pcs2h5 ( nbfop2, profho, vap2ho, + > somare, np2are, + > hetqua, + > quahex, + > lehexa, listso, listno, + > areint, + > ulsort, langue, codret ) + if (codret.ne.0) then + write (ulsort,90002) 'hexaedre', lehexa + write (ulsort,90002) 'typdec', typdec + write(ulsort,90002) 'listar 1- 6', (listar(iaux),iaux=1,6) + write(ulsort,90002) 'listar 7-12', (listar(iaux),iaux=7,12) + write (ulsort,90015)'profho(2037) =',profho(2037) + endif +c + endif +c + endif +c + 10 continue +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2p1.F b/src/tool/AP_Conversion/pcs2p1.F new file mode 100644 index 00000000..548b80ed --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p1.F @@ -0,0 +1,234 @@ + subroutine pcs2p1 ( nbfop2, profho, vap2ho, + > np2are, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 1 +c - - - +c Les milieux des aretes joignant les centres des quadrangles +c (decoupage en 8) +c remarque : pcs2p1 et pcsip1 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +#include "fractg.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer listns(15) + integer sm, nuv + integer iaux1, iaux2, iaux3, iaux4 +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c + do 10 , iaux = 1 , nbarco +c +c==== +c 2. Les sommets de l'arete du quadrangle +c==== +c + if ( iaux.eq.1 ) then + iaux1 = 1 + iaux2 = 4 + elseif ( iaux.eq.2 ) then + iaux1 = 2 + iaux2 = 5 + else + iaux1 = 3 + iaux2 = 6 + endif +c + listns(1) = listso(iaux1) + listns(2) = listso(iaux2) +c +c==== +c 3. Les sommets de la face opposee +c==== +c + if ( iaux.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 6 + elseif ( iaux.eq.2 ) then + iaux1 = 3 + iaux2 = 1 + iaux3 = 6 + iaux4 = 4 + else + iaux1 = 1 + iaux2 = 2 + iaux3 = 4 + iaux4 = 5 + endif +c + listns(3) = listso(iaux1) + listns(4) = listso(iaux2) + listns(5) = listso(iaux3) + listns(6) = listso(iaux4) +c +c==== +c 4. Les noeuds du plan du point +c==== +c + if ( iaux.eq.1 ) then + iaux1 = 1 + iaux2 = 2 + iaux3 = 4 + iaux4 = 5 + elseif ( iaux.eq.2 ) then + iaux1 = 2 + iaux2 = 3 + iaux3 = 5 + iaux4 = 6 + else + iaux1 = 3 + iaux2 = 1 + iaux3 = 6 + iaux4 = 4 + endif +c + listns( 7) = listno(iaux1) + listns( 8) = listno(iaux2) + listns( 9) = listno(iaux3) + listns(10) = listno(iaux4) +c +c==== +c 5. Les noeuds de l'arete en face +c==== +c + if ( iaux.eq.1 ) then + iaux1 = 8 + iaux2 = 9 + elseif ( iaux.eq.2 ) then + iaux1 = 9 + iaux2 = 7 + else + iaux1 = 7 + iaux2 = 8 + endif +c + listns(11) = listno(iaux1) + listns(12) = listno(iaux2) +c +c==== +c 6. Le noeud le plus proche +c==== +c + listns(13) = listno(6+iaux) +c +c==== +c 7. Les noeuds les plus eloignes +c==== +c + if ( iaux.eq.1 ) then + iaux1 = 3 + iaux2 = 6 + elseif ( iaux.eq.2 ) then + iaux1 = 1 + iaux2 = 4 + else + iaux1 = 2 + iaux2 = 5 + endif +c + listns(14) = listno(iaux1) + listns(15) = listno(iaux2) +c +c==== +c 8. Interpolation +c==== +c +cgn write(1,90002) 'arete', nuaret(iaux) + sm = np2are(nuaret(iaux)) +cgn write(1,90002) 'sm', sm + profho(sm) = 1 +c + do 81 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = - unsqu * ( vap2ho(nuv,listns(1)) + > + vap2ho(nuv,listns(2)) ) + > - trssz * ( vap2ho(nuv,listns(3)) + > + vap2ho(nuv,listns(4)) + > + vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) ) + > + unsqu * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) + > + vap2ho(nuv,listns(9)) + > + vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) ) + > + unsde * vap2ho(nuv,listns(13)) + > + unshu * ( vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) ) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 81 continue +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2p2.F b/src/tool/AP_Conversion/pcs2p2.F new file mode 100644 index 00000000..920a9e21 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p2.F @@ -0,0 +1,347 @@ + subroutine pcs2p2 ( nbfop2, profho, vap2ho, + > np2are, + > etapen, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 2 +c - - - +c Du centre aux milieux d'aretes +c remarque : pcs2p2 et pcsip2 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . etapen . e . 1 . etat du pentaedre a traiter . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fract0.h" +#include "fractf.h" +#include "fractg.h" +#include "fractl.h" +#include "fractm.h" +#include "fractn.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer etapen + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux +cgn integer jaux + integer nulono + integer iaux1(6) + integer listns(15) + integer sm, nuv +c +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'listso', (listso(iaux),iaux=1,6) +cgn write(1,90002) 'listno', (listno(iaux),iaux=1,9) +c +c==== +c Reperage des aretes entre noeud central et noeud d'une arete coupee +c . Quand une face triangulaire est coupee, etat 51/52, on doit +c regarder sucessivement les 3 aretes internes depuis les milieux +c des aretes de cette face. +c Les aretes transmises en argument sont dans l'ordre : +c . etat 51 : N1, N2, N3 +c . etat 52 : N4, N6, N5 +c . Quand 2 aretes sont coupees, etat 31-36, on doit regarder +c sucessivement les 2 aretes depuis chacun des milieux. +c Les aretes renvoyees par utaipe pointent d'abord sur le noeud +c de la face F1, puis celui de la face F2 +c +c Consequence pour la boucle 10 : +c Cas !! Etat ! iaux !! Etat ! iaux !! Etat ! iaux +c N1-M !! 51 ! 1 !! 31 ! 1 !! 34 ! 1 +c N2-M !! 51 ! 2 !! 32 ! 1 !! 35 ! 1 +c N3-M !! 51 ! 3 !! 33 ! 1 !! 36 ! 1 +c N4-M !! 52 ! 1 !! 33 ! 2 !! 35 ! 2 +c N5-M !! 52 ! 3 !! 31 ! 2 !! 36 ! 2 +c N6-M !! 52 ! 2 !! 32 ! 2 !! 34 ! 2 +c==== +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c + do 10 , iaux = 1 , nbarco +c +c==== +c 2. Reperage du noeud milieu a relier +c==== +c + if ( etapen.eq.31 ) then + if ( iaux.eq.1 ) then + nulono = 1 + else + nulono = 5 + endif + elseif ( etapen.eq.32 ) then + if ( iaux.eq.1 ) then + nulono = 2 + else + nulono = 6 + endif + elseif ( etapen.eq.33 ) then + if ( iaux.eq.1 ) then + nulono = 3 + else + nulono = 4 + endif + elseif ( etapen.eq.34 ) then + if ( iaux.eq.1 ) then + nulono = 1 + else + nulono = 6 + endif + elseif ( etapen.eq.35 ) then + if ( iaux.eq.1 ) then + nulono = 2 + else + nulono = 4 + endif + elseif ( etapen.eq.36 ) then + if ( iaux.eq.1 ) then + nulono = 3 + else + nulono = 2 + endif + elseif ( etapen.eq.51 ) then + nulono = iaux + else + if ( iaux.eq.1 ) then + nulono = 4 + elseif ( iaux.eq.2 ) then + nulono = 6 + else + nulono = 5 + endif + endif +c + listns(7) = listno(nulono) +cgn write(1,90002) 'noeud de l''arete coupee', listns(7) +c +c==== +c 3. Les sommets +c 1, 2 : les sommets de l'arete coupee +c 3 : le 3eme sommet de la face +c 4, 5, 6 : les sommets semblables sur la face opposee +c==== +c + if ( nulono.eq.1 ) then + iaux1(1) = 1 + iaux1(2) = 3 + iaux1(3) = 2 + iaux1(4) = 4 + iaux1(5) = 6 + iaux1(6) = 5 + elseif ( nulono.eq.2 ) then + iaux1(1) = 2 + iaux1(2) = 1 + iaux1(3) = 3 + iaux1(4) = 5 + iaux1(5) = 4 + iaux1(6) = 6 + elseif ( nulono.eq.3 ) then + iaux1(1) = 3 + iaux1(2) = 2 + iaux1(3) = 1 + iaux1(4) = 6 + iaux1(5) = 5 + iaux1(6) = 4 + elseif ( nulono.eq.4 ) then + iaux1(1) = 4 + iaux1(2) = 6 + iaux1(3) = 5 + iaux1(4) = 1 + iaux1(5) = 3 + iaux1(6) = 2 + elseif ( nulono.eq.5 ) then + iaux1(1) = 5 + iaux1(2) = 4 + iaux1(3) = 6 + iaux1(4) = 2 + iaux1(5) = 1 + iaux1(6) = 3 + else + iaux1(1) = 6 + iaux1(2) = 5 + iaux1(3) = 4 + iaux1(4) = 3 + iaux1(5) = 2 + iaux1(6) = 1 + endif +c + listns(1) = listso(iaux1(1)) + listns(2) = listso(iaux1(3)) + listns(3) = listso(iaux1(2)) + listns(4) = listso(iaux1(4)) + listns(5) = listso(iaux1(6)) + listns(6) = listso(iaux1(5)) +cgn write(1,90002) 'listns 1-6', (listns(jaux),jaux=1,6) +c +c==== +c 4. Les noeuds des faces triangulaires +c 8, 9 : les deux autres noeuds sur la face de l'arete coupee +c 10 : le noeud semblable sur la face opposee +c 11, 12 : les deux autres noeuds sur la face opposee +c==== +c + if ( nulono.eq.1 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 4 + iaux1(4) = 5 + iaux1(5) = 6 + elseif ( nulono.eq.2 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 5 + iaux1(4) = 6 + iaux1(5) = 4 + elseif ( nulono.eq.3 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 6 + iaux1(4) = 4 + iaux1(5) = 5 + elseif ( nulono.eq.4 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 1 + iaux1(4) = 2 + iaux1(5) = 3 + elseif ( nulono.eq.5 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 2 + iaux1(4) = 3 + iaux1(5) = 1 + else + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 3 + iaux1(4) = 1 + iaux1(5) = 2 + endif +c + listns( 8) = listno(iaux1(1)) + listns( 9) = listno(iaux1(2)) + listns(10) = listno(iaux1(3)) + listns(11) = listno(iaux1(4)) + listns(12) = listno(iaux1(5)) +cgn write(1,90002) 'listns 8-12', (listns(jaux),jaux=8,12) +c +c==== +c 5. Les noeuds des faces quadrangulaires +c 13, 14 : les noeuds du cote de l'arete coupee +c 15 : le dernier noeud +c==== +c + if ( nulono.eq.1 .or. nulono.eq.4 ) then + iaux1(1) = 7 + iaux1(2) = 9 + iaux1(3) = 8 + elseif ( nulono.eq.2 .or. nulono.eq.5 ) then + iaux1(1) = 8 + iaux1(2) = 7 + iaux1(3) = 9 + else + iaux1(1) = 9 + iaux1(2) = 8 + iaux1(3) = 7 + endif +c + listns(13) = listno(iaux1(1)) + listns(14) = listno(iaux1(2)) + listns(15) = listno(iaux1(3)) +cgn write(1,90002) 'listns 13-15', (listns(jaux),jaux=13,15) +c +c==== +c 6. Interpolation +c==== +c + sm = np2are(nuaret(iaux)) +cgn write(1,90002) 'sm',sm +c + profho(sm) = 1 +c + do 61 , nuv = 1, nbfop2 +c +cgn write(1,*) 'vap2ho=',(vap2ho(nuv,listns(jaux)),jaux=1,15) + vap2ho(nuv,sm) = cqs24 * ( vap2ho(nuv,listns(8)) + > + vap2ho(nuv,listns(9)) + > - vap2ho(nuv,listns(1)) + > - vap2ho(nuv,listns(2)) ) + > - sts48 * vap2ho(nuv,listns(3)) + > + vc144 * ( vap2ho(nuv,listns(10)) + > - vap2ho(nuv,listns(4)) + > - vap2ho(nuv,listns(5)) ) + > - tz144 * vap2ho(nuv,listns(6)) + > + vcs48 * vap2ho(nuv,listns(7)) + > + cqs72 * ( vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) ) + > + cqssz * ( vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) ) + > + unshu * vap2ho(nuv,listns(15)) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 61 continue +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2p3.F b/src/tool/AP_Conversion/pcs2p3.F new file mode 100644 index 00000000..4a34b18c --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p3.F @@ -0,0 +1,355 @@ + subroutine pcs2p3 ( nbfop2, profho, vap2ho, + > np2are, + > etapen, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 3 +c - - - +c Du centre aux sommets +c remarque : pcs2p3 et pcsip3 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . etapen . e . 1 . etat du pentaedre a traiter . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fract0.h" +#include "fracta.h" +#include "fractb.h" +#include "fractf.h" +#include "fractk.h" +#include "fractm.h" +#include "fractn.h" +#include "fracto.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer etapen + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux +cgn integer jaux + integer nuloso + integer iaux1(6) + integer listns(15) + integer sm, nuv +c +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'listso', (listso(iaux),iaux=1,6) +cgn write(1,90002) 'listno', (listno(iaux),iaux=1,9) +c +c==== +c Reperage des aretes entre noeud central et sommets +c . Quand une face triangulaire est coupee, etat 51/52, on doit +c regarder sucessivement les 3 aretes internes depuis les sommets +c de la face non decoupee. +c Les aretes transmises en argument sont dans l'ordre : +c . etat 51 : S4, S6, S5 +c . etat 52 : S1, S2, S3 +c . Quand 2 aretes sont coupees, etat 31-36, on doit regarder +c sucessivement les 6 aretes depuis chacun des sommets. +c Les aretes renvoyees par utaipe pointent d'abord sur les +c sommets de la face quadrangulaire coupee, dans cet ordre : +c . Les deux premiers sommets sont ceux qui appartiennent +c a la face triangulaire F1 +c . Les 4 sommets tournent dans le sens positif, vus +c de l'exterieur +c Ensuite, on a les 2 autres sommets, en commencant par celui +c qui appartient a la face F1 +c +c Consequence pour la boucle 10 : +c Cas !! Etat ! iaux !! Etat ! iaux !! Etat ! iaux +c S1-M !! 52 ! 1 !! 33 ! 1 !! 36 ! 1 +c S2-M !! 52 ! 2 !! 31 ! 1 !! 34 ! 1 +c S3-M !! 52 ! 3 !! 32 ! 1 !! 35 ! 1 +c S4-M !! 51 ! 1 !! 32 ! 2 !! 34 ! 2 +c S5-M !! 51 ! 3 !! 33 ! 2 !! 35 ! 2 +c S6-M !! 51 ! 2 !! 31 ! 2 !! 36 ! 2 +c==== +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c + do 10 , iaux = 1 , nbarco +c +c==== +c 2. Reperage du sommet a relier +c==== +c + if ( etapen.eq.31 ) then + if ( iaux.eq.1 ) then + nuloso = 2 + else + nuloso = 6 + endif + elseif ( etapen.eq.32 ) then + if ( iaux.eq.1 ) then + nuloso = 3 + else + nuloso = 4 + endif + elseif ( etapen.eq.33 ) then + if ( iaux.eq.1 ) then + nuloso = 1 + else + nuloso = 5 + endif + elseif ( etapen.eq.34 ) then + if ( iaux.eq.1 ) then + nuloso = 2 + else + nuloso = 4 + endif + elseif ( etapen.eq.35 ) then + if ( iaux.eq.1 ) then + nuloso = 3 + else + nuloso = 5 + endif + elseif ( etapen.eq.36 ) then + if ( iaux.eq.1 ) then + nuloso = 1 + else + nuloso = 6 + endif + elseif ( etapen.eq.51 ) then + if ( iaux.eq.1 ) then + nuloso = 4 + elseif ( iaux.eq.2 ) then + nuloso = 6 + else + nuloso = 5 + endif + else + nuloso = iaux + endif +c + listns(1) = listso(nuloso) +cgn write(1,90002) 'sommet a relier', listns(1) +c +c==== +c 3. Les sommets +c 2, 3 : les 2 autres sommets de la face +c 4 : le sommet semblable sur la face opposee +c 5, 6 : les sommets semblables sur la face opposee +c==== +c + if ( nuloso.eq.1 ) then + iaux1(1) = 3 + iaux1(2) = 2 + iaux1(3) = 4 + iaux1(4) = 6 + iaux1(5) = 5 + elseif ( nuloso.eq.2 ) then + iaux1(1) = 1 + iaux1(2) = 3 + iaux1(3) = 5 + iaux1(4) = 4 + iaux1(5) = 6 + elseif ( nuloso.eq.3 ) then + iaux1(1) = 2 + iaux1(2) = 1 + iaux1(3) = 6 + iaux1(4) = 5 + iaux1(5) = 4 + elseif ( nuloso.eq.4 ) then + iaux1(1) = 6 + iaux1(2) = 5 + iaux1(3) = 1 + iaux1(4) = 3 + iaux1(5) = 2 + elseif ( nuloso.eq.5 ) then + iaux1(1) = 4 + iaux1(2) = 6 + iaux1(3) = 2 + iaux1(4) = 1 + iaux1(5) = 3 + else + iaux1(1) = 5 + iaux1(2) = 4 + iaux1(3) = 3 + iaux1(4) = 2 + iaux1(5) = 1 + endif +c + listns(2) = listso(iaux1(1)) + listns(3) = listso(iaux1(2)) + listns(4) = listso(iaux1(3)) + listns(5) = listso(iaux1(4)) + listns(6) = listso(iaux1(5)) +cgn write(1,90002) 'listns 2-6', (listns(jaux),jaux=2,6) +c +c==== +c 4. Les noeuds des faces triangulaires +c 7, 8 : les deux noeuds les plus proches, sur la face tria proche +c 9 : l'autre noeud sur cette face proche +c 10 : le noeud translate de cet autre noeud +c 11, 12 : les deux autres noeuds sur la face opposee +c==== +c + if ( nuloso.eq.1 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 6 + iaux1(5) = 4 + iaux1(6) = 5 + elseif ( nuloso.eq.2 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( nuloso.eq.3 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 5 + iaux1(5) = 6 + iaux1(6) = 4 + elseif ( nuloso.eq.4 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 3 + iaux1(5) = 1 + iaux1(6) = 2 + elseif ( nuloso.eq.5 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 1 + iaux1(5) = 3 + iaux1(6) = 2 + else + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 2 + iaux1(5) = 3 + iaux1(6) = 1 + endif +c + listns( 7) = listno(iaux1(1)) + listns( 8) = listno(iaux1(2)) + listns( 9) = listno(iaux1(3)) + listns(10) = listno(iaux1(4)) + listns(11) = listno(iaux1(5)) + listns(12) = listno(iaux1(6)) +cgn write(1,90002) 'listns 7-12', (listns(jaux),jaux=7,12) +c +c==== +c 5. Les noeuds des faces quadrangulaires +c 13 : le noeud le plus proche, sur la face quadrangulaire proche +c 14, 15 : le dernier noeud +c==== +c + if ( nuloso.eq.1 .or. nuloso.eq.4 ) then + iaux1(1) = 7 + iaux1(2) = 9 + iaux1(3) = 8 + elseif ( nuloso.eq.2 .or. nuloso.eq.5 ) then + iaux1(1) = 8 + iaux1(2) = 7 + iaux1(3) = 9 + else + iaux1(1) = 9 + iaux1(2) = 8 + iaux1(3) = 7 + endif +c + listns(13) = listno(iaux1(1)) + listns(14) = listno(iaux1(2)) + listns(15) = listno(iaux1(3)) +cgn write(1,90002) 'listns 13-15', (listns(jaux),jaux=13,15) +c +c==== +c 6. Interpolation +c==== +c + sm = np2are(nuaret(iaux)) +cgn write(1,90002) 'sm',sm +c + profho(sm) = 1 +c + do 61 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = unsdz * ( vap2ho(nuv,listns(9)) + > - vap2ho(nuv,listns(1)) ) + > - sts48 * ( vap2ho(nuv,listns(2)) + > + vap2ho(nuv,listns(3)) ) + > - sts36 * vap2ho(nuv,listns(4)) + > - tz144 * ( vap2ho(nuv,listns(5)) + > + vap2ho(nuv,listns(6)) ) + > + unstr * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) ) + > + uns36 * vap2ho(nuv,listns(10)) + > + unsne * ( vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) ) + > + unsde * vap2ho(nuv,listns(13)) + > + unshu * ( vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) ) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 61 continue +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2p4.F b/src/tool/AP_Conversion/pcs2p4.F new file mode 100644 index 00000000..fc572d2d --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p4.F @@ -0,0 +1,263 @@ + subroutine pcs2p4 ( nbfop2, profho, vap2ho, + > np2are, + > etapen, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 4 +c - - - +c D'un milieu d'arete a un autre +c remarque : pcs2p4 et pcsip4 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . etapen . e . 1 . etat du pentaedre a traiter . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer etapen + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c +cgn integer iaux + integer iaux1(6) + integer listns(15) + integer sm, nuv +c +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'listso', (listso(iaux),iaux=1,6) +cgn write(1,90002) 'listno', (listno(iaux),iaux=1,9) +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c +c==== +c 2. Les 2 sommets sur l'arete oppose et les 4 autres sommets +c==== +c + if ( etapen.eq.21 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.22 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.23 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.24 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( etapen.eq.25 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + else + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + endif +c + listns(1) = listso(iaux1(1)) + listns(2) = listso(iaux1(2)) + listns(3) = listso(iaux1(3)) + listns(4) = listso(iaux1(4)) + listns(5) = listso(iaux1(5)) + listns(6) = listso(iaux1(6)) +cgn write(1,90002) 'listns 1-6', (listns(iaux),iaux=1,6) +c +c==== +c 3. Les noeuds +c 7, 8 : les 2 noeuds sur la face triangulaire non coupee, du cote +c de l'arete de quadrangle coupee +c 9 : le dernier noeud sur la face triangulaire non coupee +c 10, 11, 12 : les noeuds semblables sur la face coupee +c==== +c + if ( etapen.eq.21 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 2 + iaux1(5) = 3 + iaux1(6) = 1 + elseif ( etapen.eq.22 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 3 + iaux1(5) = 1 + iaux1(6) = 2 + elseif ( etapen.eq.23 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.24 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 5 + iaux1(5) = 6 + iaux1(6) = 4 + elseif ( etapen.eq.25 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 6 + iaux1(5) = 4 + iaux1(6) = 5 + else + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 4 + iaux1(5) = 4 + iaux1(6) = 6 + endif +c + listns( 7) = listno(iaux1(1)) + listns( 8) = listno(iaux1(2)) + listns( 9) = listno(iaux1(3)) + listns(10) = listno(iaux1(4)) + listns(11) = listno(iaux1(5)) + listns(12) = listno(iaux1(6)) +cgn write(1,90002) 'listns 7-12', (listns(iaux),iaux=7,12) +c +c==== +c 4. Les noeuds +c 13 : le noeud milieu de l'arete quadrangulaire coupee +c 14, 15 : les deux autres noeuds 'quadrangle' +c==== +c + if ( etapen.eq.21 .or. etapen.eq.24 ) then + iaux1(1) = 8 + iaux1(2) = 9 + iaux1(3) = 7 + elseif ( etapen.eq.22 .or. etapen.eq.25 ) then + iaux1(1) = 9 + iaux1(2) = 7 + iaux1(3) = 8 + else + iaux1(1) = 7 + iaux1(2) = 8 + iaux1(3) = 9 + endif +c + listns(13) = listno(iaux1(1)) + listns(14) = listno(iaux1(2)) + listns(15) = listno(iaux1(3)) +cgn write(1,90002) 'listns 13-15', (listns(iaux),iaux=13,15) +c +c==== +c 5. Interpolation +c==== +c + sm = np2are(nuaret(1)) +cgn write(1,90002) 'sm',sm +c + profho(sm) = 1 +c + do 51 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = unshu * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(8)) + > - vap2ho(nuv,listns(1)) + > - vap2ho(nuv,listns(2)) ) + > + trssz * ( vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) + > - vap2ho(nuv,listns(3)) + > - vap2ho(nuv,listns(4)) + > - vap2ho(nuv,listns(5)) + > - vap2ho(nuv,listns(6)) ) + > + unssz * vap2ho(nuv,listns(9)) + > + trshu * ( vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) ) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 51 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2p5.F b/src/tool/AP_Conversion/pcs2p5.F new file mode 100644 index 00000000..e466460a --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p5.F @@ -0,0 +1,260 @@ + subroutine pcs2p5 ( nbfop2, profho, vap2ho, + > np2are, + > etapen, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 5 +c - - - +c D'un milieu d'arete a un sommet +c remarque : pcs2p5 et pcsip5 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . etapen . e . 1 . etat du pentaedre a traiter . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer etapen + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c +cgn integer iaux + integer iaux1(6) + integer listns(15) + integer sm, nuv +c +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'listso', (listso(iaux),iaux=1,6) +cgn write(1,90002) 'listno', (listno(iaux),iaux=1,9) +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c +c==== +c 2. Les 2 sommets de l'arete coupee +c 2. Les 4 autres sommets +c==== +c + if ( etapen.eq.1 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( etapen.eq.2 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( etapen.eq.3 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( etapen.eq.4 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.5 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + else + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + endif +c + listns(1) = listso(iaux1(1)) + listns(2) = listso(iaux1(2)) + listns(3) = listso(iaux1(3)) + listns(4) = listso(iaux1(4)) + listns(5) = listso(iaux1(5)) + listns(6) = listso(iaux1(6)) +cgn write(1,90002) 'listns 1-6', (listns(iaux),iaux=1,6) +c +c==== +c 3. Les noeuds +c 7 : le noeud milieu de l'arete coupee +c 8, 9 : les 2 autres noeuds sur la face triangulaire coupee +c 10 : le noeud translate sur l'autre face triangulaire +c 11, 12 : les 2 autres noeuds sur l'autre face triangulaire +c==== +c + iaux1(1) = etapen + if ( etapen.eq.1 ) then + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( etapen.eq.2 ) then + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 5 + iaux1(5) = 6 + iaux1(6) = 4 + elseif ( etapen.eq.3 ) then + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 6 + iaux1(5) = 4 + iaux1(6) = 5 + elseif ( etapen.eq.4 ) then + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( etapen.eq.5 ) then + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 2 + iaux1(5) = 3 + iaux1(6) = 1 + else + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 3 + iaux1(5) = 2 + iaux1(6) = 1 + endif +c + listns( 7) = listno(iaux1(1)) + listns( 8) = listno(iaux1(2)) + listns( 9) = listno(iaux1(3)) + listns(10) = listso(iaux1(4)) + listns(11) = listso(iaux1(5)) + listns(12) = listso(iaux1(6)) +cgn write(1,90002) 'listns 7-12', (listns(iaux),iaux=7,12) +c +c==== +c 4. Les noeuds +c 13 : le noeud milieu de l'arete quadrangulaire opposee +c 14, 15 : les 2 autres noeuds sur la face quadrangulaire coupee +c==== +c + if ( etapen.eq.1 .or. etapen.eq.4 ) then + iaux1(1) = 8 + iaux1(2) = 9 + iaux1(3) = 7 + elseif ( etapen.eq.2 .or. etapen.eq.5 ) then + iaux1(1) = 9 + iaux1(2) = 8 + iaux1(3) = 7 + else + iaux1(1) = 7 + iaux1(2) = 8 + iaux1(3) = 9 + endif +c + listns(13) = listno(iaux1(1)) + listns(14) = listno(iaux1(2)) + listns(15) = listno(iaux1(3)) +cgn write(1,90002) 'listns 13-15', (listns(iaux),iaux=13,15) +c +c==== +c 5. Interpolation +c==== +c + sm = np2are(nuaret(1)) +cgn write(1,90002) 'sm',sm +c + profho(sm) = 1 +c + do 51 , nuv = 1, nbfop2 +c +cgn write(1,*) 'vap2ho=',(vap2ho(nuv,listns(iaux)),iaux=1,15) + vap2ho(nuv,sm) = unshu * ( vap2ho(nuv,listns(8)) + > + vap2ho(nuv,listns(9)) + > - vap2ho(nuv,listns(1)) + > - vap2ho(nuv,listns(2)) ) + > + trssz * ( vap2ho(nuv,listns(10)) + > + vap2ho(nuv,listns(14)) + > + vap2ho(nuv,listns(15)) + > - vap2ho(nuv,listns(3)) + > - vap2ho(nuv,listns(4)) + > - vap2ho(nuv,listns(5)) + > - vap2ho(nuv,listns(6)) ) + > + unssz * vap2ho(nuv,listns(7)) + > + trshu * ( vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) + > + vap2ho(nuv,listns(13)) ) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 51 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2p6.F b/src/tool/AP_Conversion/pcs2p6.F new file mode 100644 index 00000000..59562523 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2p6.F @@ -0,0 +1,279 @@ + subroutine pcs2p6 ( nbfop2, profho, vap2ho, + > np2are, + > etapen, + > listso, listno, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des Pentaedres - 6 +c - - - +c D'un milieu de face a un sommet +c remarque : pcs2p6 et pcsip6 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . etapen . e . 1 . etat du pentaedre a traiter . +c . listso . e . 6 . Liste des sommets ordonnes du pentaedre . +c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractf.h" +#include "fractg.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer np2are(nbarto) + integer etapen + integer listso(6), listno(9) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer iaux1(6) + integer listns(15) + integer sm, nuv +c +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'listso', (listso(jaux),jaux=1,6) +cgn write(1,90002) 'listno', (listno(jaux),jaux=1,9) +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c + do 10 , iaux = 1 , nbarco +c +c==== +c 2. Reperage du sommet a relier +c==== +c + if ( etapen.eq.43 ) then + jaux = 2 + 3*(iaux-1) + elseif ( etapen.eq.44 ) then + jaux = 3 + 3*(iaux-1) + else + jaux = 1 + 3*(iaux-1) + endif +c + listns(1) = listso(jaux) +cgn write(1,90002) 'sommet a relier', listns(1) +c +c==== +c 3. Les sommets +c 2, 3 : les 2 autres sommets de la face triangulaire du cote du +c sommet a relier +c 4 : le sommet semblable sur la face opposee +c 5, 6 : les 2 derniers sommets +c==== +c + if ( jaux .eq.1 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 4 + iaux1(4) = 5 + iaux1(5) = 6 + elseif ( jaux .eq.2 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 5 + iaux1(4) = 4 + iaux1(5) = 6 + elseif ( jaux .eq.3 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 6 + iaux1(4) = 4 + iaux1(5) = 5 + elseif ( jaux .eq.4 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 1 + iaux1(4) = 2 + iaux1(5) = 3 + elseif ( jaux .eq.5 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 2 + iaux1(4) = 3 + iaux1(5) = 1 + elseif ( jaux .eq.6 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 3 + iaux1(4) = 1 + iaux1(5) = 2 + endif +c + listns(2) = listso(iaux1(1)) + listns(3) = listso(iaux1(2)) + listns(4) = listso(iaux1(3)) + listns(5) = listso(iaux1(4)) + listns(6) = listso(iaux1(5)) +cgn write(1,90002) 'listns 2-6', (listns(jaux),jaux=2,6) +c +c==== +c 4. Les noeuds des faces triangulaires +c 7 : le noeud milieu de l'arete coupee, du cote du sommet a relier +c 8, 9 : les deux autres noeuds, sur la face tria proche +c 10 : le noeud milieu sur l'autre face triangulaire opposee +c 11, 12 : les deux autres noeuds sur la face opposee +c==== +c + if ( jaux .eq.1 ) then + iaux1(1) = 3 + iaux1(2) = 1 + iaux1(3) = 2 + iaux1(4) = 6 + iaux1(5) = 4 + iaux1(6) = 5 + elseif ( jaux .eq.2 ) then + iaux1(1) = 1 + iaux1(2) = 2 + iaux1(3) = 3 + iaux1(4) = 4 + iaux1(5) = 5 + iaux1(6) = 6 + elseif ( jaux .eq.3 ) then + iaux1(1) = 2 + iaux1(2) = 3 + iaux1(3) = 1 + iaux1(4) = 5 + iaux1(5) = 6 + iaux1(6) = 4 + elseif ( jaux .eq.4 ) then + iaux1(1) = 6 + iaux1(2) = 4 + iaux1(3) = 5 + iaux1(4) = 3 + iaux1(5) = 1 + iaux1(6) = 2 + elseif ( jaux .eq.5 ) then + iaux1(1) = 4 + iaux1(2) = 5 + iaux1(3) = 6 + iaux1(4) = 1 + iaux1(5) = 2 + iaux1(6) = 3 + elseif ( jaux .eq.6 ) then + iaux1(1) = 5 + iaux1(2) = 6 + iaux1(3) = 4 + iaux1(4) = 2 + iaux1(5) = 3 + iaux1(6) = 1 + endif +c + listns( 7) = listno(iaux1(1)) + listns( 8) = listno(iaux1(2)) + listns( 9) = listno(iaux1(3)) + listns(10) = listno(iaux1(4)) + listns(11) = listno(iaux1(5)) + listns(12) = listno(iaux1(6)) +cgn write(1,90002) 'listns 7-12', (listns(jaux),jaux=7,12) +c +c==== +c 5. Les noeuds des faces quadrangulaires +c 13, 14 : les noeuds milieux, sur la face quadrangulaire coupee +c 15 : le noeud milieu de l'arete parallelle a la face coupee +c==== +c + if ( jaux .eq.1 .or. listns(1).eq.4 ) then + iaux1(1) = 8 + iaux1(2) = 9 + iaux1(3) = 7 + elseif ( jaux .eq.2 .or. listns(1).eq.5 ) then + iaux1(1) = 9 + iaux1(2) = 7 + iaux1(3) = 8 + elseif ( jaux .eq.3 .or. listns(1).eq.6 ) then + iaux1(1) = 7 + iaux1(2) = 8 + iaux1(3) = 9 + endif +c + listns(13) = listno(iaux1(1)) + listns(14) = listno(iaux1(2)) + listns(15) = listno(iaux1(3)) +cgn write(1,90002) 'listns 13-15', (listns(jaux),jaux=13,15) +c +c==== +c 6. Interpolation +c==== +c + sm = np2are(nuaret(iaux)) +cgn write(1,90002) 'sm',sm +c + profho(sm) = 1 +c + do 61 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = trssz * ( vap2ho(nuv,listns(7)) + > + vap2ho(nuv,listns(13)) + > + vap2ho(nuv,listns(14)) + > - vap2ho(nuv,listns(1)) + > - vap2ho(nuv,listns(2)) + > - vap2ho(nuv,listns(3)) + > - vap2ho(nuv,listns(4)) ) + > + unshu * ( vap2ho(nuv,listns(11)) + > + vap2ho(nuv,listns(12)) + > - vap2ho(nuv,listns(5)) + > - vap2ho(nuv,listns(6)) ) + > + trshu * ( vap2ho(nuv,listns(8)) + > + vap2ho(nuv,listns(9)) + > + vap2ho(nuv,listns(15)) ) + > + unssz * vap2ho(nuv,listns(10)) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 61 continue +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2pe.F b/src/tool/AP_Conversion/pcs2pe.F new file mode 100644 index 00000000..36e21af6 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2pe.F @@ -0,0 +1,417 @@ + subroutine pcs2pe ( nbfop2, profho, vap2ho, + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des PEntaedres +c - -- +c remarque : on devrait optimiser cela car si le pentaedre etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2pe et pcsipe sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p1 numerotation homard . +c . . . nbnoto . . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCS2PE' ) +c +#include "envex1.h" +#include "nblang.h" +#include "fractb.h" +#include "fractk.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lepent + integer typdec, typd00 + integer etanp1 + integer sm, nuv + integer listar(9), listno(15) + integer nbarco + integer nuaret(15) +c + logical afaire +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + do 100 , jaux = 1, nbpeto +c + lepent = jaux +c +c==== +c 2. recherche des types d'interpolations a faire +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS0PE', nompro +#endif + call pcs0pe ( lepent, profho, + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > afaire, listar, listno, typdec, etanp1, sm ) +cgn write(ulsort,90002) 'typdec',typdec +c + endif +c + if ( afaire ) then +c +c==== +c 3. L'eventuel noeud central +c decoupage selon 2 aretes tria/tria +c decoupage selon 1 face traingulaire +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,2).eq.0 ) then +c + profho(sm) = 1 +c +c formule p2 : +c interpolation = -2/9(u1+...+u6) +c + 2/9(u7+...+u12)+ 1/3(u13+...+u15) +c + do 31 , nuv = 1, nbfop2 +c + daux = 0.d0 + do 311 , iaux = 1 , 6 + daux = daux - vap2ho(nuv,listno(iaux)) + 311 continue + do 312 , iaux = 7 , 12 + daux = daux + vap2ho(nuv,listno(iaux)) + 312 continue + vap2ho(nuv,sm) = desne * daux + + > unstr * ( vap2ho(nuv,listno(13)) + + > vap2ho(nuv,listno(14)) + + > vap2ho(nuv,listno(15)) ) +cgn write(ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) +c + 31 continue +c + typdec = typdec/2 +c + endif +c + endif +c +c==== +c 4. Recuperation des aretes internes +c==== +c + 40 continue +cgn write(ulsort,90002) 'typdec',typdec +c + if ( codret.eq.0 ) then +c + iaux = 1 +c + if ( mod(typdec,3).eq.0 ) then + typd00 = 3 + elseif ( mod(typdec,5).eq.0 ) then + iaux = 3 + typd00 = 5 + elseif ( mod(typdec,7).eq.0 ) then + iaux = 2 + typd00 = 7 + elseif ( mod(typdec,11).eq.0 ) then + typd00 = 11 + elseif ( mod(typdec,13).eq.0 ) then + typd00 = 13 + elseif ( mod(typdec,17).eq.0 ) then + typd00 = 17 + endif +c +c 4.4. ==> Les aretes +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'UTAIPE', nompro +#endif + call utaipe ( lepent, iaux, + > hetpen, facpen, filpen, fppyte, + > aretri, + > tritet, cotrte, + > nbarco, nuaret, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. D'un milieu de faces a un autre +c (decoupage en 8) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,3).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P1', nompro +#endif + call pcs2p1 ( nbfop2, profho, vap2ho, + > np2are, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 6. Du centre aux milieux d'aretes +c (selon 2 aretes tri ou 1 face tri) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,5).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P2', nompro +#endif + call pcs2p2 ( nbfop2, profho, vap2ho, + > np2are, + > etanp1, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 7. Du centre aux sommets +c (selon 2 aretes tri ou 1 face tri) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,7).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P3', nompro +#endif + call pcs2p3 ( nbfop2, profho, vap2ho, + > np2are, + > etanp1, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 6. D'un milieu d'arete a un autre +c (selon 2 aretes tria+quad) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,11).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P4', nompro +#endif + call pcs2p4 ( nbfop2, profho, vap2ho, + > np2are, + > etanp1, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 7. D'un milieu d'arete a un sommet +c (selon 1 arete tri) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,13).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P5', nompro +#endif + call pcs2p5 ( nbfop2, profho, vap2ho, + > np2are, + > etanp1, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 8. D'un milieu de face a un sommet +c (selon 1 face quad) +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,17).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS2P6', nompro +#endif + call pcs2p6 ( nbfop2, profho, vap2ho, + > np2are, + > etanp1, + > listno, listno(7), + > nbarco, nuaret ) +c + endif +c + endif +c +c==== +c 9. Encore ? +c==== +c + typdec = typdec/typd00 + if ( typdec.gt.1 ) then + goto 40 + endif +c + endif +c + 100 continue +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcs2qu.F b/src/tool/AP_Conversion/pcs2qu.F new file mode 100644 index 00000000..af3dff4d --- /dev/null +++ b/src/tool/AP_Conversion/pcs2qu.F @@ -0,0 +1,409 @@ + subroutine pcs2qu ( nbfop2, profho, vap2ho, + > hetqua, arequa, filqua, + > somare, np2are, + > aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des QUadrangles +c - -- +c remarque : on devrait optimiser cela car si le quadrangle etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2qu et pcsiqu sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +#include "fractg.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad + integer typdec, etanp1 + integer iaux1, iaux2, iaux3, iaux4 + integer jaux1, jaux3, jaux4 + integer m1, m2, m3, m4 + integer sm, nuv +c + integer listar(4), listno(8) +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 + integer f1hp +c + logical afaire +c + double precision daux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +cgn write (*,*) 'PCS2QU' +c + do 10 , lequad = 1, nbquto +c +c==== +c 1. interpolation p2 pour un quadrangle qui vient d'etre decoupe : +c on a une valeur a mettre sur l'eventuel noeud central et les +c milieux des aretes internes +c==== +c + iaux = lequad + call pcs0qu ( iaux, profho, + > hetqua, arequa, + > somare, np2are, + > afaire, listar, listno, typdec, etanp1 ) +c + if ( afaire ) then +cgn write(1,*) 'typdec, etanp1 =', typdec, etanp1 +c +c==== +c 2. La valeur sur le noeud au centre du quadrangle +c . Soit le quadrangle vient d'etre decoupe en 4 quadrangles alors +c qu'il ne l'etait pas a l'iteration precedente +c . Soit le quadrangle vient d'etre decoupe en 3 quadrangles +c . Soit le quadrangle vient d'etre decoupe en 2 quadrangles +c Remarque : regarder cmcdqu pour les conventions +c==== +c + if ( typdec.eq.4 .or. + > typdec.eq.21 .or. typdec.eq.22 .or. + > ( typdec.ge.41 .and. typdec.le.44 ) ) then +c + f1hp = filqua(lequad) +c +c 2.1. ==> la valeur sur le noeud au centre du quadrangle +c + if ( typdec.eq.4 ) then + sm = somare(2,arequa(f1hp,2)) + elseif ( typdec.eq.21 .or. typdec.eq.22 ) then + sm = np2are(arequa(f1hp,4)) + else + sm = somare(2,arequa(f1hp,3)) + endif + profho(sm) = 1 +cgn write(1,*) 'f1hp =', f1hp + if ( typdec.ne.4 ) then +cgn write(1,*) 'sm =', sm + endif +c +c interpolation = -1/4 (u1+u2+u3+u4) + 1/2 (u5+u6+u7+u8) +c + 1789 format( 4g13.5) + do 21, nuv = 1, nbfop2 +cgn write(1,1789) vap2ho(nuv,listno(1)) +cgn > , vap2ho(nuv,listno(2)) +cgn > , vap2ho(nuv,listno(3)) +cgn > , vap2ho(nuv,listno(4)) +cgn write(1,1789) vap2ho(nuv,listno(5)) +cgn > , vap2ho(nuv,listno(6)) +cgn > , vap2ho(nuv,listno(7)) +cgn > , vap2ho(nuv,listno(8)) +c + vap2ho(nuv,sm) = - unsqu * ( vap2ho(nuv,listno(1)) + > + vap2ho(nuv,listno(2)) + > + vap2ho(nuv,listno(3)) + > + vap2ho(nuv,listno(4)) ) + > + unsde * ( vap2ho(nuv,listno(5)) + > + vap2ho(nuv,listno(6)) + > + vap2ho(nuv,listno(7)) + > + vap2ho(nuv,listno(8)) ) + if ( typdec.ne.4 ) then +cgn write(1,1789) vap2ho(nuv,sm) + endif +c + 21 continue +c + endif +c +c==== +c 3. Les valeurs sur les noeuds au milieu des aretes tracees a +c l'interieur du quadrangle +c==== +c 3.1. ==> Le quadrangle vient d'etre decoupe en 4 quadrangles alors +c qu'il ne l'etait pas a l'iteration precedente +c Remarque : regarder cmrdqu pour les conventions +c + if ( typdec.eq.4 ) then +c + f1hp = filqua(lequad) +c +c Par convention, la deuxieme arete du i-eme fils va du +c noeud ni, milieu de l'arete ai du quadrangle pere, vers +c le noeud central. +c + m1 = np2are(arequa(f1hp,2)) + m2 = np2are(arequa(f1hp+1,2)) + m3 = np2are(arequa(f1hp+2,2)) + m4 = np2are(arequa(f1hp+3,2)) + profho(m1) = 1 + profho(m2) = 1 + profho(m3) = 1 + profho(m4) = 1 +c +c interpolation = -3/16 (u1+u2+u3+u4) +c + 3/4 u5 +3/8 (u6+u8) + 1/4 u7 +c avec u5 pour le noeud le plus proche, u6 et u8 pour ceux qui +c 'encadrent' et u7 pour le noeud 'oppose' +c + do 31, nuv = 1, nbfop2 +c + daux = - trssz * ( vap2ho(nuv,listno(1)) + > + vap2ho(nuv,listno(2)) + > + vap2ho(nuv,listno(3)) + > + vap2ho(nuv,listno(4)) ) +c + vap2ho(nuv,m1) = daux + > + trsqu * vap2ho(nuv,listno(5)) + > + trshu * ( vap2ho(nuv,listno(6)) + vap2ho(nuv,listno(8))) + > + unsqu * vap2ho(nuv,listno(7)) +c + vap2ho(nuv,m2) = daux + > + trsqu * vap2ho(nuv,listno(6)) + > + trshu * ( vap2ho(nuv,listno(7)) + vap2ho(nuv,listno(5))) + > + unsqu * vap2ho(nuv,listno(8)) +c + vap2ho(nuv,m3) = daux + > + trsqu * vap2ho(nuv,listno(7)) + > + trshu * ( vap2ho(nuv,listno(8)) + vap2ho(nuv,listno(6))) + > + unsqu * vap2ho(nuv,listno(5)) +c + vap2ho(nuv,m4) = daux + > + trsqu * vap2ho(nuv,listno(8)) + > + trshu * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(7))) + > + unsqu * vap2ho(nuv,listno(6)) +c + 31 continue +c +c 3.2. ==> Le quadrangle vient d'etre decoupe en 3 triangles +c on doit creer les valeurs sur les noeuds au milieu des +c aretes tracees +c Remarque : regarder cmcdqu pour les conventions +c + elseif ( typdec.ge.31 .and. typdec.le.34 ) then +c + f1hp = - filqua(lequad) +c +c Par convention : +c . la premiere arete du 1-er fils va du noeud ni, milieu de +c l'arete ai du quadrangle pere, vers le sommet commun +c aux aretes i+1 et i+2. +c . la troisieme arete du 1-er fils va du noeud ni, milieu de +c l'arete ai du quadrangle pere, vers le sommet commun +c aux aretes i+2 et i+3. +c +c interpolation : +c interpolee (ui,i=1,8) = -3/16 (u1+u2+u3+u4) +c + 3/4 u5 +3/8 (u6+u8) + 1/4 u7 +c avec u5 pour le noeud le plus proche, u6 et u8 pour ceux qui +c 'encadrent' et u7 pour le noeud 'oppose' +c + if ( typdec.eq.31 ) then + iaux1 = listno(5) + iaux2 = listno(6) + iaux3 = listno(7) + iaux4 = listno(8) + elseif ( typdec.eq.32 ) then + iaux1 = listno(6) + iaux2 = listno(7) + iaux3 = listno(8) + iaux4 = listno(5) + elseif ( typdec.eq.33 ) then + iaux1 = listno(7) + iaux2 = listno(8) + iaux3 = listno(5) + iaux4 = listno(6) + else + iaux1 = listno(8) + iaux2 = listno(5) + iaux3 = listno(6) + iaux4 = listno(7) + endif +c + m1 = np2are(aretri(f1hp,1)) + m2 = np2are(aretri(f1hp,3)) + profho(m1) = 1 + profho(m2) = 1 +cgn write(1,*) 'm1 =', m1, ', m2 =', m2 +c + do 32 , nuv = 1, nbfop2 +c + daux = - trssz * ( vap2ho(nuv,listno(1)) + > + vap2ho(nuv,listno(2)) + > + vap2ho(nuv,listno(3)) + > + vap2ho(nuv,listno(4)) ) + > + trshu * ( vap2ho(nuv,iaux1) + vap2ho(nuv,iaux3) ) +c + vap2ho(nuv,m1) = daux + trsqu * vap2ho(nuv,iaux2) + > + unsqu * vap2ho(nuv,iaux4) +c + vap2ho(nuv,m2) = daux + trsqu * vap2ho(nuv,iaux4) + > + unsqu * vap2ho(nuv,iaux2) +cgn write(1,1789) vap2ho(nuv,m1), vap2ho(nuv,m2) +c + 32 continue +c +c 3.3. ==> Le quadrangle vient d'etre decoupe en 3 quadrangles +c on doit creer les valeurs sur les noeuds au milieu des +c aretes tracees +c Remarque : regarder cmcdqu pour les conventions +c + elseif ( typdec.ge.41 .and. typdec.le.44 ) then +c + f1hp = filqua(lequad) +c +c pour les noeuds milieux des aretes entre le noeud central +c et des milieux d'aretes du quadrangle pere : +c interpolation = -3/16 (u1+u2+u3+u4) +c + 3/4 u5 + 3/8 (u6+u8) + 1/4 u7 +c avec u5 pour le noeud le plus proche, u6 et u8 pour ceux qui +c 'encadrent' et u7 pour le noeud 'oppose' +c +c pour le noeud milieux de l'arete entre le noeud central +c et un sommet du quadrangle pere : +c interpolation = -3/16 (u1+u3) - 1/8 u4 +c + 9/16 (u5+u6) + 3/16 (u7+u8) +c avec u1 et u3 pour les sommets qui 'encadrent', u2 pour le +c sommet le plus proche, u4 pour le sommet le plus loin, +c u5 et u6 pour les noeuds qui 'encadrent' +c et u7 et u8 pour les noeuds 'opposes' +c + if ( typdec.eq.41 ) then + jaux1 = listno(2) + jaux3 = listno(4) + jaux4 = listno(1) + iaux1 = listno(5) + iaux2 = listno(6) + iaux3 = listno(7) + iaux4 = listno(8) + elseif ( typdec.eq.42 ) then + jaux1 = listno(3) + jaux3 = listno(1) + jaux4 = listno(2) + iaux1 = listno(6) + iaux2 = listno(7) + iaux3 = listno(8) + iaux4 = listno(5) + elseif ( typdec.eq.43 ) then + jaux1 = listno(4) + jaux3 = listno(2) + jaux4 = listno(3) + iaux1 = listno(7) + iaux2 = listno(8) + iaux3 = listno(5) + iaux4 = listno(6) + else + jaux1 = listno(1) + jaux3 = listno(3) + jaux4 = listno(4) + iaux1 = listno(8) + iaux2 = listno(5) + iaux3 = listno(6) + iaux4 = listno(7) + endif +c + m1 = np2are(arequa(f1hp,4)) + m2 = np2are(arequa(f1hp,3)) + m3 = np2are(arequa(f1hp+1,3)) + profho(m1) = 1 + profho(m2) = 1 + profho(m3) = 1 +cgn write(1,*) 'm1 =', m1, ', m2 =', m2, ', m3 =', m3 +cgn write(1,*) 'listno =', listno +c + do 33 , nuv = 1, nbfop2 +c + daux = - trssz * ( vap2ho(nuv,listno(1)) + > + vap2ho(nuv,listno(2)) + > + vap2ho(nuv,listno(3)) + > + vap2ho(nuv,listno(4)) ) +c + vap2ho(nuv,m1) = daux + > + trsqu * vap2ho(nuv,iaux1) + > + trshu * ( vap2ho(nuv,iaux2) + vap2ho(nuv,iaux4) ) + > + unsqu * vap2ho(nuv,iaux3) +c + vap2ho(nuv,m2) = daux + > + trsqu * vap2ho(nuv,iaux2) + > + trshu * ( vap2ho(nuv,iaux3) + vap2ho(nuv,iaux1) ) + > + unsqu * vap2ho(nuv,iaux4) +c + vap2ho(nuv,m3) = + > - trssz * ( vap2ho(nuv,jaux1) + > + vap2ho(nuv,jaux3) ) + > - unshu * vap2ho(nuv,jaux4) + > + nessz * ( vap2ho(nuv,iaux3) + vap2ho(nuv,iaux4) ) + > + trssz * ( vap2ho(nuv,iaux1) + vap2ho(nuv,iaux2) ) +cgn write(1,1789) vap2ho(nuv,m1), vap2ho(nuv,m2), vap2ho(nuv,m3) +c + 33 continue +c + endif +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2te.F b/src/tool/AP_Conversion/pcs2te.F new file mode 100644 index 00000000..bce6e6a4 --- /dev/null +++ b/src/tool/AP_Conversion/pcs2te.F @@ -0,0 +1,149 @@ + subroutine pcs2te ( nbfop2, profho, vap2ho, + > tritet, cotrte, aretet, + > hettet, filtet, + > somare, np2are, + > aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des TEtraedres +c - -- +c ______________________________________________________________________ +c attention : il faut passer ce programme avant le traitement des +c nouveaux noeuds sur les triangles coupes, sinon les +c valeurs sur les noeuds des diagonales seront inconnues +c remarque : on devrait optimiser cela car si le tetraedre etait dans +c un etat de decoupage de conformite similaire, on recalcule +c une valeur qui est deja presente +c remarque : pcs2te et pcsite sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto), filtet(nbteto) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer letetr, adiag + integer sm, nuv + integer listar(6), listno(10) +c + logical afaire +c ______________________________________________________________________ +c +#include "impr03.h" +cgn write (1,90002) 'PCS2TE, nbfop2', nbfop2 +c + do 10 , letetr = 1, nbteto +c +c==== +c 1. interpolation p2 pour un tetraedre qui vent d'etre decoupe +c les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur du tetraedre, donc quand il y a une diagonale. +c==== +c + iaux = letetr + call pcs0te ( iaux, profho, + > tritet, cotrte, aretet, + > hettet, filtet, + > aretri, + > somare, np2are, + > afaire, listar, listno, adiag ) +c +c==== +c 2. le tetraedre vient d'etre decoupe et le champ est present +c interpolation au noeud milieu de la diagonale +c==== +c + if ( afaire ) then +c + sm = np2are(adiag) + profho(sm) = 1 +cgn write(1,90002) 'dans pcs2te, f1hp =', f1hp +cgn write(1,90002) 'sm =', sm +c +c interpolation p2 c +c +c interpolee (ui,i=1,10) = -1/8 (ui,i=1,4) + 1/4 (ui,i=5,10) +c + do 22 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = + > unsqu * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) + > + vap2ho(nuv,listno(7)) + vap2ho(nuv,listno(8)) + > + vap2ho(nuv,listno(9)) + vap2ho(nuv,listno(10)) ) + > - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(2)) + > + vap2ho(nuv,listno(3)) + vap2ho(nuv,listno(4)) ) +cgn write(1,90014) sm, vap2ho(nuv,sm) +c + 22 continue +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs2tr.F b/src/tool/AP_Conversion/pcs2tr.F new file mode 100644 index 00000000..993f35db --- /dev/null +++ b/src/tool/AP_Conversion/pcs2tr.F @@ -0,0 +1,290 @@ + subroutine pcs2tr ( nbfop2, profho, vap2ho, + > hettri, aretri, filtri, + > somare, np2are ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p2 sur les noeuds - decoupage des TRiangles +c - -- +c remarque : on devrait optimiser cela car si le triangle etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2tr et pcsitr sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "demitr.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer somare(2,nbarto), np2are(nbarto) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer typdec + integer iaux1, iaux2, iaux3 + integer letria, letri0 + integer ff, nuv, af1, af2, af3 + integer m1, m2, m3 + integer inloc + integer listno(6) +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c + integer f1hp +c + logical afaire +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr03.h" +cgn write (1,90002) 'PCS2TR, nbfop2', nbfop2 +c + do 10 , letri0 = 1, nbtrto +c + letria = letri0 +c +cgn write (1,90002) 'Triangle', letria +c==== +c 1. liste des noeuds concernes et type de decoupage +c==== +c + call pcs0tr ( letria, profho, + > hettri, aretri, + > somare, np2are, + > afaire, listno, typdec ) +cgn write (1,90002) 'typdec', typdec +c + if ( afaire ) then +c +c==== +c 2. le triangle vient d'etre decoupe en 4 triangles alors +c qu'il ne l'etait pas a l'iteration precedente +c . en standard : etat 4 +c . avec bascule pour le suivi de frontiere : etat 6, 7 ou 8 +c Remarque : regarder cmrdtr pour les conventions +c==== +c + if ( typdec.ge.4 ) then +c +c recuperation du triangle fils aine +c c'est le central si pas de basculement +c + f1hp = filtri(letria) +c +c recuperation des aretes internes au triangle decoupe +c . pour un decoupage standard, ce sont les trois du triangle +c central +c . avec une bascule, il y a eu modification du fils aine +c et du frere de rang connu par l'etat du triangle, inloc. +c l'arete basculee est celle commune a ces deux triangles. les +c deux autres aretes sont celles de rang inloc dans la +c description des deux triangles modifies. +c + if ( typdec.eq.4 ) then + af1 = aretri(f1hp,1) + af2 = aretri(f1hp,2) + af3 = aretri(f1hp,3) +c + else + inloc = typdec - 5 + af3 = 0 + do 21 , iaux1 = 1 , 3 + iaux3 = aretri(f1hp+inloc,iaux1) + do 211 , iaux2 = 1 , 3 + if ( iaux3.eq.aretri(f1hp,iaux2) ) then + af3 = iaux3 + goto 212 + endif + 211 continue + 21 continue + 212 continue + af1 = aretri(f1hp ,inloc) + af2 = aretri(f1hp+inloc,inloc) + endif +c +c recuperation des noeuds milieux sur ces aretes internes +c + m1 = np2are(af1) + m2 = np2are(af2) + m3 = np2are(af3) + profho(m1) = 1 + profho(m2) = 1 + profho(m3) = 1 +cgn write(1,90002) 'm1, m2, m3', m1, m2, m3 +c +c interpolation p2 b = -1/8 (u2+u3) + 1/2 (u4+u6) + 1/4 (u5) +c + do 22 , nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = + > unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) ) + > - unshu * ( vap2ho(nuv,listno(2)) + vap2ho(nuv,listno(3)) ) + > + unsqu * vap2ho(nuv,listno(4)) + vap2ho(nuv,m2) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) ) + > - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(3)) ) + > + unsqu * vap2ho(nuv,listno(5)) + vap2ho(nuv,m3) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) ) + > - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(2)) ) + > + unsqu * vap2ho(nuv,listno(6)) +cgn write(1,90014) nuv, vap2ho(nuv,m1), vap2ho(nuv,m2), vap2ho(nuv,m3) +c + 22 continue +c +c==== +c 3. le triangle vient d'etre decoupe en 2 +c==== +c + elseif ( typdec.eq.1 .or. typdec.eq.2 .or. typdec.eq.3 ) then +c +c 3.1. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 1 +c + if ( typdec.eq.1 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(1,2) +c +c recuperation du nouveau noeud milieu +c + m1 = np2are(aretri(ff,3)) +cgn write(1,90002) 'm1', m1 + profho(m1) = 1 +c +c interpolation p2 b = -1/8 (u2+u3) + 1/2 (u4+u6) + 1/4 (u5) +c + do 31 , nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = + > unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) ) + > - unshu * ( vap2ho(nuv,listno(2)) + vap2ho(nuv,listno(3)) ) + > + unsqu * vap2ho(nuv,listno(4)) +cgn write(1,90014) m1, vap2ho(nuv,m1) +c + 31 continue +c +c 3.2. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 2 +c + elseif ( typdec.eq.2 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(2,1) +c +c recuperation du nouveau noeud milieu +c + m2 = np2are(aretri(ff,3)) +cgn write(1,90002) 'm2', m2 +cgn write(1,90002) 'noeuds', listno + profho(m2) = 1 +c +c interpolation p2 b = -1/8 (u2+u3) + 1/2 (u4+u6) + 1/4 (u5) +c + do 32 , nuv = 1, nbfop2 +c + vap2ho(nuv,m2) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) ) + > - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(3)) ) + > + unsqu * vap2ho(nuv,listno(5)) +cgn write(1,90014) m2, vap2ho(nuv,m2) +c + 32 continue +c +c 3.3. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 3 +c + elseif ( typdec.eq.3 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(3,1) +c +c recuperation du nouveau noeud milieu +c + m3 = np2are(aretri(ff,2)) +cgn write(1,90002) 'm3', m3 + profho(m3) = 1 +c +c interpolation p2 b = -1/8 (u2+u3) + 1/2 (u4+u6) + 1/4 (u5) +c + do 33 , nuv = 1, nbfop2 +c + vap2ho(nuv,m3) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) ) + > - unshu * ( vap2ho(nuv,listno(1)) + vap2ho(nuv,listno(2)) ) + > + unsqu * vap2ho(nuv,listno(6)) +cgn write(1,90014) m3, vap2ho(nuv,m3) +c + 33 continue +cgn if ( letria.eq.-1244 ) then +cgn nuv=1 +cgn write (*,*) '==>', vap2ho(nuv,m3) +cgn endif +c + endif +c + endif +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcs3tr.F b/src/tool/AP_Conversion/pcs3tr.F new file mode 100644 index 00000000..a0aadba6 --- /dev/null +++ b/src/tool/AP_Conversion/pcs3tr.F @@ -0,0 +1,206 @@ + subroutine pcs3tr ( letria, prfcan, + > somare, hettri, aretri, + > nbanar, anfiar, + > nareca, + > afaire, typdec, etan, orient ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation p0 sur les aretes - phase 3 +c - +c decoupage des TRiangles +c -- +c ______________________________________________________________________ +c remarque : pcs0tr et pcs3tr sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . triangle a examiner . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nareca . e . * . nro des aretes dans le calcul en entree . +c . afaire . s . 1 . vrai si l'interpolation est a faire . +c . typdec . s . 1 . type de decoupage . +c . etan . s . 1 . ETAt du triangle a l'iteration N . +c . orient . s . 3 . orientation relative des aretes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer letria + integer prfcan(*) + integer somare(2,*) + integer hettri(nbtrto), aretri(nbtrto,3) + integer typdec, etan + integer nareca(rearto) + integer nbanar, anfiar(nbanar) + integer orient(3) +c + logical afaire +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lafill, lapfil + integer listar(12), nbaret +c +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etanp1 +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c ______________________________________________________________________ +c +c==== +c 1. Quel decoupage +c==== +c + etanp1 = mod(hettri(letria),10) + etan = (hettri(letria)-etanp1) / 10 +c +cgn write(1,90002) 'etan/etanp1', etan, etanp1 +c +c type de decoupage +c 4 : en 4 standard +c 6, 7, 8 : en 4 avec basculement de l'arete typdec-5 +c 1, 2, 3 : en 2 selon l'arete typdec +c + if ( ( etanp1.eq.4 ) .and. + > ( etan.eq.0 .or. etan.eq.1 .or. + > etan.eq.2 .or. etan.eq.3 ) ) then + typdec = 4 +c + elseif ( + > ( etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) .and. + > ( etan.eq.0 .or. etan.eq.1 .or. + > etan.eq.2 .or. etan.eq.3 ) ) then + typdec = etanp1 +c + elseif ( etanp1.eq.1 .or. etanp1.eq.2 .or. etanp1.eq.3 ) then + typdec = etanp1 +c + else + typdec = 0 +c + endif +cgn write(1,*) 'typdec',typdec +c +c==== +c 2. On verifie que le champ est present : +c . sur toutes les aretes du triangle, s'il etait actif +c . sur les aretes non coupee et sur les filles de l'arete coupee, +c s'il etait coupe en 2 +c==== +c + if ( typdec.ne.0 ) then +c + afaire = .true. +cgn write(1,*) 'etan',etan +c + if ( etan.ne.5 ) then +c + nbaret = 0 + do 311 , iaux = 1 , 3 +c +cgn write(1,*) aretri(letria,iaux),nareca(aretri(letria,iaux)) + if ( iaux.eq.etan .or. etan.eq.4 ) then + do 3111 , jaux = 0 , 1 + lafill = anfiar(aretri(letria,iaux)) + jaux +cgn write(1,*) '. lafill', lafill + if ( anfiar(lafill).eq.0 ) then + nbaret = nbaret + 1 + listar(nbaret) = nareca(lafill) + else + do 31111 , kaux = 0 , 1 + lapfil = anfiar(lafill) + kaux +cgn write(1,*) '.. lapfil', lapfil + nbaret = nbaret + 1 + listar(nbaret) = nareca(lapfil) +31111 continue + endif + 3111 continue + else + nbaret = nbaret + 1 + listar(nbaret) = nareca(aretri(letria,iaux)) + endif +c + 311 continue +c +cgn write(1,*) 'listar :',(listar(iaux) , iaux = 1 , nbaret) + do 312 , iaux = 1 , nbaret +c + if ( listar(iaux).eq.0 ) then + afaire = .false. + goto 32 + elseif ( prfcan(listar(iaux)).eq.0 ) then + afaire = .false. + goto 32 + endif +c + 312 continue +c + 32 continue +c + endif +c + else +c + afaire = .false. +c + endif +cgn write(1,*) 'afaire',afaire +c +c==== +c 3. Si c'est a faire, on recupere l'orientation relative des aretes +c dans le triangle +c==== +c + if ( afaire ) then +c + call utorat ( somare, + > aretri(letria,1), aretri(letria,2), aretri(letria,3), + > orient(1), orient(2), orient(3) ) +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsar0.F b/src/tool/AP_Conversion/pcsar0.F new file mode 100644 index 00000000..f4563945 --- /dev/null +++ b/src/tool/AP_Conversion/pcsar0.F @@ -0,0 +1,504 @@ + subroutine pcsar0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > hetare, ancare, filare, + > nbanar, anfiar, + > nareca, narsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c ARetes - solution P0 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . ancare . e . nbarto . anciens numeros des aretes conservees . +c . filare . e . nbarto . fille ainee de chaque arete . +c . nareca . e . * . nro des aretes dans le calcul en entree . +c . narsca . e . rsarto . numero des aretes du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSAR0' ) +c +#include "nblang.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) + integer hetare(nbarto), ancare(*) + integer filare(nbarto) + integer nbanar, anfiar(nbanar) + integer nareca(rearto), narsca(rsarto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c arcn = ARrete courante en numerotation Calcul a l'iteration N +c arcnp1 = ARrete courante en numerotation Calcul a l'iteration N+1 +c arhn = ARrete courante en numerotation Homard a l'iteration N +c arhnp1 = ARrete courante en numerotation Homard a l'iteration N+1 +c + integer arcn, arcnp1, arhn, arhnp1 +c +c f1hp = Fille 1er de l'arete en numerotation Homard a l'it. N+1 +c f1cp = Fille 1er de l'arete en numerotation Calcul a l'it. N+1 +c f2cp = Fille 2eme de l'arete en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp +c +c f1hn = Fille 1er de l'arete en numerotation Homard a l'it. N +c f1cn = Fille 1er de l'arete en numerotation Calcul a l'it. N +c f2cn = Fille 2eme de l'arete en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn +c +c etan = ETAt de l'arete a l'iteration N +c etanp1 = ETAt de l'arete a l'iteration N+1 +c + integer etan, etanp1 +c + integer nrofon + integer iaux +c + double precision coefra(2), coefde(2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,''Arete en cours : nro a l''''iteration '',a3,'' : '',i8)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = '( ''==> Aucune interpolation'')' + texte(1,7) = '(''Ce type d''''interpolation est inconnu :'',i4)' +c + texte(2,4) = + > '(/,''Current edge : # at iteration '',a3,'': '',i8)' + texte(2,5) = + > '( '' status at iteration '',a3,'': '',i4)' + texte(2,6) = '( ''==> No interpolation'')' + texte(2,7) = '(''This kind of interpolation is unknown:'',i4)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfonc', nbfonc + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'typint', typint +#endif +cgn write(ulsort,*) 'nareca' +cgn write(ulsort,91020) nareca +cgn write(ulsort,*) 'prfcan' +cgn write(ulsort,91020)(prfcan(iaux),iaux=1,74) +cgn 9999 format(1I5,g14.7,3i10) +c +c==== +c 2. on boucle sur toutes les aretes du maillage HOMARD n+1 qui sont +c des elements du calcul : pour cela, il suffit que le numero dans +c le calcul en sortie soit non nul +c on trie en fonction de l'etat de l'arete dans le maillage n +c==== +c + if ( nbfonc.ne.0 ) then +c +c 2.0. ==> coefficients multiplicateurs selon le type d'interpolation +c intensif : valeur identique +c extensif : on divise par deux +c Si l'orientation est prise en compte, on se souvient que la +c premiere fille est toujours dans le meme sens que la mere, +c la seconde etant toujours en sens inverse. +c 2.0.0. ==> Intensif, sans orientation +c + if ( typint.eq.0 ) then + coefra(1) = 1.d0 + coefra(2) = 1.d0 + coefde(1) = unsde + coefde(2) = unsde +c +c 2.0.1. ==> Extensif, sans orientation +c + elseif ( typint.eq.1 ) then + coefra(1) = unsde + coefra(2) = unsde + coefde(1) = 1.d0 + coefde(2) = 1.d0 +c +c 2.0.2. ==> Intensif, avec orientation +c + elseif ( typint.eq.2 ) then + coefra(1) = 1.d0 + coefra(2) = -1.d0 + coefde(1) = unsde + coefde(2) = -unsde +c +c 2.0.3. ==> Extensif, avec orientation +c + elseif ( typint.eq.3 ) then + coefra(1) = unsde + coefra(2) = -unsde + coefde(1) = 1.d0 + coefde(2) = -1.d0 + else + codret = -1 + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'coefra', coefra + write (ulsort,90004) 'coefde', coefde +#endif +c + do 20 , arhnp1 = 1 , nbarto +c +c 2.1. ==> caracteristiques de l'arete : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + arhn = ancare(arhnp1) + else + arhn = arhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : l'arete etait active +c etan = 2 : l'arete etait coupe en 2 +c etan = 5 : l'arete n'existait pas ; elle a ete produite par +c un decoupage. +c etan = 9 : l'arete etait coupee en 2 et une de ses filles +c est inactive +c + etanp1 = mod(hetare(arhnp1),10) + etan = (hetare(arhnp1)-etanp1) / 10 +c +cgn write (ulsort,1792) 'Arete', arhn, etan, arhnp1, etanp1 +c +c======================================================================= +c 2.1.2.1. ===> etan = 0 : l'arete etait active +c======================================================================= +c + if ( etan.eq.0 ) then +cgn write (ulsort,*) 'l''arete etait active' +c +c on repere son ancien numero dans le calcul +c il faut que arcn soit non nul : l'arete etait du calcul +c + arcn = nareca(arhn) +cgn print 1790,arcn,prfcan(arcn) +cgn 1790 format(/,'Numero du calcul precedent arcn = ',i3, +cgn > ', de profil = ',i3) +c + if ( arcn.gt.0 ) then +c + if ( prfcan(arcn).gt.0 ) then +c +cgn print 1789,(vafoen(nrofon,prfcan(arcn)),nrofon = 1 , nbfonc) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c 2.1.2.1.1. ===> etanp1 = 0 : l'arete etait active et l'est encore ; +c elle est inchangee +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero de l'arete. +c +c O...............O ===> O...............O +c + if ( etanp1.eq.0 ) then +c + arcnp1 = narsca(arhnp1) + prfcap(arcnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc + vafott(nrofon,arcnp1) = vafoen(nrofon,prfcan(arcn)) +cgn write(ulsort,7778) vafoen(nrofon,prfcan(arcn)) + 221 continue +cgn write(21,9999) arcnp1,vafott(15,arcnp1),0,arcn,prfcan(arcn) +cgn write(ulsort,7777) arcn,-1,arcnp1 +c +c 2.1.2.1.2. ===> etanp1 = 2 : l'arete etait active et est decoupee +c en deux. +c les deux filles prennent la valeur de la fonction sur la +c mere, eventuellement divisee par deux, eventuellement signee +c +c O...............O ===> O.......O.......O +c + elseif ( etanp1.eq.2 ) then +c + f1hp = filare(arhnp1) + f1cp = narsca(f1hp) + f2cp = narsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 2221 , nrofon = 1 , nbfonc + vafott(nrofon,f1cp) = coefra(1)*vafoen(nrofon,prfcan(arcn)) + vafott(nrofon,f2cp) = coefra(2)*vafoen(nrofon,prfcan(arcn)) +cgn write(ulsort,7778) vafoen(nrofon,prfcan(arcn)) + 2221 continue +cgn write(22,9999) f1cp,vafott(15,f1cp),2,arcn,prfcan(arcn) +cgn write(22,9999) f2cp,vafott(15,f1cp),2,arcn,prfcan(arcn) +cgn write(22,7777) f1cp,f2cp +cgn write(ulsort,7777) arcn,-1, +cgn > f1cp,f2cp +c +c doc.0.erreur. ==> aucun autre etat sur l'arete courante n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', arhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', arhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c + endif +c +c======================================================================= +c 2.1.2.2. ===> etan = 2 : l'arete etait coupee en 2 +c======================================================================= +c + elseif ( etan.eq.2 ) then +c +cgn write (ulsort,*) 'l''arete etait coupee en 2' +c on repere les numeros dans le calcul pour ses deux filles a +c l'iteration n +c + f1hn = anfiar(arhn) + f1cn = nareca(f1hn) + f2cn = nareca(f1hn+1) +c +c il faut que f1cn soit non nul : les filles etaient du calcul +c + if (f1cn.gt.0 ) then +cgn write(ulsort,90002) 'prfcan(f1/2cn)',prfcan(f1cn),prfcan(f2cn) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c 2.1.2.2.1. ===> etanp1 = 0 : l'arete est reactivee. +c on lui attribue la valeur moyenne sur les deux +c anciennes filles. +c remarque : cela arrive seulement avec du deraffinement. +c +c O.......O.......O ===> O...............O +c + if ( etanp1.eq.0 ) then +c + arcnp1 = narsca(arhnp1) +cgn write(ulsort,90002) 'arhnp1, arcnp1', arhnp1, arcnp1 + prfcap(arcnp1) = 1 + do 231 , nrofon = 1 , nbfonc + vafott(nrofon,arcnp1) = + > coefde(1)*vafoen(nrofon,prfcan(f1cn)) + > + coefde(2)*vafoen(nrofon,prfcan(f2cn)) +cgn write(ulsort,90004) '=> valeur', vafott(nrofon,arcnp1) + 231 continue +cgn write(31,7777) arcnp1 +cgn write(ulsort,7777) f1cn,f2cn,-1,arcnp1 +c +c 2.1.2.2.2. ===> etanp1 = etan : l'arete est decoupee en deux +c c'est le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car la situation +c au voisinage est inchangee. +c la fille prend la valeur de la fonction sur l'ancienne +c fille qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdar), la premiere fille +c est toujours la meme, la seconde egalement. on prendra +c alors la valeur sur la fille de rang identique a +c l'iteration n. +c +c O.......O.......O ===> O.......O.......O +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filare(arhnp1) + f1cp = narsca(f1hp) + f2cp = narsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 232 , nrofon = 1 , nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) +cgn write(ulsort,7778) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 232 continue +cgn write(32,7777) f1cp,f2cp +cgn write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp +c +c 2.1.2.2.3. ===> etanp1 = 9 : l'arete est decoupee en deux et une de +c ses filles est decoupee ; +c rien n'est a faire +c aucun autre etat sur l'arete courante n'est possible +c + elseif ( etanp1.ne.9 ) then +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', arhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', arhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c======================================================================= +c doc.4. ==> l'arete n'existait pas +c======================================================================= +c + else +c +cgn print *,'l arete n''existait pas' + write (ulsort,texte(langue,6)) +c +#endif +c +c======================================================================= +c + endif +c + 20 continue +c + endif +c + endif +c +cgn write(ulsort,91020)(prfcap(iaux),iaux=1,nbtrto) +cgn print *,'nbfonc = ',nbfonc +cgn etan = 1 +cgn etanp1 = nbarto +cgn do 30001 , iaux=etan,etanp1 +cgn if ( mod(hetare(iaux),10).eq.0 ) then +cgn print 11790, +cgn > ntrsca(iaux),prfcap(narsca(iaux)),vafott(1,narsca(iaux)) +cgn endif +cgn30001 continue +cgn11790 format(i4,' : ',i2,' / ',g15.7) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,7)) typint + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsar1.F b/src/tool/AP_Conversion/pcsar1.F new file mode 100644 index 00000000..c7996a34 --- /dev/null +++ b/src/tool/AP_Conversion/pcsar1.F @@ -0,0 +1,666 @@ + subroutine pcsar1 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > hetare, ancare, filare, + > nbanar, anfiar, + > somare, + > hettri, aretri, filtri, + > nareca, narsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c ARetes - solution P0 - etape 1 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . ancare . e . nbarto . anciens numeros des aretes conservees . +c . filare . e . nbarto . fille ainee de chaque arete . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nareca . e . * . nro des aretes dans le calcul en entree . +c . narsca . e . rsarto . numero des aretes du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSAR1' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +#include "demitr.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) + integer hetare(nbarto), ancare(*) + integer filare(nbarto) + integer nbanar, anfiar(nbanar) + integer somare(2,*) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer nareca(rearto), narsca(rsarto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c arcn = ARetes en numerotation Calcul a l'iteration N +c arhnp1 = ARetes en numerotation HOMARD a l'iteration N+1 +c arcnp1 = ARetes en numerotation Calcul a l'iteration N+1 +c + integer arcn(4) + integer arhnp1(3) + integer arcnp1(3) +c +c etan = ETAt du triangle a l'iteration N +c + integer etan +c +c f1trhp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c + integer f1trhp +c +c f1hn = Fille 1er de l'arete en numerotation Homard a l'it. N +c + integer f1hn +c + integer letria, letri0 +c + integer typdec + integer nrofon + integer lareth, laretc + integer iaux, jaux + integer oripei(3), orifii(3) + integer nufilo(3,3), nuarfi(3,3), nuarff(3,4) +c + double precision champ0(3), champ1(3,3), flux + double precision oriped(3) +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,''Arete en cours : nro a l''''iteration '',a3,'' : '',i8)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = '( ''==> Aucune interpolation'')' +c + texte(2,4) = + > '(/,''Current edge : # at iteration '',a3,'' : '',i8)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' + texte(2,6) = '( ''==> No interpolation'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfonc', nbfonc +#endif +cgn write(ulsort,*) 'nareca' +cgn write(ulsort,91020) nareca +cgn write(ulsort,*) 'prfcan' +cgn write(ulsort,91020)(prfcan(iaux),iaux=1,74) +c +c==== +c 2. on boucle sur toutes les triangles du maillage HOMARD +c==== +c + do 20 , letri0 = 1, nbtrto +c + letria = letri0 +c +cgn write (ulsort,*) ' ' +cgn write (ulsort,90002) 'Triangle', letria +cgn write (ulsort,90012) '. aretes du triangle HOMARD', letria, +cgn > (aretri(letria,iaux),iaux=1,3) +cgn if ( mod(hettri(letria),10).eq.0 ) then +cgn write (ulsort,90012) '. aretes du triangle Calcul', letria, +cgn > (narsca(aretri(letria,iaux)),iaux=1,3) +cgn endif +c +c 2.1. ==> Type de decoupage +c + call pcs3tr ( letria, prfcan, + > somare, hettri, aretri, + > nbanar, anfiar, + > nareca, + > afaire, typdec, etan, oripei ) +c +cgn write (ulsort,90015) '. typdec', typdec,', etan', etan +cgn write (ulsort,99001) 'afaire', afaire +c + if ( afaire ) then +c +c 2.2. ==> Les caracteritiques du triangle +c + arhnp1(1) = aretri(letria,1) + arhnp1(2) = aretri(letria,2) + arhnp1(3) = aretri(letria,3) +c +c 2.2.1. ==> Orientations relatives des aretes du triangle +c +cgn write (ulsort,90002) '. orientations ', +cgn > oripei + do 221 , iaux = 1 , 3 + oriped(iaux) = dble(oripei(iaux)) + 221 continue +cgn if ( typdec.eq.4 ) then +cgn write (ulsort,90002) '. filles arete 1 du triangle H/C n+1', +cgn > filare(arhnp1(1)),filare(arhnp1(1))+1, +cgn > narsca(filare(arhnp1(1))),narsca(filare(arhnp1(1))+1) +cgn write (ulsort,90002) '. filles arete 2 du triangle H/C n+1', +cgn > filare(arhnp1(2)),filare(arhnp1(2))+1, +cgn > narsca(filare(arhnp1(2))),narsca(filare(arhnp1(2))+1) +cgn write (ulsort,90002) '. filles arete 3 du triangle H/C n+1', +cgn > filare(arhnp1(3)),filare(arhnp1(3))+1, +cgn > narsca(filare(arhnp1(3))),narsca(filare(arhnp1(3))+1) +cgn else +cgn write (ulsort,90015) '. filles arete', typdec, +cgn > ' du triangle HOMARD n+1', +cgn > filare(arhnp1(typdec)),filare(arhnp1(typdec))+1 +cgn write (ulsort,90015) '. filles arete', typdec, +cgn > ' du triangle Calcul n+1', +cgn > narsca(filare(arhnp1(typdec))), +cgn > narsca(filare(arhnp1(typdec))+1) +cgn endif +c +c 2.2.2. ==> Le fils du triangle +c +cgn write (ulsort,90015) '. typdec', typdec,', etan', etan + f1trhp = filtri(letria) +cgn write (ulsort,90015) '. aretes du fils', f1trhp,' HOMARD n+1', +cgn > (aretri(f1trhp,iaux),iaux=1,3) +cgn write (ulsort,90015) '. aretes du fils', f1trhp,' Calcul n+1', +cgn > (narsca(aretri(f1trhp,iaux)),iaux=1,3) +c +c 2.2.3. ==> Orientations relatives des aretes du fils du triangle +c s'il est coupe en 4 +c + if ( typdec.eq.4 ) then +c + call utorat ( somare, + > aretri(f1trhp,1), aretri(f1trhp,2), aretri(f1trhp,3), + > orifii(1), orifii(2), orifii(3) ) +cgn write (ulsort,90002) '. orientations ', +cgn > orifii +c + endif +c +c 2.2.4. ==> Les aretes du triangle +c 2.2.4.1. ==> S'il etait actif : arcn(1), (2), (3) +c + if ( etan.eq.0 ) then +c + arcn(1) = nareca(arhnp1(1)) + arcn(2) = nareca(arhnp1(2)) + arcn(3) = nareca(arhnp1(3)) +cgn write(ulsort,90012)'. arete avant H Cn arcn(1)', +cgn > arhnp1(1), arcn(1) +cgn write(ulsort,90012)'. arete avant H Cn arcn(2)', +cgn > arhnp1(2), arcn(2) +cgn write(ulsort,90012)'. arete avant H Cn arcn(3)', +cgn > arhnp1(3), arcn(3) +c +c 2.2.4.2. ==> S'il etait coupe en deux : +c arcn(1) : l'arete non coupee, avant celle coupee +c arcn(2) : l'arete non coupee, apres celle coupee +c arcn(3), arcn(4) : les 2 filles de l'aretes coupee +c + elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then +c + arcn(1) = nareca(aretri(letria,per1a3(-1,etan))) +cgn write(ulsort,90012)'. arete avant H Cn arcn(1)', +cgn > aretri(letria,per1a3(-1,etan)), arcn(1) + arcn(2) = nareca(aretri(letria,per1a3( 1,etan))) +cgn write(ulsort,90012)'. arete apres H Cn arcn(2)', +cgn > aretri(letria,per1a3( 1,etan)), arcn(2) + f1hn = anfiar(aretri(letria,etan)) +cgn write(ulsort,90012) +cgn > '. ancienne fille HOMARD de l''arete coupee', +cgn > aretri(letria,etan), f1hn + arcn(3) = nareca(f1hn) +cgn write(ulsort,90015) +cgn > '. 1ere fille arete coupee H',f1hn, +cgn > ', Cn arcn(3) =', arcn(3) + arcn(4) = nareca(f1hn+1) +cgn write(ulsort,90015)'. 2nde fille arete coupee H',f1hn+1, +cgn > ', Cn arcn(4) =',arcn(4) +c +c 2.2.4.3. ==> Decoupage en 4 avec bascule d'aretes +c + elseif ( etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then + codret = 2243 + goto 2000 + endif +c +c 2.3. ==> Decoupage en 4 standard +c + if ( typdec.eq.4 ) then +c +c 2.3.1. ==> Quelles aretes tracees sur ce triangle ? +c + do 231 , iaux = 1 , 3 + arcnp1(iaux) = narsca(aretri(f1trhp,iaux)) + if ( arcnp1(iaux).eq.0 ) then + goto 20 + endif + 231 continue +c +c 2.3.2. ==> Enregistrement +c + prfcap(arcnp1(1)) = 1 + prfcap(arcnp1(2)) = 1 + prfcap(arcnp1(3)) = 1 +c +c 2.3.3. ==> Parcours des fonctions +c 2.3.3.1. ==> numero des filles +c nufilo(i,j) = numero local de la fille de la j-eme arete +c du pere pour le calcul de la valeur +c sur la i-eme arete du fils + if ( oripei(1).gt.0 ) then + nufilo(2,1) = 0 + nufilo(3,1) = 1 + else + nufilo(2,1) = 1 + nufilo(3,1) = 0 + endif + if ( oripei(2).gt.0 ) then + nufilo(1,2) = 1 + nufilo(3,2) = 0 + else + nufilo(1,2) = 0 + nufilo(3,2) = 1 + endif + if ( oripei(3).gt.0 ) then + nufilo(1,3) = 0 + nufilo(2,3) = 1 + else + nufilo(1,3) = 1 + nufilo(2,3) = 0 + endif +c + iaux = filare(arhnp1(3)) + nufilo(1,3) + nuarfi(1,3) = narsca(iaux) + if ( nuarfi(1,3).eq.0 ) then + nuarff(1,1) = narsca(filare(iaux)) + nuarff(1,2) = narsca(filare(iaux)+1) + endif +c + iaux = filare(arhnp1(2)) + nufilo(1,2) + nuarfi(1,2) = narsca(iaux) + if ( nuarfi(1,2).eq.0 ) then + nuarff(1,3) = narsca(filare(iaux)) + nuarff(1,4) = narsca(filare(iaux)+1) + endif +c + iaux = filare(arhnp1(1)) + nufilo(2,1) + nuarfi(2,1) = narsca(iaux) + if ( nuarfi(2,1).eq.0 ) then + nuarff(2,1) = narsca(filare(iaux)) + nuarff(2,2) = narsca(filare(iaux)+1) + endif +c + iaux = filare(arhnp1(3)) + nufilo(2,3) + nuarfi(2,3) = narsca(iaux) + if ( nuarfi(2,3).eq.0 ) then + nuarff(2,3) = narsca(filare(iaux)) + nuarff(2,4) = narsca(filare(iaux)+1) + endif +c + iaux = filare(arhnp1(1)) + nufilo(3,1) + nuarfi(3,1) = narsca(iaux) + if ( nuarfi(3,1).eq.0 ) then + nuarff(3,1) = narsca(filare(iaux)) + nuarff(3,2) = narsca(filare(iaux)+1) + endif +c + iaux = filare(arhnp1(2)) + nufilo(3,2) + nuarfi(3,2) = narsca(iaux) + if ( nuarfi(3,2).eq.0 ) then + nuarff(3,3) = narsca(filare(iaux)) + nuarff(3,4) = narsca(filare(iaux)+1) + endif +cgn write (ulsort,90002) '. filles pour 1', nuarfi(1,3), nuarfi(1,2) +cgn if ( nuarfi(1,3).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 1', +cgn > nuarff(1,1), nuarff(1,2) +cgn endif +cgn if ( nuarfi(1,2).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 1', +cgn > nuarff(1,3), nuarff(1,4) +cgn endif +cgn write (ulsort,90002) '. filles pour 2', nuarfi(2,1), nuarfi(2,3) +cgn if ( nuarfi(2,1).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 2', +cgn > nuarff(2,1), nuarff(2,2) +cgn endif +cgn if ( nuarfi(2,3).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 2', +cgn > nuarff(2,3), nuarff(2,4) +cgn endif +cgn write (ulsort,90002) '. filles pour 3', nuarfi(3,2), nuarfi(3,1) +cgn if ( nuarfi(3,2).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 3', +cgn > nuarff(3,1), nuarff(3,2) +cgn endif +cgn if ( nuarfi(3,1).eq.0 ) then +cgn write (ulsort,90002) '. petites filles pour 3', +cgn > nuarff(3,3), nuarff(3,4) +cgn endif +c +c 2.3.3.2. ==> Interpolation +c + do 2321 , nrofon = 1 , nbfonc +c + if ( etan.eq.0 ) then + champ0(1) = vafoen(nrofon,prfcan(arcn(1))) + champ0(2) = vafoen(nrofon,prfcan(arcn(2))) + champ0(3) = vafoen(nrofon,prfcan(arcn(3))) + elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then +cgn write (ulsort,*) 'le triangle etait coupe en 2' + champ0(etan) = vafoen(nrofon,prfcan(arcn(3))) + > - vafoen(nrofon,prfcan(arcn(4))) + champ0(per1a3(-1,etan)) = vafoen(nrofon,prfcan(arcn(1))) + champ0(per1a3( 1,etan)) = vafoen(nrofon,prfcan(arcn(2))) + endif +cgn write (ulsort,90004) '. champ0', champ0 +c + call utflt0 ( somare, arhnp1, + > champ0, flux, + > ulsort, langue, codret ) + flux = unsqu*flux +cgn write (ulsort,90004) '. flux sur les 4 fils', flux +c + if ( nuarfi(1,3).ne.0 ) then + champ1(1,3) = vafott(nrofon,nuarfi(1,3)) + else + champ1(1,3) = vafott(nrofon,nuarff(1,1)) + > - vafott(nrofon,nuarff(1,2)) + endif + if ( nuarfi(1,2).ne.0 ) then + champ1(1,2) = vafott(nrofon,nuarfi(1,2)) + else + champ1(1,2) = vafott(nrofon,nuarff(1,3)) + > - vafott(nrofon,nuarff(1,4)) + endif + if ( nuarfi(2,1).ne.0 ) then + champ1(2,1) = vafott(nrofon,nuarfi(2,1)) + else + champ1(2,1) = vafott(nrofon,nuarff(2,1)) + > - vafott(nrofon,nuarff(2,2)) + endif + if ( nuarfi(2,3).ne.0 ) then + champ1(2,3) = vafott(nrofon,nuarfi(2,3)) + else + champ1(2,3) = vafott(nrofon,nuarff(2,3)) + > - vafott(nrofon,nuarff(2,4)) + endif + if ( nuarfi(3,2).ne.0 ) then + champ1(3,2) = vafott(nrofon,nuarfi(3,2)) + else + champ1(3,2) = vafott(nrofon,nuarff(3,1)) + > - vafott(nrofon,nuarff(3,2)) + endif + if ( nuarfi(3,1).ne.0 ) then + champ1(3,1) = vafott(nrofon,nuarfi(3,1)) + else + champ1(3,1) = vafott(nrofon,nuarff(3,3)) + > - vafott(nrofon,nuarff(3,4)) + endif +cgn write (ulsort,90004) '. champ1 pour 1', champ1(1,3), champ1(1,2) +cgn write (ulsort,90004) '. champ1 pour 2', champ1(2,1), champ1(2,3) +cgn write (ulsort,90004) '. champ1 pour 3', champ1(3,2), champ1(3,1) +c + vafott(nrofon,arcnp1(1)) = + > orifii(1) * ( champ1(1,3) - champ1(1,2) - flux ) + vafott(nrofon,arcnp1(2)) = + > orifii(2) * ( champ1(2,1) - champ1(2,3) - flux ) + vafott(nrofon,arcnp1(3)) = + > orifii(3) * ( champ1(3,2) - champ1(3,1) - flux ) +cgn do 2322 , iaux = 1 , 3 +cgn write (ulsort,90024) '. arete',aretri(f1trhp,iaux), +cgn > vafott(nrofon,arcnp1(iaux)) +cgn 2322 continue +c + 2321 continue +c +c 2.4. ==> Decoupage en 2 +c + elseif ( typdec.eq.1 .or. typdec.eq.2 .or. typdec.eq.3 ) then +c +c 2.4.1. ==> Quelle arete tracee sur ce triangle ? +c On base tout le raisonnement sur le triangle fils +c au rang nutrde(i,i+1) dans la numerotation +c Voir cmcdtr pour les conventions +c le bon fils : + iaux = f1trhp + nutrde(typdec, per1a3(1,typdec)) +cgn write (ulsort,90002) '. les 2 fils ', f1trhp, f1trhp+1 +cgn write (ulsort,90002) '. le bon fils', iaux +c la bonne arete : celle a la place i-1 +cgn write (ulsort,90002) '. per1a3(-1,typdec)', per1a3(-1,typdec) + lareth = aretri(iaux,per1a3(-1,typdec)) +cgn write (ulsort,90002) '. lareth', lareth, narsca(lareth) + arcnp1(3) = narsca(lareth) + if ( arcnp1(3).eq.0 ) then + goto 20 + endif +cgn write (ulsort,90015) '. arete centrale HOMARD', lareth, +cgn > ', Calcul n+1', arcnp1(3) +c +c 2.4.2. ==> Les demi-aretes de la base du triangle +c arcnp1(1) : la premiere fille de l'arete coupee +c arcnp1(2) : la seconde fille de l'arete coupee +c + arcnp1(1) = narsca(filare(aretri(letria,typdec))) + arcnp1(2) = narsca(filare(aretri(letria,typdec))+1) +cgn write (ulsort,90002) '. aretes filles', arcnp1(1),arcnp1(2) +c +c 2.4.3. ==> Enregistrement +c + prfcap(arcnp1(3)) = 1 +c +c 2.4.4. ==> Parcours des fonctions +c 2.4.4.1. ==> numero des filles +c nufilo(i,j) = numero local de la fille de la j-eme arete +c pour le calcul de la i-eme valeur + if ( oripei(typdec).gt.0 ) then + jaux = 1 + else + jaux = 0 + endif +cgn write (ulsort,90002) '. jaux/arete du pere/fille HOMARD', +cgn > jaux,arhnp1(typdec),filare(arhnp1(typdec))+jaux + laretc = narsca(filare(arhnp1(typdec))+jaux) +cgn write (ulsort,90114) '. champ sur cette arete Cn+1', +cgn > laretc, vafott(1,laretc) +c +c 2.4.4.2. ==> Interpolation +c +cgn write (ulsort,90002) '. arhnp1', arhnp1 +cgn write (ulsort,90002) '. arcn ', arcn +c + do 2422 , nrofon = 1 , nbfonc +c + if ( etan.eq.0 ) then + champ0(1) = vafoen(nrofon,prfcan(arcn(1))) + champ0(2) = vafoen(nrofon,prfcan(arcn(2))) + champ0(3) = vafoen(nrofon,prfcan(arcn(3))) + elseif ( etan.eq.1 .or. etan.eq.2 .or. etan.eq.3 ) then +cgn write (ulsort,*) 'le triangle etait coupe en 2' + champ0(etan) = vafoen(nrofon,prfcan(arcn(3))) + > - vafoen(nrofon,prfcan(arcn(4))) + champ0(per1a3(-1,etan)) = vafoen(nrofon,prfcan(arcn(1))) + champ0(per1a3( 1,etan)) = vafoen(nrofon,prfcan(arcn(2))) + elseif ( etan.le.5 ) then +cgn if ( etan.eq.4 ) then +cgn write (ulsort,*) 'le triangle etait coupe en 4' +cgn else +cgn write (ulsort,*) 'le triangle n''existait pas' +cgn endif + champ0(typdec) = vafott(nrofon,arcnp1(1)) + > - vafott(nrofon,arcnp1(2)) + champ0(per1a3(-1,typdec)) = + > vafott(nrofon,narsca(arhnp1(per1a3(-1,typdec)))) + champ0(per1a3( 1,typdec)) = + > vafott(nrofon,narsca(arhnp1(per1a3( 1,typdec)))) + endif +cgn write (ulsort,90004) '. champ0', champ0 +c + call utflt0 ( somare, arhnp1, + > champ0, flux, + > ulsort, langue, codret ) + flux = unsde*flux +cgn write (ulsort,90004) '. flux sur les 2 fils', flux +cgn write (ulsort,90114) '. champ sur l''arete fille n+1 laretc', +cgn > laretc,vafott(nrofon,laretc) +cgn write (ulsort,90112) '. arcn ', per1a3(1,typdec), +cgn >arcn(per1a3(1,typdec)),prfcan(arcn(per1a3(1,typdec))) +cgn write (ulsort,90114) '. arcn ', per1a3(1,typdec), +cgn >oriped(per1a3(1,typdec)), +cgn >vafoen(nrofon,prfcan(arcn(per1a3(1,typdec)))) +c + vafott(nrofon,arcnp1(3)) = + > ( flux + > + vafott(nrofon,laretc) + > - oriped(per1a3(1,typdec))*champ0(per1a3( 1,typdec)) ) +cgn write (ulsort,90004) '. val', vafott(nrofon,arcnp1(3)) +c + 2422 continue +c + endif +c + endif +c + 20 continue +c + 2000 continue +c +cgn write(ulsort,91020)(prfcap(iaux),iaux=1,nbtrto) +cgn print *,'nbfonc = ',nbfonc +cgn etan = 1 +cgn etanp1 = nbarto +cgn do 30001 , iaux=etan,etanp1 +cgn if ( mod(hetare(iaux),10).eq.0 ) then +cgn print 11790, +cgn > ntrsca(iaux),prfcap(narsca(iaux)),vafott(1,narsca(iaux)) +cgn endif +cgn30001 continue +cgn11790 format(i4,' : ',i2,' / ',g15.7) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseh0.F b/src/tool/AP_Conversion/pcseh0.F new file mode 100644 index 00000000..452bb8be --- /dev/null +++ b/src/tool/AP_Conversion/pcseh0.F @@ -0,0 +1,323 @@ + subroutine pcseh0 ( etan, etanp1, hehn, hehnp1, typint, + > prfcan, prfcap, + > nfhexp, nfpyrp, nftetp, ficp, propor, + > nheeca, nhesca, + > nbfonc, vafoen, vafott, + > vatett, prftep, + > vapytt, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres d'etat anterieur 0 +c - - +c remarque : pcseh0 et pcsep0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt de l'hexaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt de l'hexaedre a l'iteration N+1 . +c . hehn . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . hehnp1 . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nfhexp . e . 1 . nombre de fils hexaedres . +c . nfpyrp . e . 1 . nombre de fils pyramides . +c . nftetp . e . 1 . nombre de fils tetraedres . +c . ficp . e . 3,18 . numeros des fils en numerotation du calcul . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 18 . proportion de volume entre fils et pere . +c . nheeca . e . reteto . numero des hexaedres dans le calcul entree . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEH0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, hehn, hehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) +c + integer nfhexp, nfpyrp, nftetp + integer ficp(3,18) +c + integer nheeca(reheto), nhesca(rsheto) + integer prftep(*) + integer prfpyp(*) +c + double precision propor(18) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c hecn = Hexaedre courant en numerotation du Calcul a l'it. N +c hecnp1 = Hexaedre courant en numerotation du Calcul a l'it. N+1 +c + integer hecn, hecnp1 +c + integer nrofon +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Hexa. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'('' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current hexahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + codret = 0 +c +c==== +c 2. seulement si une valeur existe +c==== +c + hecn = nheeca(hehn) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n ', hehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', hehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + write (ulsort,90002) 'prfcan(hecn)', prfcan(hecn) + call dmflsh (iaux) + write (ulsort,90002) 'nfhexp', nfhexp + write (ulsort,90002) 'nfpyrp', nfpyrp + write (ulsort,90002) 'nftetp', nftetp +#endif +c + if ( prfcan(hecn).gt.0 ) then +cgn write(ulsort,90002) 'typint', typint +cgn write(ulsort,90002) 'etanp1', etanp1 +c +c==== +c 3. parcours des types de decoupages +c==== +c 3.1. ==> etanp1 = 0 : l'hexaedre etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero de l'hexaedre. +c + if ( etanp1.eq.0 ) then +c + hecnp1 = nhesca(hehnp1) + prfcap(hecnp1) = 1 +c + do 31 , nrofon = 1, nbfonc + vafott(nrofon,hecnp1) = vafoen(nrofon,prfcan(hecn)) + 31 continue +c +c 3.2. ==> etanp1 > 11 : l'hexaedre etait actif et est en conformite +c + elseif ( etanp1.ge.11 ) then +c + if ( typint.eq.0 ) then +c + do 320 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(hecn)) + do 3201 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3201 continue + do 3202 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3202 continue + 320 continue +c + else +c + do 321 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(hecn)) + do 3211 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3211 continue + do 3212 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3212 continue + 321 continue +c + endif +c +c 3.3. ==> etan p1 = 8 : l'hexaedre est decoupe en 8. +c + elseif ( etanp1.eq.8 ) then +c + if ( typint.eq.0 ) then +c + do 330 , nrofon = 1, nbfonc + daux = vafoen(nrofon,prfcan(hecn)) + do 3301 , iaux = 1 , nfhexp + vafott(nrofon,ficp(1,iaux)) = daux + 3301 continue + 330 continue +c + else +c + do 331 , nrofon = 1, nbfonc + daux = vafoen(nrofon,prfcan(hecn)) + do 3311 , iaux = 1 , nfhexp + vafott(nrofon,ficp(1,iaux)) = daux * propor(iaux) + 3311 continue + 331 continue +c + endif +c +c 3.4. ==> aucun autre etat sur l'hexaedre courant n'est possible +c + else +c + codret = 1 + write (ulsort,texte(langue,4)) 'n ', hehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', hehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c +c==== +c 4. affectation des profils +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. affectation des profils ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nfhexp + prfcap(ficp(1,iaux)) = 1 + 41 continue +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseh1.F b/src/tool/AP_Conversion/pcseh1.F new file mode 100644 index 00000000..85751d2a --- /dev/null +++ b/src/tool/AP_Conversion/pcseh1.F @@ -0,0 +1,452 @@ + subroutine pcseh1 ( etan, etanp1, hehn, hehnp1, typint, + > prfcap, + > nfpyrn, nftetn, ficn, + > nfpyrp, nftetp, ficp, propor, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, filhex, fhpyte, + > nhesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres - decoupage par conformite avant +c - +c remarque : pcseh1 et pcsep1 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt de l'hexaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt de l'hexaedre a l'iteration N+1 . +c . hehn . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . hehnp1 . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nfpyrn . e . 1 . nombre de fils pyramides n . +c . nftetn . e . 1 . nombre de fils tetraedres n . +c . ficn . e . 3,18 . fils en numerotation du calcul n . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . nfpyrp . e . 1 . nombre de fils pyramides n+1 . +c . nftetp . e . 1 . nombre de fils tetraedres n+1 . +c . ficp . e . 3,18 . fils en numerotation du calcul n+1 . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 18 . proportion de volume entre fils et pere . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie . +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vateen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les tetraedres . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prften . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapyen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les pyramides . +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEH1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, hehn, hehnp1 + integer typint + integer nbfonc + integer prfcap(*) +c + integer nfpyrn, nftetn + integer ficn(3,18) + integer nfpyrp, nftetp + integer ficp(3,18) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hethex(nbheto), filhex(nbheto), fhpyte(2,nbheco) + integer nhesca(rsheto) + integer ntesca(rsteto) + integer npysca(rspyto) + integer prften(*), prftep(*) + integer prfpyn(*), prfpyp(*) +c + double precision propor(18) + double precision coonoe(nbnoto,sdim) + double precision vafott(nbfonc,*) + double precision vateen(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapyen(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer hecnp1 + integer f1hp +c + integer nrofon +c + logical afaire +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. seulement si des valeurs existent +c==== +c + afaire = .true. +c + do 21 , iaux = 1 , nfpyrn + if ( prfpyn(ficn(2,iaux)).eq.0 ) then + afaire = .false. + endif + 21 continue +c + do 22 , iaux = 1 , nftetn + if ( prften(ficn(3,iaux)).eq.0 ) then + afaire = .false. + endif + 22 continue +c + if ( afaire ) then +c +cgn write(ulsort,90002) 'etanp1', etanp1 +cgn write(ulsort,90002) 'hehnp1', hehnp1 +cgn write(ulsort,90002) 'nfpyrn, nftetn', nfpyrn, nftetn + daux1 = 1.d0 / dble(nfpyrn+nftetn) +c +c==== +c 3. L'hexaedre etait coupe en conformite +c==== +c 3.1. ==> etanp1 = 0 : l'hexaedre est reactive. +c 0n lui attribue la valeur moyenne ou totale sur les +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*) '... l''hexaedre est reactive' +c + hecnp1 = nhesca(hehnp1) + prfcap(hecnp1) = 1 +c + if ( typint.eq.0 ) then +c + do 310 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3101 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3101 continue + do 3102 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3102 continue +c + vafott(nrofon,hecnp1) = daux * daux1 +c + 310 continue +c + else +c + do 311 , nrofon = 1 , nbfonc + daux = 0.d0 + do 3111 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3111 continue + do 3112 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3112 continue + vafott(nrofon,hecnp1) = daux + 311 continue +c + endif +c +c 3.2. ==> etanp1 = etan : l'hexaedre est decoupe selon +c le meme decoupage. Comme les conventions sont les memes, +c on remet les memes valeurs. +c + elseif ( etanp1.eq.etan ) then +c + do 32 , nrofon = 1 , nbfonc + do 321 , iaux = 1 , nfpyrn + vapytt(nrofon,ficp(2,iaux)) = + > vapyen(nrofon,prfpyn(ficn(2,iaux))) + 321 continue + do 322 , iaux = 1 , nftetn + vatett(nrofon,ficp(3,iaux)) = + > vateen(nrofon,prften(ficn(3,iaux))) + 322 continue + 32 continue +c +c 3.3. ==> un autre decoupage de conformite +c + elseif ( etanp1.ge.11 ) then +c + if ( typint.eq.0 ) then +c + do 330 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3301 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3301 continue + do 3302 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3302 continue + daux = daux * daux1 +c + do 3303 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3303 continue + do 3304 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3304 continue +c + 330 continue +c + else +c + do 331 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3311 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3311 continue + do 3312 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3312 continue +c + do 3313 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3313 continue + do 3314 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3314 continue +c + 331 continue +c + endif +c +c 3.4. ==> etanp1 = 8 : l'hexaedre est decoupe en 8 hexaedres +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement de l'hexaedre. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur 1,2,3 ou 4 des fils. +c Ce ou ces fils sont obligatoirement du cote du precedent +c point de non conformite. +c + elseif ( etanp1.eq.8 ) then +cgn print *,'... l''hexa est coupe en 8 hexa' +c + f1hp = filhex(hehnp1) + daux1 = 1.d0 / dble(nfpyrn+nftetn) +cgn write(ulsort,*) 'f1hp = ', f1hp + do 34 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3401 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3401 continue + do 3402 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3402 continue +c + iaux = nrofon +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEH9', nompro +#endif + call pcseh9 ( etan, etanp1, hehn, hehnp1, typint, + > f1hp, iaux, daux, daux1, prfcap, + > ficp, propor, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, filhex, fhpyte, + > nhesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > prftep, vatett, + > prfpyp, vapytt, + > ulsort, langue, codret ) +c + 34 continue +c + endif +c +c==== +c 4. affectation des profils +c Attention : pour les fils en hexaedres, c'est fait dans pcseh9 +c==== +c + if ( codret.eq.0 ) then +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseh8.F b/src/tool/AP_Conversion/pcseh8.F new file mode 100644 index 00000000..e909ba98 --- /dev/null +++ b/src/tool/AP_Conversion/pcseh8.F @@ -0,0 +1,301 @@ + subroutine pcseh8 ( etanp1, hehnp1, typint, + > prfcan, prfcap, + > ficn, + > nfpyrp, nftetp, ficp, propor, + > nhesca, + > nbfonc, vafoen, vafott, + > vatett, + > prftep, + > vapytt, + > prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres d'etat anterieur 80 +c - - +c remarque : pcseh8 et pcsep8 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du hexaedre a l'iteration N+1 . +c . hehnp1 . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ficn . e . 3,18 . fils en numerotation du calcul n . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . nfpyrp . e . 1 . nombre de fils pyramides n+1 . +c . nftetp . e . 1 . nombre de fils tetraedres n+1 . +c . ficp . e . 3,18 . fils en numerotation du calcul n+1 . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEH8' ) +c +#include "nblang.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etanp1, hehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) +c + integer ficn(3,18) + integer nfpyrp, nftetp + integer ficp(3,18) +c + integer nhesca(rsheto) + integer prftep(*) + integer prfpyp(*) +c + double precision propor(18) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer hecnp1 + integer nrofon +c + logical afaire +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. seulement si des valeurs existent +c==== +c + afaire = .true. +c + do 21 , iaux = 1 , 8 + if ( prfcan(ficn(1,iaux)).eq.0 ) then + afaire = .false. + endif + 21 continue +c + if ( afaire ) then +c +c==== +c 3. L'hexaedre etait coupe en 8 hexaedres +c==== +c 3.1. ==> etanp1 = 0 : l'hexaedre est reactive. +c on lui attribue la valeur moyenne sur les huit anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c==== +c +cgn write(ulsort,90002) 'etanp1', etanp1 + if ( etanp1.eq.0 ) then +c + hecnp1 = nhesca(hehnp1) + prfcap(hecnp1) = 1 +c + if ( typint.eq.0 ) then +c + do 310 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3101 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3101 continue +c + vafott(nrofon,hecnp1) = daux * unshu +c + 310 continue +c + else +c + do 311 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3111 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3111 continue +c + vafott(nrofon,hecnp1) = daux +c + 311 continue +c + endif +c +c 3.2. ==> un decoupage de conformite +c + elseif ( etanp1.ge.11 ) then +c + if ( typint.eq.0 ) then +c + do 320 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3201 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3201 continue + daux = daux * unshu +c + do 3203 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3203 continue + do 3204 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3204 continue +c + 320 continue +c + else +c + do 321 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3211 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3211 continue +c + do 3213 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3213 continue + do 3214 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3214 continue +c + 321 continue +c + endif +c + endif +c +c==== +c 4. affectation des profils +c==== +c + if ( codret.eq.0 ) then +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseh9.F b/src/tool/AP_Conversion/pcseh9.F new file mode 100644 index 00000000..ce28ef13 --- /dev/null +++ b/src/tool/AP_Conversion/pcseh9.F @@ -0,0 +1,331 @@ + subroutine pcseh9 ( etan, etanp1, hehn, hehnp1, typint, + > f1hp, nrofon, valeur, coef, prfcap, + > ficp, propor, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, filhex, fhpyte, + > nhesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > prftep, vatett, + > prfpyp, vapytt, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres d'etat 80 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt de l'hexaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du hexaedre a l'iteration N+1 . +c . hehn . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . hehnp1 . e . 1 . Hexaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . f1hp . e . 1 . Fils 1er de l'hexaedre en numerotation . +c . . . . Homard a l'iteration N+1 . +c . nrofon . e . 1 . numero de la fonction en cours d'examen . +c . valeur . e . 1 . valeur de la fonction en cours d'examen . +c . coef . e . 1 . coefficient pour la moyenne . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ficp . e . 3,18 . fils en numerotation du calcul n+1 . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 18 . proportion de volume entre fils et pere . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nhesca . e . rsteto . numero des hexaedres dans le calcul sortie . +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEH9' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, hehn, hehnp1 + integer typint + integer f1hp, nrofon + integer nbfonc + integer prfcap(*) + integer ficp(3,18) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hethex(nbheto) + integer filhex(nbheto), fhpyte(2,nbheco) + integer nhesca(rsheto) + integer ntesca(rsteto) + integer npysca(rspyto) + integer prftep(*) + integer prfpyp(*) +c + double precision valeur, coef +c + double precision propor(18) + double precision coonoe(nbnoto,sdim) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer fihp + integer etatfi +c + integer nfhexf, nfpyrf, nftetf + integer ficf(3,18) +c + double precision daux + double precision propof(18) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Hexa. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current hexahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +c==== +c 2. Exploration des 8 fils +c==== +c + do 20 , iaux = 0 , 7 +c + if ( codret.eq.0 ) then +c + fihp = f1hp + iaux + etatfi = mod(hethex(fihp),1000) +cgn write (ulsort,*) '. fihp', fihp,', etat =', hethex(fihp) +c +c 2.1. ==> Le fils est actif +c + if ( etatfi.eq.0 ) then +c + if ( typint.eq.0 ) then + daux = valeur*coef + else + daux = valeur*propor(iaux+1) + endif +cgn write (ulsort,*) '. ficp', ficp(1,iaux+1) + vafott(nrofon,ficp(1,iaux+1)) = daux + prfcap(ficp(1,iaux+1)) = 1 +c +c 2.2. ==> Le fils est coupe en conformite +c + elseif ( etatfi.ge.11 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEHY', nompro +#endif + call pcsehy ( nfhexf, nfpyrf, nftetf, ficf, + > fihp, etatfi, + > filhex, fhpyte, + > nhesca, ntesca, npysca, + > ulsort, langue, codret ) +c + if ( typint.eq.0 ) then +c + daux = valeur*coef + do 2203 , jaux = 1 , nfpyrf + vapytt(nrofon,ficf(2,jaux)) = daux + 2203 continue + do 2204 , jaux = 1 , nftetf + vatett(nrofon,ficf(3,jaux)) = daux + 2204 continue +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEHZ', nompro +#endif + call pcsehz ( propof, + > fihp, etatfi, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > filhex, fhpyte, + > ulsort, langue, codret ) +c + daux = valeur*propor(iaux+1) + do 2213 , jaux = 1 , nfpyrf + vapytt(nrofon,ficf(2,jaux)) = daux * propof(jaux) + 2213 continue + do 2214 , jaux = 1 , nftetf + vatett(nrofon,ficf(3,jaux)) = daux * propof(jaux+nfpyrf) + 2214 continue +c + endif +c + if ( codret.eq.0 ) then +c + do 222 , jaux = 1 , nfpyrf + prfpyp(ficf(2,jaux)) = 1 + 222 continue +c + do 223 , jaux = 1 , nftetf + prftep(ficf(3,jaux)) = 1 + 223 continue +c + endif +c + else +c + codret = 1 + write (ulsort,texte(langue,4)) 'n ', hehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', hehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsehy.F b/src/tool/AP_Conversion/pcsehy.F new file mode 100644 index 00000000..59c7400e --- /dev/null +++ b/src/tool/AP_Conversion/pcsehy.F @@ -0,0 +1,199 @@ + subroutine pcsehy ( nfhexa, nfpyra, nftetr, ficalc, + > lehexa, etat, + > filhex, fhpyte, + > nhecca, ntecca, npycca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres - reperages des fils +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfhexa . s . 1 . nombre de fils hexaedres . +c . nfpyra . s . 1 . nombre de fils pyramides . +c . nftetr . s . 1 . nombre de fils tetraedres . +c . ficalc . s . 3,18 . numeros des fils en numerotation du calcul . +c . . . . 1 : hexaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . lehexa . e . 1 . hexaedre courant . +c . etat . e . 1 . etat de l'hexaedre . +c . filhex . e . * . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nhecca . e . * . numero des hexaedres dans le calcul e/s . +c . ntecca . e . * . numero des tetraedres dans le calcul e/s . +c . npycca . e . * . pyramides en sortie dans le calcul e/s . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEHY' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer nfhexa, nfpyra, nftetr + integer ficalc(3,18) + integer lehexa, etat +c + integer filhex(*), fhpyte(2,*) + integer nhecca(*) + integer ntecca(*) + integer npycca(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp2.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lehexa, etat +#endif +c +c==== +c 2. denombrement des fils pour les differents cas de figure +c==== +c + jaux = chbiet(etat) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etat, ' ==> code binaire', jaux +#endif +c + nfhexa = chnhe(jaux) + nfpyra = chnpy(jaux) + nftetr = chnte(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nfhexa', nfhexa + write (ulsort,90002) 'nfpyra', nfpyra + write (ulsort,90002) 'nftetr', nftetr +#endif +c +c==== +c 3. Calcul +c==== +c 3.1. ==> Reperage des hexaedres fils de l'hexaedre +c + if ( nfhexa.gt.0 ) then +c + jaux = filhex(lehexa) - 1 + do 31 , iaux = 1 , nfhexa +cgn write(ulsort,90002) 'fils', iaux,jaux+iaux + ficalc(1,iaux) = nhecca(jaux+iaux) + 31 continue +cgn write(ulsort,90002) 'nfhexa', nfhexa +cgn write(ulsort,91020) (ficalc(1,iaux) , iaux = 1 , nfhexa) +c + endif +c +c 3.2. ==> Reperage des pyramides filles de l'hexaedre +c + if ( nfpyra.gt.0 ) then +c + jaux = fhpyte(1,-filhex(lehexa)) - 1 + do 32 , iaux = 1 , nfpyra + ficalc(2,iaux) = npycca(jaux+iaux) + 32 continue +cgn write(ulsort,90002) 'nfpyra', nfpyra +cgn write(ulsort,91020) (ficalc(2,iaux) , iaux = 1 , nfpyra) +c + endif +c +c 3.3. ==> Reperage des tetraedres fils de l'hexaedre +c + if ( nftetr.gt.0 ) then +c + jaux = fhpyte(2,-filhex(lehexa)) - 1 + do 33 , iaux = 1 , nftetr + ficalc(3,iaux) = ntecca(jaux+iaux) + 33 continue +cgn write(ulsort,90002) 'nftetr', nftetr +cgn write(ulsort,91020) (ficalc(3,iaux) , iaux = 1 , nftetr) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsehz.F b/src/tool/AP_Conversion/pcsehz.F new file mode 100644 index 00000000..9b423356 --- /dev/null +++ b/src/tool/AP_Conversion/pcsehz.F @@ -0,0 +1,265 @@ + subroutine pcsehz ( propor, + > lehexa, etat, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > filhex, fhpyte, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Hexaedres - calcul des proportions fils/pere +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . propor . s . 18 . proportion de volume entre fils et pere . +c . lehexa . e . 1 . hexaedre courant . +c . etat . e . 1 . etat de l'hexaedre . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEHZ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer lehexa, etat +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer filhex(nbheto), fhpyte(2,nbheco) +c + double precision propor(18) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer fihexa, fipyra, fitetr + integer nfhexa, nfpyra, nftetr, nbfils +c + double precision daux + double precision daux0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp2.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lehexa, etat +#endif +c +c==== +c 2. denombrement des fils pour les differents cas de figure +c==== +c + jaux = chbiet(etat) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etat, ' ==> code binaire', jaux +#endif +c + nfhexa = chnhe(jaux) + nfpyra = chnpy(jaux) + nftetr = chnte(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nfhexa', nfhexa + write (ulsort,90002) 'nfpyra', nfpyra + write (ulsort,90002) 'nftetr', nftetr +#endif +c +c==== +c 3. Calcul +c==== +c 3.1. ==> Calcul des volumes +c Remarque : certains des volumes des fils sont identiques +c par paires, par construction. On les calcule quand meme +c pour la lisibilite du programme. +c + nbfils = nfhexa + nfpyra + nftetr +c +c 3.1.1. ==> Hexaedres +c + if ( nfhexa.gt.0 ) then +c + fihexa = filhex(lehexa) - 1 + do 321 , iaux = 1, nfhexa + call utvhex ( fihexa+iaux, propor(iaux), + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) + 321 continue +c + endif +c +c 3.1.2. ==> Pyramides +c + if ( nfpyra.gt.0 ) then +c + fipyra = fhpyte(1,-filhex(lehexa)) - 1 + do 322 , iaux = 1 , nfpyra + call utvpyr ( fipyra+iaux, propor(iaux), + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) + 322 continue +c + endif +c +c 3.1.3. ==> Tetraedres +c + if ( nftetr.gt.0 ) then +c + fitetr = fhpyte(2,-filhex(lehexa)) - 1 + do 323 , iaux = 1 , nftetr + call utvtet ( fitetr+iaux, propor(iaux+nfpyra), + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + 323 continue +c + endif +c +c 3.2. ==> Le volume total ; c'est donc le volume du pere +c + daux0 = 0.d0 + do 32 , iaux = 1, nbfils + daux0 = daux0 + propor(iaux) + 32 continue +c +c 3.3. ==> Rapport +c + do 33 , iaux = 1, nbfils + propor(iaux) = propor(iaux) / daux0 + 33 continue +c +#ifdef _DEBUG_HOMARD_ + if ( nfhexa.gt.0 ) then + write (ulsort,90015) 'propor pour les', nfhexa,' hexaedres' + do 3391 , iaux = 1, nfhexa + write (ulsort,90014) iaux, propor(iaux) + 3391 continue + endif + if ( nfpyra.gt.0 ) then + write (ulsort,90015) 'propor pour les', nfpyra, ' pyramides' + do 3392 , iaux = 1, nfpyra + write (ulsort,90014) iaux, propor(iaux) + 3392 continue + endif + if ( nftetr.gt.0 ) then + write (ulsort,90015) 'propor pour les', nftetr, ' tetradres' + do 3393 , iaux = 1, nftetr + write (ulsort,90014) iaux, propor(iaux+nfpyra) + 3393 continue + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsep0.F b/src/tool/AP_Conversion/pcsep0.F new file mode 100644 index 00000000..93645659 --- /dev/null +++ b/src/tool/AP_Conversion/pcsep0.F @@ -0,0 +1,338 @@ + subroutine pcsep0 ( etan, etanp1, pehn, pehnp1, typint, + > prfcan, prfcap, + > nfpenp, nfpyrp, nftetp, ficp, propor, + > npeeca, npesca, + > nbfonc, vafoen, vafott, + > vatett, prftep, + > vapytt, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres d'etat anterieur 0 +c - - +c remarque : pcseh0 et pcsep0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du pentaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du pentaedre a l'iteration N+1 . +c . pehn . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . pehnp1 . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nfpenp . e . 1 . nombre de fils pentaedres . +c . nfpyrp . e . 1 . nombre de fils pyramides . +c . nftetp . e . 1 . nombre de fils tetraedres . +c . ficp . e . 3,11 . numeros des fils en numerotation du calcul . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 11 . proportion de volume entre fils et pere . +c . npeeca . e . * . numero des pentaedres dans le calcul entree. +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEP0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, pehn, pehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) +c + integer nfpenp, nfpyrp, nftetp + integer ficp(3,11) +c + integer npeeca(reheto), npesca(rsheto) + integer prftep(*) + integer prfpyp(*) +c + double precision propor(11) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c pecn = Pentaedre courant en numerotation du Calcul a l'it. N +c pecnp1 = Pentaedre courant en numerotation du Calcul a l'it. N+1 +c + integer pecn, pecnp1 +c + integer nrofon +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Pent. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'('' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current prism : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '('' status at iteration '',a3,'' : '',i4)' +c + codret = 0 +c +c==== +c 2. seulement si une valeur existe +c==== +c + pecn = npeeca(pehn) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n ', pehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', pehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + write (ulsort,90002) 'prfcan(pecn)', prfcan(pecn) + call dmflsh (iaux) + write (ulsort,90002) 'nfpenp', nfpenp + write (ulsort,90002) 'nfpyrp', nfpyrp + write (ulsort,90002) 'nftetp', nftetp +#endif +c + if ( prfcan(pecn).gt.0 ) then +cgn write(ulsort,90002) 'typint', typint +cgn write(ulsort,90002) 'etanp1', etanp1 +c +c==== +c 3. parcours des types de decoupages +c==== +c 3.1. ==> etanp1 = 0 : le pentaedre est actif ; il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du pentaedre. +c + if ( etanp1.eq.0 ) then +c + pecnp1 = npesca(pehnp1) + prfcap(pecnp1) = 1 +c + do 31 , nrofon = 1, nbfonc + vafott(nrofon,pecnp1) = vafoen(nrofon,prfcan(pecn)) + 31 continue +c +c 3.2. ==> etanp1 = 1, ..., 6 : le pentaedre est coupe en +c 1 tetraedre et 2 pyramides +c etanp1 = 17, ..., 19 : le pentaedre est coupe en +c 2 tetraedres et 1 pyramide +c etanp1 = 21, ..., 26 : le pentaedre est coupe en +c 6 tetraedres +c etanp1 = 31, ..., 36 : le pentaedre est coupe en +c 10 tetraedres et 1 pyramide +c etanp1 = 43, ..., 45 : le pentaedre est coupe en +c 2 tetraedres et 4 pyramides +c etanp1 = 51, 52 : le pentaedre est coupe en +c 11 tetraedres +c + elseif ( ( etanp1.ge.1 .and. etanp1.le.6 ) .or. + > ( etanp1.ge.17 .and. etanp1.le.19 ) .or. + > ( etanp1.ge.21 .and. etanp1.le.26 ) .or. + > ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.43 .and. etanp1.le.45 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then +c + if ( typint.eq.0 ) then +c + do 320 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(pecn)) + do 3201 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3201 continue + do 3202 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3202 continue + 320 continue +c + else +c + do 321 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(pecn)) + do 3211 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3211 continue + do 3212 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3212 continue + 321 continue +c + endif +c +c 3.3. ==> etanp1 = 80 : le pentaedre est decoupe en 8. +c + elseif ( etanp1.eq.80 ) then +c + if ( typint.eq.0 ) then +c + do 330 , nrofon = 1, nbfonc + daux = vafoen(nrofon,prfcan(pecn)) + do 3301 , iaux = 1 , nfpenp + vafott(nrofon,ficp(1,iaux)) = daux + 3301 continue + 330 continue +c + else +c + do 331 , nrofon = 1, nbfonc + daux = vafoen(nrofon,prfcan(pecn)) + do 3311 , iaux = 1 , nfpenp + vafott(nrofon,ficp(1,iaux)) = daux * propor(iaux) + 3311 continue + 331 continue +c + endif +c +c 3.4. ==> aucun autre etat sur le pentaedre courant n'est possible +c + else +c + codret = 1 + write (ulsort,texte(langue,4)) 'n ', pehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', pehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c +c==== +c 4. affectation des profils +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. affectation des profils ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nfpenp + prfcap(ficp(1,iaux)) = 1 + 41 continue +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsep1.F b/src/tool/AP_Conversion/pcsep1.F new file mode 100644 index 00000000..b53882de --- /dev/null +++ b/src/tool/AP_Conversion/pcsep1.F @@ -0,0 +1,459 @@ + subroutine pcsep1 ( etan, etanp1, pehn, pehnp1, typint, + > prfcap, + > nfpyrn, nftetn, ficn, + > nfpyrp, nftetp, ficp, propor, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, filpen, fppyte, + > npesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres - decoupage par conformite avant +c - +c remarque : pcseh1 et pcsep1 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du pentaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du pentaedre a l'iteration N+1 . +c . pehn . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . pehnp1 . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nfpyrn . e . 1 . nombre de fils pyramides n . +c . nftetn . e . 1 . nombre de fils tetraedres n . +c . ficn . e . 3,11 . fils en numerotation du calcul n . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . nfpyrp . e . 1 . nombre de fils pyramides n+1 . +c . nftetp . e . 1 . nombre de fils tetraedres n+1 . +c . ficp . e . 3,11 . fils en numerotation du calcul n+1 . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 11 . proportion de volume entre fils et pere . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vateen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les tetraedres . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prften . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapyen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les pyramides . +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEP1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, pehn, pehnp1 + integer typint + integer nbfonc + integer prfcap(*) +c + integer nfpyrn, nftetn + integer ficn(3,11) + integer nfpyrp, nftetp + integer ficp(3,11) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hetpen(nbpeto), filpen(nbpeto), fppyte(2,nbpeco) + integer npesca(rsheto) + integer ntesca(rsteto) + integer npysca(rspyto) + integer prften(*), prftep(*) + integer prfpyn(*), prfpyp(*) +c + double precision propor(11) + double precision coonoe(nbnoto,sdim) + double precision vafott(nbfonc,*) + double precision vateen(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapyen(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer pecnp1 + integer f1hp +c + integer nrofon +c + logical afaire +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. seulement si des valeurs existent +c==== +c + afaire = .true. +c + do 21 , iaux = 1 , nfpyrn + if ( prfpyn(ficn(2,iaux)).eq.0 ) then + afaire = .false. + endif + 21 continue +c + do 22 , iaux = 1 , nftetn + if ( prften(ficn(3,iaux)).eq.0 ) then + afaire = .false. + endif + 22 continue +c + if ( afaire ) then +c +cgn write(ulsort,90002) 'etanp1', etanp1 +cgn write(ulsort,90002) 'pehnp1', pehnp1 +cgn write(ulsort,90002) 'nfpyrn, nftetn', nfpyrn, nftetn + daux1 = 1.d0 / dble(nfpyrn+nftetn) +c +c==== +c 3. Le pentaedre etait coupe en conformite +c==== +c 3.1. ==> etanp1 = 0 : le pentaedre est reactive. +c 0n lui attribue la valeur moyenne ou totale sur les +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*) '... le pentaedre est reactive' +c + pecnp1 = npesca(pehnp1) +cgn write(ulsort,*) 'prfcap pour',pecnp1 + prfcap(pecnp1) = 1 +c + if ( typint.eq.0 ) then +c + do 310 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3101 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3101 continue + do 3102 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3102 continue +c + vafott(nrofon,pecnp1) = daux * daux1 +c + 310 continue +c + else +c + do 311 , nrofon = 1 , nbfonc + daux = 0.d0 + do 3111 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3111 continue + do 3112 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3112 continue + vafott(nrofon,pecnp1) = daux + 311 continue +c + endif +c +c 3.2. ==> etanp1 = etan : le pentaedre est decoupe selon +c le meme decoupage. Comme les conventions sont les memes, +c on remet les memes valeurs. +c + elseif ( etanp1.eq.etan ) then +c + do 32 , nrofon = 1 , nbfonc + do 321 , iaux = 1 , nfpyrn + vapytt(nrofon,ficp(2,iaux)) = + > vapyen(nrofon,prfpyn(ficn(2,iaux))) + 321 continue + do 322 , iaux = 1 , nftetn + vatett(nrofon,ficp(3,iaux)) = + > vateen(nrofon,prften(ficn(3,iaux))) + 322 continue + 32 continue +c +c 3.3. ==> un autre decoupage de conformite +c + elseif ( ( etanp1.ge. 1 .and. etanp1.le. 6 ) .or. + > ( etanp1.ge.17 .and. etanp1.le.19 ) .or. + > ( etanp1.ge.21 .and. etanp1.le.26 ) .or. + > ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.43 .and. etanp1.le.45 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then +c + if ( typint.eq.0 ) then +c + do 330 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3301 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3301 continue + do 3302 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3302 continue + daux = daux * daux1 +c + do 3303 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3303 continue + do 3304 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3304 continue +c + 330 continue +c + else +c + do 331 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3311 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3311 continue + do 3312 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3312 continue +c + do 3313 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3313 continue + do 3314 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3314 continue +c + 331 continue +c + endif +c +c 3.4. ==> etanp1 = 80 : le pentaedre est coupe en 8 pentaedres +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du pentaedre. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur 1,2,3 ou 4 des fils. +c Ce ou ces fils sont obligatoirement du cote du precedent +c point de non conformite. +c + elseif ( etanp1.eq.80 ) then +cgn print *,'... le penta est coupe en 8 penta' +c + f1hp = filpen(pehnp1) + daux1 = 1.d0 / dble(nfpyrn+nftetn) +cgn write(ulsort,*) 'f1hp = ', f1hp + do 34 , nrofon = 1 , nbfonc +c + daux = 0.d0 + do 3401 , iaux = 1 , nfpyrn + daux = daux + vapyen(nrofon,prfpyn(ficn(2,iaux))) + 3401 continue + do 3402 , iaux = 1 , nftetn + daux = daux + vateen(nrofon,prften(ficn(3,iaux))) + 3402 continue +c + iaux = nrofon +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEP9', nompro +#endif + call pcsep9 ( etan, etanp1, pehn, pehnp1, typint, + > f1hp, iaux, daux, daux1, prfcap, + > ficp, propor, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, filpen, fppyte, + > npesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > prftep, vatett, + > prfpyp, vapytt, + > ulsort, langue, codret ) +c + 34 continue +c + endif +c +c==== +c 4. affectation des profils +c Attention : pour les fils en pentaedres, c'est fait dans pcsep9 +c==== +c + if ( codret.eq.0 ) then +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsep8.F b/src/tool/AP_Conversion/pcsep8.F new file mode 100644 index 00000000..00ae0c9f --- /dev/null +++ b/src/tool/AP_Conversion/pcsep8.F @@ -0,0 +1,306 @@ + subroutine pcsep8 ( etanp1, pehnp1, typint, + > prfcan, prfcap, + > ficn, + > nfpyrp, nftetp, ficp, propor, + > npesca, + > nbfonc, vafoen, vafott, + > vatett, + > prftep, + > vapytt, + > prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres d'etat anterieur 80 +c - - +c remarque : pcseh8 et pcsep8 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du pentaedre a l'iteration N+1 . +c . pehnp1 . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ficn . e . 3,11 . fils en numerotation du calcul n . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . nfpyrp . e . 1 . nombre de fils pyramides n+1 . +c . nftetp . e . 1 . nombre de fils tetraedres n+1 . +c . ficp . e . 3,11 . fils en numerotation du calcul n+1 . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEP8' ) +c +#include "nblang.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etanp1, pehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) +c + integer ficn(3,11) + integer nfpyrp, nftetp + integer ficp(3,11) +c + integer npesca(rsheto) + integer prftep(*) + integer prfpyp(*) +c + double precision propor(11) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer pecnp1 + integer nrofon +c + logical afaire +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. seulement si des valeurs existent +c==== +c + afaire = .true. +c + do 21 , iaux = 1 , 8 + if ( prfcan(ficn(1,iaux)).eq.0 ) then + afaire = .false. + endif + 21 continue +c + if ( afaire ) then +c +c==== +c 3. Le pentaedre etait coupe en 8 pentaedres +c==== +c 3.1. ==> etanp1 = 0 : le pentaedre est reactive. +c on lui attribue la valeur moyenne sur les huit anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c==== +c +cgn write(ulsort,90002) 'etanp1', etanp1 + if ( etanp1.eq.0 ) then +c + pecnp1 = npesca(pehnp1) + prfcap(pecnp1) = 1 +c + if ( typint.eq.0 ) then +c + do 310 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3101 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3101 continue +c + vafott(nrofon,pecnp1) = daux * unshu +c + 310 continue +c + else +c + do 311 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3111 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3111 continue +c + vafott(nrofon,pecnp1) = daux +c + 311 continue +c + endif +c +c 3.2. ==> un decoupage de conformite +c + elseif ( ( etanp1.ge. 1 .and. etanp1.le. 6 ) .or. + > ( etanp1.ge.17 .and. etanp1.le.19 ) .or. + > ( etanp1.ge.21 .and. etanp1.le.26 ) .or. + > ( etanp1.ge.31 .and. etanp1.le.36 ) .or. + > ( etanp1.ge.43 .and. etanp1.le.45 ) .or. + > ( etanp1.ge.51 .and. etanp1.le.52 ) ) then +c + if ( typint.eq.0 ) then +c + do 320 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3201 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3201 continue + daux = daux * unshu +c + do 3203 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux + 3203 continue + do 3204 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux + 3204 continue +c + 320 continue +c + else +c + do 321 , nrofon = 1, nbfonc +c + daux = 0.d0 + do 3211 , iaux = 1 , 8 + daux = daux + vafoen(nrofon,prfcan(ficn(1,iaux))) + 3211 continue +c + do 3213 , iaux = 1 , nfpyrp + vapytt(nrofon,ficp(2,iaux)) = daux * propor(iaux) + 3213 continue + do 3214 , iaux = 1 , nftetp + vatett(nrofon,ficp(3,iaux)) = daux * propor(iaux+nfpyrp) + 3214 continue +c + 321 continue +c + endif +c + endif +c +c==== +c 4. affectation des profils +c==== +c + if ( codret.eq.0 ) then +c + do 42 , iaux = 1 , nfpyrp + prfpyp(ficp(2,iaux)) = 1 + 42 continue +c + do 43 , iaux = 1 , nftetp + prftep(ficp(3,iaux)) = 1 + 43 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsep9.F b/src/tool/AP_Conversion/pcsep9.F new file mode 100644 index 00000000..1aa65687 --- /dev/null +++ b/src/tool/AP_Conversion/pcsep9.F @@ -0,0 +1,338 @@ + subroutine pcsep9 ( etan, etanp1, pehn, pehnp1, typint, + > f1hp, nrofon, valeur, coef, prfcap, + > ficp, propor, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, filpen, fppyte, + > npesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > prftep, vatett, + > prfpyp, vapytt, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres d'etat 80 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du pentaedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du pentaedre a l'iteration N+1 . +c . pehn . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . pehnp1 . e . 1 . PEntaedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . f1hp . e . 1 . Fils 1er du pentaedre en numerotation . +c . . . . Homard a l'iteration N+1 . +c . nrofon . e . 1 . numero de la fonction en cours d'examen . +c . valeur . e . 1 . valeur de la fonction en cours d'examen . +c . coef . e . 1 . coefficient pour la moyenne . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . ficp . e . 3,11 . fils en numerotation du calcul n+1 . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . propor . e . 11 . proportion de volume entre fils et pere . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEP9' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, pehn, pehnp1 + integer typint + integer f1hp, nrofon + integer nbfonc + integer prfcap(*) + integer ficp(3,11) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hetpen(nbpeto) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer npesca(rsheto) + integer ntesca(rsteto) + integer npysca(rspyto) + integer prftep(*) + integer prfpyp(*) +c + double precision valeur, coef +c + double precision propor(11) + double precision coonoe(nbnoto,sdim) + double precision vafott(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapytt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer fihp + integer etatfi +c + integer nfpenf, nfpyrf, nftetf + integer ficf(3,11) +c + double precision daux + double precision propof(11) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Pent. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current prism : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c +c==== +c 2. Exploration des 8 fils +c==== +c + do 20 , iaux = 0 , 7 +c + if ( codret.eq.0 ) then +c + fihp = f1hp + iaux + etatfi = mod(hetpen(fihp),100) +cgn write (ulsort,90015) 'fihp', fihp,', etat', hetpen(fihp) +c +c 2.1. ==> Le fils est actif +c + if ( etatfi.eq.0 ) then +c + if ( typint.eq.0 ) then + daux = valeur*coef + else + daux = valeur*propor(iaux+1) + endif +cgn write (ulsort,*) '. ficp', ficp(1,iaux+1) + vafott(nrofon,ficp(1,iaux+1)) = daux + prfcap(ficp(1,iaux+1)) = 1 +c +c 2.2. ==> Le fils est coupe en conformite +c + elseif ( ( etatfi.ge. 1 .and. etatfi.le. 6 ) .or. + > ( etatfi.ge.17 .and. etatfi.le.19 ) .or. + > ( etatfi.ge.21 .and. etatfi.le.26 ) .or. + > ( etatfi.ge.31 .and. etatfi.le.36 ) .or. + > ( etatfi.ge.43 .and. etatfi.le.45 ) .or. + > ( etatfi.ge.51 .and. etatfi.le.52 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEPY', nompro +#endif + call pcsepy ( nfpenf, nfpyrf, nftetf, ficf, + > fihp, etatfi, + > filpen, fppyte, + > npesca, ntesca, npysca, + > ulsort, langue, codret ) +c + if ( typint.eq.0 ) then +c + daux = valeur*coef + do 2203 , jaux = 1 , nfpyrf + vapytt(nrofon,ficf(2,jaux)) = daux + 2203 continue + do 2204 , jaux = 1 , nftetf + vatett(nrofon,ficf(3,jaux)) = daux + 2204 continue +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEPZ', nompro +#endif + call pcsepz ( propof, + > fihp, etatfi, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > filpen, fppyte, + > ulsort, langue, codret ) +c + daux = valeur*propor(iaux+1) + do 2213 , jaux = 1 , nfpyrf + vapytt(nrofon,ficf(2,jaux)) = daux * propof(jaux) + 2213 continue + do 2214 , jaux = 1 , nftetf + vatett(nrofon,ficf(3,jaux)) = daux * propof(jaux+nfpyrf) + 2214 continue +c + endif +c + if ( codret.eq.0 ) then +c + do 222 , jaux = 1 , nfpyrf + prfpyp(ficf(2,jaux)) = 1 + 222 continue +c + do 223 , jaux = 1 , nftetf + prftep(ficf(3,jaux)) = 1 + 223 continue +c + endif +c + else +c + codret = 1 + write (ulsort,texte(langue,4)) 'n ', pehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', pehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsepy.F b/src/tool/AP_Conversion/pcsepy.F new file mode 100644 index 00000000..af2ebc8d --- /dev/null +++ b/src/tool/AP_Conversion/pcsepy.F @@ -0,0 +1,247 @@ + subroutine pcsepy ( nfpent, nfpyra, nftetr, ficalc, + > lepent, etat, + > filpen, fppyte, + > npecca, ntecca, npycca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres - reperages des fils +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfpent . s . 1 . nombre de fils pentaedres . +c . nfpyra . s . 1 . nombre de fils pyramides . +c . nftetr . s . 1 . nombre de fils tetraedres . +c . ficalc . s . 3,11 . numeros des fils en numerotation du calcul . +c . . . . 1 : pentaedres . +c . . . . 2 : pyramides . +c . . . . 3 : tetraedres . +c . lepent . e . 1 . hexaedre courant . +c . etat . e . 1 . etat du pentaedre . +c . filpen . e . * . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . npecca . e . * . numero des pentaedres dans le calcul e/s . +c . ntecca . e . * . numero des tetraedres dans le calcul e/s . +c . npycca . e . * . pyramides en sortie dans le calcul e/s . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEPY' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nfpent, nfpyra, nftetr + integer ficalc(3,11) + integer lepent, etat +c + integer filpen(*), fppyte(2,*) + integer npecca(*) + integer ntecca(*) + integer npycca(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp2.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lepent, etat +#endif +c +c==== +c 2. denombrement des fils pour les differents cas de figure +c==== +c 2.0. ==> a priori, aucun +c + nfpent = 0 + nfpyra = 0 + nftetr = 0 +c +c 2.1. ==> etat = 1, ..., 6 : +c decoupage en 1 tetraedre et 2 pyramides +c + if ( etat.ge.1 .and. etat.le.6 ) then +c + nfpyra = 2 + nftetr = 1 +c +c 2.2. ==> etat = 17, ..., 19 : +c decoupage en 2 tetraedres et 1 pyramide. +c + elseif ( etat.ge.17 .and. etat.le.19 ) then +c + nfpyra = 1 + nftetr = 2 +c +c 2.3. ==> etat = 21, ..., 26 : +c decoupage en 6 tetraedres +c + elseif ( etat.ge.21 .and. etat.le.26 ) then +c + nftetr = 6 +c +c 2.4. ==> etat = 31, ..., 36 : +c decoupage en 10 tetraedres et 1 pyramide. +c + elseif ( etat.ge.31 .and. etat.le.36 ) then +c + nfpyra = 1 + nftetr = 10 +c +c 2.5. ==> etat = 43, ..., 45 : +c decoupage en 2 tetraedres et 4 pyramides +c + elseif ( etat.ge.43 .and. etat.le.45 ) then +c + nfpyra = 4 + nftetr = 2 +c +c 2.6. ==> etat = 51, 52 : +c decoupage en 11 tetraedres +c + elseif ( etat.ge.51 .and. etat.le.52 ) then +c + nftetr = 11 +c +c 2.7. ==> etat = 80 : +c decoupage en 8 pentaedres. +c + elseif ( etat.eq.80 .or. etat.eq.99 ) then +c + nfpent = 8 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nfpent', nfpent + write (ulsort,90002) 'nfpyra', nfpyra + write (ulsort,90002) 'nftetr', nftetr +#endif +c +c==== +c 3. Calcul +c==== +c 3.1. ==> Reperage des pentaedres fils du pentaedre +c + if ( nfpent.gt.0 ) then +c + jaux = filpen(lepent) - 1 + do 31 , iaux = 1 , nfpent + ficalc(1,iaux) = npecca(jaux+iaux) + 31 continue +cgn write(ulsort,90002) 'nfpent', nfpent +cgn write(ulsort,91020) (ficalc(1,iaux) , iaux = 1 , nfpent) +c + endif +c +c 3.2. ==> Reperage des pyramides filles du pentaedre +c + if ( nfpyra.gt.0 ) then +c + jaux = fppyte(1,-filpen(lepent)) - 1 + do 32 , iaux = 1 , nfpyra + ficalc(2,iaux) = npycca(jaux+iaux) + 32 continue +cgn write(ulsort,90002) 'nfpyra', nfpyra +cgn write(ulsort,91020) (ficalc(2,iaux) , iaux = 1 , nfpyra) +c + endif +c +c 3.3. ==> Reperage des tetraedres fils du pentaedre +c + if ( nftetr.gt.0 ) then +c + jaux = fppyte(2,-filpen(lepent)) - 1 + do 33 , iaux = 1 , nftetr + ficalc(3,iaux) = ntecca(jaux+iaux) + 33 continue +cgn write(ulsort,90002) 'nftetr', nftetr +cgn write(ulsort,91020) (ficalc(3,iaux) , iaux = 1 , nftetr) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsepz.F b/src/tool/AP_Conversion/pcsepz.F new file mode 100644 index 00000000..3b5fb0d5 --- /dev/null +++ b/src/tool/AP_Conversion/pcsepz.F @@ -0,0 +1,321 @@ + subroutine pcsepz ( propor, + > lepent, etat, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > filpen, fppyte, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Pentaedres - calcul des proportions fils/pere +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . propor . s . 11 . proportion de volume entre fils et pere . +c . lepent . e . 1 . hexaedre courant . +c . etat . e . 1 . etat du pentaedre . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEPZ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + integer lepent, etat +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer filpen(nbpeto), fppyte(2,nbpeco) +c + double precision propor(11) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer fipent, fipyra, fitetr + integer nfpent, nfpyra, nftetr, nbfils +c + double precision daux + double precision daux0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp2.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lepent, etat +#endif +c +c==== +c 2. denombrement des fils pour les differents cas de figure +c==== +c 2.0. ==> a priori, aucun +c + nfpent = 0 + nfpyra = 0 + nftetr = 0 +c +c 2.1. ==> etat = 1, ..., 6 : +c decoupage en 1 tetraedre et 2 pyramides +c + if ( etat.ge.1 .and. etat.le.6 ) then +c + nfpyra = 2 + nftetr = 1 +c +c 2.2. ==> etat = 17, ..., 19 : +c decoupage en 2 tetraedres et 1 pyramide. +c + elseif ( etat.ge.17 .and. etat.le.19 ) then +c + nfpyra = 1 + nftetr = 2 +c +c 2.3. ==> etat = 21, ..., 26 : +c decoupage en 6 tetraedres +c + elseif ( etat.ge.21 .and. etat.le.26 ) then +c + nftetr = 6 +c +c 2.4. ==> etat = 31, ..., 36 : +c decoupage en 10 tetraedres et 1 pyramide. +c + elseif ( etat.ge.31 .and. etat.le.36 ) then +c + nfpyra = 1 + nftetr = 10 +c +c 2.5. ==> etat = 43, ..., 45 : +c decoupage en 2 tetraedres et 4 pyramides +c + elseif ( etat.ge.43 .and. etat.le.45 ) then +c + nfpyra = 4 + nftetr = 2 +c +c 2.6. ==> etat = 51, 52 : +c decoupage en 11 tetraedres +c + elseif ( etat.ge.51 .and. etat.le.52 ) then +c + nftetr = 11 +c +c 2.7. ==> etat = 80 : +c decoupage en 8 pentaedres. +c + elseif ( etat.eq.80 .or. etat.eq.99 ) then +c + nfpent = 8 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nfpent', nfpent + write (ulsort,90002) 'nfpyra', nfpyra + write (ulsort,90002) 'nftetr', nftetr +#endif +c +c==== +c 3. Calcul +c==== +c 3.1. ==> Calcul des volumes +c Remarque : certains des volumes des fils sont identiques +c par paires, par construction. On les calcule quand meme +c pour la lisibilite du programme. +c + nbfils = nfpent + nfpyra + nftetr +c +c 3.1.1. ==> Pentaedres +c + if ( nfpent.gt.0 ) then +c + fipent = filpen(lepent) - 1 + do 321 , iaux = 1, nfpent + call utvpen ( fipent+iaux, propor(iaux), + > coonoe, somare, arequa, + > facpen, cofape, arepen ) + 321 continue +c + endif +c +c 3.1.2. ==> Pyramides +c + if ( nfpyra.gt.0 ) then +c + fipyra = fppyte(1,-filpen(lepent)) - 1 + do 322 , iaux = 1 , nfpyra + call utvpyr ( fipyra+iaux, propor(iaux), + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) + 322 continue +c + endif +c +c 3.1.3. ==> Tetraedres +c + if ( nftetr.gt.0 ) then +c + fitetr = fppyte(2,-filpen(lepent)) - 1 + do 323 , iaux = 1 , nftetr + call utvtet ( fitetr+iaux, propor(iaux+nfpyra), + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + 323 continue +c + endif +c +c 3.2. ==> Le volume total ; c'est donc le volume du pere +c + daux0 = 0.d0 + do 32 , iaux = 1, nbfils + daux0 = daux0 + propor(iaux) + 32 continue +c +c 3.3. ==> Rapport +c + do 33 , iaux = 1, nbfils + propor(iaux) = propor(iaux) / daux0 + 33 continue +c +#ifdef _DEBUG_HOMARD_ + if ( nfpent.gt.0 ) then + write (ulsort,90015) 'propor pour les', nfpent, ' pentaedres' + do 3391 , iaux = 1, nfpent + write (ulsort,90014) iaux, propor(iaux) + 3391 continue + endif + if ( nfpyra.eq.1 ) then + write (ulsort,90015) 'propor pour la pyramide' + write (ulsort,90014) 1, propor(1) + elseif ( nfpyra.gt.0 ) then + write (ulsort,90015) 'propor pour les', nfpyra, ' pyramides' + do 3392 , iaux = 1, nfpyra + write (ulsort,90014) iaux, propor(iaux) + 3392 continue + endif + if ( nftetr.eq.1 ) then + write (ulsort,90015) 'propor pour le tetradre' + write (ulsort,90014) 1, propor(1+nfpyra) + elseif ( nftetr.gt.0 ) then + write (ulsort,90015) 'propor pour les', nftetr, ' tetradres' + do 3393 , iaux = 1, nftetr + write (ulsort,90014) iaux, propor(iaux+nfpyra) + 3393 continue + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseq0.F b/src/tool/AP_Conversion/pcseq0.F new file mode 100644 index 00000000..42a7cb0b --- /dev/null +++ b/src/tool/AP_Conversion/pcseq0.F @@ -0,0 +1,471 @@ + subroutine pcseq0 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, filqua, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Quadrangles d'etat anterieur 0 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du quadrangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 . +c . quhn . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEQ0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, quhn, quhnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), filqua(nbquto) + integer nqueca(requto), nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntrsca(rstrto) + integer prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c + integer qucn, qucnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c + integer coderr + integer nrofon + integer iaux +c + double precision daux + double precision daux0, daux1, daux2, daux3, daux4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + coderr = 0 +c +c 1.2. ==> on repere son ancien numero dans le calcul +c + qucn = nqueca(quhn) +#ifdef _DEBUG_HOMARD_ + write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 + write(ulsort,90002) 'qucn', qucn + call dmflsh (iaux) +#endif +c + if ( prfcan(qucn).gt.0 ) then +c +c==== +c 2. etan = 0 : le quadrangle etait actif +c On explore tous les etats du quadrangle a l'iteration n+1 +c==== +c 2.1. ==> etanp1 = 0 : le quadrangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du quadrangle. +c +c ................. ................. +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,90002)'quadrangle garde - prfcan', prfcan(qucn) +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc + vafott(nrofon,qucnp1) = vafoen(nrofon,prfcan(qucn)) +cgn write(ulsort,90004)'Valeurs anciennes', +cgn > vafoen(nrofon,prfcan(qucn)) + 21 continue +cgn write(ulsort,90002) 'qucnp1',qucnp1 +c +c 2.2. ==> etanp1 = 21/22 : le quadrangle etait actif et +c il est decoupe en 2. +c les deux fils prennent la valeur de la fonction sur le pere +c ................. ................. +c . . . . +c . . . . +c . . . . +c . . ===> ................. +c . . . . +c . . . . +c . . . . +c ................. ................. +c + elseif ( etanp1.eq.21 .or. etanp1.eq.22 ) then +cgn write(ulsort,*)'... quadrangle coupe en 2' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +cgn write(*,*) 'f1cp = ',f1cp +cgn write(*,*) 'f2cp = ',f2cp + if ( typint.eq.0 ) then + do 221 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) daux + 221 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + do 222 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux +cgn write(ulsort,92010) daux + 222 continue + endif +cgn write(23,91010) f1cp,f2cp +cgn write(ulsort,91010) qucn,-1, +cgn > f1cp,f2cp +c +c 2.3. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle etait actif +c et il est decoupe en 3 triangles. +c les trois fils prennent la valeur de la fonction sur le pere +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . ===> . . . . +c . . . . . . +c . . . . . . +c . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +cgn write(ulsort,91010) f1cp,f2cp,f3cp +cgn write(ulsort,91010) qucn,-1, +cgn > f1cp,f2cp,f3cp + if ( typint.eq.0 ) then + do 231 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vatrtt(nrofon,f1cp) = daux + vatrtt(nrofon,f2cp) = daux + vatrtt(nrofon,f3cp) = daux + 231 continue + else + call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri ) + call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri ) + call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 232 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vatrtt(nrofon,f1cp) = daux1 * daux + vatrtt(nrofon,f2cp) = daux2 * daux + vatrtt(nrofon,f3cp) = daux3 * daux + 232 continue + endif +c +c 2.4. ==> etanp1 = 4 : le quadrangle etait actif et +c il est decoupe en 4. +c les quatre fils prennent la valeur de la fonction sur le pere +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.eq.4 ) then +cgn write(ulsort,*)'... quadrangle coupe en 4 quadrangles' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +cgn write(*,*) 'f1cp = ',f1cp +cgn write(*,*) 'f2cp = ',f2cp +cgn write(*,*) 'f3cp = ',f3cp +cgn write(*,*) 'f4cp = ',f4cp + if ( typint.eq.0 ) then + do 241 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux +cgn write(ulsort,92010) daux + 241 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + call utqqua ( f1hp+3, daux, daux4, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux4 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + daux4 = daux4 / daux0 + do 242 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux + vafott(nrofon,f3cp) = daux3 * daux + vafott(nrofon,f4cp) = daux4 * daux +cgn write(ulsort,92010) daux + 242 continue + endif +cgn write(23,91010) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,91010) qucn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +c +c 2.5. ==> etanp1 = 41, ..., 44 : le quadrangle etait actif +c et est decoupe en 3 quadrangles. +c les trois fils prennent la valeur de la fonction +c sur le pere +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ......... . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 quadrangles' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +cgn write(*,*) 'f1cp = ',f1cp +cgn write(*,*) 'f2cp = ',f2cp +cgn write(*,*) 'f3cp = ',f3cp + if ( typint.eq.0 ) then + do 251 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + 251 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 252 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(qucn)) + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux + vafott(nrofon,f3cp) = daux3 * daux + 252 continue + endif +cgn write(23,91010) f1cp,f2cp,f3cp +cgn write(ulsort,91010) qucn,-1, +cgn > f1cp,f2cp,f3cp +c +c 2.6. ==> aucun autre etat sur le quadrangle courant n'est possible +c + else +c + coderr = 1 + write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 + write (ulsort,*) ' ' +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + coderr +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseq1.F b/src/tool/AP_Conversion/pcseq1.F new file mode 100644 index 00000000..f7874ca8 --- /dev/null +++ b/src/tool/AP_Conversion/pcseq1.F @@ -0,0 +1,680 @@ + subroutine pcseq1 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Quadrangles d'etat anterieur 21-22 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du quadrangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 . +c . quhn . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEQ1' ) +c +#include "nblang.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, quhn, quhnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntrsca(rstrto) + integer prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c + integer qucnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du quadrangle en numerotation Homard a l'it. N+1 +c ficp = Fils ieme du quadrangle en numerotation Calcul a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, fihp, ficp + integer f1cp, f2cp, f3cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn +c +c f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1 +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fhp, f1fcp, f2fcp, f3fcp +c + integer coderr + integer nrofon + integer iaux +c + double precision daux + double precision daux0, daux1, daux2, daux3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour les fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c==== +c 2. le quadrangle etait coupe en 2 quadrangles +c==== +c 2.1. ==> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c on lui attribue la valeur moyenne des deux anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . +c . . . . +c . . . . +c ................. ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*)'... quadrangle reactive' +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + if ( typint.eq.0 ) then + daux1 = unsde + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1 , nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,qucnp1) = daux + 21 continue +c +c 2.2. ==> etanp1 = etan : le quadrangle est decoupe en +c deux quadrangles selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c quadrangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdqu), le premier fils +c est toujours le meme, le 2nd egalement. +c on prendra alors la valeur sur le fils de rang identique +c a l'iteration n. +c ................. ................. +c . . . . +c . . . . +c . . . . +c ................. ===> ................. +c . . . . +c . . . . +c . . . . +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +cgn write(ulsort,*)'... quadrangle coupe en 2 ; meme decoupage' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 22 , nrofon = 1 , nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) + 22 continue +cgn write(ulsort,90002)'f1cp, f2cp', f1cp, f2cp +c +c 2.3. ==> etanp1 = 21/22 : le quadrangle est decoupe en +c deux quadrangles selon un autre decoupage. +c On donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> . . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. + elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then +cgn write(ulsort,*)'... quadrangle coupe en 2 ; autre decoupage' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + if ( typint.eq.0 ) then + do 231 , nrofon = 1 , nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 231 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + do 232 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux +cgn write(ulsort,92010) daux + 232 continue + endif +c +c 2.4. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle est decoupe en +c trois triangles. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . .. .. +c . . . . . . +c . . . . . . +c ................. ===> . . . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 241 , nrofon = 1 , nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,90004) 'daux', daux + vatrtt(nrofon,f1cp) = daux + vatrtt(nrofon,f2cp) = daux + vatrtt(nrofon,f3cp) = daux + 241 continue +c + else +c + call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri ) + call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri ) + call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 242 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + vatrtt(nrofon,f1cp) = daux1 * daux + vatrtt(nrofon,f2cp) = daux2 * daux + vatrtt(nrofon,f3cp) = daux3 * daux + 242 continue +c + endif +c +c 2.5. ==> etanp1 = 4 : le quadrangle est decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur un ou plusieurs +c des fils. Ce ou ces fils sont obligatoirement du cote du +c precedent point de non conformite. Ils ne peuvent pas etre +c des decoupages en 2 car une arte interne ne peut pas avoir +c ete coupee puisqu'elle n'existait pas. +c +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . .. .. . +c ................. ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . +c . . .... . . +c . . . . . . +c ................. ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c +c On parcourt chacun des 4 quadrangles fils et on distingue +c le cas ou il est actif et le cas ou il est coupe en 3 triangles +c ou en 3 quadrangles +c + elseif ( etanp1.eq.4 ) then +cgn write(ulsort,*)'... quadrangle coupe en 4 quadrangles' +c + f1hp = filqua(quhnp1) + if ( typint.eq.0 ) then +c + do 251 , nrofon = 1 , nbfonc +c + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,90004) 'daux', daux +c + do 2511 , iaux = 0 , 3 + fihp = f1hp + iaux +cgn write (ulsort,texte(langue,4)) 'n+1', fihp +cgn write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) + vafott(nrofon,ficp) = daux + prfcap(ficp) = 1 + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + vatrtt(nrofon,f1fcp) = daux + vatrtt(nrofon,f2fcp) = daux + vatrtt(nrofon,f3fcp) = daux + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + vafott(nrofon,f3fcp) = daux + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif + 2511 continue +c + 251 continue +c + else +c + call utqqua ( quhn, daux, daux0, coonoe, somare, arequa ) +c + do 252 , iaux = 0 , 3 +c + fihp = f1hp + iaux + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) + prfcap(ficp) = 1 + call utqqua ( fihp, daux, daux1, coonoe, somare, arequa ) + do 2521 , nrofon = 1 , nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) / daux0 + vafott(nrofon,ficp) = daux + 2521 continue + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + call utqtri ( f1fhp , daux, daux1, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+1, daux, daux2, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+2, daux, daux3, + > coonoe, somare, aretri ) + do 2522 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + vatrtt(nrofon,f1fcp) = daux1 * daux / daux0 + vatrtt(nrofon,f2fcp) = daux2 * daux / daux0 + vatrtt(nrofon,f3fcp) = daux3 * daux / daux0 + 2522 continue + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + call utqqua ( f1fhp , daux, daux1, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+1, daux, daux2, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+2, daux, daux3, + > coonoe, somare, arequa ) + do 2523 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + vafott(nrofon,f1fcp) = daux1 * daux / daux0 + vafott(nrofon,f2fcp) = daux2 * daux / daux0 + vafott(nrofon,f3fcp) = daux3 * daux / daux0 + 2523 continue + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif +c + 252 continue +c + endif +c +c 2.6. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en +c trois quadrangles +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> ......... . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 quadrangles' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c +cgn write(*,91010) f1cp,f2cp + if ( typint.eq.0 ) then +c + do 261 , nrofon = 1 , nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux +cgn write(*,92010) daux + 261 continue +c + else +c + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 262 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) +cgn write(ulsort,90004) 'unsqu*daux', unsqu*daux +cgn write(ulsort,90004) 'trshu*daux', trshu*daux + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux + vafott(nrofon,f3cp) = daux3 * daux +cgn write(*,92010) daux + 262 continue +c + endif +c +c 2.7. ==> aucun autre etat sur le quadrangle courant n'est possible +c + else +c + coderr = 1 + write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + coderr +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseq2.F b/src/tool/AP_Conversion/pcseq2.F new file mode 100644 index 00000000..647fe972 --- /dev/null +++ b/src/tool/AP_Conversion/pcseq2.F @@ -0,0 +1,726 @@ + subroutine pcseq2 ( etan, etanp1, quhn, quhnp1, typint, + > prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqusca, + > aretri, + > ntreca, ntrsca, + > nbfonc, vafott, + > vatren, vatrtt, + > prftrn, prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Quadrangles d'etat anterieur 31, 32, 33, 34 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du quadrangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 . +c . quhn . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatren . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEQ2' ) +c +#include "nblang.h" +#include "fractb.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, quhn, quhnp1 + integer typint + integer nbfonc + integer prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu) + integer nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntreca(retrto), ntrsca(rstrto) + integer prftrn(*), prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafott(nbfonc,*) + double precision vatren(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c + integer qucnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du quadrangle en numerotation Homard a l'it. N+1 +c ficp = Fils ieme du quadrangle en numerotation Calcul a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, fihp, ficp + integer f1cp, f2cp, f3cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn +c +c f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1 +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fhp, f1fcp, f2fcp, f3fcp +c + integer coderr + integer nrofon + integer iaux +c + double precision daux + double precision daux0, daux1, daux2, daux3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour les fils +c a l'iteration n +c + f1hn = -anfiqu(quhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) +c + if ( prftrn(f1cn).gt.0 .and. prftrn(f2cn).gt.0 .and. + > prftrn(f3cn).gt.0 ) then +c +c==== +c 2. le quadrangle etait coupe en 3 triangles +c==== +c 2.1. ==> etanp1 = 0 : le quadrangle est actif. il est +c reactive. +c on lui attribue la valeur moyenne sur les trois +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . . . ===> . . +c . . . . . . +c . . . . . . +c .. .. . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*)'... quadrangle reactive' +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + if ( typint.eq.0 ) then + daux1 = unstr + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1 , nbfonc + daux = daux1 * ( vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,qucnp1) = daux +cgn write(ulsort,92010) vatren(nrofon,prftrn(qucnp1)) + 21 continue +c +c 2.2. ==> etanp1 = 21 ou 22 : le quadrangle est decoupe en deux +c quadrangles +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> . . . +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c + elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then +cgn write(ulsort,*)'... quadrangle coupe en 2' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +cgn write (ulsort,90002) 'f1cp, f2cp', f1cp, f2cp +c + if ( typint.eq.0 ) then + do 221 , nrofon = 1 , nbfonc + daux = unstr * ( vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(*,92010) daux + 221 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + do 222 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux +cgn write(*,92010) daux + 222 continue + endif +c +c 2.3. ==> etanp1 = etan : le quadrangle est decoupe en +c trois triangles selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c quadrangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdqu), le premier fils +c est toujours le meme, le 2eme et le 3eme egalement. +c on prendra alors la valeur sur le fils de rang identique +c a l'iteration n. +c ................. ................. +c . . . . . . . . +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. .. .. +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles ; meme dec' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c +cgn write(32,91010) f1cp,f2cp,f3cp + do 230 , nrofon = 1 , nbfonc + vatrtt(nrofon,f1cp) = vatren(nrofon,prftrn(f1cn)) + vatrtt(nrofon,f2cp) = vatren(nrofon,prftrn(f2cn)) + vatrtt(nrofon,f3cp) = vatren(nrofon,prftrn(f3cn)) +cgn write(ulsort,92010) vatren(nrofon,prftrn(f1cn)), +cgn > vatren(nrofon,prftrn(f2cn)), +cgn > vatren(nrofon,prftrn(f3cn)) + 230 continue +c +c 2.4. ==> etanp1 = 31, 32, 33 ou 34 et different de etan : +c le quadrangle est encore decoupe en trois triangles, +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . .. .. +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles ; autre' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 241 , nrofon = 1 , nbfonc + daux = unstr * ( vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux + vatrtt(nrofon,f1cp) = daux + vatrtt(nrofon,f2cp) = daux + vatrtt(nrofon,f3cp) = daux + 241 continue +c + else +c + call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri ) + call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri ) + call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 242 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) +cgn write(ulsort,90004) 'unsde*daux', unsde*daux +cgn write(ulsort,90004) 'unsqu*daux', unsqu*daux + vatrtt(nrofon,f1cp) = daux1 * daux + vatrtt(nrofon,f2cp) = daux2 * daux + vatrtt(nrofon,f3cp) = daux3 * daux + 242 continue +c + endif +c +c 2.5. ==> etanp1 = 4 : le quadrangle est decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur un ou plusieurs +c des fils. Ce ou ces fils sont obligatoirement du cote du +c precedent point de non conformite. Ils ne peuvent pas etre +c des decoupages en 2 car une arte interne ne peut pas avoir +c ete coupee puisqu'elle n'existait pas. +c +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . . . . +c . . . . . . . . . +c . . . . .. .. . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . . . +c . . . . .... . . +c . . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c +c On parcourt chacun des 4 quadrangles fils et on distingue +c le cas ou il est actif et le cas ou il est coupe en 3 triangles +c ou en 3 quadrangles +c + elseif ( etanp1.eq.4 ) then +cgn write(ulsort,*)'... quadrangle coupe en 4 quadrangles' +c + f1hp = filqua(quhnp1) + if ( typint.eq.0 ) then +c + do 251 , nrofon = 1 , nbfonc +c + daux = unstr * ( vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux +c + do 2511 , iaux = 0 , 3 + fihp = f1hp + iaux +cgn write (ulsort,texte(langue,4)) 'n+1', fihp +cgn write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) +cgn write (ulsort,90002) 'ficp', ficp + vafott(nrofon,ficp) = daux + prfcap(ficp) = 1 + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + vatrtt(nrofon,f1fcp) = daux + vatrtt(nrofon,f2fcp) = daux + vatrtt(nrofon,f3fcp) = daux + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + vafott(nrofon,f3fcp) = daux + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif + 2511 continue +c + 251 continue +c + else +c + call utqqua ( quhn, daux, daux0, coonoe, somare, arequa ) +c + do 252 , iaux = 0 , 3 +c + fihp = f1hp + iaux + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) + prfcap(ficp) = 1 + call utqqua ( fihp, daux, daux1, coonoe, somare, arequa ) + do 2521 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) + vafott(nrofon,ficp) = daux * daux1 / daux0 + 2521 continue + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + call utqtri ( f1fhp , daux, daux1, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+1, daux, daux2, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+2, daux, daux3, + > coonoe, somare, aretri ) + do 2522 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) + vatrtt(nrofon,f1fcp) = daux1 * daux / daux0 + vatrtt(nrofon,f2fcp) = daux2 * daux / daux0 + vatrtt(nrofon,f3fcp) = daux3 * daux / daux0 + 2522 continue + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + call utqqua ( f1fhp , daux, daux1, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+1, daux, daux2, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+2, daux, daux3, + > coonoe, somare, arequa ) + do 2523 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) + vafott(nrofon,f1fcp) = daux1 * daux / daux0 + vafott(nrofon,f2fcp) = daux2 * daux / daux0 + vafott(nrofon,f3fcp) = daux3 * daux / daux0 + 2523 continue + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif +c + 252 continue +c + endif +c +c 2.6. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en +c trois quadrangles +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ......... . +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 quadrangles' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 261 , nrofon = 1 , nbfonc + daux = unstr * ( vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + 261 continue +c + else +c + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 262 , nrofon = 1 , nbfonc + daux = vatren(nrofon,prftrn(f1cn)) + > + vatren(nrofon,prftrn(f2cn)) + > + vatren(nrofon,prftrn(f3cn)) + vafott(nrofon,f1cp) = daux1 * daux + vafott(nrofon,f2cp) = daux2 * daux + vafott(nrofon,f3cp) = daux3 * daux + 262 continue +c + endif + +c 2.7. ==> aucun autre etat sur le quadrangle courant n'est possible +c + else +c + coderr = 1 + write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + coderr +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseq3.F b/src/tool/AP_Conversion/pcseq3.F new file mode 100644 index 00000000..5e08b6f7 --- /dev/null +++ b/src/tool/AP_Conversion/pcseq3.F @@ -0,0 +1,458 @@ + subroutine pcseq3 ( etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Quadrangles d'etat anterieur 4 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 . +c . quhn . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEQ3' ) +c +#include "nblang.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etanp1, quhn, quhnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), filqua(nbquto) + integer nbanqu, anfiqu(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntrsca(rstrto) + integer prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c + integer qucnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c + integer coderr + integer nrofon + integer iaux +c + double precision daux + double precision daux0, daux1, daux2, daux3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour les fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) + f3cn = nqueca(f1hn+2) + f4cn = nqueca(f1hn+3) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f3cn).gt.0 ) then +c +c==== +c 2. le quadrangle etait coupe en 4 quadrangles +c==== +c 2.1. ==> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c on lui attribue la valeur moyenne des quatre anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*)'... quadrangle reactive' +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + if ( typint.eq.0 ) then + daux1 = unsqu + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1 , nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,qucnp1) = daux + 21 continue +c +c 2.2. ==> etanp1 = 21/22 : le quadrangle est decoupe en +c deux quadrangles +c On donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ===> . . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. + elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then +cgn write(ulsort,*)'... quadrangle coupe en 2' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + if ( typint.eq.0 ) then + do 221 , nrofon = 1 , nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 221 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + do 222 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + vafott(nrofon,f1cp) = daux * daux1 + vafott(nrofon,f2cp) = daux * daux2 + 222 continue + endif +c +c 2.3. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle est +c decoupe en trois triangles. +c on attribue la valeur moyenne sur les quatre anciens +c fils a chacune des trois nouveaux fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 + if ( typint.eq.0 ) then + do 231 , nrofon = 1 , nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vatrtt(nrofon,f1cp) = daux + vatrtt(nrofon,f2cp) = daux + vatrtt(nrofon,f3cp) = daux + 231 continue + else + call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri ) + call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri ) + call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 232 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + vatrtt(nrofon,f1cp) = daux * daux1 + vatrtt(nrofon,f2cp) = daux * daux2 + vatrtt(nrofon,f3cp) = daux * daux3 + 232 continue + endif +c +c 2.4. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en +c trois quadrangles +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ===> ......... . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +cgn print *,'... le quadrangle est coupe en 3 quadrangles' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 241 , nrofon = 1 , nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + 241 continue +c + else +c + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 242 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) +cgn write(ulsort,90004) 'unsqu*daux', unsqu*daux +cgn write(ulsort,90004) 'trshu*daux', trshu*daux + vafott(nrofon,f1cp) = daux * daux1 + vafott(nrofon,f2cp) = daux * daux2 + vafott(nrofon,f3cp) = daux * daux3 + 242 continue +c + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + coderr +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcseq4.F b/src/tool/AP_Conversion/pcseq4.F new file mode 100644 index 00000000..907515fd --- /dev/null +++ b/src/tool/AP_Conversion/pcseq4.F @@ -0,0 +1,694 @@ + subroutine pcseq4 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Quadrangles d'etat anterieur 41, 42, 43, 44 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du quadrangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 . +c . quhn . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSEQ4' ) +c +#include "nblang.h" +#include "fractb.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, quhn, quhnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntrsca(rstrto) + integer prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c + integer qucnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du quadrangle en numerotation Homard a l'it. N+1 +c ficp = Fils ieme du quadrangle en numerotation Calcul a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, fihp, ficp + integer f1cp, f2cp, f3cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn +c +c f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1 +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fhp, f1fcp, f2fcp, f3fcp +c + integer coderr + integer nrofon + integer iaux +c + double precision daux + double precision daux0, daux1, daux2, daux3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour les fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) + f3cn = nqueca(f1hn+2) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 ) then +c +c==== +c 2. le quadrangle etait coupe en 2 quadrangles +c==== +c 2.1. ==> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c on lui attribue la valeur moyenne des deux anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ......... . ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn write(ulsort,*)'... quadrangle reactive' +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + if ( typint.eq.0 ) then + daux1 = unstr + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1 , nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux + vafott(nrofon,qucnp1) = daux + 21 continue +c +c 2.2. ==> etanp1 = 21 ou 22 : le quadrangle est decoupe en +c deux quadrangles +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ......... . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.eq.21 .or. etanp1.eq.22 ) then +cgn write(ulsort,*)'... quadrangle coupe en 2' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + do 221 , nrofon = 1 , nbfonc + daux = unstr * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 221 continue + else + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + do 222 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vafott(nrofon,f1cp) = daux * daux1 + vafott(nrofon,f2cp) = daux * daux2 + 222 continue + endif +c +c 2.3. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle est decoupe en +c trois triangles. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . .. .. +c . . . . . . . +c . . . . . . . +c ......... . ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 triangles' +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 231 , nrofon = 1 , nbfonc + daux = unstr * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) ) + vatrtt(nrofon,f1cp) = daux + vatrtt(nrofon,f2cp) = daux + vatrtt(nrofon,f3cp) = daux + 231 continue +c + else +c + call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri ) + call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri ) + call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 232 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vatrtt(nrofon,f1cp) = daux * daux1 + vatrtt(nrofon,f2cp) = daux * daux2 + vatrtt(nrofon,f3cp) = daux * daux3 + 232 continue +c + endif +c +c 2.4. ==> etanp1 = 4 : le quadrangle est decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur un ou plusieurs +c des fils. Ce ou ces fils sont obligatoirement du cote du +c precedent point de non conformite. Ils ne peuvent pas etre +c des decoupages en 2 car une arte interne ne peut pas avoir +c ete coupee puisqu'elle n'existait pas. +c +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ......... . ===> ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . . . +c . . . . . . . . +c . . . .. .. . +c ......... . ===> ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c +c ................. ................. +c . . . . . . . +c . . . .... . . +c . . . . . . . +c ......... . ===> ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c +c On parcourt chacun des 4 quadrangles fils et on distingue +c le cas ou il est actif et le cas ou il est coupe en 3 triangles +c + elseif ( etanp1.eq.4 ) then + if ( quhn.eq.498 ) then + write(ulsort,*)'... quadrangle coupe en 4 quadrangles' + endif +c + f1hp = filqua(quhnp1) + if ( typint.eq.0 ) then +c + do 241 , nrofon = 1 , nbfonc +c + daux = unstr * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) ) +cgn write(ulsort,90004) 'daux', daux +c + do 2411 , iaux = 0 , 3 + fihp = f1hp + iaux +cgn if ( quhn.eq.498 ) then +cgn write (ulsort,texte(langue,4)) 'n+1', fihp +cgn write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) +cgn endif + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) + vafott(nrofon,ficp) = daux + prfcap(ficp) = 1 + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + vatrtt(nrofon,f1fcp) = daux + vatrtt(nrofon,f2fcp) = daux + vatrtt(nrofon,f3fcp) = daux + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + vafott(nrofon,f3fcp) = daux + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif + 2411 continue +c + 241 continue +c + else +c + call utqqua ( quhn, daux, daux0, coonoe, somare, arequa ) +c + do 242 , iaux = 0 , 3 +c + fihp = f1hp + iaux + if ( mod(hetqua(fihp),100).eq.0 ) then + ficp = nqusca(fihp) + prfcap(ficp) = 1 + call utqqua ( fihp, daux, daux1, coonoe, somare, arequa ) + do 2421 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vafott(nrofon,ficp) = daux * daux1 / daux0 + 2421 continue + elseif ( mod(hetqua(fihp),100).ge.31 .and. + > mod(hetqua(fihp),100).le.34 ) then + f1fhp = -filqua(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 + prftrp(f3fcp) = 1 + call utqtri ( f1fhp , daux, daux1, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+1, daux, daux2, + > coonoe, somare, aretri ) + call utqtri ( f1fhp+2, daux, daux3, + > coonoe, somare, aretri ) + do 2422 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vatrtt(nrofon,f1fcp) = daux * daux1 / daux0 + vatrtt(nrofon,f2fcp) = daux * daux2 / daux0 + vatrtt(nrofon,f3fcp) = daux * daux3 / daux0 + 2422 continue + elseif ( mod(hetqua(fihp),100).ge.41 .and. + > mod(hetqua(fihp),100).le.44 ) then + f1fhp = filqua(fihp) + f1fcp = nqusca(f1fhp) + f2fcp = nqusca(f1fhp+1) + f3fcp = nqusca(f1fhp+2) +c + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + call utqqua ( f1fhp , daux, daux1, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+1, daux, daux2, + > coonoe, somare, arequa ) + call utqqua ( f1fhp+2, daux, daux3, + > coonoe, somare, arequa ) + do 2423 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vafott(nrofon,f1fcp) = daux * daux1 / daux0 + vafott(nrofon,f2fcp) = daux * daux2 / daux0 + vafott(nrofon,f3fcp) = daux * daux3 / daux0 + 2423 continue + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hetqua(fihp) + write (ulsort,texte(langue,7)) etan + endif +c + 242 continue +c + endif +c +c 2.5. ==> etanp1 = etan : le quadrangle est decoupe en +c trois quadrangles selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdqu), le premier fils +c est toujours le meme, le 2eme et le 3eme egalement. +c on prendra alors la valeur sur le fils de rang identique +c a l'iteration n. +c +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ......... . ===> ......... . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 quad ; meme dec' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +cgn write(ulsort,90002) 'f1cp,f2cp,f3cp', f1cp,f2cp,f3cp +c +cgn write(ulsort,90004) 'vafoen', vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)),vafoen(nrofon,prfcan(f3cn)) + do 25 , nrofon = 1 , nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) + vafott(nrofon,f3cp) = vafoen(nrofon,prfcan(f3cn)) + 25 continue +c +c 2.6. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en +c trois quadrangles +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c ......... . ===> . ......... +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +cgn write(ulsort,*)'... quadrangle coupe en 3 quad; autre dec' +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c + if ( typint.eq.0 ) then +c + do 261 , nrofon = 1 , nbfonc + daux = unstr * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + 261 continue +c + else +c + call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa ) + call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa ) + call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa ) + daux0 = daux1 + daux2 + daux3 + daux1 = daux1 / daux0 + daux2 = daux2 / daux0 + daux3 = daux3 / daux0 + do 262 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + vafott(nrofon,f1cp) = daux * daux1 + vafott(nrofon,f2cp) = daux * daux2 + vafott(nrofon,f3cp) = daux * daux3 + 262 continue +c + endif +c +c 2.7. ==> aucun autre etat sur le quadrangle courant n'est possible +c + else +c + coderr = 1 + write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcset0.F b/src/tool/AP_Conversion/pcset0.F new file mode 100644 index 00000000..8f550fd5 --- /dev/null +++ b/src/tool/AP_Conversion/pcset0.F @@ -0,0 +1,328 @@ + subroutine pcset0 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > filtet, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Tetraedres d'etat anterieur 0 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSET0' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer filtet(nbteto) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c tecn = TEtraedre courant en numerotation du Calcul a l'it. N +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecn, tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f5cp = Fils 5eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f6cp = Fils 6eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f7cp = Fils 7eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f8cp = Fils 8eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp, f5cp, f6cp, f7cp, f8cp +c + integer coderr + integer nrofon +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'( ''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'( ''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +#include "impr03.h" +c +c 1.2. ==> on repere son ancien numero dans le calcul +c +cgn print *,(ntesca(nrofon),nrofon=1,nbteto) +cgn print *,(filtet(nrofon),nrofon=1,nbteto) + tecn = nteeca(tehn) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,4)) 'nca', tecn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + write (ulsort,*) ' ==> prfcan(tecn) = ', prfcan(tecn) + call dmflsh (iaux) +#endif +c +c==== +c 2. On explore tous les etats du tetraedre a l'iteration n+1 +c==== +c + if ( prfcan(tecn).gt.0 ) then +c +c 2.1. ==> etanp1 = 0 : le tetraedre est actif ; il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du tetraedre. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + do 21 , nrofon = 1, nbfonc + vafott(nrofon,tecnp1) = vafoen(nrofon,prfcan(tecn)) +cgn write(ulsort,90014) nrofon,vafoen(nrofon,prfcan(tecn)) + 21 continue +c +c 2.2. ==> etanp1 = 21, ..., 26 : le tetraedre est decoupe en 2. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + daux1 = 1.d0 + else + daux1 = unsde + endif + do 22 , nrofon = 1, nbfonc + daux = daux1 * vafoen(nrofon,prfcan(tecn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 22 continue +cgn write(12,91020) f1cp,f2cp +cgn write(ulsort,91020) tecn,-1, +cgn > f1cp,f2cp +c +c 2.3. ==> etanp1 = 41, ... 47 : le tetraedre est decoupe en 4. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + if ( typint.eq.0 ) then + daux1 = 1.d0 + else + daux1 = unsqu + endif + do 23 , nrofon = 1, nbfonc + daux = daux1 * vafoen(nrofon,prfcan(tecn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux + 23 continue +c +c 2.4. ==> etanp1 = 81, 86, 87 : le tetraedre est decoupe en 8. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + f5cp = ntesca(f1hp+4) + f6cp = ntesca(f1hp+5) + f7cp = ntesca(f1hp+6) + f8cp = ntesca(f1hp+7) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + prfcap(f5cp) = 1 + prfcap(f6cp) = 1 + prfcap(f7cp) = 1 + prfcap(f8cp) = 1 + if ( typint.eq.0 ) then + daux1 = 1.d0 + else + daux1 = unshu + endif + do 24 , nrofon = 1, nbfonc + daux = daux1 * vafoen(nrofon,prfcan(tecn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux + vafott(nrofon,f5cp) = daux + vafott(nrofon,f6cp) = daux + vafott(nrofon,f7cp) = daux + vafott(nrofon,f8cp) = daux + 24 continue +cgn write(14,91020) f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp +cgn write(ulsort,91020) tecn,-1, +cgn > f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp +c +c 2.5. ==> aucun autre etat sur le tetraedre courant n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcset2.F b/src/tool/AP_Conversion/pcset2.F new file mode 100644 index 00000000..acaeff99 --- /dev/null +++ b/src/tool/AP_Conversion/pcset2.F @@ -0,0 +1,462 @@ + subroutine pcset2 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Tetraedres d'etat anterieur 2 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSET2' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer hettet(nbteto), filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c fihp = Fils ieme u tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn +c +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1 +c f4fcp = Fils 4eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fcp, f2fcp, f3fcp, f4fcp +c + integer nrofon + integer coderr +c + integer iaux + integer lglist, nrlist + integer list(30) +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses deux fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c==== +c 2. Le tetraedre etait coupe en 2 +c On explore tous les etats du tetraedre a l'iteration n+1 +c==== +c +c 2.1. ==> etanp1 = 0 : le tetraedre est reactive. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 + if ( typint.eq.0 ) then + daux1 = unsde + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,tecnp1) = daux + 21 continue +c +c 2.1. ==> etanp1 = etan : le tetraedre est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdte), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 22 , nrofon = 1, nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) + 22 continue +cgn write(22,7777) f1cp,f2cp +cgn write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp +c +c 2.3. ==> etanp1 = 21, ..., 26 et different de etan : +c le tetraedre est encore decoupe en 2 par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 23 , nrofon = 1, nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 23 continue +cgn write(23,7777) f1cp,f2cp +cgn write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp +c +c 2.4. ==> etanp1 = 41, 42, 43 ou 44 : le tetraedre est +c decoupe en quatre par une face. +c 2.5. ==> etanp1 = 45, 46 ou 47 : le tetraedre est +c decoupe en quatre par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + if ( typint.eq.0 ) then + daux1 = unsde + else + daux1 = unsqu + endif + do 24 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux + 24 continue +cgn write(24,7777) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,7777) f1cn,f2cn,-1,f1cp,f2cp,f3cp,f4cp +c +c 2.6. ==> etanp1 = 85, 86 ou 87 : le tetraedre est +c decoupe en huit par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c le tetraedre a ete decoupe en standard. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c attention : il est possible que les fils sur les bords +c soient decoupes par de la conformite. Il faut +c alors transmettre la valeur a leurs 2 ou 4 +c fils. +c attention : ce n'est pas comme en 2D ; il faut examiner +c tous les fils, car par contamination de faces +c coupees en 2, les fils centraux peuvent etre +c decoupes. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + if ( typint.eq.0 ) then +c + lglist = 0 + do 250 , nrlist = 1 , 8 + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntesca(fihp) + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+2) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+3) + else + coderr = 1 + endif + 250 continue +c + do 260 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 260 continue +c + do 270 , nrofon = 1, nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + do 2701 , nrlist = 1 , lglist + vafott(nrofon,list(nrlist)) = daux + 2701 continue + 270 continue +c + else +c + do 251 , nrlist = 1 , 8 +c + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + f1cp = ntesca(fihp) + prfcap(f1cp) = 1 + do 2511 , nrofon = 1, nbfonc + daux = unshu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1cp) = daux + 2511 continue + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + f1fcp = ntesca(filtet(fihp)) + f2fcp = ntesca(filtet(fihp)+1) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + do 2512 , nrofon = 1, nbfonc + daux = unssz * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + 2512 continue + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + f1fcp = ntesca(filtet(fihp)) + f2fcp = ntesca(filtet(fihp)+1) + f3fcp = ntesca(filtet(fihp)+2) + f4fcp = ntesca(filtet(fihp)+3) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + prfcap(f4fcp) = 1 + do 2513 , nrofon = 1, nbfonc + daux = unstr2 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + vafott(nrofon,f3fcp) = daux + vafott(nrofon,f4fcp) = daux + 2513 continue + else + coderr = 1 + endif +c + 251 continue +c + endif +c +cgn write(26,7777) (list(nrlist),nrlist = 1 , lglist) +cgn write(ulsort,7777) f1cn,f2cn,-1, +cgn > (list(nrlist),nrlist = 1 , lglist) +cgn7777 format(I3) +c +c 2.7. ==> aucun autre etat sur le tetraedre courant +c n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcset4.F b/src/tool/AP_Conversion/pcset4.F new file mode 100644 index 00000000..6661321b --- /dev/null +++ b/src/tool/AP_Conversion/pcset4.F @@ -0,0 +1,493 @@ + subroutine pcset4 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de volume - +c - - - - +c Tetraedres d'etat anterieur 4 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSET4' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +#include "fractg.h" +#include "fracth.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer hettet(nbteto), filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c fihp = Fils ieme u tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c f3cn = Fils 3eme du tetraedre en numerotation du Calcul a l'it. N +c f4cn = Fils 4eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c f3fcp = Fils 3eme du Fils en numerotation Calcul a l'it. N+1 +c f4fcp = Fils 4eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fcp, f2fcp, f3fcp, f4fcp +c + integer nrofon + integer coderr +c + integer iaux + integer lglist, nrlist + integer list(30) +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) + f3cn = nteeca(f1hn+2) + f4cn = nteeca(f1hn+3) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c==== +c 2. etan = 41, ..., 44 : le tetraedre etait coupe en 4 +c selon la face 1, 2, 3, 4 +c etan = 45, 46, 47 : le tetraedre etait coupe en 4 +c selon une diagonale +c==== +c +c 2.1. ==> etanp1 = 0 : le tetraedre est reactive. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + if ( typint.eq.0 ) then + daux1 = unsqu + else + daux1 = 1.d0 + endif + do 21 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,tecnp1) = daux + 21 continue +cgn write (41,7777) tecnp1 +cgn write (ulsort,7777) f1cn,f2cn,f3cn,f4cn,-1,tecnp1 +cgn7777 format(I3) +c +c 2.2. ==> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciennes et nouvelles filles. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + daux1 = unsqu + else + daux1 = unsde + endif + do 22 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 22 continue +cgn write(42,7777) f1cp,f2cp +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp +c +c 2.3. ==> etanp1 = etan : le tetraedre est decoupe en +c quatre selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdte), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 23 , nrofon = 1, nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) + vafott(nrofon,f3cp) = vafoen(nrofon,prfcan(f3cn)) + vafott(nrofon,f4cp) = vafoen(nrofon,prfcan(f4cn)) + 23 continue +cgn write(43,7777) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +c +c 2.4. ==> etanp1 = 41, ..., 47 et different de +c etan : le tetraedre est decoupe en quatre +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 24 , nrofon = 1, nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux + 24 continue +cgn write(44,7777) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +c +c 2.5. ==> etanp1 = 85, 86 ou 87 : le tetraedre est +c decoupe en huit par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c attention : il est possible que les fils sur les bords +c soient decoupes par de la conformite. Il faut +c alors transmettre la valeur a leurs 2 ou 4 +c fils. +c attention : ce n'est pas comme en 2D ; il faut examiner +c tous les fils, car par contamination de faces +c coupees en 2, les fils centraux peuvent etre +c decoupes. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + if ( typint.eq.0 ) then +c + lglist = 0 + do 250 , nrlist = 1 , 8 + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntesca(fihp) + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+2) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+3) + else + coderr = 1 + endif + 250 continue +c + do 260 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 260 continue +c + do 270 , nrofon = 1, nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + do 2701 , nrlist = 1 , lglist + vafott(nrofon,list(nrlist)) = daux + 2701 continue + 270 continue +c + else +c + do 251 , nrlist = 1 , 8 +c + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + f1cp = ntesca(fihp) + prfcap(f1cp) = 1 + do 2511 , nrofon = 1, nbfonc + daux = unshu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1cp) = daux + 2511 continue + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + f1fcp = ntesca(filtet(fihp)) + f2fcp = ntesca(filtet(fihp)+1) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + do 2512 , nrofon = 1, nbfonc + daux = unssz * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + 2512 continue + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + f1fcp = ntesca(filtet(fihp)) + f2fcp = ntesca(filtet(fihp)+1) + f3fcp = ntesca(filtet(fihp)+2) + f4fcp = ntesca(filtet(fihp)+3) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + prfcap(f3fcp) = 1 + prfcap(f4fcp) = 1 + do 2513 , nrofon = 1, nbfonc + daux = unstr2 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1fcp) = daux + vafott(nrofon,f2fcp) = daux + vafott(nrofon,f3fcp) = daux + vafott(nrofon,f4fcp) = daux + 2513 continue + else + coderr = 1 + endif +c + 251 continue +c + endif +cgn write(46,7777) (list(nrlist),nrlist = 1 , lglist) +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,-1, +cgn > (list(nrlist),nrlist = 1 , lglist) +c +c 2.6. ==> aucun autre etat sur le tetraedre courant +c n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcset8.F b/src/tool/AP_Conversion/pcset8.F new file mode 100644 index 00000000..300c08e8 --- /dev/null +++ b/src/tool/AP_Conversion/pcset8.F @@ -0,0 +1,334 @@ + subroutine pcset8 ( etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Elements de Volume - +c - - - - - +c Tetraedres d'etat anterieur 8 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSET8' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etanp1, tehn, tehnp1 + integer typint + integer nbfonc + integer prfcan(*), prfcap(*) + integer filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 + + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c f3cn = Fils 3eme du tetraedre en numerotation du Calcul a l'it. N +c f4cn = Fils 4eme du tetraedre en numerotation du Calcul a l'it. N +c f5cn = Fils 5eme du tetraedre en numerotation du Calcul a l'it. N +c f6cn = Fils 6eme du tetraedre en numerotation du Calcul a l'it. N +c f7cn = Fils 7eme du tetraedre en numerotation du Calcul a l'it. N +c f8cn = Fils 8eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn, f5cn, f6cn, f7cn, f8cn +c + integer nrofon + integer coderr +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses huit fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) + f3cn = nteeca(f1hn+2) + f4cn = nteeca(f1hn+3) + f5cn = nteeca(f1hn+4) + f6cn = nteeca(f1hn+5) + f7cn = nteeca(f1hn+6) + f8cn = nteeca(f1hn+7) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 .and. + > prfcan(f5cn).gt.0 .and. prfcan(f6cn).gt.0 .and. + > prfcan(f7cn).gt.0 .and. prfcan(f8cn).gt.0 ) then +c +c==== +c 2. etan = 85, 86, 87 : le tetraedre etait coupe en 8 +c==== +c +c 2.1. ==> etanp1 = 0 : le tetraedre est reactive. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + if ( typint.eq.0 ) then + do 210 , nrofon = 1, nbfonc + daux = unshu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + > + vafoen(nrofon,prfcan(f5cn)) + > + vafoen(nrofon,prfcan(f6cn)) + > + vafoen(nrofon,prfcan(f7cn)) + > + vafoen(nrofon,prfcan(f8cn)) ) + vafott(nrofon,tecnp1) = daux + 210 continue + else + do 211 , nrofon = 1, nbfonc + daux = vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + > + vafoen(nrofon,prfcan(f5cn)) + > + vafoen(nrofon,prfcan(f6cn)) + > + vafoen(nrofon,prfcan(f7cn)) + > + vafoen(nrofon,prfcan(f8cn)) + vafott(nrofon,tecnp1) = daux + 211 continue + endif +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > tecnp1 +cgn write(81,7777) tecnp1 +c +c 2.2. ==> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux +c c'est ce qui se passe quand un decoupage de conformite +c est cree apres du deraffinement. +c on donne la valeur moyenne de la fonction sur les huit +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciennes et nouvelles filles. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + daux1 = unshu + else + daux1 = unsde + endif + do 22 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + > + vafoen(nrofon,prfcan(f5cn)) + > + vafoen(nrofon,prfcan(f6cn)) + > + vafoen(nrofon,prfcan(f7cn)) + > + vafoen(nrofon,prfcan(f8cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + 22 continue +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > f1cp,f2cp +cgn write(82,7777) f1cp,f2cp +c +c 2.3. ==> etanp1 = 41, ..., 44 : le tetraedre est +c decoupe en quatre par une face. +c etanp1 = 45, 46, 47 : le tetraedre est decoupe +c en 4 par une diagonale +c c'est ce qui se passe quand un decoupage de conformite +c est cree apres du deraffinement. +c on donne la valeur moyenne de la fonction sur les huit +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + if ( typint.eq.0 ) then + daux1 = unshu + else + daux1 = unsqu + endif + do 23 , nrofon = 1, nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) + > + vafoen(nrofon,prfcan(f5cn)) + > + vafoen(nrofon,prfcan(f6cn)) + > + vafoen(nrofon,prfcan(f7cn)) + > + vafoen(nrofon,prfcan(f8cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux + 23 continue +cgn write(ulsort,7777) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(83,7777) f1cp,f2cp,f3cp,f4cp +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcshe0.F b/src/tool/AP_Conversion/pcshe0.F new file mode 100644 index 00000000..16eccd34 --- /dev/null +++ b/src/tool/AP_Conversion/pcshe0.F @@ -0,0 +1,436 @@ + subroutine pcshe0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > vafoen, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c HExaedres - solution P0 +c -- - +c remarque : pcshe0 et pcspe0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nbanhe . e . 1 . nombre de hexaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfihe . e . nbanhe . tableau filhex du maillage de l'iteration n. +c . anpthe . e . 2** . tableau fhpyte du maillage de l'iteration n. +c . nheeca . e . * . numero des hexaedres dans le calcul entree . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie . +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npyeca . e . * . numero des pyramides dans le calcul entree . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vateen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les tetraedres . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prften . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapyen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les pyramides . +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSHE0' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hethex(nbheto), anchex(*) + integer filhex(nbheto), fhpyte(2,nbheco) + integer nbanhe, anfihe(nbanhe), anpthe(2,*) + integer nheeca(reheto), nhesca(rsheto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) + integer prften(*), prftep(*) + integer prfpyn(*), prfpyp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vateen(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapyen(nbfonc,*) + double precision vapytt(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c hehn = HExaedre courant en numerotation Homard a l'it. N +c hehnp1 = HExaedre courant en numerotation Homard a l'it. N+1 +c + integer hehn, hehnp1 +c +c etan = ETAt de l'hexaedre a l'iteration N +c etanp1 = ETAt de l'hexaedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nfhexp, nfpyrp, nftetp + integer ficp(3,18) + integer nfhexn, nfpyrn, nftetn + integer ficn(3,18) +c + double precision propor(18) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. on boucle sur tous les hexaedres du maillage HOMARD n+1 +c on trie en fonction de l'etat de l'hexaedre dans le maillage n +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , iaux = 1 , nbheto +c +c 2.1. ==> caracteristiques de l'hexaedre : +c + if ( codret.eq.0 ) then +c +c 2.1.1. ==> son numero homard dans le maillage precedent +c + hehnp1 = iaux + if ( deraff ) then + hehn = anchex(hehnp1) + else + hehn = hehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etat = 0 : le hexaedre est actif. +c etat = 8 : l'hexaedre est coupe en 8. +c etat >= 11 : l'hexaedre est coupe par conformite +c + etanp1 = mod(hethex(hehnp1),1000) + etan = (hethex(hehnp1)-etanp1) / 1000 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==========================================' + write (ulsort,90002) mess14(langue,1,6), hehnp1 + write (ulsort,90002) '. hehn =', hehn + write (ulsort,90002) '. etan =', etan + write (ulsort,90002) '. etanp1 =', etanp1 +#endif +c +c 2.1.3. ==> prealables a l'iteration n +c + if ( etan.ne.5 .and. etan.ne.9 ) then +c +c 2.1.3.1. ==> numerotation des fils +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEHY n', nompro +#endif + call pcsehy ( nfhexn, nfpyrn, nftetn, ficn, + > hehn, etan, + > anfihe, anpthe, + > nheeca, nteeca, npyeca, + > ulsort, langue, codret ) +c + endif +c +c 2.1.4. ==> prealables a l'iteration n+1 +c + if ( etanp1.ne.5 .and. etanp1.ne.9 ) then +c +c 2.1.4.1. ==> numerotation des fils +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEHY n+1', nompro +#endif + call pcsehy ( nfhexp, nfpyrp, nftetp, ficp, + > hehnp1, etanp1, + > filhex, fhpyte, + > nhesca, ntesca, npysca, + > ulsort, langue, codret ) +c +c 2.1.4.2. ==> en mode extensif, calcul des proportions +c + if ( typint.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEHZ', nompro +#endif + call pcsehz ( propor, + > hehnp1, etanp1, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > filhex, fhpyte, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 2.2. ==> Examen des differents etats +c + if ( codret.eq.0 ) then +c +c======================================================================= +c 2.2.1. ==> etan = 0 : l'hexaedre etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEH0', nompro +#endif +c + call pcseh0 ( etan, etanp1, hehn, hehnp1, typint, + > prfcan, prfcap, + > nfhexp, nfpyrp, nftetp, ficp, propor, + > nheeca, nhesca, + > nbfonc, vafoen, vafott, + > vatett, prftep, + > vapytt, prfpyp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEH0' +c +c======================================================================= +c 2.2.2. ==> l'hexaedre etait coupe en conformite +c======================================================================= +c + elseif ( etan.ge.11 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEH1', nompro +#endif +c + call pcseh1 ( etan, etanp1, hehn, hehnp1, typint, + > prfcap, + > nfpyrn, nftetn, ficn, + > nfpyrp, nftetp, ficp, propor, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, filhex, fhpyte, + > nhesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c +c======================================================================= +c 2.2.3. ==> etan = 8 : le hexaedre etait coupe en 8 hexaedres +c======================================================================= +c + elseif ( etan.eq.8 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEH8', nompro +#endif +c + call pcseh8 ( etanp1, hehnp1, typint, + > prfcan, prfcap, + > ficn, + > nfpyrp, nftetp, ficp, propor, + > nhesca, + > nbfonc, vafoen, vafott, + > vatett, + > prftep, + > vapytt, + > prfpyp, + > ulsort, langue, codret ) +c + endif +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsi00.F b/src/tool/AP_Conversion/pcsi00.F new file mode 100644 index 00000000..f7a3d9c7 --- /dev/null +++ b/src/tool/AP_Conversion/pcsi00.F @@ -0,0 +1,108 @@ + subroutine pcsi00 ( nbfop2, profho, vap2ho, + > somare, np2are, + > nbarco, nuaret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso/p2 sur les noeuds - phase 00 +c - -- +c Moyenne des valeurs aux extremites d'un ensmble d'aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . nbarco . e . 1 . nombre d'aretes concernees . +c . nuaret . e . nbarco . numero des aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer somare(2,nbarto), np2are(nbarto) + integer nbarco, nuaret(nbarco) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer larete + integer s1, s2, sm, nuv +c ______________________________________________________________________ +c +#include "impr03.h" +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c + do 10 , iaux = 1 , nbarco +c +c==== +c 1. L'arete concernee +c==== + larete = nuaret(iaux) +cgn write(1,90002) 'larete',larete +c +c==== +c 2. Interpolation +c==== +c + s1 = somare(1,larete) + s2 = somare(2,larete) + sm = np2are(larete) +cgn write(1,90002) 'sm =',sm +c + profho(sm) = 1 +c + do 21 , nuv = 1, nbfop2 +c +cgn write(1,90002) 'sommets',s1, s2) + vap2ho(nuv,sm) = unsde * ( vap2ho(nuv,s1) + vap2ho(nuv,s2) ) +cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) + 21 continue +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsiar.F b/src/tool/AP_Conversion/pcsiar.F new file mode 100644 index 00000000..98a20027 --- /dev/null +++ b/src/tool/AP_Conversion/pcsiar.F @@ -0,0 +1,123 @@ + subroutine pcsiar ( nbfop2, profho, vap2ho, + > hetare, somare, np2are, filare ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso-p2 sur les noeuds lors du decoupage des ARetes +c - -- +c remarque : pcs2ar et pcsiar sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables iso-p2 numerotation homard . +c . . . nbnoto . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer filare(nbarto) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer larete, a1, a2, sm, s1, s2, m1, m2, nuv +c ______________________________________________________________________ +c +c==== +c 1. interpolation pour les aretes qui viennent d'etre decoupees +c==== +c + do 10 , larete = 1, nbarto +c + if ( hetare(larete).eq.2 ) then +c +c recuperation des aretes filles +c + a1 = filare(larete) + a2 = a1 + 1 +c +c recuperation des sommets de l'arete +c + s1 = somare(1,larete) + s2 = somare(2,larete) +c +c recuperation du nouveau noeud sommet +c + sm = np2are(larete) +c + if ( profho(s1).eq.1 .and. profho(s2).eq.1 .and. + > profho(sm).eq.1 ) then +c +c recuperation des nouveaux noeuds milieux +c + m1 = np2are(a1) + m2 = np2are(a2) + profho(m1) = 1 + profho(m2) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 11, nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = + > unsde * ( vap2ho(nuv,s1) + vap2ho(nuv,sm) ) + vap2ho(nuv,m2) = + > unsde * ( vap2ho(nuv,s2) + vap2ho(nuv,sm) ) +c + 11 continue +c + endif +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsihe.F b/src/tool/AP_Conversion/pcsihe.F new file mode 100644 index 00000000..5ddd9e38 --- /dev/null +++ b/src/tool/AP_Conversion/pcsihe.F @@ -0,0 +1,227 @@ + subroutine pcsihe ( nbfop2, profho, vap2ho, + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso/p2 sur les noeuds - decoupage des HExaedres +c - -- +c remarque : on devrait optimiser cela car si l'hexaedre etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2he et pcsihe sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p1 numerotation homard . +c . . . nbnoto . . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSIHE' ) +c +#include "nblang.h" +c +#include "fract0.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +c +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer hethex(nbheto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer filhex(nbheto) + integer fhpyte(2,nbheco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer lehexa + integer bindec, typdec, etanp1 + integer sm, nuv + integer s1, s2, noemi + integer nbarcp, tbarcp(12), areint(20) +c + integer listar(12), listso(8), listno(12) +c + logical afaire +c + double precision daux +c + integer langue + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +#include "impr01.h" +#include "impr03.h" +cgn write (*,*) 'Entree dans ', nompro, ' avec nbheto = ',nbheto + langue = 1 +c + do 10 , lehexa = 1, nbheto +c +c==== +c 1. interpolation iso-p2 pour un hexaedre qui vient d'etre decoupe : +c on a une valeur a mettre sur l'eventuel noeud central et les +c milieux des aretes internes +c==== +c + iaux = lehexa +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'PCS0HE', nompro +#endif + call pcs0he ( iaux, profho, + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > afaire, listar, listso, listno, + > bindec, typdec, etanp1, + > nbarcp, tbarcp, areint, sm ) +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'typdec', typdec + write(*,90002) 'listar 1- 6', (listar(iaux),iaux=1,6) + write(*,90002) 'listar 7-12', (listar(iaux),iaux=7,12) + write(*,90002) 'listno 1- 6', (listno(iaux),iaux=1,6) + write(*,90002) 'listno 7-12', (listno(iaux),iaux=7,12) +#endif +c + if ( afaire ) then +c +c==== +c 2. L'eventuel noeud central +c==== +c + if ( ( mod(typdec,2).eq.0 ) .or. + > ( mod(typdec,17).eq.0 ) ) then +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'noeud central', sm +#endif +c + profho(sm) = 1 +c +c formule iso-p2 : +c interpolation = moyenne des valeurs sur les noeuds au milieu +c des aretes de l'hexaedre +c remarque : pour un decoupage en 8, cela equivaut a prendre +c la moyenne sur les milieux des faces +c + do 22 , nuv = 1, nbfop2 +c + daux = 0.d0 + do 221 , iaux = 1 , 12 + daux = daux + vap2ho(nuv,listno(iaux)) + 221 continue + vap2ho(nuv,sm) = unsdz * daux +cgn write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) +c + 22 continue +c + endif +c +c==== +c 3. Les noeuds sur les aretes internes +c==== +c + do 31 , iaux = 1 , chnar(bindec) +c + s1 = somare(1,areint(iaux)) + s2 = somare(2,areint(iaux)) + noemi = np2are(areint(iaux)) + profho(noemi) = 1 +c + do 311, nuv = 1 , nbfop2 +c + vap2ho(nuv,noemi) = unsde * ( vap2ho(nuv,s1) + > + vap2ho(nuv,s2) ) +cgn write(*,*) 'vap2ho(nuv,',noemi,') =',vap2ho(nuv,noemi) +c + 311 continue +c + 31 continue +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsipe.F b/src/tool/AP_Conversion/pcsipe.F new file mode 100644 index 00000000..1ded451e --- /dev/null +++ b/src/tool/AP_Conversion/pcsipe.F @@ -0,0 +1,289 @@ + subroutine pcsipe ( nbfop2, profho, vap2ho, + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso/p2 sur les noeuds - decoupage des PEntaedres +c - -- +c remarque : on devrait optimiser cela car si le pentaedre etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcsipe et pcsipe sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p1 numerotation homard . +c . . . nbnoto . . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSIPE' ) +c +#include "nblang.h" +#include "fracte.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(*) + integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) +c + double precision vap2ho(nbfop2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lepent + integer typdec, etanp1 + integer sm, nuv + integer listar(9), listno(15) + integer nbarco + integer nuaret(15) +c + logical afaire +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + do 100 , jaux = 1, nbpeto +c + lepent = jaux +c +c==== +c 2. recherche des types d'interpolations a faire +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCS0PE', nompro +#endif + call pcs0pe ( lepent, profho, + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > afaire, listar, listno, typdec, etanp1, sm ) +cgn write(ulsort,90002) 'typdec',typdec +c + endif +c + if ( afaire ) then +c +c==== +c 3. L'eventuel noeud central +c decoupage selon 2 aretes tria/tria +c decoupage selon 1 face traingulaire +c==== +c + if ( codret.eq.0 ) then +c + if ( mod(typdec,2).eq.0 ) then +c + profho(sm) = 1 +c +c formule iso-p2 : +c interpolation = moyenne des valeurs sur les noeuds au milieu +c des aretes du pentaedre +c + do 31 , nuv = 1, nbfop2 +c + daux = 0.d0 + do 311 , iaux = 9 , 15 + daux = daux + vap2ho(nuv,listno(iaux)) + 311 continue + vap2ho(nuv,sm) = unssix * daux +cgn write(ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm) +c + 31 continue +c + endif +c + endif +c +c==== +c 4. Recuperation des aretes internes +c==== +c + if ( codret.eq.0 ) then +c + iaux = 1 +c +c 4.1. ==> Du centre aux milieux d'aretes +c (selon 2 aretes tri ou 1 face tri) +c + if ( mod(typdec,5).eq.0 ) then + iaux = iaux*3 + endif +c +c 4.2. ==> Du centre aux sommets +c (selon 2 aretes tri ou 1 face tri) +c + if ( mod(typdec,7).eq.0 ) then + iaux = iaux*2 + endif +c +c 4.3. ==> Entre les milieux de faces +c D'un milieu d'arete a un autre +c D'un milieu d'arete a un sommet +c D'un milieu de face a un sommet +c + if ( mod(typdec,3).eq.0 .or. + > mod(typdec,11).eq.0 .or. + > mod(typdec,13).eq.0 .or. + > mod(typdec,17).eq.0 ) then + iaux = iaux*5 + endif +c +c 4.4. ==> Les aretes +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'UTAIPE', nompro +#endif + call utaipe ( lepent, iaux, + > hetpen, facpen, filpen, fppyte, + > aretri, + > tritet, cotrte, + > nbarco, nuaret, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Les valeurs +c==== +c + if ( codret.eq.0 ) then +cgn write(ulsort,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,3)) 'PCSI00', nompro +#endif + call pcsi00 ( nbfop2, profho, vap2ho, + > somare, np2are, + > nbarco, nuaret ) +c + endif +c + endif +c + 100 continue +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsiqu.F b/src/tool/AP_Conversion/pcsiqu.F new file mode 100644 index 00000000..47f5a884 --- /dev/null +++ b/src/tool/AP_Conversion/pcsiqu.F @@ -0,0 +1,207 @@ + subroutine pcsiqu ( nbfop2, profho, vap2ho, + > hetqua, arequa, filqua, + > somare, np2are, + > aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso-p2 sur les noeuds - decoupage des QUadrangles +c - -- +c remarque : on devrait optimiser cela car si le quadrangle etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2qu et pcsiqu sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables iso-p2 numerotation homard . +c . . . nbnoto . . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad + integer typdec, etanp1 + integer s1, s2, noemi + integer sm, nuv +c + integer listar(4), listno(8) + integer nbain, areint(4) +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 + integer f1hp +c + logical afaire +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c ______________________________________________________________________ +cgn write (1,*) 'PCSIQU' +cgn 1789 format(a,10i4) +cgn 1791 format(8g12.5) +c + do 10 , lequad = 1, nbquto +c +c==== +c 1. interpolation iso-p2 pour un quadrangle qui vient d'etre decoupe +c==== +c + iaux = lequad + call pcs0qu ( iaux, profho, + > hetqua, arequa, + > somare, np2are, + > afaire, listar, listno, typdec, etanp1 ) +c +cgn write (1,90002) 'quad/typdec', lequad, typdec + if ( afaire ) then +c + f1hp = filqua(lequad) +c +c==== +c 2. L'eventuel noeud central +c==== +c + if ( typdec.eq.4 .or. + > ( etanp1.ge.41 .and. etanp1.le.44 ) ) then +c + if ( typdec.eq.4 ) then + sm = somare(2,arequa(f1hp,2)) + else + sm = somare(2,arequa(f1hp,3)) + endif + profho(sm) = 1 +cgn write(6,1789) 'f1hp =', f1hp +cgn write(6,1789) 'sm =', sm +c +c interpolation = 1/4 (u5+u6+u7+u8) +c +cgn 1789 format( 4g13.5) + do 21, nuv = 1, nbfop2 +cgn write(6,1791) vap2ho(nuv,listno(5)), vap2ho(nuv,listno(6)) +cgn > , vap2ho(nuv,listno(7)), vap2ho(nuv,listno(8)) +c + vap2ho(nuv,sm) = + unsqu * ( vap2ho(nuv,listno(5)) + > + vap2ho(nuv,listno(6)) + > + vap2ho(nuv,listno(7)) + > + vap2ho(nuv,listno(8)) ) +cgn write(6,1791) vap2ho(nuv,sm) +c + 21 continue +c + endif +c +c==== +c 3. Les noeuds sur les aretes internes +c==== +c 3.1. Recherche des aretes internes +c voir cmrdqu, cmcdq2, cmcdq3 et cmcdq5 pour les conventions +c + nbain = 0 + if ( typdec.eq.4) then + do 311 , iaux = 0, 3 + nbain = nbain + 1 + areint(nbain) = arequa(f1hp+iaux,2) + 311 continue + elseif ( typdec.eq.21 .or. typdec.eq.22 ) then + nbain = nbain + 1 + areint(nbain) = arequa(f1hp,4) + elseif ( typdec.ge.31 .and. typdec.le.34 ) then + nbain = nbain + 1 + areint(nbain) = aretri(-f1hp,1) + nbain = nbain + 1 + areint(nbain) = aretri(-f1hp,3) + elseif ( typdec.ge.41 .and. typdec.le.44 ) then + nbain = nbain + 1 + areint(nbain) = arequa(f1hp,3) + nbain = nbain + 1 + areint(nbain) = arequa(f1hp,4) + nbain = nbain + 1 + areint(nbain) = arequa(f1hp+1,3) + endif +cgn write(1,90002) 'nbain', nbain, (areint(iaux),iaux=1,nbain) +c +c 3.2. ==> les valeurs sur les noeuds +c + do 32 , iaux = 1 , nbain +c + s1 = somare(1,areint(iaux)) + s2 = somare(2,areint(iaux)) + noemi = np2are(areint(iaux)) + profho(noemi) = 1 +c + do 321, nuv = 1 , nbfop2 +c + vap2ho(nuv,noemi) = unsde * ( vap2ho(nuv,s1) + > + vap2ho(nuv,s2) ) +cgn write(*,*) 'vap2ho(nuv,',noemi,') =',vap2ho(nuv,noemi) +c + 321 continue +c + 32 continue +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsite.F b/src/tool/AP_Conversion/pcsite.F new file mode 100644 index 00000000..0670d762 --- /dev/null +++ b/src/tool/AP_Conversion/pcsite.F @@ -0,0 +1,140 @@ + subroutine pcsite ( nbfop2, profho, vap2ho, + > tritet, cotrte, aretet, + > hettet, filtet, + > somare, np2are, + > aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso-p2 sur les noeuds - decoupage des TEtraedres +c - -- +c ______________________________________________________________________ +c attention : il faut passer ce programme avant le traitement des +c nouveaux noeuds sur les triangles coupes, sinon les +c valeurs sur les noeuds des diagonales seront inconnues +c remarque : on devrait optimiser cela car si le tetraedre etait dans +c un etat de decoupage de conformite similaire, on recalcule +c une valeur qui est deja presente +c remarque : pcs2te et pcsite sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto), filtet(nbteto) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer iaux + integer letetr, adiag + integer sm, nuv + integer ni, nj + integer listar(6), listno(10) +c + logical afaire +c ______________________________________________________________________ +cgn write (*,*) 'PCSITE' +c + do 10 , letetr = 1, nbteto +c +c==== +c 1. interpolation iso-p2 pour un tetraedre qui vent d'etre decoupe +c les seuls cas interessants sont ceux ou un noeud est cree a +c l'interieur du tetraedre, donc quand il y a une diagonale. +c==== +c + iaux = letetr + call pcs0te ( iaux, profho, + > tritet, cotrte, aretet, + > hettet, filtet, + > aretri, + > somare, np2are, + > afaire, listar, listno, adiag ) +c +c==== +c 2. le tetraedre vient d'etre decoupe et le champ est present +c interpolation au noeud milieu de la diagonale +c==== +c + if ( afaire ) then +c + ni = somare(1,adiag) + nj = somare(2,adiag) +c + sm = np2are(adiag) + profho(sm) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 22 , nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = unsde * ( vap2ho(nuv,ni) + vap2ho(nuv,nj) ) +c + 22 continue +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsitr.F b/src/tool/AP_Conversion/pcsitr.F new file mode 100644 index 00000000..f39973c3 --- /dev/null +++ b/src/tool/AP_Conversion/pcsitr.F @@ -0,0 +1,259 @@ + subroutine pcsitr ( nbfop2, profho, vap2ho, + > hettri, aretri, filtri, + > somare, np2are ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c interpolation iso-p2 sur les noeuds - decoupage des TRiangles +c - -- +c remarque : on devrait optimiser cela car si le triangle etait dans +c un etat de decoupage similaire, on recalcule une valeur +c qui est deja presente +c remarque : pcs2tr et pcsitr sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vap2ho . es . nbfop2*. variables iso-p2 numerotation homard . +c . . . nbnoto . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "demitr.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer somare(2,nbarto), np2are(nbarto) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer typdec + integer iaux1, iaux2, iaux3 + integer letria, letri0 + integer ff, nuv, af1, af2, af3 + integer m1, m2, m3 + integer inloc + integer listno(6) +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c + integer f1hp +c + logical afaire +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +cgn write (*,*) 'PCSITR' +c + do 10 , letri0 = 1, nbtrto +c + letria = letri0 +c +cgn write (1,90002) 'Triangle', letria +c==== +c 1. liste des noeuds concernes et type de decoupage +c==== +c + call pcs0tr ( letria, profho, + > hettri, aretri, + > somare, np2are, + > afaire, listno, typdec ) +cgn write (1,90002) 'typdec', typdec +c + if ( afaire ) then +c +c==== +c 2. le triangle vient d'etre decoupe en 4 triangles alors +c qu'il ne l'etait pas a l'iteration precedente +c . en standard : etat 4 +c . avec bascule pour le suivi de frontiere : etat 6, 7 ou 8 +c Remarque : regarder cmrdtr pour les conventions +c==== +c + if ( typdec.ge.4 ) then +c +c recuperation du triangle fils aine +c c'est le central si pas de basculement +c + f1hp = filtri(letria) +c +c recuperation des aretes internes au triangle decoupe +c . pour un decoupage standard, ce sont les trois du triangle +c central +c . avec une bascule, il y a eu modification du fils aine +c et du frere de rang connu par l'etat du triangle, inloc. +c l'arete basculee est celle commune a ces deux triangles. les +c deux autres aretes sont celles de rang inloc dans la +c description des deux triangles modifies. +c + if ( typdec.eq.4 ) then + af1 = aretri(f1hp,1) + af2 = aretri(f1hp,2) + af3 = aretri(f1hp,3) +c + else + inloc = typdec - 5 + af3 = 0 + do 21 , iaux1 = 1 , 3 + iaux3 = aretri(f1hp+inloc,iaux1) + do 211 , iaux2 = 1 , 3 + if ( iaux3.eq.aretri(f1hp,iaux2) ) then + af3 = iaux3 + endif + 211 continue + 21 continue + af1 = aretri(f1hp ,inloc) + af2 = aretri(f1hp+inloc,inloc) + endif +c +c recuperation des noeuds milieux sur ces aretes internes +c + m1 = np2are(af1) + m2 = np2are(af2) + m3 = np2are(af3) + profho(m1) = 1 + profho(m2) = 1 + profho(m3) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 22 , nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = + > unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) ) + vap2ho(nuv,m2) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) ) + vap2ho(nuv,m3) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) ) +c + 22 continue +c +c==== +c 3. le triangle vient d'etre decoupe en 2 +c==== +c + elseif ( typdec.eq.1 .or. typdec.eq.2 .or. typdec.eq.3 ) then +c +c 3.1. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 1 +c + if ( typdec.eq.1 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(1,2) +c +c recuperation du nouveau noeud milieu +c + m1 = np2are(aretri(ff,3)) + profho(m1) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 31 , nuv = 1, nbfop2 +c + vap2ho(nuv,m1) = + > unsde * ( vap2ho(nuv,listno(5)) + vap2ho(nuv,listno(6)) ) +c + 31 continue +c +c 3.2. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 2 +c + elseif ( typdec.eq.2 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(2,1) +c +c recuperation du nouveau noeud milieu +c + m2 = np2are(aretri(ff,3)) + profho(m2) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 32 , nuv = 1, nbfop2 +c + vap2ho(nuv,m2) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(6)) ) +c + 32 continue +c +c 3.3. ==> le triangle vient d'etre decoupe en 2 par l'arete numero 3 +c + elseif ( typdec.eq.3 ) then +c +c recuperation d'un triangle fils +c + ff = filtri(letria) + nutrde(3,1) +c +c recuperation du nouveau noeud milieu +c + m3 = np2are(aretri(ff,2)) + profho(m3) = 1 +c +c interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 33 , nuv = 1, nbfop2 +c + vap2ho(nuv,m3) = + > unsde * ( vap2ho(nuv,listno(4)) + vap2ho(nuv,listno(5)) ) +c + 33 continue +c + endif +c + endif +c + endif +c + 10 continue +c + end diff --git a/src/tool/AP_Conversion/pcsmar.F b/src/tool/AP_Conversion/pcsmar.F new file mode 100644 index 00000000..86e765a6 --- /dev/null +++ b/src/tool/AP_Conversion/pcsmar.F @@ -0,0 +1,114 @@ + subroutine pcsmar ( nbfop2, profho, + > somare, np2are, + > vap2ho ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c Modification de degre +c - +c interpolation p1 sur les noeuds lors du decoupage des ARetes +c -- +c remarque : pcs1ar et pcsmar sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . profho . es . * . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . vap2ho . es . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer nbfop2 + integer profho(nbnoto) + integer somare(2,nbarto), np2are(nbarto) +c + double precision vap2ho(nbfop2,*) +c +c 0.4. ==> variables locales +c + integer larete, nuv, s1, s2, sm +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. interpolation p1 pour toutes les aretes +c==== +c + if ( nbfop2.ne.0 ) then +c + do 1000, larete = 1, nbarto +c +c recuperation des sommets de l'arete +c + s1 = somare(1,larete) + s2 = somare(2,larete) +cgn write(*,90001) 'profil de', s1, profho(s1) +cgn write(*,90001) 'profil de', s2, profho(s2) +c + if ( profho(s1).eq.1 .and. profho(s2).eq.1 ) then +c +c recuperation du nouveau noeud sommet +c + sm = np2are(larete) + profho(sm) = 1 +cgn write(*,90001) '==> profil de', sm, profho(sm) +c +c interpolation : interpolee (ui,i=1,2) = 1/2 (u1+u2) +c + do 11, nuv = 1, nbfop2 +c + vap2ho(nuv,sm) = unsde + > * ( vap2ho(nuv,s1) + vap2ho(nuv,s2) ) +c + 11 continue +c + endif +c + 1000 continue +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsoar.F b/src/tool/AP_Conversion/pcsoar.F new file mode 100644 index 00000000..4256a3cc --- /dev/null +++ b/src/tool/AP_Conversion/pcsoar.F @@ -0,0 +1,362 @@ + subroutine pcsoar ( typint, deraff, + > nbpara, carenf, carchf, nrfonc, + > hetare, ancare, filare, + > somare, + > coonoe, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > nbanar, anfiar, + > nareca, narsca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - ARetes +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . ancare . e . nbarto . anciens numeros des aretes conservees . +c . filare . e . nbarto . fille ainee de chaque arete . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nareca . e . * . nro des aretes dans le calcul en entree . +c . narsca . e . rsarto . numero des aretes du calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOAR' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer typint + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer hetare(nbarto), ancare(*) + integer filare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer nbanar, anfiar(nbanar) + integer somare(2,*) +c + integer nareca(rearto), narsca(rsarto) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenmx, npvapr + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas + integer adpcan, adpcap + integer nrfon2, nrfon3 +c + character*8 nofonc, obpcan, obpcap, obprof + character*8 oblopg +c +#ifdef _DEBUG_HOMARD_ + integer jaux + integer aretes(3) + double precision champ(3), flux, lgaret(3) +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs utiles +c==== +c 2.1. ==> recuperation +c + if ( codret.eq.0 ) then +c + iaux = nrfonc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenmx, npvapr, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblopg, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofonc', nofonc + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'p1vane', p1vane + endif +#endif +c +c==== +c 3. interpolation des variables +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Interpolation ; codret', codret +#endif +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +c +c 3.1.1. ==> pour les aretes decoupees/reactivees +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSAR0', nompro +#endif + call pcsar0 ( nbtafo, typint, deraff, + > imem(adpcan), imem(adpcap), + > hetare, ancare, filare, + > nbanar, anfiar, + > nareca, narsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.1.2. ==> pour les triangles decoupes/reactives +c + if ( nbtrma.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSAR1', nompro +#endif + call pcsar1 ( nbtafo, typint, deraff, + > imem(adpcan), imem(adpcap), + > hetare, ancare, filare, + > nbanar, anfiar, + > somare, + > hettri, aretri, filtri, + > nareca, narsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c + do 312 , iaux = 1 , nbtrto +c + if ( mod(hettri(iaux),10).eq.0 ) then + write (ulsort,90002) 'Triangle', iaux +c + do 3121 , jaux = 1 , 3 + aretes(jaux) = aretri(iaux,jaux) + champ(jaux) = rmem(p1vatt-1+narsca(aretes(jaux))) + 3121 continue + jaux = 0 + call utfltr ( jaux, coonoe, somare, aretes, + > champ, flux, lgaret, + > ulsort, langue, codret ) + write (ulsort,90024) '==> Flux pour le triangle', iaux, flux +c + endif +c + 312 continue + do 3122 , iaux = 1 , nbarto + if ( narsca(iaux).gt.0 ) then + write(ulsort,90014) iaux, rmem(p1vatt-1+narsca(iaux)) + endif + 3122 continue +cgn do 3123 , iaux = 1 , nbarto +cgn if ( narsca(iaux).gt.0 ) then +cgn write(ulsort,90014) narsca(iaux)-17, +cgn > rmem(p1vatt-1+narsca(iaux)) +cgn endif +cgn 3123 continue +#endif +c + else +c + codret = 8 +c + endif +cgn print *, 'codret = ', codret +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsohe.F b/src/tool/AP_Conversion/pcsohe.F new file mode 100644 index 00000000..b9aa5b45 --- /dev/null +++ b/src/tool/AP_Conversion/pcsohe.F @@ -0,0 +1,529 @@ + subroutine pcsohe ( typint, deraff, + > nbpara, carenf, carchf, nrfonc, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anhehe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - HExaedres +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : n1vapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenm1 . +c . . . . 16 : npvap1 . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpc1n . +c . . . . 5 : obpc1p . +c . . . . 6 : obpro1 . +c . . . . 7 : oblo1g . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nbanhe . e . 1 . nombre de hexaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfihe . e . nbanhe . tableau filhex du maillage de l'iteration n. +c . anhehe . e . nbanhe . tableau hethex du maillage de l'iteration n. +c . anpthe . e . 2** . tableau fhpyte du maillage de l'iteration n. +c . nheeca . e . * . numero des hexaedres dans le calcul entree . +c . nhesca . e . rsheto . numero des hexaedres dans le calcul sortie . +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npyeca . e . * . numero des pyramides dans le calcul entree . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOHE' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombsr.h" +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + integer typint + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hethex(nbheto), anchex(*) + integer filhex(nbheto), fhpyte(2,nbheco) + integer nbanhe, anfihe(nbanhe), anhehe(nbanhe), anpthe(2,*) +c + integer nheeca(reheto), nhesca(rsheto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) +c + double precision coonoe(nbnoto,sdim) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, n1vapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenm1, npvap1 + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas +c + integer nrfon2 + integer typfo2, typch2, typge2, typas2 + integer ngaus2, nnenm2, nnvap2, carsu2, nbtaf2 + integer n2vale, n2valr, n2obpr, n2obch, n2lipr + integer npenm2, npvap2 + integer p2vale, p2valr, p2obpr, p2obch, p2vatt + integer p2vane, p2tyas +c + integer nrfon3 + integer typfo3, typch3, typge3, typas3 + integer ngaus3, nnenm3, nnvap3, carsu3, nbtaf3 + integer n3vale, n3valr, n3obpr, n3obch, n3lipr + integer npenm3, npvap3 + integer p3vale, p3valr, p3obpr, p3obch, p3vatt + integer p3vane, p3tyas +c + integer adpc1n, adpc1p + integer adpc2n, adpc2p + integer adpc3n, adpc3p +c + character*8 nofon1, obpc1n, obpc1p, obpro1, oblo1g + character*8 nofon2, obpc2n, obpc2p, obpro2, oblo2g + character*8 nofon3, obpc3n, obpc3p, obpro3, oblo3g +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp1.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +#endif +c +c==== +c 2. grandeurs utiles +c==== +c +c 2.1. ==> la fonction de base +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfonc),iaux= 1,9) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, n1vapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenm1, npvap1, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofon1, + > obpc1n, obpc1p, obpro1, adpc1n, adpc1p, + > oblo1g, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon1', nofon1 + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nrfon2', nrfon2 + write (ulsort,90002) 'nrfon3', nrfon3 + write (ulsort,90003) 'oblo1g', oblo1g + endif +#endif +c +c 2.2. ==> les fonctions annexes +c 2.2.1. ==> tetraedres +c + if ( nrfon2.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfon2 + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfon2),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2_te', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > nrfon2, + > typfo2, typch2, typge2, typas2, + > ngaus2, nnenm2, nnvap2, carsu2, nbtaf2, + > n2vale, n2valr, n2obpr, n2obch, n2lipr, + > npenm2, npvap2, + > p2vale, p2valr, p2obpr, p2obch, p2vatt, + > p2vane, p2tyas, + > iaux, jaux, + > nofon2, + > obpc2n, obpc2p, obpro2, adpc2n, adpc2p, + > oblo2g, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon2', nofon2 + write (ulsort,90002) 'typfo2', typfo2 + write (ulsort,90002) 'typch2', typch2 + write (ulsort,90002) 'typge2', typge2 + write (ulsort,90002) 'typas2', typas2 + write (ulsort,90002) 'carsu2', carsu2 + write (ulsort,90002) 'ngaus2', ngaus2 +c write (ulsort,90003) 'oblo2g', oblo2g + endif +#endif +c + endif +c + endif +c +c 2.2.2. ==> pyramides +c + if ( nrfon3.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfon3 + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfon3),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2_py', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > nrfon3, + > typfo3, typch3, typge3, typas3, + > ngaus3, nnenm3, nnvap3, carsu3, nbtaf3, + > n3vale, n3valr, n3obpr, n3obch, n3lipr, + > npenm3, npvap3, + > p3vale, p3valr, p3obpr, p3obch, p3vatt, + > p3vane, p3tyas, + > iaux, jaux, + > nofon3, + > obpc3n, obpc3p, obpro3, adpc3n, adpc3p, + > oblo3g, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon3', nofon3 + write (ulsort,90002) 'typfo3', typfo3 + write (ulsort,90002) 'typch3', typch3 + write (ulsort,90002) 'typge3', typge3 + write (ulsort,90002) 'typas3', typas3 + write (ulsort,90002) 'carsu3', carsu3 + write (ulsort,90002) 'ngaus3', ngaus3 +c write (ulsort,90003) 'oblo3g', oblo3g + endif +#endif +c + endif +c + endif +c +c==== +c 3. interpolation des variables +c==== +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSHE0', nompro +#endif + call pcshe0 ( nbtafo, typint, deraff, + > imem(adpc1n), imem(adpc1p), + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > rmem(n1valr), rmem(p1vatt), + > rmem(n2valr), rmem(p2vatt), + > imem(adpc2n), imem(adpc2p), + > rmem(n3valr), rmem(p3vatt), + > imem(adpc3n), imem(adpc3p), + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,*) 'hexa' +cgn if ( nbhexa.eq.8 ) then +cgn codret=67 +cgn else +cgn codret=178 +cgn endif +cgn write(ulsort,3000) (rmem(p1vatt+codret+iaux),iaux=0,nbheto-1) +cgn write(ulsort,*) 'hexr' +cgn write(ulsort,3000) (rmem(p2vatt+iaux),iaux=0,nbhexa-1) +cgn write(ulsort,*) 'pyra' +cgn if ( nbhexa.eq.8 ) then +cgn codret=75 +cgn else +cgn codret=225 +cgn endif +cgn write(ulsort,3000) (rmem(p3vatt+codret+iaux),iaux=0,nbpyto-1) +cgn 3000 format(10g13.5) +cgn codret = 0 +c + else +c +c 3.2. ==> avec plusieurs points de Gauss +c +c 3.2.1. ==> champ aux noeuds par element +c + if ( carsup.eq.1 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8)) mess14(langue,1,6) + write (ulsort,texte(langue,10)) + codret = 321 +c + endif +c +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEHE1', nompro +#endif + call pcehe1 ( nbtafo, ngauss, deraff, + > imem(adpc1n), imem(adpc1p), + > hethex, anchex, filhex, fhpyte, + > nbanhe, anfihe, anhehe, anpthe, + > nheeca, nhesca, + > nteeca, ntesca, + > npyeca, npysca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.2. ==> vrai champ aux points de Gauss +c + else +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,9)) mess14(langue,1,6) + write (ulsort,texte(langue,10)) + codret = 322 +c + endif +c + endif +c + endif +cgn print *, 'codret = ', codret +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsolu.F b/src/tool/AP_Conversion/pcsolu.F new file mode 100644 index 00000000..68ecde3c --- /dev/null +++ b/src/tool/AP_Conversion/pcsolu.F @@ -0,0 +1,248 @@ + subroutine pcsolu ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de SOLUtion +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOLU' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux + integer option +c + character*6 saux + character*8 typobs + character*8 nosvmn, nohmap, norenn, norenp + character*8 nocson, nocsop +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONVERSION DE LA SOLUTION'')' + texte(1,5) = '(32(''=''),/)' + texte(1,6) = '(''... '',a,'' : '',i6)' +c + texte(2,4) = '(/,a6,'' SOLUTION CONVERSION'')' + texte(2,5) = '(26(''=''),/)' + texte(2,6) = '(''... '',a,'' : '',i6)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage homard a l'iteration n+1 +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codret ) +c +c 2.2. ==> la solution a l'iteration n +c + nocson = taopts(9) +c +c 2.3. ==> les sauvegardes du maillage a l'iteration n +c + nosvmn = taopts(14) +c +c==== +c 3. les renumerotations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. les renumerotations ; codret', codret +#endif +c +c 3.1. ==> la renumerotation a l'iteration n +c + if ( codret.eq.0 ) then +c + call gmnomc ( nosvmn//'.RenuMail', norenn, codret ) +c + endif +c +c 3.2. ==> la renumerotation a l'iteration n+1 +c + if ( codret.eq.0 ) then +c + call gmnomc ( nohmap//'.RenuMail', norenp, codret ) +c + endif +c +c==== +c 4. conversions +c==== +c 4.1. ==> Option : +c 0 : Adaptation complete +c 1 : Modification de degre +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. option ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Mode de fonctionnement HOMARD', taopti(4) + write (ulsort,90002) 'Modification de degre', taopti(41) +#endif +c + if ( taopti(4).eq.1 .or. taopti(4).eq.4 ) then + option = 0 + elseif ( taopti(4).eq.3 .and. taopti(41).eq.1 ) then + option = 1 + elseif ( taopti(4).eq.3 .and. taopti(41).eq.0 ) then + option = -1 + else + codret = 41 + endif +c + endif +c +c 4.2. ==> Conversion effective +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. conversion effective ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOVR', nompro + call dmflsh (iaux) +#endif + call pcsovr ( nocson, nocsop, + > nohmap, norenn, nosvmn, + > option, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + taopts(10) = nocsop + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AP_Conversion/pcsono.F b/src/tool/AP_Conversion/pcsono.F new file mode 100644 index 00000000..3330845c --- /dev/null +++ b/src/tool/AP_Conversion/pcsono.F @@ -0,0 +1,1057 @@ + subroutine pcsono ( numnp1, numnp2, typint, deraff, option, + > nbpara, carenf, carchf, nrfonc, + > hetnoe, ancnoe, + > nnoeho, nnoeca, nnosho, + > hetare, somare, filare, + > np2are, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > tritet, cotrte, aretet, + > filtet, hettet, + > quahex, coquhe, arehex, + > filhex, hethex, fhpyte, + > facpen, cofape, arepen, + > filpen, hetpen, fppyte, + > facpyr, cofapy, arepyr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de SOlution - NOeud +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numnp1 . e . 1 . nombre de noeuds de la fonction si P1 . +c . numnp2 . e . 1 . nombre de noeuds de la fonction si P2 . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . ancnoe . e . nbnoto . ancien numero de noeud si deraffinement . +c . nnoeho . e . renoto . numero des noeuds en entree pour homard . +c . nnoeca . e . renoto . numero des noeuds en entree dans le calcul . +c . nnosho . e . rsnoto . numero des noeuds en sortie pour homard . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. code des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSONO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer numnp1, numnp2 + integer typint + integer option +c + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer hetnoe(nbnoto), ancnoe(nbnoto) + integer nnoeho(renoto), nnoeca(renoto) + integer nnosho(rsnoto) + integer hetare(nbarto), somare(2,nbarto), filare(nbarto) + integer np2are(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer filtet(nbteto), hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto), filhex(nbheto), fhpyte(2,nbheco) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer filpen(nbpeto), hetpen(nbpeto), fppyte(2,nbpeco) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + integer typfon, typcha, typgeo, typass + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenmx, npvapr + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas + integer adpcan, adpcap + integer nrfon2, nrfon3 + integer typprf, typin0 +c + integer nbfop1, nbfop2 + integer pvap1h, pvap2h +c + character*8 nofonc, obpcan, obpcap, obprof + character*8 oblopg + character*8 nvap1h, nvap2h +c + integer nbmess + parameter ( nbmess = 120 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +#include "esimpr.h" +c + texte(1,4) = '(5x,''Fonctions '',a2,'' :'')' + texte(1,5) = + > '(5x,''. nombre de noeuds dans leur definition : '',i10)' + texte(1,6) = + > '(5x,''. nombre de noeuds dans le maillage initial : '',i10)' + texte(1,7) = + > '(5x,''. nombre de valeurs du profil : '',i10)' + texte(1,8) = '(''... Premiere(s) valeur(s) : '',5i10)' + texte(1,9) = '(''... Dernieres valeurs : '',5i10)' + texte(1,10) = '(''. Interpolation '',a)' +c + texte(2,4) = '(5x,''Fonctions '',a2,'' :'')' + texte(2,5) = + > '(5x,''. number of nodes in their definition : '',i10)' + texte(2,6) = + > '(5x,''. number of nodes in the initial mesh : '',i10)' + texte(2,7) = + > '(5x,''. length of profile : '',i10)' + texte(2,8) = '(''... First value(s) : '',5i10)' + texte(2,9) = '(''... Last value(s) : '',5i10)' + texte(2,10) = '(''. '',a,'' interpolation '')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c==== +c 2. grandeurs utiles +c==== +c 2.1. ==> recuperation +c + if ( codret.eq.0 ) then +c + iaux = nrfonc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, typass, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenmx, npvapr, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblopg, + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,*) 'apres pcfor2' +cgn write(ulsort,90002) 'carsup', carsup +cgn write(ulsort,90002) 'nnvapr', nnvapr +cgn write(ulsort,90002) 'nbtafo', nbtafo +c +c 2.2. ==> type de profil +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. type de profil ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( degre.eq.2 .and. nnvapr.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPRN', nompro +#endif + call pcsprn ( typprf, numnp1, + > hetnoe, nnoeho, + > nnvapr, imem(n1lipr) ) +c + else +c + typprf = 0 +c + endif +c + endif +c +c 2.3. ==> grandeurs deduites +c . Si on n'a rien de special sur le profil, on est fidele +c au degre +c . Sinon, c'est une fonction de degre 1 +c + if ( codret.eq.0 ) then +c + if ( typprf.eq.0 ) then +c + if ( degre.eq.1 ) then + nbfop1 = nbtafo + nbfop2 = 0 + else + nbfop1 = 0 + nbfop2 = nbtafo + endif +c + else +c + nbfop1 = nbtafo + nbfop2 = 0 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfop1, nbfop2, typint', + > nbfop1, nbfop2, typint + write (ulsort,texte(langue,7)) nnvapr + if ( nnvapr.gt.0 ) then + write (ulsort,texte(langue,8)) + > (imem(iaux),iaux=n1lipr,n1lipr+min(4,nnvapr-1)) + if ( nnvapr.gt.5 ) then + write (ulsort,texte(langue,9)) + > (imem(iaux),iaux=n1lipr+nnvapr-5,n1lipr+nnvapr-1) + endif + endif +#endif +c + endif +c +c 2.4. ==> verification des coherences de taille +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. verification ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nnvapr.le.0 ) then +c + if ( nbfop1.ne.0 ) then + if ( numnp1.ne.reno1i ) then + write (ulsort,texte(langue,4)) 'P1' + write (ulsort,texte(langue,5)) numnp1 + write (ulsort,texte(langue,6)) reno1i + write (ulsort,texte(langue,7)) nnvapr + codret = 4 + endif + endif +c + if ( nbfop2.ne.0 ) then + if ( numnp2.ne.renoto ) then + write (ulsort,texte(langue,4)) 'P2' + write (ulsort,texte(langue,5)) numnp2 + write (ulsort,texte(langue,6)) renoto + write (ulsort,texte(langue,7)) nnvapr + codret = 4 + endif + endif +c + endif +c + endif +c +c 2.5. ==> type d'interpolation +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. type interpolation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + typin0 = -1 +c + if ( option.eq.1 ) then + if ( nbfop1.ne.0 ) then + typin0 = 5 + else + typin0 = 4 + endif + elseif ( typint.eq.0 ) then + if ( nbfop1.ne.0 ) then + typin0 = 1 + else + typin0 = 2 + endif + elseif ( typint.eq.1 ) then + typin0 = 1 + if ( nbfop1.eq.0 ) then + write (ulsort,texte(langue,100+typin0)) + write (ulsort,texte(langue,117)) 1, nbfop1 + codret = 251 + endif + elseif ( typint.eq.2 .or. typint.eq.3 ) then + typin0 = typint + if ( nbfop2.eq.0 ) then + write (ulsort,texte(langue,100+typin0)) + write (ulsort,texte(langue,117)) 2, nbfop2 + codret = 252 + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typin0', typin0 + if ( typin0.ge.0 .and. typin0.le.5 ) then + write (ulsort,texte(langue,100+typin0)) + write (ulsort,texte(langue,117)) 1, nbfop1 + write (ulsort,texte(langue,117)) 2, nbfop2 + endif +#endif +c +c==== +c 3. interpolation des variables aux noeuds +c remarque : si les fonctions sont inexistantes dans l'une des +c categories, on alloue quand meme les tableaux. les +c longueurs sont nulles donc on ne perd pas de place. +c la lisibilite du programme compense le peu de temps cpu +c necessaire a cela. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. redistribution ; codret', codret +#endif +c +c 3.1. ==> allocations des tableaux intermediaires pour les fonctions +c aux noeuds +c + if ( codret.eq.0 ) then +c + if ( nbfop1.ne.0 ) then + iaux = nbfop1 * max(renoto,nbnoto) + else + iaux = 0 + endif + call gmalot ( nvap1h, 'reel ', iaux, pvap1h, codre1 ) + iaux = nbfop2 * max(renoto,nbnoto) + call gmalot ( nvap2h, 'reel ', iaux, pvap2h, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 3.2. ==> redistribution des valeurs dans la numerotation homard +c +cgn write (*,*) 'fonctions P1' +cgn write (*,92010) +cgn >(rmem(iaux),iaux=n1valr,n1valr-1+nbfop1*max(nnvapr,renoto)) +cgn write (*,*) 'fonctions P2' +cgn write (*,92010) +cgn >(rmem(iaux),iaux=n1valr,n1valr-1+nbfop2*max(nnvapr,renoto)) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSRHO', nompro +#endif + call pcsrho ( nbfop1, nbfop2, numnp1, numnp2, + > deraff, option, + > hetnoe, ancnoe, + > nnoeho, nnoeca, + > nnvapr, imem(n1lipr), imem(adpcan), imem(adpcap), + > rmem(n1valr), rmem(n1valr), + > rmem(pvap1h), rmem(pvap2h), + > ulsort, langue, codret ) +c + endif +cgn write (*,*)'apres pcsrho' +cgn call gmprsx (nompro, nvap1h ) +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073) +cgn write(*,92010) (rmem(pvap1h-1+iaux),iaux=1,nbnoto) +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto) +c +c==== +c 4. Interpolation p1 des variables aux noeuds +c==== +c + if ( codret.eq.0 ) then +c + if ( typin0.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. ==> Interpolation p1 ; codret', codret +#endif +c + write (ulsort,texte(langue,10)) 'P1' +c +c 4.1. ==> interpolation p1 pour les aretes decoupees +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS1AR', nompro +#endif + call pcs1ar ( nbfop1, imem(adpcap), + > hetare, somare, filare, + > rmem(pvap1h) ) +cgn write (*,*)'apres pcs1ar' +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073) +cgn write(*,92010) (rmem(pvap1h-1+iaux),iaux=2073,2073) +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +c +c 4.2. ==> interpolation p1 pour les quadrangles decoupes +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS1QU', nompro +#endif + call pcs1qu ( nbfop1, imem(adpcap), + > somare, + > hetqua, arequa, filqua, + > rmem(pvap1h) ) +cgn write (*,*)'apres pcs1qu' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +c + endif +c +c 4.3. ==> interpolation p1 pour les hexaedres decoupes +c + if ( nbheto.ne.0 ) then +c +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS1HE', nompro +#endif + call pcs1he ( nbfop1, imem(adpcap), + > somare, + > aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > filhex, hethex, fhpyte, + > facpyr, cofapy, arepyr, + > rmem(pvap1h) ) +c +cgn write (*,*)'apres pcs1he' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) + endif +c +c 4.3. ==> interpolation p1 pour les pentaedres decoupes +c + if ( nbpeto.ne.0 ) then +c +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS1PE', nompro +#endif + call pcs1pe ( nbfop1, imem(adpcap), + > somare, + > aretri, arequa, + > tritet, cotrte, + > facpen, cofape, arepen, + > filpen, hetpen, fppyte, + > facpyr, cofapy, arepyr, + > rmem(pvap1h) ) +c +cgn write (*,*)'apres pcs1pe' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) + endif +c +c==== +c 5. Interpolation p2 des variables aux noeuds +c Attention a respecter l'ordre dans l'enchainement des appels +c==== +c + elseif ( typin0.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Interpolation p2 ; codret', codret +#endif +c + write (ulsort,texte(langue,10)) 'P2' +c +c 5.1. ==> pour les aretes decoupees +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2AR', nompro +#endif + call pcs2ar ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetare, somare, np2are, filare ) +cgn write (*,*)'apres pcs2ar' +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto-1) +cgn write (*,92010) +cgn > (rmem(pvap2h-1+iaux),iaux=nbfop2*nbnoto-1,nbfop2*nbnoto-1) +c +c 5.2. ==> pour les tetraedres decoupes +c + if ( nbtema.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2TE', nompro +#endif + call pcs2te ( nbfop2, imem(adpcap), rmem(pvap2h), + > tritet, cotrte, aretet, + > hettet, filtet, + > somare, np2are, + > aretri ) +c + endif +c +c 5.3. ==> quadrangles et hexaedres decoupes +c Remarque : avec les hexaedres, il faut faire deux passages +c pour gerer les raffinements sur deux niveaux +c Tant pis si des calculs sont faits deux fois. +c + jaux = 1 + if ( nbheto.ne.0 ) then + jaux = 2 + endif +c + do 53 , iaux = 1 , jaux +c +c 5.3.1. ==> pour les quadrangles jaux +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2QU', nompro +#endif + call pcs2qu ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetqua, arequa, filqua, + > somare, np2are, + > aretri ) +cgn write(ulsort,*)'apres pcs2qu' +cgn write(ulsort,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write(ulsort,92010)(rmem(pvap2h-1+iaux),iaux=1,nbnoto) +c + endif +c +c 5.3.2. ==> pour les hexaedres decoupes +c + if ( nbheto.ne.0 ) then +c +cgn write (*,*)'avant pcs2he' +cgn call gmprsx ( 'avant pcs2he',nvap2h ) +cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2HE', nompro +#endif + call pcs2he ( nbfop2, imem(adpcap), rmem(pvap2h), + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > hetqua, arequa, filqua, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > ulsort, langue, codret ) +c +cgn write (*,*)'apres pcs2he' +cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto) +cgn call gmprsx ( 'apres pcs2he',nvap2h ) +cgn call gmprsx ( 'apres pcs2he',obpcap) + endif +c + 53 continue +c +c 5.4. ==> pour les pentaedres decoupes +c + if ( nbpeto.ne.0 ) then +c +cgn call gmprsx ( 'avant pcs2pe',nvap2h ) +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2PE', nompro +#endif + call pcs2pe ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > ulsort, langue, codret ) +c +cgn write (*,*)'apres pcs2pe' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto) +cgn call gmprsx ( 'apres pcs2he',nvap2h ) +cgn call gmprsx ( 'apres pcs2he',obpcap) + endif +cgn call gmprsx ( 'au final',nvap2h ) +cgn call gmprsx ( 'au final',obpcap) +c +c 5.5. ==> pour les triangles decoupes +c + if ( nbtrma.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCS2TR', nompro +#endif + call pcs2tr ( nbfop2, imem(adpcap), rmem(pvap2h), + > hettri, aretri, filtri, + > somare, np2are ) +cgn write (*,*)'apres pcs2tr' +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbnoto) +cgn write (*,92010) +cgn > (rmem(pvap2h-1+iaux),iaux=nbfop2*nbnoto,nbfop2*nbnoto) +c + endif +c +c==== +c 6. Interpolation iso-p2 des variables aux noeuds +c Attention a respecter l'ordre dans l'enchainement des appels +c==== +c + elseif ( typin0.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Interpolation iso-p2 ; codret', codret +#endif +c + write (ulsort,texte(langue,10)) 'iso-P2' +cgn write (*,*)'au debut' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto) +c +c 6.1. ==> pour les aretes decoupees +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSIAR', nompro +#endif + call pcsiar ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetare, somare, np2are, filare ) +cgn write (*,*)'apres pcsiar' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto) +c +c 6.2. ==> pour les tetraedres decoupes +c + if ( nbtema.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSITE', nompro +#endif + call pcsite ( nbfop2, imem(adpcap), rmem(pvap2h), + > tritet, cotrte, aretet, + > hettet, filtet, + > somare, np2are, + > aretri ) +c + endif +c +c 6.3. ==> quadrangles et hexaedres decoupes +c Remarque : avec les hexaedres, il faut faire deux passages +c pour gerer les raffinements sur deux niveaux +c Tant pis si des calculs sont faits deux fois. +c + jaux = 1 + if ( nbheto.ne.0 ) then + jaux = 2 + endif +c + do 63 , iaux = 1 , jaux +c +c 6.3.1. ==> pour les quadrangles decoupes +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSIQU', nompro +#endif + call pcsiqu ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetqua, arequa, filqua, + > somare, np2are, + > aretri ) +cgn write (*,*)'apres pcsiqu' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto) +c + endif +c +c 6.3.2. ==> pour les hexaedres decoupes +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSIHE', nompro +#endif + call pcsihe ( nbfop2, imem(adpcap), rmem(pvap2h), + > hethex, quahex, coquhe, arehex, + > filhex, fhpyte, + > somare, np2are, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr ) +c +cgn write (*,*)'apres pcs2he' +cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto) +cgn call gmprsx ( 'apres pcs2he',nvap2h ) +cgn call gmprsx ( 'apres pcs2he',obpcap) +c + endif +c + 63 continue +c +c 6.4. ==> pour les pentaedres decoupes +c + if ( nbpeto.ne.0 ) then +c +cgn call gmprsx ( 'avant pcsipe',nvap2h ) +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSIPE', nompro +#endif + call pcsipe ( nbfop2, imem(adpcap), rmem(pvap2h), + > hetpen, facpen, cofape, filpen, fppyte, + > somare, np2are, + > aretri, arequa, + > tritet, cotrte, + > facpyr, cofapy, + > ulsort, langue, codret ) +c + endif +c +c 6.5. ==> pour les triangles decoupes +c + if ( nbtrma.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSITR', nompro +#endif + call pcsitr ( nbfop2, imem(adpcap), rmem(pvap2h), + > hettri, aretri, filtri, + > somare, np2are ) +cgn write (*,*)'apres pcsitr' +cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto) +c + endif +c +c==== +c 7. Interpolation des variables aux noeuds P1 vers P2 +c Les nouveaux noeuds P2 sont tous des milieux d'aretes (cf mmcnp2) +c==== +c + elseif ( typin0.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. modification P1 vers P2 ; codret', codret +#endif +c + write (ulsort,texte(langue,10)) 'P1' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSMAR', nompro +#endif + call pcsmar ( nbfop2, imem(adpcap), + > somare, np2are, + > rmem(pvap2h) ) +cgn write (*,*)'apres pcsmar' +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073) +cgn write(*,92010) (rmem(pvap2h-1+iaux),iaux=1,nbnoto) +c +c==== +c 8. Interpolation des variables aux noeuds P2 vers P1 +c Rien n'est a faire puisque la copie des valeurs sur les noeuds P1 +c a eu lieu au depart +c==== +c + elseif ( typin0.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. modification P2 vers P1 ; codret', codret +#endif +c + write (ulsort,texte(langue,10)) 'P1' +c +c==== +c 9. Type inconnu +c==== +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. type inconnu ; codret', codret +#endif +c + write (ulsort,texte(langue,109)) + codret = 90 +c + endif +c + endif +c +c==== +c 10. redistribution des valeurs dans la numerotation du calcul +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. ==> redistribution ; codret', codret +#endif +cgn write (ulsort,90002)'avant pcsrc0 : nbfop1, nbfop2', +cgn > nbfop1, nbfop2 +cgn do 888 , iaux = 1 , nbnoto +cgn if ( imem(adpcap-1+iaux).eq.0 ) then +cgn write(ulsort,*) 'Noeud', iaux +cgn endif +cgn 888 continue +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto) +cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*rsnoto-1) +c + if ( nbfop1.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSRC0_d1', nompro +#endif + call pcsrc0 ( nbfop1, rsnoto, + > imem(adpcap), nnosho, + > rmem(pvap1h), rmem(p1valr) ) +c +cgn write (*,*)'apres pcsrc0' +cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073) +cgn write(*,92010) (rmem(p1valr-1+iaux),iaux=2073,2073) +cgn write(*,92010)(rmem(iaux),iaux=p1valr,p1valr-1+nbfop1*rsnoto-1) + endif +c + endif +c + if ( nbfop2.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSRC0_d2', nompro +#endif + call pcsrc0 ( nbfop2, rsnoto, + > imem(adpcap), nnosho, + > rmem(pvap2h), rmem(p1valr) ) +cgn write (*,*)nbnoto, rsnoto +cgn write (*,*)'apres pcsrc0' +cgn write (*,92010)(rmem(iaux),iaux=p1valr,p1valr-1+nbfop2*rsnoto) +cgn write (*,92010) +cgn > (rmem(p1valr-1+iaux),iaux=nbfop2*nbnoto-5,nbfop2*nbnoto) +cgn do 889 , iaux = 1 , nbnoto +cgn if ( imem(adpcap-1+iaux).eq.0 ) then +cgn write(ulsort,*) 'Noeud', iaux +cgn endif +cgn 889 continue +c + endif +c + endif +c +c==== +c 11. menage +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GMLBOJ', nompro +#endif +c + call gmlboj ( nvap1h, codre1 ) + call gmlboj ( nvap2h, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +cgn write(ulsort,90002)'debut du profil', +cgn > (imem(adpcap+iaux),iaux=0,4) +cgn write(ulsort,90004)'debut des valeurs', +cgn > (rmem(pvap2h+iaux),iaux=0,4) +cgn do 999 , iaux = 1 , nbnoto +cgn if ( imem(adpcap-1+iaux).eq.0 ) then +cgn write(ulsort,90002) 'oubli de', iaux +cgn endif +cgn 999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsope.F b/src/tool/AP_Conversion/pcsope.F new file mode 100644 index 00000000..ab3b94e3 --- /dev/null +++ b/src/tool/AP_Conversion/pcsope.F @@ -0,0 +1,535 @@ + subroutine pcsope ( typint, deraff, + > nbpara, carenf, carchf, nrfonc, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, ancpen, filpen, fppyte, + > nbanpe, anfipe, anhepe, anptpe, + > npeeca, npesca, + > nteeca, ntesca, + > npyeca, npysca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - PEntaedres +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : n1vapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenm1 . +c . . . . 16 : npvap1 . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpc1n . +c . . . . 5 : obpc1p . +c . . . . 6 : obpro1 . +c . . . . 7 : oblo1g . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . nbanpe . e . 1 . nombre de pentaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfipe . e . nbanpe . tableau filpen du maillage de l'iteration n. +c . anhepe . e . nbanpe . tableau hetpen du maillage de l'iteration n. +c . anptpe . e . 2** . tableau fppyte du maillage de l'iteration n. +c . npeeca . e . * . numero des pentaedres dans le calcul entree. +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npyeca . e . * . numero des pyramides dans le calcul entree . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOPE' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombsr.h" +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + integer typint + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hetpen(nbpeto), ancpen(*) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer nbanpe, anfipe(nbanpe), anhepe(nbanpe), anptpe(2,*) +c + integer npeeca(repeto), npesca(rspeto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) +c + double precision coonoe(nbnoto,sdim) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, n1vapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenm1, npvap1 + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas +c + integer nrfon2 + integer typfo2, typch2, typge2, typas2 + integer ngaus2, nnenm2, nnvap2, carsu2, nbtaf2 + integer n2vale, n2valr, n2obpr, n2obch, n2lipr + integer npenm2, npvap2 + integer p2vale, p2valr, p2obpr, p2obch, p2vatt + integer p2vane, p2tyas +c + integer nrfon3 + integer typfo3, typch3, typge3, typas3 + integer ngaus3, nnenm3, nnvap3, carsu3, nbtaf3 + integer n3vale, n3valr, n3obpr, n3obch, n3lipr + integer npenm3, npvap3 + integer p3vale, p3valr, p3obpr, p3obch, p3vatt + integer p3vane, p3tyas +c + integer adpc1n, adpc1p + integer adpc2n, adpc2p + integer adpc3n, adpc3p +c + character*8 nofon1, obpc1n, obpc1p, obpro1, oblo1g + character*8 nofon2, obpc2n, obpc2p, obpro2, oblo2g + character*8 nofon3, obpc3n, obpc3p, obpro3, oblo3g +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp1.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +#endif +c +c==== +c 2. grandeurs utiles +c==== +c +c 2.1. ==> la fonction de base +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfonc),iaux= 1,9) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, n1vapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenm1, npvap1, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofon1, + > obpc1n, obpc1p, obpro1, adpc1n, adpc1p, + > oblo1g, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon1', nofon1 + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nrfon2', nrfon2 + write (ulsort,90002) 'nrfon3', nrfon3 + write (ulsort,90003) 'oblo1g', oblo1g + endif +#endif +c +c 2.2. ==> les fonctions annexes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. fonctions annexes ; codret', codret +#endif +c 2.2.1. ==> tetraedres +c + if ( nrfon2.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfon2 + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfon2),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2_te', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > nrfon2, + > typfo2, typch2, typge2, typas2, + > ngaus2, nnenm2, nnvap2, carsu2, nbtaf2, + > n2vale, n2valr, n2obpr, n2obch, n2lipr, + > npenm2, npvap2, + > p2vale, p2valr, p2obpr, p2obch, p2vatt, + > p2vane, p2tyas, + > iaux, jaux, + > nofon2, + > obpc2n, obpc2p, obpro2, adpc2n, adpc2p, + > oblo2g, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon2', nofon2 + write (ulsort,90002) 'typfo2', typfo2 + write (ulsort,90002) 'typch2', typch2 + write (ulsort,90002) 'typge2', typge2 + write (ulsort,90002) 'typas2', typas2 + write (ulsort,90002) 'carsu2', carsu2 + write (ulsort,90002) 'ngaus2', ngaus2 +c write (ulsort,90003) 'oblo2g', oblo2g + endif +#endif +c + endif +c + endif +c +c 2.2.2. ==> pyramides +c + if ( nrfon3.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfon3 + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfon3),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2_py', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > nrfon3, + > typfo3, typch3, typge3, typas3, + > ngaus3, nnenm3, nnvap3, carsu3, nbtaf3, + > n3vale, n3valr, n3obpr, n3obch, n3lipr, + > npenm3, npvap3, + > p3vale, p3valr, p3obpr, p3obch, p3vatt, + > p3vane, p3tyas, + > iaux, jaux, + > nofon3, + > obpc3n, obpc3p, obpro3, adpc3n, adpc3p, + > oblo3g, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon3', nofon3 + write (ulsort,90002) 'typfo3', typfo3 + write (ulsort,90002) 'typch3', typch3 + write (ulsort,90002) 'typge3', typge3 + write (ulsort,90002) 'typas3', typas3 + write (ulsort,90002) 'carsu3', carsu3 + write (ulsort,90002) 'ngaus3', ngaus3 +c write (ulsort,90003) 'oblo3g', oblo3g + endif +#endif +c + endif +c + endif +c +c==== +c 3. interpolation des variables +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. interpolation variables ; codret', codret +#endif +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPE0', nompro +#endif + call pcspe0 ( nbtafo, typint, deraff, + > imem(adpc1n), imem(adpc1p), + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, ancpen, filpen, fppyte, + > nbanpe, anfipe, anptpe, + > npeeca, npesca, + > nteeca, ntesca, + > npyeca, npysca, + > rmem(n1valr), rmem(p1vatt), + > rmem(n2valr), rmem(p2vatt), + > imem(adpc2n), imem(adpc2p), + > rmem(n3valr), rmem(p3vatt), + > imem(adpc3n), imem(adpc3p), + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,*) 'pent' +cgn if ( nbpent.eq.8 ) then +cgn codret=67 +cgn else +cgn codret=178 +cgn endif +cgn write(ulsort,92010) (rmem(p1vatt+iaux),iaux=0,nbpeto-1) +cgn write(ulsort,*) 'penr' +cgn write(ulsort,3000) (rmem(p2vatt+iaux),iaux=0,nbpent-1) +cgn write(ulsort,*) 'pyra' +cgn if ( nbpent.eq.8 ) then +cgn codret=75 +cgn else +cgn codret=225 +cgn endif +cgn write(ulsort,3000) (rmem(p3vatt+codret+iaux),iaux=0,nbpyto-1) +cgn 3000 format(10g13.5) +cgn codret = 0 +c + else +c +c 3.2. ==> avec plusieurs points de Gauss +c +c 3.2.1. ==> champ aux noeuds par element +c + if ( carsup.eq.1 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8)) mess14(langue,1,6) + write (ulsort,texte(langue,10)) + codret = 321 +c + endif +c +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEPE1', nompro +#endif + call pcepe1 ( nbtafo, ngauss, deraff, + > imem(adpc1n), imem(adpc1p), + > hetpen, ancpen, filpen, fppyte, + > nbanpe, anfipe, anhepe, anptpe, + > npeeca, npesca, + > nteeca, ntesca, + > npyeca, npysca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.2. ==> vrai champ aux points de Gauss +c + else +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,9)) mess14(langue,1,6) + write (ulsort,texte(langue,10)) + codret = 322 +c + endif +c + endif +c + endif +cgn print *, 'codret = ', codret +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsoqu.F b/src/tool/AP_Conversion/pcsoqu.F new file mode 100644 index 00000000..7535c51d --- /dev/null +++ b/src/tool/AP_Conversion/pcsoqu.F @@ -0,0 +1,551 @@ + subroutine pcsoqu ( typint, deraff, option, + > nbpara, carenf, carchf, nrfonc, + > coonoe, + > somare, + > aretri, + > arequa, hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > nbantr, anfatr, + > ntreca, ntrsca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - QUadrangles +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n +c . anhequ . e . nbanqu . tableau hetqua du maillage de l'iteration n +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . nbantr . e . 1 . nombre de triangles issus du decoupage par . +c . . . . conformite sur le maillage avant adaptation. +c . anfatr . e . nbantr . tableau famtri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrac . numero des triangles du calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOQU' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombsr.h" +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer typint + integer option + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4), hetqua(nbquto), ancqua(*) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu), anhequ(nbanqu) + integer nbantr, anfatr(nbantr) +c + integer nqueca(requto), nqusca(rsquto) + integer ntreca(retrto), ntrsca(rstrto) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, n1vapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenm1, npvap1 + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas + integer dimcpg +c + integer typfo2, typch2, typge2, nbtya2 + integer ngaus2, nnenm2, nnvap2, carsu2, nbtaf2 + integer n2vale, n2valr, n2obpr, n2obch, n2lipr + integer npenm2, npvap2 + integer p2vale, p2valr, p2obpr, p2obch, p2vatt + integer p2vane, p2tyas + integer nrfon2 +c + integer nrfon3 +c + integer adpc1n, adpc1p + integer adpc2n, adpc2p +c + integer nbnor1 + integer adcon1, adcop1, adpop1, adwip1 +c + character*8 nofon1, obpc1n, obpc1p, obpro1, oblo1g + character*8 nofon2, obpc2n, obpc2p, obpro2, oblo2g + character*8 ntrava + character*64 nolop1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c + codret = 0 +c +#include "pcimp1.h" +#include "impr03.h" +c +c==== +c 2. grandeurs utiles +c==== +c +c 2.1. ==> la fonction de base +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfonc),iaux= 1,9) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, n1vapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenm1, npvap1, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofon1, + > obpc1n, obpc1p, obpro1, adpc1n, adpc1p, + > oblo1g, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofon1', nofon1 + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'nrfon2', nrfon2 +cgn write (ulsort,90003) 'oblo1g', oblo1g + endif +#endif +c +c 2.2. ==> la fonction annexe +c + if ( nrfon2.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfon2 + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux= 1,10) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=11,20) + write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=21,nbpara) + write(ulsort,90003) 'carchf',(carchf(iaux,nrfon2),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2_tr', nompro +#endif + call pcfor2 ( nbpara, carenf, carchf, + > nrfon2, + > typfo2, typch2, typge2, nbtya2, + > ngaus2, nnenm2, nnvap2, carsu2, nbtaf2, + > n2vale, n2valr, n2obpr, n2obch, n2lipr, + > npenm2, npvap2, + > p2vale, p2valr, p2obpr, p2obch, p2vatt, + > p2vane, p2tyas, + > iaux, jaux, + > nofon2, + > obpc2n, obpc2p, obpro2, adpc2n, adpc2p, + > oblo2g, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'typfo2', typfo2 + write (ulsort,90002) 'typch2', typch2 + write (ulsort,90002) 'typge2', typge2 + write (ulsort,90002) 'nbtya2', nbtya2 + write (ulsort,90002) 'carsu2', carsu2 + write (ulsort,90002) 'ngaus2', ngaus2 +cgn write (ulsort,90003) 'oblo2g', oblo2g + endif +#endif +c + endif +c +c==== +c 3. interpolation des variables +c==== +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSQU0', nompro +#endif + call pcsqu0 ( nbtafo, typint, deraff, + > imem(adpc1n), imem(adpc1p), + > coonoe, + > somare, + > arequa, hetqua, ancqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > rmem(n2valr), rmem(p2vatt), + > imem(adpc2n), imem(adpc2p), + > ulsort, langue, codret ) +c + endif +c + else +c +c 3.2. ==> avec plusieurs points de Gauss +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.2 plusieurs pts de Gauss ; codret = ', codret +#endif +c +c 3.2.1. ==> champ aux noeuds par element +c + if ( carsup.eq.1 ) then +c +c 3.2.1.1. ==> en degre 1 +c + if ( degre.eq.1 ) then +c +c 3.2.1.1.1. ==> adaptation standard +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEQU1', nompro +#endif + call pcequ1 ( nbtafo, ngauss, deraff, + > imem(adpc1n), imem(adpc1p), + > hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.1.1.2. ==> modification de degre : de 2 vers 1 +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEQU3', nompro +#endif + iaux = 8 + call pcequ3 ( nbtafo, iaux, ngauss, + > imem(adpc1n), imem(adpc1p), + > nqueca, nqusca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2.1.2. ==> en degre 2 +c + else +c +c 3.2.1.2.1. ==> adaptation standard +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEQU2', nompro +#endif + call pcequ2 ( nbtafo, ngauss, deraff, + > imem(adpc1n), imem(adpc1p), + > hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > nbantr, anfatr, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > rmem(n2valr), rmem(p2vatt), + > imem(adpc2n), imem(adpc2p), + > ulsort, langue, codret ) +c + endif +c +c 3.2.1.2.2. ==> modification de degre : de 1 vers 2 +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCEQU4', nompro +#endif + iaux = 4 + call pcequ4 ( nbtafo, iaux, ngauss, + > imem(adpc1n), imem(adpc1p), + > nqueca, nqusca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + endif +cgn print*,'retour de pcequ2 dans pcsoqu' +c + endif +c +c 3.2.2. ==> vrai champ aux points de Gauss +c + else +c +c 3.2.2.1. ==> recuperation de la localisation des points de Gauss +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPG', nompro +#endif +c + call utcapg ( oblo1g, + > nolop1, typgeo, ngauss, dimcpg, + > adcon1, adcop1, adpop1, + > ulsort, langue, codret ) +c + if ( degre.eq.1 ) then + nbnor1 = 4 + else + nbnor1 = 8 + endif +c + endif +c +c 3.2.2.2. ==> interpolation +c + if ( codret.eq.0 ) then + iaux = ngauss*nbnor1 + call gmalot ( ntrava, 'reel ', iaux, adwip1, codret ) + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSQUG', nompro +#endif + call pcsqug ( nbtafo, ngauss, nbnor1, typgeo, deraff, + > imem(adpc1n), imem(adpc1p), + > hetqua, ancqua, filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > rmem(adcon1), rmem(adcop1), rmem(adwip1), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrava , codret ) + endif +c + endif +c + endif +cgn print *, 'codret = ', codret +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) rmem(n1valr), rmem(p1vatt) + write (ulsort,*) rmem(n1valr+1), rmem(p1vatt+1) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsote.F b/src/tool/AP_Conversion/pcsote.F new file mode 100644 index 00000000..59d80f0d --- /dev/null +++ b/src/tool/AP_Conversion/pcsote.F @@ -0,0 +1,370 @@ + subroutine pcsote ( typint, deraff, + > nbpara, carenf, carchf, nrfonc, + > hettet, anctet, filtet, + > nbante, anfite, anhete, + > nteeca, ntesca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - TEtraedres +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : typass . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblo1g . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n. +c . anhete . e . nbante . tableau hettet du maillage de l'iteration n. +c . nteeca . e . * . tetraedres en entree dans le calcul . +c . ntesca . e . rsteto . tetraedres en sortie dans le calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOTE' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer typint + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer hettet(nbteto), anctet(*) + integer filtet(nbteto) + integer nbante, anfite(nbante), anhete(nbante) +c + integer nteeca(reteto), ntesca(rsteto) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer typfon, typcha, typgeo, typass + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenmx, npvapr + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas + integer adpcan, adpcap + integer nrfon2, nrfon3 + integer nbnorf + integer adcono, adcopg, adpopg, adwipg + integer dimcpg +c + character*8 nofonc, obpcan, obpcap, obprof + character*8 oblo1g + character*8 ntrava + character*64 nolopg +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "pcimp1.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +#endif +c +c==== +c 2. grandeurs utiles +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'carenf ',(carenf(iaux,nrfonc),iaux= 1,10) + write(ulsort,90002) 'carenf ',(carenf(iaux,nrfonc),iaux=11,20) + write(ulsort,90002) 'carenf ', + > (carenf(iaux,nrfonc),iaux=21,nbpara) + write(ulsort,90003) 'carchf ',(carchf(iaux,nrfonc),iaux= 1,9) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, typass, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenmx, npvapr, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblo1g, + > ulsort, langue, codret ) +c + endif +c + +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofonc', nofonc + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'typass', typass + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90003) 'oblo1g', oblo1g + endif +#endif +c +c==== +c 3. interpolation des variables +c==== +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSTE0', nompro +#endif +cgn print *,(rmem(n1valr+iaux-1),iaux=1,5) + call pcste0 ( nbtafo, typint, deraff, + > imem(adpcan), imem(adpcap), + > hettet, anctet, filtet, + > nbante, anfite, + > nteeca, ntesca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +cgn print *,(rmem(p1vatt+iaux-1),iaux=1,18) +c + else +c +c 3.2. ==> avec plusieurs points de Gauss +c +c 3.2.1. ==> champ aux noeuds par element +c + if ( carsup.eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCETE1', nompro +#endif + call pcete1 ( nbtafo, ngauss, deraff, + > imem(adpcan), imem(adpcap), + > hettet, anctet, filtet, + > nbante, anfite, anhete, + > nteeca, ntesca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.2. ==> vrai champ aux points de Gauss +c + else +c +c 3.2.2.1. ==> recuperation de la localisation des points de Gauss +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPG', nompro +#endif +c + call utcapg ( oblo1g, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c + if ( degre.eq.1 ) then + nbnorf = 4 + else + nbnorf = 10 + endif +c + endif +c +c 3.2.2.2. ==> interpolation +c + if ( codret.eq.0 ) then + iaux = ngauss*nbnorf + call gmalot ( ntrava, 'reel ', iaux, adwipg, codret ) + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSTEG', nompro +#endif + call pcsteg ( nbtafo, ngauss, nbnorf, typgeo, deraff, + > imem(adpcan), imem(adpcap), + > hettet, anctet, filtet, + > nbante, anfite, + > nteeca, ntesca, + > rmem(n1valr), rmem(p1vatt), + > rmem(adcono), rmem(adcopg), rmem(adwipg), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrava , codret ) + endif +c + endif +c + endif +cgn print *, 'codret = ', codret +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsotr.F b/src/tool/AP_Conversion/pcsotr.F new file mode 100644 index 00000000..0386d7e6 --- /dev/null +++ b/src/tool/AP_Conversion/pcsotr.F @@ -0,0 +1,446 @@ + subroutine pcsotr ( typint, deraff, option, + > nbpara, carenf, carchf, nrfonc, + > hettri, anctri, filtri, + > nbantr, anfitr, anhetr, + > ntreca, ntrsca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - TRiangles +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc. +c . carenf . s .nbpara* . caracteristiques entieres des fonctions : . +c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee . +c . . . . 1, pour une ancienne associee a une . +c . . . . autre fonction . +c . . . . -1, pour une nouvelle fonction . +c . . . . 2 : typcha . +c . . . . 3 : typgeo . +c . . . . 4 : nbtyas . +c . . . . 5 : ngauss . +c . . . . 6 : nnenmx . +c . . . . 7 : nnvapr . +c . . . . 8 : carsup . +c . . . . 9 : nbtafo . +c . . . . 10 : anvale . +c . . . . 11 : anvalr . +c . . . . 12 : anobch . +c . . . . 13 : anprpg . +c . . . . 14 : anlipr . +c . . . . 15 : npenmx . +c . . . . 16 : npvapr . +c . . . . 17 : apvale . +c . . . . 18 : apvalr . +c . . . . 19 : apobch . +c . . . . 20 : apprpg . +c . . . . 21 : apvatt . +c . . . . 22 : apvane . +c . . . . 23 : antyas . +c . . . . 24 : aptyas . +c . . . . 25 : numero de la 1ere fonction associee . +c . . . . 26 : numero de la 2nde fonction associee . +c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :. +c . . . nnfopa. 1 : nom de la fonction . +c . . . . 2 : nom de la fonction n associee . +c . . . . 3 : nom de la fonction p associee . +c . . . . 4 : obpcan . +c . . . . 5 : obpcap . +c . . . . 6 : obprof . +c . . . . 7 : oblopg . +c . . . . 8 : si aux points de Gauss, nom de la . +c . . . . fonction n ELNO correspondante . +c . . . . 9 : si aux points de Gauss, nom de la . +c . . . . fonction p ELNO correspondante . +c . nrfonc . e . 1 . numero de la fonction principale . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . anctri . e . nbtrto . anciens numeros des triangles conserves . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n. +c . anhetr . e . nbantr . tableau hettri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOTR' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombsr.h" +#include "nomber.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer typint + integer option + integer nbpara + integer carenf(nbpara,*) + integer nrfonc +c + integer hettri(nbtrto), anctri(*) + integer filtri(nbtrto) + integer nbantr, anfitr(nbantr), anhetr(nbantr) +c + integer ntreca(retrto), ntrsca(rstrto) +c + character*8 carchf(nbpara,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer typfon, typcha, typgeo, nbtyas + integer ngauss, nnenmx, nnvapr, carsup, nbtafo + integer n1vale, n1valr, n1obpr, n1obch, n1lipr + integer npenmx, npvapr + integer p1vale, p1valr, p1obpr, p1obch, p1vatt + integer p1vane, p1tyas + integer adpcan, adpcap + integer nrfon2, nrfon3 + integer nbnorf + integer adcono, adcopg, adpopg, adwipg + integer dimcpg +c + character*8 nofonc, obpcan, obpcap, obprof + character*8 oblopg + character*8 ntrava + character*64 nolopg +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c + codret = 0 +c +#include "pcimp1.h" +c +c==== +c 2. grandeurs utiles +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFOR2', nompro +#endif + iaux = nrfonc + call pcfor2 ( nbpara, carenf, carchf, + > iaux, + > typfon, typcha, typgeo, nbtyas, + > ngauss, nnenmx, nnvapr, carsup, nbtafo, + > n1vale, n1valr, n1obpr, n1obch, n1lipr, + > npenmx, npvapr, + > p1vale, p1valr, p1obpr, p1obch, p1vatt, + > p1vane, p1tyas, + > nrfon2, nrfon3, + > nofonc, + > obpcan, obpcap, obprof, adpcan, adpcap, + > oblopg, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90003) 'nofonc', nofonc + write (ulsort,90002) 'typfon', typfon + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'p1vane', p1vane + write (ulsort,90002) 'p1tyas', p1tyas + endif +#endif +c +c==== +c 3. interpolation des variables +c==== +c +c 3.1. ==> sans point de Gauss +c + if ( ngauss.eq.ednopg ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1 sans pts de Gauss ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSTR0', nompro +#endif + call pcstr0 ( nbtafo, typint, deraff, + > imem(adpcan), imem(adpcap), + > hettri, anctri, filtri, + > nbantr, anfitr, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + else +c +c 3.2. ==> avec plusieurs points de Gauss +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2 plusieurs pts de Gauss ; codret', codret +#endif +c +c 3.2.1. ==> champ aux noeuds par element +c + if ( carsup.eq.1 ) then +c +c 3.2.1.1. ==> en degre 1 +c + if ( degre.eq.1 ) then +c +c 3.2.1.1.1. ==> adaptation standard +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCETR1', nompro +#endif + call pcetr1 ( nbtafo, deraff, + > imem(adpcan), imem(adpcap), + > hettri, anctri, filtri, + > nbantr, anfitr, anhetr, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.1.1.2. ==> modification de degre : de 2 vers 1 +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCETR3', nompro +#endif + iaux = 6 + call pcetr3 ( nbtafo, iaux, ngauss, + > imem(adpcan), imem(adpcap), + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2.1.2. ==> en degre 2 +c + else +c +c 3.2.1.2.1. ==> adaptation standard +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCETR2', nompro +#endif + call pcetr2 ( nbtafo, deraff, + > imem(adpcan), imem(adpcap), + > hettri, anctri, filtri, + > nbantr, anfitr, anhetr, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c +c 3.2.1.2.2. ==> modification de degre : de 1 vers 2 +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCETR4', nompro +#endif + iaux = 3 + call pcetr4 ( nbtafo, iaux, ngauss, + > imem(adpcan), imem(adpcap), + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 3.2.2. ==> vrai champ aux points de Gauss +c + else +c +c 3.2.2.1. ==> recuperation de la localisation des points de Gauss +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPG', nompro +#endif +c + call utcapg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c + if ( degre.eq.1 ) then + nbnorf = 3 + else + nbnorf = 6 + endif +c + endif +c +c 3.2.2.2. ==> interpolation +c + if ( codret.eq.0 ) then + iaux = ngauss*nbnorf + call gmalot ( ntrava, 'reel ', iaux, adwipg, codret ) + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSTRG', nompro +#endif + call pcstrg ( nbtafo, ngauss, nbnorf, typgeo, deraff, + > imem(adpcan), imem(adpcap), + > hettri, anctri, filtri, + > nbantr, anfitr, + > ntreca, ntrsca, + > rmem(n1valr), rmem(p1vatt), + > rmem(adcono), rmem(adcopg), rmem(adwipg), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrava , codret ) + endif +c + endif +c + endif +cgn print 90002, 'codret', codret +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsovr.F b/src/tool/AP_Conversion/pcsovr.F new file mode 100644 index 00000000..12e1d491 --- /dev/null +++ b/src/tool/AP_Conversion/pcsovr.F @@ -0,0 +1,1620 @@ + subroutine pcsovr ( nocson, nocsop, + > nomail, norenn, nosvmn, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution VRaie +c - - - -- +c ______________________________________________________________________ +c remarque : en principe, tous les cas de figure sont couverts ... +c mais c'est tellement alambique que je prefere mettre un +c code de retour non nul au cas ou ... +c comme disait le quotidien de mon enfance : +c "On peut etre trop petit ou trop grand, +c on n'est jamais trop prudent." +c La Montagne - 1972 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsop . s . char8 . nom de l'objet solution iteration n+1 . +c . nocson . e . char8 . nom de l'objet solution iteration n . +c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . norenn . e . char8 . nom de l'objet renumerotation iteration n . +c . nosvmn . e . char8 . nom de l'objet contenant les sauvegardes . +c . . . . du maillage n . +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSOVR' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envada.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nomber.h" +#include "nombsr.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nocsop, nocson + character*8 nomail, norenn, nosvmn +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3 + integer codre0 +c + integer nbcham, nbpafo, nbprof, nblopg + integer phetno, pcoono, pancno + integer phetar, psomar, pnp2ar, pfilar, pancar + integer phettr, paretr, pfiltr, ppertr, panctr, adpetr + integer phetqu, parequ, pfilqu, pperqu, pancqu, adhequ + integer phette, ptrite, pcotrt, parete, pfilte, pmerte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pmerhe, panche + integer adhes2 + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pmerpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pmerpe, pancpe + integer adpes2 + integer pcfaar, pcfatr, pcfaqu + integer pfamar, pfamtr, pfamqu, pfamte, pfamhe, pfampy, pfampe +c + integer adnbrn, adnbrp + integer adnohp, adnocp + integer adarcp + integer adtrcp + integer adqucp + integer adtecp + integer adhecp + integer adpycp + integer adpecp + integer adnohn, adnocn, adnoin, lgnoin + integer admphn, admpcn, admpin, lgmpin + integer adarhn, adarcn, adarin, lgarin + integer adtrhn, adtrcn, adtrin, lgtrin + integer adquhn, adqucn, adquin, lgquin + integer adtehn, adtecn, adtein, lgtein + integer adhehn, adhecn, adhein, lghein + integer adpyhn, adpycn, adpyin, lgpyin + integer adpehn, adpecn, adpein, lgpein +c + integer aninch, aninpf, aninpr, aninlg + integer apinch, apinpf, apinpr, apinlg + integer npprof, approf, nbproi + integer nplopg, aplopg, nblpgi + integer nnfopa, tnpgpf, anobfo, antyge + integer npfopa, typgpf, apobfo, aptyge + integer typint + integer nbpara + integer nrpafo + integer nrfonc + integer adtr1i, adtr1s + integer adtra2, adtrav, nbtrav + integer nrpass +c + integer typgeo, ngauss, carsup +c + integer nbanar, adafar, adaear + integer nbantr, adaftr, adaetr + integer nbanqu, adafqu, adaequ + integer nbante, adafte, adaete + integer nbanhe, adafhe, adaehe, adaihe + integer nbanpy, adafpy, adaepy + integer nbanpe, adafpe, adaepe, adaipe + integer pafatr +c + integer tbiaux(1) + integer nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra + integer decanu(-1:7) +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nnpafo, nppafo + character*8 ntrav1, ntrav2 + character*8 ntrava + character*8 liprof + character*8 lilopg + character*8 tbsaux(1) +c + logical deraff + logical extrus +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Solution a l''''iteration '',a,'' : '')' + texte(1,5) = '(''Nombre de paquets de fonctions : '', i3)' + texte(1,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' + texte(1,8) = '(/,''Champs sur les '',a)' + texte(1,9) = '(/,''Champs aux noeuds par element sur les '',a)' + texte(1,10) = '(/,''Champs aux points de Gauss des '',a)' + texte(1,11) = '(/,''Champs aux points de Gauss des '',a)' + texte(1,12) = '(''Paquet de fonction '',a,'' numero : '',i3)' + texte(1,13) = '(''... fonction numero : '',i3)' +c + texte(2,4) = '(''Solution at iteration '',a,'' : '')' + texte(2,5) = '(''Number of packs of functions : '', i3)' + texte(2,7) = '(5x,''Conversion HOMARD ----> '',a18,/)' + texte(2,8) = '(/,''Fields over '',a)' + texte(2,9) = '(/,''Fields based on nodes per element for '',a)' + texte(2,10) = '(/,''Fields based on Gauss points for '',a)' + texte(2,11) = '(/,''Fields based on Gauss points for '',a)' + texte(2,12) = '(''Function pack '',a,'' # : '',i3)' + texte(2,13) = '(''.. Function # : '',i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c 1.2. ==> nombre de parametres a enregistrer par fonction +c + nbpara = 26 +c +#ifdef _DEBUG_HOMARD_ +10000 format(43('=')) + write (ulsort,10000) + write (ulsort,texte(langue,4)) 'n' + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoCham' ) + call gmprsx (nompro, '%%%%%%%9' ) + call gmprsx (nompro, '%%%%%%%9.Nom_Comp' ) + call gmprsx (nompro, '%%%%%%%9.Cham_Ent' ) + call gmprsx (nompro, '%%%%%%%9.Cham_Car' ) +cgn call gmprsx (nompro, '%%%%%%10' ) +cgn call gmprsx (nompro, '%%%%%%10.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%10.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%11' ) +cgn call gmprsx (nompro, '%%%%%%11.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%11.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%8' ) +cgn call gmprsx (nompro, '%%%%%%%8.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%8.Cham_Car' ) +cgn call gmprsx (nompro, '%%%%%%%9' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Car' ) + call gmprsx (nompro, nocson//'.InfoPaFo' ) + call gmprsx (nompro, '%%%%%%13' ) + call gmprsx (nompro, '%%%%%%13.Fonction' ) + call gmprsx (nompro, '%%%%%%12' ) +cgn call gmprsx (nompro, '%%%%%%19.Fonction' ) +cgn call gmprsx (nompro, '%%%%%%18' ) +cgn call gmprsx (nompro, '%%%%%%18.InfoPrPG' ) +cgn call gmprsx (nompro, nocson//'.InfoProf' ) + write (ulsort,10000) +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +#include "mslve4.h" + endif +c + if ( codret.eq.0 ) then +c + if ( ( rafdef.eq.3 .or. rafdef.eq.4 ) .and. nbiter.gt.0 ) then + deraff = .true. + else + deraff = .false. + endif +c + if ( typcca.eq.26 .or .typcca.eq.46 ) then + extrus = .false. + elseif ( maextr.ne.0 ) then + extrus = .true. + else + extrus = .false. + endif +c + endif +c +c 2.2. ==> les tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2 ==> les tableaux ; codret', codret +#endif +c +c 2.2.1. ==> tableaux lies a la solution +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro +#endif + call utcaso ( nocson, + > nbcham, nbpafo, nbprof, nblopg, + > aninch, aninpf, aninpr, aninlg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbpafo +#endif +c + endif +c +c 2.2.2. ==> les renumerotations +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.2 ==> renumerotations ; codret', codret +#endif +c +c 2.2.2.1. ==> la renumerotation a l'iteration n +c + if ( codret.eq.0 ) then +c + call gmadoj ( norenn//'.Nombres', adnbrn, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > renois, renoei, renomp, + > renop1, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > iaux, iaux, + > iaux, iaux, + > ulsort, langue, codret ) +c + reno1i = renois + renoei + renomp + renop1 +c +c cf. eslmm2 + decanu(-1) = 0 + decanu(3) = 0 + decanu(2) = nbtetr + decanu(1) = nbtetr + nbtria + decanu(0) = nbtetr + nbtria + nbsegm + decanu(4) = nbtetr + nbtria + nbsegm + nbmapo + decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmapo', nbmapo + write(ulsort,90002) 'nbsegm', nbsegm + write(ulsort,90002) 'nbtria', nbtria + write(ulsort,90002) 'nbtetr', nbtetr + write(ulsort,90002) 'nbquad', nbquad + write(ulsort,90002) 'nbhexa', nbhexa + write(ulsort,90002) 'nbpent', nbpent + write(ulsort,90002) 'nbpyra', nbpyra + write(ulsort,90002) 'decanu', decanu +#endif +c + endif +c +c 2.2.2.2. ==> la renumerotation a l'iteration n+1 +c + if ( codret.eq.0 ) then +c + call gmadoj ( norenu//'.Nombres', adnbrp, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + rsnois = imem(adnbrp) + rsnoei = imem(adnbrp+1) + rsnomp = imem(adnbrp+2) + rsnop1 = imem(adnbrp+3) + rsnop2 = imem(adnbrp+4) + rsnoim = imem(adnbrp+5) + rseutc = imem(adnbrp+6) +c + endif +c +c 2.2.3. ==> les tableaux generaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.3 tableaux generaux ; codret', codret +#endif +c +c 2.2.3.1. ==> pour les noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 6 + call utad01 ( iaux, nhnoeu, + > phetno, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( deraff .or. + > ( option.eq.1 .and. degre.eq.1 ) ) then + call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codre0 ) + codret = max ( abs(codre0), codret ) + else + pancno = 1 + endif +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. apres noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no_new', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > rsnoac, rsnoto, adnohp, adnocp, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no_old', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenn, + > renoac, renoto, adnohn, adnocn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_no_old', nompro +#endif + iaux = -1 + jaux = 11 + call utre04 ( iaux, jaux, norenn, + > lgnoin, adnoin, + > ulsort, langue, codret) +c + endif +c +c 2.2.3.2. ==> pour les aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_ar', nompro +#endif + iaux = 1 + jaux = 1 + call utad97 ( iaux, jaux, deraff, extrus, + > nharet, norenu, norenn, nosvmn, + > phetar, psomar, kaux, pfilar, kaux, + > pfamar, pcfaar, pnp2ar, kaux, + > nbanar, pancar, + > adafar, adaear, kaux, kaux, + > rsarto, adarcp, + > rearac, rearto, adarhn, adarcn, + > lgarin, adarin, + > ulsort, langue, codret ) +c + endif +c +c +c 2.2.3.3. ==> pour les triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.3. triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_tr', nompro +#endif + iaux = 2 + jaux = 1 + call utad97 ( iaux, jaux, deraff, extrus, + > nhtria, norenu, norenn, nosvmn, + > phettr, paretr, kaux, pfiltr, ppertr, + > pfamtr, pcfatr, adpetr, kaux, + > nbantr, panctr, + > adaftr, adaetr, pafatr, kaux, + > rstrto, adtrcp, + > retrac, retrto, adtrhn, adtrcn, + > lgtrin, adtrin, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3.4. ==> pour les tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.4. tetraedres ; codret', codret +#endif +c + if ( nbteto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_te', nompro +#endif + iaux = 3 + jaux = 1 + call utad97 ( iaux, jaux, deraff, extrus, + > nhtetr, norenu, norenn, nosvmn, + > phette, ptrite, parete, pfilte, pmerte, + > pfamte, kaux, pcotrt, kaux, + > nbante, pancte, + > adafte, adaete, kaux, kaux, + > rsteto, adtecp, + > reteac, reteto, adtehn, adtecn, + > lgtein, adtein, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3.5. ==> pour les quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.5. quadrangles ; codret', codret +#endif +c + if ( nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_qu', nompro +#endif + iaux = 4 + jaux = 1 + call utad97 ( iaux, jaux, deraff, extrus, + > nhquad, norenu, norenn, nosvmn, + > phetqu, parequ, kaux, pfilqu, pperqu, + > pfamqu, pcfaqu, adhequ, kaux, + > nbanqu, pancqu, + > adafqu, adaequ, kaux, kaux, + > rsquto, adqucp, + > requac, requto, adquhn, adqucn, + > lgquin, adquin, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3.6. ==> pour les pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.6. pyramides ; codret', codret +#endif +c + if ( nbpyto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_py', nompro +#endif + iaux = 5 + jaux = 1 + call utad97 ( iaux, jaux, deraff, extrus, + > nhpyra, norenu, norenn, nosvmn, + > phetpy, pfacpy, parepy, pfilpy, pmerpy, + > pfampy, kaux, pcofay, kaux, + > nbanpy, pancpy, + > adafpy, adaepy, kaux, kaux, + > rspyto, adpycp, + > repyac, repyto, adpyhn, adpycn, + > lgpyin, adpyin, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3.7. ==> pour les hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.7. hexaedres ; codret', codret +#endif +c + if ( nbheto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_He', nompro +#endif + iaux = 6 + if ( nbheco.eq.0 ) then + jaux = 1 + else + jaux = 2 + endif + call utad97 ( iaux, jaux, deraff, extrus, + > nhhexa, norenu, norenn, nosvmn, + > phethe, pquahe, parehe, pfilhe, pmerhe, + > pfamhe, kaux, pcoquh, adhes2, + > nbanhe, panche, + > adafhe, adaehe, kaux, adaihe, + > rsheto, adhecp, + > reheac, reheto, adhehn, adhecn, + > lghein, adhein, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3.8. ==> pour les pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)' 2.2.3.8. pentaedres ; codret', codret +#endif +c + if ( nbpeto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD97_Pe', nompro +#endif + iaux = 7 + if ( nbpeco.eq.0 ) then + jaux = 1 + else + jaux = 2 + endif + call utad97 ( iaux, jaux, deraff, extrus, + > nhpent, norenu, norenn, nosvmn, + > phetpe, pfacpe, parepe, pfilpe, pmerpe, + > pfampe, kaux, pcofap, adpes2, + > nbanpe, pancpe, + > adafpe, adaepe, kaux, adaipe, + > rspeto, adpecp, + > repeac, repeto, adpehn, adpecn, + > lgpein, adpein, + > ulsort, langue, codret ) +c + endif +c + endif +c +cgn call gmprsx(nompro,norenn//'.InfoSupE') +cgn call gmprsx(nompro,norenn//'.InfoSupE.Tab3') +cgn call gmprsx(nompro,norenn//'.InfoSupE.Tab4') +cgn call gmprsx(nompro,norenn//'.InfoSupE.Tab6') +cgn call gmprsx(nompro,norenn//'.TrCalcul') +cgn call gmprsx(nompro,norenn//'.TrHOMARD') +cgn call gmprsx(nompro,norenn//'.QuCalcul') +cgn call gmprsx(nompro,norenn//'.QuHOMARD') +c==== +c 3. allocations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. allocation ; codret', codret +#endif +c +c 3.1. ==> allocation de l'objet de tete +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALSO', nompro +#endif + call utalso ( nocsop, + > nbcham, nbpafo, nbprof, nblopg, + > apinch, apinpf, apinpr, apinlg, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> copie des caracteristiques des champs +c + if ( codret.eq.0 ) then +c + call gmcpgp ( nocson//'.InfoCham', + > nocsop//'.InfoCham', codre1 ) + call gmadoj ( nocsop//'.InfoCham', apinch, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +cgn call gmprsx (nompro, nocsop ) +cgn call gmprsx (nompro, nocsop//'.InfoCham' ) +cgn call gmprsx('1er champ :', smem(apinch)) +cgn call gmprsx (' Fonction Profil LocaPG ', +cgn > smem(apinch)//'.Cham_Car') +cgn if ( nbcham.ge.2 ) then +cgn call gmprsx('2nd champ :', smem(apinch+1)) +cgn call gmprsx (' Fonction Profil LocaPG ', +cgn > smem(apinch+1)//'.Cham_Car') +c + endif +c +c 3.3. ==> allocation d'une memorisation des profils eventuels +c on alloue 3 fois plus grand pour tenir compte des +c eventuelles mailles de conformite +c + if ( codret.eq.0 ) then +c + npprof = 0 +c +cgn write (ulsort,90002) 'nbprof', nbprof + nbproi = 3*nbprof + call gmalot ( liprof, 'chaine ', nbproi, approf, codret ) +c + endif +c +c 3.4. ==> allocation d'une memorisation des localisations de points +c de Gauss eventuelles +c on alloue 3 fois plus grand pour tenir compte des +c eventuelles mailles de conformite +c + if ( codret.eq.0 ) then +c + nplopg = 0 +c +cgn write (ulsort,90002) 'nbpafo =', nbpafo + nblpgi = 3*nbpafo + call gmalot ( lilopg, 'chaine ', nblpgi, aplopg, codret ) +c + endif +c +c 3.5. ==> allocation d'une memorisation des tableaux temporaires +c + if ( codret.eq.0 ) then +c + iaux = 20*nbpafo + call gmalot ( ntrava, 'chaine ', iaux, adtrav, codret ) +c + endif +c +c==== +c 4. On classe les paquets de fonctions ainsi : +c . la premiere serie traite les champs aux noeuds par element +c . la seconde serie traite les autres champs +c Cela est indispensable pour pouvoir traiter les interpolations +c des champs exprimes aux points de Gauss dans le cas ou ils +c sont lies aux champs aux noeuds par elements : ils ont besoin des +c valeurs actualisees de leurs projection aux noeuds par element +c +c Pour chaque paquet de fonctions : +c tnpgpf : type geometrique associe +c ngauss : nombre de points de gauss +c carsup : caracteristiques du support +c 1, si aux noeuds par elements +c 2, si aux points de Gauss, associe avec +c un champ aux noeuds par elements +c 3, si aux points de Gauss autonome +c 0, sinon +c typint : type d'interpolation +c 0, si automatique +c aux noeuds : 1 si degre 1, 2 si degre 2, 3 si iso-P2 +c par element : 0 si intensif, 1 si extensif +c +c La liste allouee ici contient donc les noms des paquets de +c fonctions dans l'ordre du traitement. Cela occupe les nbpafo +c premieres cases. +c Dans les nbpafo cases suivantes, on memorise le paquet associe +c dans le cas de champs aux noeuds par elements ou aux points +c de Gauss. +c +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. classement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2*nbpafo + call gmalot ( ntrav2, 'chaine ', iaux, adtra2, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + jaux = adtra2 +c + do 41 , nrpass = 1 , 2 +cgn write (ulsort,90002) '== NRPASS ====', nrpass +c + do 411 , nrpafo = 1 , nbpafo +c + if ( codret.eq.0 ) then +c + nnpafo = smem(aninpf+nrpafo-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nnpafo, nrpafo +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( nnpafo, + > nnfopa, tnpgpf, ngauss, carsup, typint, + > anobfo, antyge, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'nnfopa', nnfopa + write (ulsort,90002) 'tnpgpf', tnpgpf + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + write (ulsort,*) (smem(anobfo+iaux),' ',iaux=0,nnfopa) + endif +#endif +c + if ( nrpass.eq.1 .and. carsup.eq.1 ) then + iaux = 1 + elseif ( nrpass.eq.2 .and. + > ( carsup.eq.0 .or. carsup.eq.2 .or. carsup.eq.3) ) then + iaux = 1 + else + iaux = 0 + endif +cgn write (ulsort,90002) '===> iaux', iaux + if ( iaux.ne.0 ) then + smem(jaux) = nnpafo +cc smem(jaux+nbpafo) = smem(anobfo+nnfopa) + jaux = jaux + 1 + endif +c + endif +c + 411 continue +c + 41 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ntrav2 ) +#endif +c +c==== +c 5. Exploration des divers paquets de fonctions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Exploration ; codret', codret +#endif +c + do 50 , nrpafo = 1 , nbpafo +c + nbtrav = 0 +c +c 5.1. ==> caracterisation du paquet de fonctions courant +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1. caracterisation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nnpafo = smem(adtra2+nrpafo-1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,12)) nnpafo, nrpafo +#endif +c +#ifdef _DEBUG_HOMARD_ +c write (ulsort,10000) + write (ulsort,texte(langue,12)) 'n', nrpafo + call gmprsx (nompro, nnpafo ) +c couple (nom objet Fonction, nom objet Fonction associe eventuel) +cgn call gmprsx ( +cgn > 'couples (objet Fonction, objet Fonction associe eventuel) :', +cgn > nnpafo//'.Fonction' ) +cgn call gmprsx (nompro, nnpafo//'.TypeSuAs' ) + if ( nrpafo.eq.-1 ) then + call gmprsx (nompro, '%%%%%%15' ) + elseif ( nrpafo.eq.-2 ) then + call gmprsx (nompro, '%%%%%%16' ) + elseif ( nrpafo.eq.-3 ) then + call gmprsx (nompro, '%%%%%%17' ) + endif +cgn call gmprsx (nompro, '%%%%%%%9' ) +cgn call gmprsx (nompro, '%%%%%%%9.InfoPrPG' ) +cgn call gmprsx (nompro, '%%%%%%14.ListEnti' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( nnpafo, + > nnfopa, tnpgpf, ngauss, carsup, typint, + > anobfo, antyge, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'nnfopa', nnfopa + write (ulsort,90002) 'tnpgpf', tnpgpf + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + write (ulsort,*) + >'couples (objet Fonction, objet Fonction associe eventuel) :' + write (ulsort,*) (smem(anobfo+iaux),' ',iaux=0,nnfopa) + call gmprsx ('1ere fonction du paquet', smem(anobfo) ) + call gmprsx (' Profil LocaPG F. Associee', + > smem(anobfo)//'.InfoPrPG' ) + endif +#endif +c + endif +c +c 5.2. ==> creation du paquet pour la solution en sortie +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. creation ; codret', codret +#endif +c 5.2.1. ==> allocation d'un nouveau paquet +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPF', nompro +#endif + npfopa = 0 + typgpf = tnpgpf + call utalpf ( nppafo, + > npfopa, typgpf, ngauss, carsup, typint, + > apobfo, aptyge, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Le paquet ',nppafo,' est cree :' + call gmprsx (nompro, nppafo ) +#endif +c + endif +c +c 5.2.2. ==> memorisation +c + if ( codret.eq.0 ) then +c + smem(apinpf+nrpafo-1) = nppafo + smem(adtra2+nrpafo-1+nbpafo) = nppafo +c + endif +c +c 5.3. ==> copie eventuelle des types associes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.3. copie ; codret', codret +#endif +c + if ( typgpf.lt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif + iaux = 5 + jaux = abs(typgpf) + call utmopf ( nppafo, iaux, + > jaux, tbsaux, imem(antyge), + > nnpafo, + > npfopa, typgpf, ngauss, carsup, typint, + > apobfo, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) (smem(apobfo+iaux),iaux=0,npfopa),nompro + endif +#endif +c + endif +c +c 5.4. ==> Pour un champ aux points de Gauss avec lien sur des +c elements aux noeuds, memorisation du paquet associe +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.4. paquet associe ; codret', codret +#endif +c + if ( carsup.eq.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif + iaux = 4 + call utmopf ( nppafo, iaux, + > nbpafo, smem(adtra2), tbiaux, + > nnpafo, + > npfopa, typgpf, ngauss, carsup, typint, + > apobfo, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) (smem(apobfo+iaux),iaux=0,npfopa),nompro + endif +#endif +c + endif +c +c 5.5. ==> stockage des informations liees aux fonctions du paquet +c adtr1i : caracteristiques entieres des fonctions : +c anc/nou, typcha, typgeo, typass, ngauss, etc. +c adtr1s : caracteristiques caracteres des fonctions +c nom fonc., nom fonc. n, nom fonc. p, etc. +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.5. stockage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbpara*nnfopa*3 + call gmalot ( ntrav1, 'entier ', iaux, adtr1i, codre1 ) + smem(adtrav) = ntrav1 + call gmalot ( ntrav1, 'chaine ', iaux, adtr1s, codre2 ) + smem(adtrav+1) = ntrav1 + nbtrav = 2 +cgn print *,nompro,' 5.4 nbtrav = ', nbtrav +cgn print *,(' ',smem(adtrav+iaux-1),iaux=1,nbtrav) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCFORE', nompro + call gmprsx (nompro,smem(anobfo+nnfopa-1)) + call gmprsx (nompro,smem(anobfo+nnfopa-1)//'.InfoCham') +cgn call gmprsx (nompro,'%%%%%%%8') +cgn call gmprsx (nompro,'%%%%%%%8.Nom_Comp') +cgn call gmprsx (nompro,'%%%%%%%8.Cham_Ent') +cgn call gmprsx (nompro,'%%%%%%%8.Cham_Car') +cgn call gmprsx (nompro,smem(anobfo+nnfopa-1)//'.InfoPrPG') +#endif + call pcfore ( option, extrus, + > nnfopa, anobfo, + > npfopa, nppafo, + > nbpara, imem(adtr1i), smem(adtr1s), + > nbtrav, smem(adtrav), + > adpetr, adhequ, + > adnohn, admphn, adarhn, adtrhn, adquhn, + > adtehn, adpyhn, adhehn, adpehn, + > adnocn, admpcn, adarcn, adtrcn, adqucn, + > adtecn, adpycn, adhecn, adpecn, + > adnoin, admpin, adarin, adtrin, adquin, + > adtein, adpyin, adhein, adpein, + > lgnoin, lgmpin, lgarin, lgtrin, lgquin, + > lgtein, lgpyin, lghein, lgpein, + > decanu, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'Apres PCFORE, npfopa', npfopa +cgn write (ulsort,10000) +cgn call gmprsx (nompro,smem(adtrav)) +cgn call gmprsx (nompro,smem(adtrav+1)) + write (ulsort,texte(langue,12)) 'p', nrpafo + call gmprsx (nompro, nppafo ) + call gmprsx (nompro, nppafo//'.Fonction' ) +cgn call gmprsx (nompro, nppafo//'.TypeSuAs' ) + endif +#endif +c +c 5.6. ==> mise a jour selon le support de chaque fonction du paquet +cgn print *,nompro,' 5.6 nbtrav = ', nbtrav +cgn print *,(' ',smem(adtrav+iaux-1),iaux=1,nbtrav) +cgn call gmprsx (nompro, '%%%%%%25' ) +cgn call gmprsx (nompro, '%%%%%%26' ) +cgn call gmprsx (nompro, '%%%%%%28' ) +cgn call gmprsx (nompro, '%%%%%%29' ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.6. mise a jour ; codret', codret +#endif +c + do 56 , nrfonc = 1 , nnfopa +c +c 5.6.1. ==> le type de support +c + if ( codret.eq.0 ) then +c + typgeo = imem(adtr1i-1+nbpara*(nrfonc-1)+3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==============================' + write (ulsort,texte(langue,13)) nrfonc + write (ulsort,90002) 'typgeo', typgeo +#endif +c + endif +c + iaux = nrfonc +c +c 5.6.2. ==> sur les noeuds +c + if ( typgeo.eq.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8)) mess14(langue,3,-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSONO', nompro +#endif + call pcsono ( renop1, renoto, typint, deraff, option, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > imem(phetno), imem(pancno), + > imem(adnohn), imem(adnocn), imem(adnohp), + > imem(phetar), imem(psomar), imem(pfilar), + > imem(pnp2ar), + > imem(phettr), imem(paretr), imem(pfiltr), + > imem(phetqu), imem(parequ), imem(pfilqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pfilte), imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(pfilhe), imem(phethe), imem(adhes2), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(pfilpe), imem(phetpe), imem(adpes2), + > imem(pfacpy), imem(pcofay), imem(parepy), + > ulsort, langue, codret ) +c + endif +c +c 5.6.3. ==> sur les aretes +c + elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,1) +cgn print *,'sur les aretes, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOAR', nompro +#endif + call pcsoar ( typint, deraff, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > imem(phetar), imem(pancar), imem(pfilar), + > imem(psomar), + > rmem(pcoono), + > imem(phettr), imem(paretr), imem(pfiltr), + > imem(phetqu), imem(parequ), imem(pfilqu), + > nbanar, imem(adafar), + > imem(adarcn), imem(adarcp), + > ulsort, langue, codret ) +c + endif +c +c 5.6.4. ==> sur les triangles +c + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,2) +cgn print *,'sur les triangles, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOTR', nompro +#endif + call pcsotr ( typint, deraff, option, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > imem(phettr), imem(panctr), imem(pfiltr), + > nbantr, imem(adaftr), imem(adaetr), + > imem(adtrcn), imem(adtrcp), + > ulsort, langue, codret ) +c + endif +c +c 5.6.5. ==> sur les quadrangles +c + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,4) +cgn print *,'sur les quadrangles, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOQU', nompro +#endif + call pcsoqu ( typint, deraff, option, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > rmem(pcoono), + > imem(psomar), + > imem(paretr), + > imem(parequ), + > imem(phetqu), imem(pancqu), imem(pfilqu), + > nbanqu, imem(adafqu), imem(adaequ), + > imem(adqucn), imem(adqucp), + > nbantr, imem(pafatr), + > imem(adtrcn), imem(adtrcp), + > ulsort, langue, codret ) +c + endif +c +c 5.6.6. ==> sur les tetraedres +c + elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,3) +cgn print *,'sur les tetraedres, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOTE', nompro +#endif + call pcsote ( typint, deraff, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > imem(phette), imem(pancte), imem(pfilte), + > nbante, imem(adafte), imem(adaete), + > imem(adtecn), imem(adtecp), + > ulsort, langue, codret ) +c + endif +c +c +c 5.6.7. ==> sur les hexaedres +c + elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,6) +cgn print *,'sur les hexaedres, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOHE', nompro +#endif + call pcsohe ( typint, deraff, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > rmem(pcoono), + > imem(psomar), + > imem(paretr), + > imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phethe), imem(panche), imem(pfilhe), + > imem(adhes2), + > nbanhe, + > imem(adafhe), imem(adaehe), imem(adaihe), + > imem(adhecn), imem(adhecp), + > imem(adtecn), imem(adtecp), + > imem(adpycn), imem(adpycp), + > ulsort, langue, codret ) +c + endif +c +c 5.6.8. ==> sur les pentaedres +c + elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8+carsup)) mess14(langue,3,7) +cgn print *,'sur les pentaedres, avec carsup = ', carsup +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOPE', nompro +#endif + call pcsope ( typint, deraff, + > nbpara, imem(adtr1i), smem(adtr1s), iaux, + > rmem(pcoono), + > imem(psomar), + > imem(paretr), + > imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpe), imem(pancpe), imem(pfilpe), + > imem(adpes2), + > nbanpe, + > imem(adafpe), imem(adaepe), imem(adaipe), + > imem(adpecn), imem(adpecp), + > imem(adtecn), imem(adtecp), + > imem(adpycn), imem(adpycp), + > ulsort, langue, codret ) +c + endif +c +c 5.6.9. ==> sur les pyramides +c +cgn elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then +c +cgn if ( codret.eq.0 ) then +c +cgn write (ulsort,texte(langue,8+carsup)) mess14(langue,3,5) +cgn print *,'sur les pyramides, avec carsup = ', carsup +cgn codret = 568 +c +cgn endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,12)) 'p', nrpafo + endif +#endif +c + 56 continue +c +c 5.7. ==> mise a jour +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.7. mise a jour ; codret', codret +#endif +c +c 5.7.1. ==> recuperation des caracteristiques du paquet de fonctions p +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( nppafo, + > npfopa, typgpf, ngauss, carsup, typint, + > apobfo, aptyge, + > ulsort, langue, codret ) +c + endif +c +c 5.7.2. ==> mise a jour des caracteristiques des profils +cgn write(ulsort,93020)'5.7.2',(smem(adtr1s+iaux-1),iaux=1,7) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCAPR', nompro +#endif + call pccapr ( npfopa, npprof, smem(approf), + > nbpara, imem(adtr1i), smem(adtr1s), + > ulsort, langue, codret ) +c + endif +c +c 5.7.3. ==> mise a jour des localisations des points de Gauss +cgn write(ulsort,93020)'5.7.3 - debut',(smem(adtr1s+iaux-1),iaux=1,7) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCAPG', nompro +#endif + call pccapg ( npfopa, nplopg, smem(aplopg), + > nbpara, imem(adtr1i), smem(adtr1s), + > ulsort, langue, codret ) +c + endif +c +c 5.7.4. ==> mise a jour des caracteristiques du paquet de fonctions +cgn write(ulsort,93020)'5.7.4',(smem(adtr1s+iaux-1),iaux=1,7) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCCAPF', nompro +#endif + call pccapf ( nppafo, npfopa, nbcham, smem(apinch), + > nbpara, imem(adtr1i), smem(adtr1s), + > option, + > ulsort, langue, codret ) +c + endif +c +c 5.8. ==> menage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.8. menage ; codret', codret + write (ulsort,90002) 'nombre de tableaux', nbtrav +#endif +c + do 58 , iaux = 1 , nbtrav +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'tableau ', smem(adtrav+iaux-1) +#endif +c + call gmobal ( smem(adtrav+iaux-1) , jaux ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'jaux', jaux +cgn if ( smem(adtrav+iaux-1).eq.'%%%%%%41')then +cgn call gmprsx ( nompro, smem(adtrav+iaux-1)) +cgn endif +#endif +c + if ( jaux.eq.1 ) then + call gmsgoj ( smem(adtrav+iaux-1) , codret ) + elseif ( jaux.eq.2 ) then + call gmlboj ( smem(adtrav+iaux-1) , codret ) + else + codret = -1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'codret', codret +#endif +c + endif +c + 58 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'entre 58 et 50 continue ; codret', codret +#endif +c + 50 continue +c +c==== +c 6. finitions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. finitions ; codret', codret +#endif +c +c 6.1. ==> menage de la solution en entree desormais inutile et des +c tableaux de travail +c + do 61 , iaux = 1 , nbpafo +c + if ( codret.eq.0 ) then +c + call gmsgoj ( smem(adtra2+iaux-1) , codret ) +c + endif +c + 61 continue +c + if ( codret.eq.0 ) then +c + call gmsgoj ( nocson , codre1 ) + call gmlboj ( ntrava , codre2 ) + call gmlboj ( ntrav2 , codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.2. ==> memorisation des profils +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. profils ; codret', codret +#endif +c + if ( npprof.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' liste des profils', liprof ) +#endif + if ( codret.eq.0 ) then + call gmmod ( liprof, approf, nbproi, npprof, 1, 1, codret ) + endif +c + if ( codret.eq.0 ) then + call gmecat ( nocsop, 3, npprof, codre1 ) + call gmcpgp ( liprof, nocsop//'.InfoProf', codre2 ) + call gmlboj ( liprof, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) + endif +c + endif +c +c 6.3. ==> memorisation des localisations de points de Gauss +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. Gauss ; codret', codret + write (ulsort,90002) 'nplopg', nplopg +#endif +c + if ( nplopg.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, lilopg ) +#endif + if ( codret.eq.0 ) then + call gmmod ( lilopg, approf, nblpgi, nplopg, 1, 1, codret ) + endif +c + if ( codret.eq.0 ) then + call gmecat ( nocsop, 4, nplopg, codre1 ) + call gmcpgp ( lilopg, nocsop//'.InfoLoPG', codre2 ) + call gmlboj ( lilopg, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +cgn write (ulsort,10000) + write (ulsort,texte(langue,4)) 'p' + call gmprsx (nompro//' apres 6.3', nocsop ) +cgn call gmprsx (nompro, nocsop//'.InfoCham' ) +cgn call gmprsx('1er champ :', smem(apinch)) +cgn call gmprsx (' Fonction Profil LocaPG ', +cgn > smem(apinch)//'.Cham_Car') +cgn if ( nbcham.ge.2 ) then +cgn call gmprsx('2nd champ :', smem(apinch+1)) +cgn call gmprsx (' Fonction Profil LocaPG ', +cgn > smem(apinch+1)//'.Cham_Car') +cgn endif +cgn call gmprsx (' Profil LocaPG F. Associee', +cgn > '%%%%%%20.InfoPrPG' ) +cgn call gmprsx (nompro, '%%%%%%%9' ) +cgn call gmprsx (nompro, '%%%%%%%9.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Car' ) +cgn call gmprsx (nompro, '%%%%%%10' ) +cgn call gmprsx (nompro, '%%%%%%10.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%10.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%11' ) +cgn call gmprsx (nompro, '%%%%%%11.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%11.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%8' ) +cgn call gmprsx (nompro, '%%%%%%%8.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%8.Cham_Car' ) +cgn call gmprsx (nompro, '%%%%%%%9' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%%9.Cham_Car' ) +cgn call gmprsx (nompro, nocsop//'.InfoPaFo' ) +cgn call gmprsx (nompro, '%%%%%%16' ) +cgn call gmprsx (nompro, '%%%%%%16.Fonction' ) +cgn call gmprsx (nompro, '%%%%%%24' ) +cgn call gmprsx (nompro, '%%%%%%24.ValeursR' ) +cgn call gmprsx (nompro, '%%%%%%24.InfoCham' ) +cgn call gmprsx (nompro, '%%%%%%16' ) +cgn call gmprsx (nompro, '%%%%%%16.Fonction' ) +cgn call gmprsx (nompro, '%%%%%%23' ) +cgn call gmprsx (nompro, '%%%%%%23.ValeursR' ) +cgn call gmprsx (nompro, '%%%%%%23.InfoCham' ) +cgn call gmprsx (nompro, nocsop//'.InfoProf' ) +cgncgn write (ulsort,10000) + endif +#endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcspe0.F b/src/tool/AP_Conversion/pcspe0.F new file mode 100644 index 00000000..b8630747 --- /dev/null +++ b/src/tool/AP_Conversion/pcspe0.F @@ -0,0 +1,454 @@ + subroutine pcspe0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, ancpen, filpen, fppyte, + > nbanpe, anfipe, anptpe, + > npeeca, npesca, + > nteeca, ntesca, + > npyeca, npysca, + > vafoen, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c PEntaedres - solution P0 +c -- - +c remarque : pcshe0 et pcspe0 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . nbanpe . e . 1 . nombre de pentaedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfipe . e . nbanpe . tableau filpen du maillage de l'iteration n. +c . anptpe . e . 2** . tableau fppyte du maillage de l'iteration n. +c . npeeca . e . * . numero des pentaedres dans le calcul entree. +c . npesca . e . rspeto . numero des pentaedres dans le calcul sortie. +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . npyeca . e . * . numero des pyramides dans le calcul entree . +c . npysca . e . rspyto . numero des pyramides dans le calcul sortie . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vateen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les tetraedres . +c . vatett . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les tetraedres . +c . prften . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . prftep . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le tetraedre est absent du profil . +c . . . . 1 : le tetraedre est present dans le profil. +c . vapyen . e . nbfonc*. variables en entree de l'adaptation pour . +c . . . * . les pyramides . +c . vapytt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les pyramides . +c . prfpyn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil. +c . prfpyp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : la pyramide est absente du profil . +c . . . . 1 : la pyramide est presente dans le profil +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPE0' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer hetpen(nbpeto), ancpen(*) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer nbanpe, anfipe(nbanpe), anptpe(2,*) + integer npeeca(repeto), npesca(rspeto) + integer nteeca(reteto), ntesca(rsteto) + integer npyeca(repyto), npysca(rspyto) + integer prften(*), prftep(*) + integer prfpyn(*), prfpyp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vateen(nbfonc,*) + double precision vatett(nbfonc,*) + double precision vapyen(nbfonc,*) + double precision vapytt(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c pehn = PEntaedre courant en numerotation Homard a l'it. N +c pehnp1 = PEntaedre courant en numerotation Homard a l'it. N+1 +c + integer pehn, pehnp1 +c +c etan = ETAt du pentaedre a l'iteration N +c etanp1 = ETAt du pentaedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nfpenp, nfpyrp, nftetp + integer ficp(3,11) + integer nfpenn, nfpyrn, nftetn + integer ficn(3,11) +c + double precision propor(11) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. on boucle sur tous les pentaedres du maillage HOMARD n+1 +c on trie en fonction de l'etat de du pentaedre dans le maillage n +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , iaux = 1 , nbpeto +c +c 2.1. ==> caracteristiques du pentaedre : +c + if ( codret.eq.0 ) then +c +c 2.1.1. ==> son numero homard dans le maillage precedent +c + pehnp1 = iaux + if ( deraff ) then + pehn = ancpen(pehnp1) + else + pehn = pehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etat = 0 : le pentaedre est actif. +c etat = 1, ..., 6 : le pentaedre est coupe en 2 pyramides et +c 1 tetraedre selon l'arete 1, ..., 6. +c etat = 17, ..., 19 : le pentaedre est coupe en 1 pyramide et +c 2 tetraedres selon l'arete 7, 8, 9. +c etat = 21, ..., 26 : le pentaedre est coupe en 6 tetraedres. +c etat = 31, ..., 36 : le pentaedre est coupe en 1 pyramide et +c 10 tetraedres. +c etat = 43, ..., 45 : le pentaedre est coupe en 4 pyramides et +c 2 tetraedres. +c etat = 51, 52 : le pentaedre est coupe en 11 tetraedres. +c etat = 55 : le pentaedre n'existait pas ; il a ete produit par +c un decoupage. +c etat = 80 : le pentaedre est coupe en 8. +c + etanp1 = mod(hetpen(pehnp1),100) + etan = (hetpen(pehnp1)-etanp1) / 100 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==========================================' + write (ulsort,90002) mess14(langue,1,7), pehnp1 + write (ulsort,90002) 'pehn ', pehn + write (ulsort,90002) 'etan ', etan + write (ulsort,90002) 'etanp1', etanp1 +cgn if ( pehn.eq.0 ) stop +#endif +c +c 2.1.3. ==> prealables a l'iteration n +c + if ( etan.ne.55 .and. etan.ne.99 ) then +c +c 2.1.3.1. ==> numerotation des fils +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEPY n', nompro +#endif + call pcsepy ( nfpenn, nfpyrn, nftetn, ficn, + > pehn, etan, + > anfipe, anptpe, + > npeeca, nteeca, npyeca, + > ulsort, langue, codret ) +c + endif +c +c 2.1.4. ==> prealables a l'iteration n+1 +c + if ( etanp1.ne.55 .and. etanp1.ne.99 ) then +c +c 2.1.4.1. ==> numerotation des fils +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEPY n+1', nompro +#endif + call pcsepy ( nfpenp, nfpyrp, nftetp, ficp, + > pehnp1, etanp1, + > filpen, fppyte, + > npesca, ntesca, npysca, + > ulsort, langue, codret ) +c +c 2.1.4.2. ==> en mode extensif, calcul des proportions +c + if ( typint.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEPZ', nompro +#endif + call pcsepz ( propor, + > pehnp1, etanp1, + > coonoe, somare, aretri, arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > filpen, fppyte, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 2.2. ==> Examen des differents etats +c + if ( codret.eq.0 ) then +c +c======================================================================= +c 2.2.1 ==> etan = 0 : le pentaedre etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEP0', nompro +#endif +c + call pcsep0 ( etan, etanp1, pehn, pehnp1, typint, + > prfcan, prfcap, + > nfpenp, nfpyrp, nftetp, ficp, propor, + > npeeca, npesca, + > nbfonc, vafoen, vafott, + > vatett, prftep, + > vapytt, prfpyp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEH0' +c +c======================================================================= +c 2.2.2. ==> le pentaedre etait coupe en conformite +c======================================================================= +c + elseif ( ( etan.ge.1 .and. etan.le.6 ) .or. + > ( etan.ge.17 .and. etan.le.19 ) .or. + > ( etan.ge.21 .and. etan.le.26 ) .or. + > ( etan.ge.31 .and. etan.le.36 ) .or. + > ( etan.ge.43 .and. etan.le.45 ) .or. + > ( etan.ge.51 .and. etan.le.52 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEP1', nompro +#endif +c + call pcsep1 ( etan, etanp1, pehn, pehnp1, typint, + > prfcap, + > nfpyrn, nftetn, ficn, + > nfpyrp, nftetp, ficp, propor, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > facpen, cofape, arepen, + > facpyr, cofapy, arepyr, + > hetpen, filpen, fppyte, + > npesca, + > ntesca, + > npysca, + > nbfonc, vafott, + > vateen, vatett, + > prften, prftep, + > vapyen, vapytt, + > prfpyn, prfpyp, + > ulsort, langue, codret ) +c +c +c======================================================================= +c 2.2.3. ==> etan = 80 : le pentaedre etait coupe en 8 pentaedres +c======================================================================= +c + elseif ( etan.eq.80 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEP8', nompro +#endif +c + call pcsep8 ( etanp1, pehnp1, typint, + > prfcan, prfcap, + > ficn, + > nfpyrp, nftetp, ficp, propor, + > npesca, + > nbfonc, vafoen, vafott, + > vatett, + > prftep, + > vapytt, + > prfpyp, + > ulsort, langue, codret ) +c + endif +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsprn.F b/src/tool/AP_Conversion/pcsprn.F new file mode 100644 index 00000000..f8edaa7b --- /dev/null +++ b/src/tool/AP_Conversion/pcsprn.F @@ -0,0 +1,125 @@ + subroutine pcsprn ( typprf, numnp1, + > hetnoe, nnoeho, + > nbvapr, listpr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - PRofil - Noeuds +c - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typprf . s . 1 . type du support defini par le profil . +c . . . . 0 : rien de special . +c . . . . 1 : tous les noeuds P1 et eux seuls . +c . . . . 2 : une partie des noeuds P1 . +c . numnp1 . e . 1 . nombre de noeuds P1 en entree . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . nnoeho . e . renoac . numero des noeuds en entre pour homard . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . listpr . e . * . liste des numeros de noeuds ou la fonction . +c . . . . est definie. . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'PCSPRN' ) +c +c 0.2. ==> communs +c +#include "nomber.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer typprf + integer numnp1 +c + integer nbvapr, listpr(*) +c + integer hetnoe(nbnoto) + integer nnoeho(renoac) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbnpr1, nbnpr2 +c ______________________________________________________________________ +c + nbnpr1 = 0 + nbnpr2 = 0 +c +c==== +c 1. si le maillage est inchange ou s'il n'y a eu que du raffinement, +c chaque noeud en entree de HOMARD est encore un noeud en sortie. +c Le numero d'un noeud dans HOMARD reste inchange. +c Il suffit de tester l'etat du noeud en entree +c Numero dans le calcul en entree <---> Numero HOMARD +c lenoeu <---> nnoeho(lenoeu) +c==== +c +cgn write(*,*) 'Dans pcsprn, nbvapr =', nbvapr +cgn 1789 format(a,'(',i5,',) =',i10,', noeud',i10) +c + do 10 , iaux = 1 , nbvapr +cgn write (*,1789)'listpr',iaux,listpr(iaux),nnoeho(listpr(iaux)) + jaux = hetnoe(nnoeho(listpr(iaux))) + if ( ((jaux-mod(jaux,10))/10).eq.1 ) then + nbnpr1 = nbnpr1 + 1 + else + nbnpr2 = nbnpr2 + 1 + goto 20 + endif + 10 continue +c +c==== +c 2. Bilan +c Si au moins un noeud non P1 est dans le profil, c'est du quelconque +c Sinon, on trie +c==== +c + 20 continue +c +cgn write(*,*) 'Dans pcsprn, nbnpr1 =', nbnpr1 +cgn write(*,*) 'Dans pcsprn, nbnpr2 =', nbnpr2 +cgn write(*,*) 'Dans pcsprn, numnp1 =', numnp1 + if ( nbnpr2.gt.0 ) then + typprf = 0 + else + if ( nbnpr1.eq.numnp1 ) then + typprf = 1 + elseif ( nbnpr1.lt.numnp1 ) then + typprf = 2 + else + typprf = 0 + endif + endif +cgn write(*,*) 'Dans pcsprn, typprf =', typprf +c + end diff --git a/src/tool/AP_Conversion/pcspt0.F b/src/tool/AP_Conversion/pcspt0.F new file mode 100644 index 00000000..727558aa --- /dev/null +++ b/src/tool/AP_Conversion/pcspt0.F @@ -0,0 +1,332 @@ + subroutine pcspt0 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Tetraedres d'etat anterieur 0 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss*. . +c . . . nbeven . . +c . vafott . es . nbfonc*. tableau temporaire de la solution . +c . . . ngauss*. . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPT0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer filtet(nbteto) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c tecn = TEtraedre courant en numerotation du Calcul a l'it. N +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecn, tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f5cp = Fils 5eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f6cp = Fils 6eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f7cp = Fils 7eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f8cp = Fils 8eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp, f5cp, f6cp, f7cp, f8cp +c + integer coderr + integer nrofon, nugaus +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c + coderr = 0 +c +c 1.2. ==> on repere son ancien numero dans le calcul +c + tecn = nteeca(tehn) +cgn write (ulsort,texte(langue,4)) 'nca', tecn +cgn write (ulsort,*) 'prfcan(tecn)', prfcan(tecn) +cgncc if ( prfcan(tecn).eq.0 ) then +cgn write (ulsort,texte(langue,4)) 'n ', tehn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgncc endif +c +c==== +c 2. etan = 0 : le tetraedre etait actif +c On explore tous les etats du tetraedre a l'iteration n+1 +c==== +c + if ( prfcan(tecn).gt.0 ) then +c +c ===> etanp1 = 0 : le tetraedre etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du tetraedre. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c +cgn write (ulsort,90002) 'tecnp1',tecnp1 + do 21 , nrofon = 1, nbfonc + do 211 , nugaus = 1 , ngauss +cgn write (ulsort,92010) vafoen(nrofon,nugaus,prfcan(tecn)) + vafott(nrofon,nugaus,tecnp1) = + > vafoen(nrofon,nugaus,prfcan(tecn)) + 211 continue + 21 continue +cgn write(ulsort,91010) tecn,-1,tecnp1 +c +c ==> etanp1 = 21, ..., 26 : le tetraedre etait actif et +c est decoupe en 2. +c les deux fils prennent la valeur de la fonction sur le pere +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(ngauss) + do 22 , nrofon = 1, nbfonc + daux = vafoen(nrofon,1,prfcan(tecn)) +cgn write (ulsort,*) 'daux', daux + do 221 , nugaus = 2, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(tecn)) + 221 continue + daux = daux*daux1 + do 222 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 222 continue + 22 continue +cgn write(12,91010) f1cp,f2cp +cgn write(ulsort,91010) tecn,-1, +cgn > f1cp,f2cp +c +c ==> etanp1 = 41, ... 47 : le tetraedre etait actif et est +c decoupe en 4. +c les quatre fils prennent la valeur de la fonction sur le +c pere +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(ngauss) + do 23 , nrofon = 1, nbfonc + daux = vafoen(nrofon,1,prfcan(tecn)) + do 231 , nugaus = 2, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(tecn)) + 231 continue + daux = daux*daux1 + do 232 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 232 continue + 23 continue +cgn write(13,91010) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,91010) tecn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +c +c ==> etanp1 = 81, 86, 87 : le tetraedre etait actif et est +c decoupe en 8. +c les huit fils prennent la valeur de la fonction sur le +c pere +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + f5cp = ntesca(f1hp+4) + f6cp = ntesca(f1hp+5) + f7cp = ntesca(f1hp+6) + f8cp = ntesca(f1hp+7) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + prfcap(f5cp) = 1 + prfcap(f6cp) = 1 + prfcap(f7cp) = 1 + prfcap(f8cp) = 1 + daux1 = 1.d0/dble(ngauss) + do 24 , nrofon = 1, nbfonc + daux = vafoen(nrofon,1,prfcan(tecn)) + do 241 , nugaus = 2, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(tecn)) + 241 continue + daux = daux*daux1 + do 242 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + vafott(nrofon,nugaus,f5cp) = daux + vafott(nrofon,nugaus,f6cp) = daux + vafott(nrofon,nugaus,f7cp) = daux + vafott(nrofon,nugaus,f8cp) = daux + 242 continue + 24 continue +cgn write(14,91010) f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp +cgn write(ulsort,91010) tecn,-1, +cgn > f1cp,f2cp,f3cp,f4cp,f5cp,f6cp,f7cp,f8cp +c +c ==> aucun autre etat sur le tetraedre courant n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcspt2.F b/src/tool/AP_Conversion/pcspt2.F new file mode 100644 index 00000000..c1b32480 --- /dev/null +++ b/src/tool/AP_Conversion/pcspt2.F @@ -0,0 +1,412 @@ + subroutine pcspt2 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Tetraedres d'etat anterieur 2 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n. +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss*. . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . ngauss*. . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPT2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer hettet(nbteto), filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn +c + integer nrofon, nugaus + integer coderr +c + integer iaux + integer lglist, nrlist + integer list(30) +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses deux fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) +c +c==== +c 2. etan = 21, ..., 26 : le tetraedre etait coupe en 2 +c On explore tous les etats du tetraedre a l'iteration n+1 +c==== +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c ===> etanp1 = 0 : le tetraedre est actif +c Cela veut dire qu'il est reactive. +c on lui attribue la valeur moyenne sur les deux anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + daux1 = 1.d0/dble(2*ngauss) + do 21 , nrofon = 1, nbfonc + daux = 0.d0 + do 211 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 211 continue + daux = daux*daux1 + do 212 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,tecnp1) = daux + 212 continue + 21 continue +cgn write(21,91010) tecnp1 +cgn write(ulsort,91010) f1cn,f2cn,-1,tecnp1 +c +c ===> etanp1 = etan : le tetraedre est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdte), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 22 , nrofon = 1, nbfonc + do 221 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = + > vafoen(nrofon,nugaus,prfcan(f1cn)) + vafott(nrofon,nugaus,f2cp) = + > vafoen(nrofon,nugaus,prfcan(f2cn)) + 221 continue + 22 continue +cgn write(22,91010) f1cp,f2cp +cgn write(ulsort,91010) f1cn,f2cn,-1,f1cp,f2cp +c +c ===> etanp1 = 21, ..., 26 et different de +c etan : le tetraedre est decoupe en deux +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(2*ngauss) + do 23 , nrofon = 1, nbfonc + daux = 0.d0 + do 231 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 231 continue + daux = daux*daux1 + do 232 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 232 continue + 23 continue +cgn write(23,91010) f1cp,f2cp +cgn write(ulsort,91010) f1cn,f2cn,-1,f1cp,f2cp +c +c ===> etanp1 = 41, 42, 43 ou 44 : le tetraedre est +c decoupe en quatre par une face. +c ===> etanp1 = 45, 46 ou 47 : le tetraedre est +c decoupe en quatre par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(2*ngauss) + do 24 , nrofon = 1, nbfonc + daux = 0.d0 + do 241 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 241 continue + daux = daux*daux1 + do 242 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 242 continue + 24 continue +cgn write(24,91010) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,91010) f1cn,f2cn,-1,f1cp,f2cp,f3cp,f4cp +c +c ===> etanp1 = 85, 86 ou 87 : le tetraedre est +c decoupe en huit par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c attention : il est possible que les fils sur les bords +c soient decoupes par de la conformite. Il faut +c alors transmettre la valeur a leurs 2 ou 4 +c fils. +c attention : ce n'est pas comme en 2D ; il faut examiner +c tous les fils, car par contamination de faces +c coupees en 2, les fils centraux peuvent etre +c decoupes. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + lglist = 0 + do 251 , nrlist = 1 , 8 + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntesca(fihp) + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+2) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+3) + else + coderr = 1 + endif + 251 continue +c + do 252 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 252 continue +c + daux1 = 1.d0/dble(2*ngauss) + do 25 , nrofon = 1, nbfonc + daux = 0.d0 + do 253 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 253 continue + daux = daux*daux1 + do 254 , nugaus = 1 , ngauss + do 255 , nrlist = 1 , lglist + vafott(nrofon,nugaus,list(nrlist)) = daux + 255 continue + 254 continue + 25 continue +cgn write(26,91010) (list(nrlist),nrlist = 1 , lglist) +cgn write(ulsort,91010) f1cn,f2cn,-1, +cgn > (list(nrlist),nrlist = 1 , lglist) +c +c ==> aucun autre etat sur le tetraedre courant n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcspt4.F b/src/tool/AP_Conversion/pcspt4.F new file mode 100644 index 00000000..677b650b --- /dev/null +++ b/src/tool/AP_Conversion/pcspt4.F @@ -0,0 +1,673 @@ + subroutine pcspt4 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss- +c - - - - +c Tetraedres d'etat anterieur 4 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du tetraedre a l'iteration N . +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss* . . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . ngauss* . . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPT4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, tehn, tehnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer hettet(nbteto), filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c f3cn = Fils 3eme du tetraedre en numerotation du Calcul a l'it. N +c f4cn = Fils 4eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c + integer nrofon, nugaus + integer coderr +c + integer iaux + integer lglist, nrlist + integer list(30) +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Tetr. en cours : numero a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + >'( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current tetrahedron : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c + coderr = 0 +c ______________________________________________________________________ +c +c 1.2. ==> on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) + f3cn = nteeca(f1hn+2) + f4cn = nteeca(f1hn+3) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c==== +c 2. etan = 41, ..., 44 : le tetraedre etait coupe en 4 +c selon la face 1, 2, 3, 4 +c==== +c + if ( etan.ge.41 .and. etan.le.44 ) then +c +c ===> etanp1 = 0 : le tetraedre est actif et est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + daux1 = 1.d0/dble(4*ngauss) + do 21 , nrofon = 1, nbfonc + daux = 0.d0 + do 211 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 211 continue + daux = daux*daux1 + do 212 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,tecnp1) = daux + 212 continue + 21 continue +cgn write (41,91010) f1cn,f2cn,f3cn,f4cn,-1,tecnp1 +cgn write (ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1,tecnp1 +cgn91010 format(I3) +c +c ===> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(4*ngauss) + do 22 , nrofon = 1, nbfonc + daux = 0.d0 + do 221 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 221 continue + daux = daux*daux1 + do 222 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 222 continue + 22 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp +cgn write(42,91010) f1cp,f2cp +c +c doc.41-44.41-44. ===> etanp1 = etan : le tetraedre est decoupe en +c quatre selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdte), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 23 , nrofon = 1, nbfonc + do 231 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = + > vafoen(nrofon,nugaus,prfcan(f1cn)) + vafott(nrofon,nugaus,f2cp) = + > vafoen(nrofon,nugaus,prfcan(f2cn)) + vafott(nrofon,nugaus,f3cp) = + > vafoen(nrofon,nugaus,prfcan(f3cn)) + vafott(nrofon,nugaus,f4cp) = + > vafoen(nrofon,nugaus,prfcan(f4cn)) + 231 continue + 23 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(43,91010) f1cp,f2cp,f3cp,f4cp +c +c ===> etanp1 = 41, ..., 44 et different de etan : le tetraedre est +c decoupe en quatre mais par un autre decoupage. +c ===> etanp1 = 45, 46 ou 47 : le tetraedre est +c decoupe en quatre par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(4*ngauss) + do 24 , nrofon = 1, nbfonc + daux = 0.d0 + do 241 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 241 continue + daux = daux*daux1 + do 242 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 242 continue + 24 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(44,91010) f1cp,f2cp,f3cp,f4cp +c +c ===> etanp1 = 85, 86 ou 87 : le tetraedre est +c decoupe en huit par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c attention : il est possible que les fils sur les bords +c soient decoupes par de la conformite. Il faut +c alors transmettre la valeur a leurs 2 ou 4 +c fils. +c attention : ce n'est pas comme en 2D ; il faut examiner +c tous les fils, car par contamination de faces +c coupees en 2, les fils centraux peuvent etre +c decoupes. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + lglist = 0 + do 251 , nrlist = 1 , 8 + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntesca(fihp) + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+2) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+3) + else + coderr = 1 + endif + 251 continue +c + do 252 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 252 continue +c + daux1 = 1.d0/dble(4*ngauss) + do 25 , nrofon = 1, nbfonc + daux = 0.d0 + do 253 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 253 continue + daux = daux*daux1 + do 254 , nugaus = 1 , ngauss + do 255 , nrlist = 1 , lglist + vafott(nrofon,nugaus,list(nrlist)) = daux + 255 continue + 254 continue + 25 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > (list(nrlist),nrlist = 1 , lglist) +cgn write(46,91010) (list(nrlist),nrlist = 1 , lglist) +c +c doc.41-44.erreur. ==> aucun autre etat sur le tetraedre courant +c n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c +c==== +c 3. doc.45-47.p. ==> etan = 45, 46, 47 : le tetraedre etait coupe en 4 +c selon une diagonale +c==== +c + elseif ( etan.ge.45 .and. etan.le.47 ) then +c +c ===> etanp1 = 0 : le tetraedre est actif et est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + daux1 = 1.d0/dble(4*ngauss) + do 31 , nrofon = 1, nbfonc + daux = 0.d0 + do 311 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 311 continue + daux = daux*daux1 + do 312 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,tecnp1) = daux + 312 continue + 31 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > tecnp1 +cgn write(51,91010) tecnp1 +c +c ===> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(4*ngauss) + do 32 , nrofon = 1, nbfonc + daux = 0.d0 + do 321 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 321 continue + daux = daux*daux1 + do 322 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 322 continue + 32 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp +cgn write(52,91010) f1cp,f2cp +c +c doc.45-47.45-47. ===> etanp1 = etan : le tetraedre est decoupe en +c quatre selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdte), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 33 , nrofon = 1, nbfonc + do 331 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = + > vafoen(nrofon,nugaus,prfcan(f1cn)) + vafott(nrofon,nugaus,f2cp) = + > vafoen(nrofon,nugaus,prfcan(f2cn)) + vafott(nrofon,nugaus,f3cp) = + > vafoen(nrofon,nugaus,prfcan(f3cn)) + vafott(nrofon,nugaus,f4cp) = + > vafoen(nrofon,nugaus,prfcan(f4cn)) + 331 continue + 33 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(43,91010) f1cp,f2cp,f3cp,f4cp +c +c ===> etanp1 = 41, ..., 44 : le tetraedre est decoupe en quatre par une +c face. +c ===> etanp1 = 45, 46, 47 et different de etan : +c le tetraedre est decoupe en quatre mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.41 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(4*ngauss) + do 34 , nrofon = 1, nbfonc + daux = 0.d0 + do 341 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 341 continue + daux = daux*daux1 + do 342 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 342 continue + 34 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(53,91010) f1cp,f2cp,f3cp,f4cp +c +c doc.45-47.85-87 ===> etanp1 = 85, 86 ou 87 : le tetraedre est +c decoupe en huit par une diagonale. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, puis +c remis differement car l'environnement a change. +c on donne la valeur moyenne de la fonction sur les quatre +c anciens fils a chaque nouveau fils. +c attention : il est possible que les fils sur les bords +c soient decoupes par de la conformite. Il faut +c alors transmettre la valeur a leurs 2 ou 4 +c fils. +c attention : ce n'est pas comme en 2D ; il faut examiner +c tous les fils, car par contamination de faces +c coupees en 2, les fils centraux peuvent etre +c decoupes. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c + elseif ( etanp1.ge.85 .and. etanp1.le.87 ) then +c + f1hp = filtet(tehnp1) + lglist = 0 + do 351 , nrlist = 1 , 8 + fihp = f1hp+nrlist-1 + iaux = mod(hettet(fihp),100) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntesca(fihp) + elseif ( iaux.ge.21 .and. iaux.le.26 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + elseif ( iaux.ge.41 .and. iaux.le.47 ) then + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+1) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+2) + lglist = lglist + 1 + list(lglist) = ntesca(filtet(fihp)+3) + else + coderr = 1 + endif + 351 continue +c + do 352 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 352 continue +c + daux1 = 1.d0/dble(4*ngauss) + do 35 , nrofon = 1, nbfonc + daux = 0.d0 + do 353 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 353 continue + daux = daux*daux1 + do 354 , nugaus = 1 , ngauss + do 355 , nrlist = 1 , lglist + vafott(nrofon,nugaus,list(nrlist)) = daux + 355 continue + 354 continue + 35 continue +cgn write(56,91010) (list(nrlist),nrlist = 1 , lglist) +cgn write(ulsort,91010) f1cn,f2cn,-1, +cgn > (list(nrlist),nrlist = 1 , lglist) +cgn91010 format(I3) +c +c ==> aucun autre etat sur le tetraedre courant n'est possible +c + else +c + coderr = 2 + write (ulsort,texte(langue,4)) 'n ', tehn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', tehnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcspt8.F b/src/tool/AP_Conversion/pcspt8.F new file mode 100644 index 00000000..6dd7fd27 --- /dev/null +++ b/src/tool/AP_Conversion/pcspt8.F @@ -0,0 +1,364 @@ + subroutine pcspt8 ( etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Tetraedres d'etat anterieur 8 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du tetraedre a l'iteration N+1 . +c . tehn . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N . +c . tehnp1 . e . 1 . TEtraedre courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n +c . nteeca . e . reteto . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss* . . +c . . . nbeven . . +c . vafott . es . nbfonc*. variables en sortie de l'adaptation . +c . . . ngauss* . . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPT8' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etanp1, tehn, tehnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer filtet(nbteto) + integer nbante + integer anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c tecnp1 = TEtraedre courant en numerotation du Calcul a l'it. N+1 +c + integer tecnp1 +c +c f1hp = Fils 1er du tetraedre en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du tetraedre en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du tetraedre en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du tetraedre en numerota. du Calcul a l'it. N+1 + + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du tetraedre en numerotation Homard a l'it. N +c f1cn = Fils 1er du tetraedre en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du tetraedre en numerotation du Calcul a l'it. N +c f3cn = Fils 3eme du tetraedre en numerotation du Calcul a l'it. N +c f4cn = Fils 4eme du tetraedre en numerotation du Calcul a l'it. N +c f5cn = Fils 5eme du tetraedre en numerotation du Calcul a l'it. N +c f6cn = Fils 6eme du tetraedre en numerotation du Calcul a l'it. N +c f7cn = Fils 7eme du tetraedre en numerotation du Calcul a l'it. N +c f8cn = Fils 8eme du tetraedre en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn, f5cn, f6cn, f7cn, f8cn +c + integer nrofon, nugaus +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses huit fils +c a l'iteration n +c + f1hn = anfite(tehn) + f1cn = nteeca(f1hn) + f2cn = nteeca(f1hn+1) + f3cn = nteeca(f1hn+2) + f4cn = nteeca(f1hn+3) + f5cn = nteeca(f1hn+4) + f6cn = nteeca(f1hn+5) + f7cn = nteeca(f1hn+6) + f8cn = nteeca(f1hn+7) +c ______________________________________________________________________ +c +c==== +c 2. doc.85-87.p. ==> etan = 85, 86, 87 : le tetraedre etait coupe en 8 +c selon une diagonale +c==== +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 .and. + > prfcan(f5cn).gt.0 .and. prfcan(f6cn).gt.0 .and. + > prfcan(f7cn).gt.0 .and. prfcan(f8cn).gt.0 ) then +c +c ===> etanp1 = 0 : le tetraedre est actif et est reactive. +c on lui attribue la valeur moyenne sur les huit anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + tecnp1 = ntesca(tehnp1) + prfcap(tecnp1) = 1 +c + daux1 = 1.d0/dble(8*ngauss) + do 21 , nrofon = 1, nbfonc + daux = 0.d0 + do 211 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + > + vafoen(nrofon,nugaus,prfcan(f5cn)) + > + vafoen(nrofon,nugaus,prfcan(f6cn)) + > + vafoen(nrofon,nugaus,prfcan(f7cn)) + > + vafoen(nrofon,nugaus,prfcan(f8cn)) + 211 continue + daux = daux*daux1 + do 212 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,tecnp1) = daux + 212 continue + 21 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > tecnp1 +cgn write(81,91010) tecnp1 +c +c ===> etanp1 = 21, ...,26 : le tetraedre est decoupe en deux +c c'est ce qui se passe quand un decoupage de conformite +c est cree apres du deraffinement. +c on donne la valeur moyenne de la fonction sur les huit +c anciens fils a chaque nouveau fils. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.21 .and. etanp1.le.26 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(8*ngauss) + do 22 , nrofon = 1, nbfonc + daux = 0.d0 + do 221 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + > + vafoen(nrofon,nugaus,prfcan(f5cn)) + > + vafoen(nrofon,nugaus,prfcan(f6cn)) + > + vafoen(nrofon,nugaus,prfcan(f7cn)) + > + vafoen(nrofon,nugaus,prfcan(f8cn)) + 221 continue + daux = daux*daux1 + do 222 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 222 continue + 22 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > f1cp,f2cp +cgn write(82,91010) f1cp,f2cp +c +c doc.85-87.41-44 ===> etanp1 = 41, ..., 44 : le tetraedre est +c decoupe en quatre par une face. +c c'est ce qui se passe quand un decoupage de conformite +c est cree apres du deraffinement. +c on donne la valeur moyenne de la fonction sur les huit +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(8*ngauss) + do 23 , nrofon = 1, nbfonc + daux = 0.d0 + do 231 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + > + vafoen(nrofon,nugaus,prfcan(f5cn)) + > + vafoen(nrofon,nugaus,prfcan(f6cn)) + > + vafoen(nrofon,nugaus,prfcan(f7cn)) + > + vafoen(nrofon,nugaus,prfcan(f8cn)) + 231 continue + daux = daux*daux1 + do 232 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 232 continue + 23 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(83,91010) f1cp,f2cp,f3cp,f4cp +c +c doc.85-87.45-47. ===> etanp1 = 45, 46, 47 : le tetraedre est decoupe +c en 4 par une diagonale +c c'est ce qui se passe quand un decoupage de conformite +c est cree apres du deraffinement. +c on donne la valeur moyenne de la fonction sur les huit +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.45 .and. etanp1.le.47 ) then +c + f1hp = filtet(tehnp1) + f1cp = ntesca(f1hp) + f2cp = ntesca(f1hp+1) + f3cp = ntesca(f1hp+2) + f4cp = ntesca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(8*ngauss) + do 24 , nrofon = 1, nbfonc + daux = 0.d0 + do 241 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + > + vafoen(nrofon,nugaus,prfcan(f5cn)) + > + vafoen(nrofon,nugaus,prfcan(f6cn)) + > + vafoen(nrofon,nugaus,prfcan(f7cn)) + > + vafoen(nrofon,nugaus,prfcan(f8cn)) + 241 continue + daux = daux*daux1 + do 242 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 242 continue + 24 continue +cgn write(ulsort,91010) f1cn,f2cn,f3cn,f4cn,f5cn,f6cn,f7cn,f8cn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +cgn write(84,91010) f1cp,f2cp,f3cp,f4cp +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsptd.F b/src/tool/AP_Conversion/pcsptd.F new file mode 100644 index 00000000..e2ce1f55 --- /dev/null +++ b/src/tool/AP_Conversion/pcsptd.F @@ -0,0 +1,337 @@ + subroutine pcsptd ( etan, etanp1, trhn, trhnp1, + > prfcan, prfcap, + > hettri, filtri, nbantr, anfitr, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Triangles d'etat anterieur Deux +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du triangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du triangle a l'iteration N+1 . +c . trhn . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . trhnp1 . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n. +c . ntreca . e . retrto . numero des triangles dans le calcul entree . +c . ntrsca . e . rstrto . numero des triangles du calcul en sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss*. . +c . . . nbeven . . +c . vafott . es . nbfonc*. tableau temporaire de la solution . +c . . . ngauss*. . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPTD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, trhn, trhnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer hettri(nbtrto), filtri(nbtrto) + integer nbantr + integer anfitr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c + integer trcnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerota. du Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp +c +c f1hn = Fils 1er du triangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du triangle en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du triangle en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn +c + integer iaux + integer lglist, nrlist + integer list(30) +c + integer coderr + integer nrofon, nugaus +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current triangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c + coderr = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses deux fils +c a l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) +c +c==== +c 2. etan = 1, 2, 3 : le triangle etait actif +c On explore tous les etats du triangle a l'iteration n+1 +c==== +cgn write (ulsort,90002) 'etanp1', etanp1 +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c ===> etanp1 = 0 : le triangle est actif +c Cela veut dire qu'il est reactive. +c on lui attribue la valeur moyenne sur les deux anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + daux1 = 1.d0/dble(2*ngauss) + do 21 , nrofon = 1 , nbfonc + daux = 0.d0 + do 211 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 211 continue + daux = daux*daux1 + do 212 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,trcnp1) = daux + 212 continue + 21 continue +c +c etanp1 = etan : le triangle est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les faces +c autour n'ont pas change entre les deux iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdtr), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 22 , nrofon = 1, nbfonc + do 221 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = + > vafoen(nrofon,nugaus,prfcan(f1cn)) + vafott(nrofon,nugaus,f2cp) = + > vafoen(nrofon,nugaus,prfcan(f2cn)) + 221 continue + 22 continue +c +c etanp1 = 1, 2, 3 et different de etan : le triangle est decoupe +c en deux mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : cela arrive seulement avec du deraffinement. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(2*ngauss) + do 23 , nrofon = 1 , nbfonc + daux = 0.d0 + do 231 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 231 continue + daux = daux*daux1 + do 232 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,trcnp1) = daux + 232 continue + 23 continue +c +c etanp1 = 4, 6, 7, 8 : le triangle est decoupe en 4 +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c + elseif ( etanp1.eq.4 .or. + > ( etanp1.ge.6 .and. etanp1.le.8 ) ) then +c + f1hp = filtri(trhnp1) + lglist = 0 + do 241 , nrlist = 1 , 4 + fihp = f1hp+nrlist-1 + iaux = mod(hettri(fihp),10) + if ( iaux.eq.0 ) then + lglist = lglist + 1 + list(lglist) = ntrsca(fihp) + elseif ( iaux.ge.1 .and. iaux.le.3 ) then + lglist = lglist + 1 + list(lglist) = ntrsca(filtri(fihp)) + lglist = lglist + 1 + list(lglist) = ntrsca(filtri(fihp)+1) + else + coderr = 1 + endif + 241 continue +c + do 242 , nrlist = 1 , lglist + prfcap(list(nrlist)) = 1 + 242 continue +c + daux1 = 1.d0/dble(2*ngauss) + do 24 , nrofon = 1 , nbfonc + daux = 0.d0 + do 243 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + 243 continue + daux = daux*daux1 + do 244 , nugaus = 1, ngauss + do 245 , nrlist = 1 , lglist + vafott(nrofon,nugaus,list(nrlist)) = daux + 245 continue + 244 continue + 24 continue +c +c +c doc.0.erreur. ==> aucun autre etat sur le courant elgnairt +c n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsptq.F b/src/tool/AP_Conversion/pcsptq.F new file mode 100644 index 00000000..26cbe8c2 --- /dev/null +++ b/src/tool/AP_Conversion/pcsptq.F @@ -0,0 +1,249 @@ + subroutine pcsptq ( etanp1, trhn, trhnp1, + > prfcan, prfcap, + > filtri, nbantr, anfitr, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Triangles d'etat anterieur Quatre +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etanp1 . e . 1 . ETAt du triangle a l'iteration N+1 . +c . trhn . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . trhnp1 . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n. +c . ntreca . e . retrto . numero des triangles dans le calcul entree . +c . ntrsca . e . rstrto . numero des triangles du calcul en sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss*. . +c . . . nbeven . . +c . vafott . es . nbfonc*. tableau temporaire de la solution . +c . . . ngauss*. . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPTQ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etanp1, trhn, trhnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer filtri(nbtrto) + integer nbantr + integer anfitr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c + integer trcnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerota. du Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp +c +c f1hn = Fils 1er du triangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du triangle en numerotation du Calcul a l'it. N +c f2cn = Fils 2eme du triangle en numerotation du Calcul a l'it. N +c f3cn = Fils 3eme du triangle en numerotation du Calcul a l'it. N +c f4cn = Fils 4eme du triangle en numerotation du Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c + integer nrofon, nugaus +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current triangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c + codret = 0 +c +c 1.2. ==> on repere les numeros dans le calcul pour ses deux fils +c a l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) + f4cn = ntreca(f1hn+3) +c +c==== +c 2. etan = 4, 6, 7, 8 : le triangle etait coupe en 4 +c On explore tous les etats du triangle a l'iteration n+1 +c==== +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c doc.0.0. ===> etanp1 = 0 : le triangle est actif +c Cela veut dire qu'il est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + daux1 = 1.d0/dble(4*ngauss) + do 21 , nrofon = 1 , nbfonc + daux = 0.d0 + do 211 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 211 continue + daux = daux*daux1 + do 212 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,trcnp1) = daux + 212 continue + 21 continue +c +c etanp1 = etan : le triangle est decoupe en deux +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(4*ngauss) + do 22 , nrofon = 1, nbfonc + daux = 0.d0 + do 221 , nugaus = 1, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) + 221 continue + daux = daux*daux1 + do 222 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 222 continue + 22 continue +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsptz.F b/src/tool/AP_Conversion/pcsptz.F new file mode 100644 index 00000000..4ca7963a --- /dev/null +++ b/src/tool/AP_Conversion/pcsptz.F @@ -0,0 +1,275 @@ + subroutine pcsptz ( etan, etanp1, trhn, trhnp1, + > prfcan, prfcap, + > filtri, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution Points de Gauss - +c - - - - +c Triangles d'etat anterieur Zero +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etan . e . 1 . ETAt du triangle a l'iteration N . +c . etanp1 . e . 1 . ETAt du triangle a l'iteration N+1 . +c . trhn . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N . +c . trhnp1 . e . 1 . TRiangle courant en numerotation Homard . +c . . . . a l'iteration N+1 . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . filtri . e . nbtrto . premier fils des triangles . +c . ntreca . e . retrto . numero des triangles dans le calcul entree . +c . ntrsca . e . rstrto . numero des triangles du calcul en sortie . +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss*. . +c . . . nbeven . . +c . vafott . es . nbfonc*. tableau temporaire de la solution . +c . . . ngauss*. . +c . . . nbevso . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSPTZ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer etan, etanp1, trhn, trhnp1 + integer nbfonc, ngauss + integer prfcan(*), prfcap(*) + integer filtri(nbtrto) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +c trcn = TRiangle courant en numerotation Calcul a l'iteration N +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c + integer trcn, trcnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerota. du Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerota. du Calcul a l'it. N+1 +c f3cp = Fils 3eme du triangle en numerota. du Calcul a l'it. N+1 +c f4cp = Fils 4eme du triangle en numerota. du Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c + integer coderr + integer nrofon, nugaus +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current triangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c + coderr = 0 +c +c 1.2. ==> on repere son ancien numero dans le calcul +c + trcn = ntreca(trhn) +c +c==== +c 2. etan = 0 : le triangle etait actif +c On explore tous les etats du triangle a l'iteration n+1 +c==== +c + if ( prfcan(trcn).gt.0 ) then +c +c ===> etanp1 = 0 : le triangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du triangle. +c . . +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 21 , nrofon = 1 , nbfonc +cgn write(ulsort,90014) nrofon, +cgn > (vafoen(nrofon,nugaus,trcn),nugaus=1,ngauss) + do 211 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,trcnp1) = + > vafoen(nrofon,nugaus,prfcan(trcn)) + 211 continue + 21 continue +cgn write(21,91010) trcnp1 +cgn write(ulsort,91010) trcn,-1,trcnp1 +c +c ==> etanp1 = 1, 2, 3 : le triangle etait actif et est decoupe en 2. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + daux1 = 1.d0/dble(ngauss) + do 22 , nrofon = 1, nbfonc + daux = vafoen(nrofon,1,prfcan(trcn)) + do 221 , nugaus = 2, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(trcn)) + 221 continue + daux = daux*daux1 + do 222 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + 222 continue + 22 continue +c +c ==> etanp1 = 4,6,7,8 : le triangle etait actif et est decoupe en 4. +c + elseif ( etanp1.eq.4 .or. + > ( etanp1.ge.6 .and. etanp1.le.8 ) ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + daux1 = 1.d0/dble(ngauss) + do 23 , nrofon = 1, nbfonc + daux = vafoen(nrofon,1,prfcan(trcn)) + do 231 , nugaus = 2, ngauss + daux = daux + vafoen(nrofon,nugaus,prfcan(trcn)) + 231 continue + daux = daux*daux1 + do 232 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 232 continue + 23 continue +c +c ==> aucun autre etat sur le triangle courant n'est possible +c + else +c + coderr = 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( coderr.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) coderr + codret = codret + 1 +c + endif +c + end diff --git a/src/tool/AP_Conversion/pcsqu0.F b/src/tool/AP_Conversion/pcsqu0.F new file mode 100644 index 00000000..71dc617c --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu0.F @@ -0,0 +1,474 @@ + subroutine pcsqu0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, hetqua, ancqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntreca, ntrsca, + > vafoen, vafott, + > vatren, vatrtt, + > prftrn, prftrp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c QUadrangles - solution P0 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n. +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . vatren . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour . +c . . . * . les triangles de conformite . +c . prftrn . es . * . En numero du calcul a l'iteration n : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . prftrp . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : le triangle est absent du profil . +c . . . . 1 : le triangle est present dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSQU0' ) +c +#include "nblang.h" +#include "fractb.h" +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), hetqua(nbquto), ancqua(*) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer aretri(nbtrto,3) + integer ntreca(retrto), ntrsca(rstrto) + integer prftrn(*), prftrp(*) +c + double precision coonoe(nbnoto,sdim) + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) + double precision vatren(nbfonc,*) + double precision vatrtt(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c quhnp1 = QUadrangle courant en numerotation Homard a l'it. N+1 +c + integer qucn, qucnp1, quhn, quhnp1 +c +c etan = ETAt du quadrangle a l'iteration N +c etanp1 = ETAt du quadrangle a l'iteration N+1 +c + integer etan, etanp1 +c + integer nrofon + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Elements hierarchiques :'',i2)' +c + texte(2,4) = '(''Hierarchical elements :'',i2)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfonc', nbfonc + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'requto, rsquto', requto, rsquto +#endif +c +cgn write(ulsort,*) 'nqueca' +cgn write(ulsort,91020) nqueca +cgn write(ulsort,*) 'prfcan' +cgn write(ulsort,91020) (prfcan(iaux),iaux=1,74) +cgn print *,'vafoen :' +cgn print 1790,(vafoen(1,iaux),iaux=1,min(nbquto,10)) +cgn print *,'prftrn = ',(prftrn(iaux),iaux=1,6) +cgn print *,'vatren :' +cgn print 1790,(vatren(1,iaux),iaux=1,6) +cgn write(ulsort,91020) (nqusca(iaux),iaux=1,rsquto) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) hierar +#endif + codret = 0 +c +c==== +c 2. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du quadrangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un quadrangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , quhnp1 = 1 , nbquto + if ( codret.ne.0 ) goto 20 +c +c 2.1. ==> caracteristiques du quadrangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + quhn = ancqua(quhnp1) + else + quhn = quhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le quadrangle etait actif +c etan = 4 : le quadrangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 55 : le quadrangle n'existait pas ; il a ete produit +c par un decoupage. +c etan = 31, 32, 33, 34 : le quadrangle etait coupe en 3 +c triangles ; il y a eu deraffinement. +c + etanp1 = mod(hetqua(quhnp1),100) + etan = (hetqua(quhnp1)-etanp1) / 100 +c +cgn if ( quhn.eq.498 .or. quhn.eq.1083 ) then +cgn write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +cgn endif +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le quadrangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEQ0', nompro +#endif +c + call pcseq0 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, filqua, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEQ0' +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 21 ou 22 : le quadrangle etait coupe +c en 2 quadrangles +c======================================================================= +c + elseif ( etan.eq.21 .or. etan.eq.22 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEQ1', nompro +#endif +c + call pcseq1 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEQ1' +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 31, 32, 33 ou 34 : le quadrangle etait coupe +c en 3 triangles +c======================================================================= +c + elseif ( etan.ge.31 .and. etan.le.34 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEQ2', nompro +#endif +c + call pcseq2 ( etan, etanp1, quhn, quhnp1, typint, + > prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqusca, + > aretri, + > ntreca, ntrsca, + > nbfonc, vafott, + > vatren, vatrtt, + > prftrn, prftrp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEQ2' +c +c======================================================================= +c doc.4. ==> le quadrangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEQ3', nompro +#endif +c + call pcseq3 ( etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEQ3' +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 41, 42, 43 ou 44 : le quadrangle etait coupe +c en 3 quadrangles +c======================================================================= +c + elseif ( etan.ge.41 .and. etan.le.44 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSEQ4', nompro +#endif +c + call pcseq4 ( etan, etanp1, quhn, quhnp1, typint, + > prfcan, prfcap, + > coonoe, + > somare, + > arequa, hetqua, filqua, + > nbanqu, anfiqu, + > nqueca, nqusca, + > aretri, + > ntrsca, + > nbfonc, vafoen, vafott, + > vatrtt, + > prftrp, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'retour de PCSEQ4' +c + endif +c + 20 continue +c + endif +c +c==== +c 3. cas particulier : on garde tous les quadrangles de tous les niveaux +c on boucle sur tous les quadrangles inactifs du maillage HOMARD n+1 +c on leur met la valeur qu'ils avaient dans le maillage n +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. cas particulier ; codret = ', codret +#endif +c + if ( nbfonc.ne.0 .and. hierar.ne.0 ) then +c + do 30 , quhnp1 = 1 , nbquto +c + if ( deraff ) then + quhn = ancqua(quhnp1) + else + quhn = quhnp1 + endif +c + etanp1 = mod(hetqua(quhnp1),100) +c + if ( etanp1.ne.0 ) then +c +c on repere son ancien numero dans le calcul +c + qucn = nqueca(quhn) +c + if ( prfcan(qucn).gt.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 311 , nrofon = 1 , nbfonc + vafott(nrofon,qucnp1) = vafoen(nrofon,prfcan(qucn)) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(qucn)) + 311 continue +cgn write(21,91010) qucnp1 +cgn write(ulsort,91010) qucn,-1,qucnp1 +c + endif +c + endif +c + 30 continue +c + endif +c +cgn write(ulsort,91020)(prfcap(iaux),iaux=1,nbquto) +cgn print *,nompro,' ==> codret = ',codret +cgn print *,'nbfonc = ',nbfonc +cgn print *,'Quadrangles (prfcap/vafott) : ' +cgn etan = min(2*nbquto,11) +cgn etan = 1 +cgn etanp1 = nbquto +cgn do 30001 , iaux=etan,etanp1 +cgn if ( mod(hetqua(iaux),100).eq.0 ) then +cgn print 11790, +cgn > nqusca(iaux),prfcap(nqusca(iaux)),vafott(1,nqusca(iaux)) +cgn endif +cgn30001 continue +cgn print *,'Triangles (prftrp/vatrtt) : ' +cgn etan = 1 +cgn etanp1 = 27 +cgn do 30002 , iaux=etan,etanp1 +cgnc if ( mod(hettri(iaux),10).eq.0 ) then +cgn print 11790, +cgn > ntrsca(iaux),prftrp(ntrsca(iaux)),vatrtt(1,ntrsca(iaux)) +cgnc endif +cgn30002 continue +cgn11790 format(i4,' : ',i2,' / ',g15.7) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsqu2_1.h b/src/tool/AP_Conversion/pcsqu2_1.h new file mode 100644 index 00000000..f5518b4f --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_1.h @@ -0,0 +1,299 @@ +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . ===> . . . . +c . . . . . . +c . . . . . . +c . . .. .. +c ................. ................. +c +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + q1t = 1 + q2t = 2 + q3t = 3 + q4t = 4 + q5t = 5 + q6t = 6 + +c Pour un decoupage par l'arete numero 1 : + + if ( etanp1.eq.31 ) then +c + do 2221 , nrofon = 1 , nbfonc +c +c Pour le triangle NT1 : +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q2t,f1cp) = vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q4t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q6,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q5t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q8,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q6t,f1cp) = vafoen(nrofon,q7,prqucn) +c +c Pour le triangle NT2 : +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = + > trshu*vafoen(nrofon,q2,prqucn)- + > unshu*vafoen(nrofon,q1,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q6t,f2cp) = vafoen(nrofon,q6,prqucn) +c +c Pour le triangle NT3 : +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q4t,f3cp) = vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q5t,f3cp) = + > trshu*vafoen(nrofon,q1,prqucn)- + > unshu*vafoen(nrofon,q2,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2221 continue + +c Pour un decoupage par l'arete numero 2 : + + elseif ( etanp1.eq.32 ) then +c + do 2222 , nrofon = 1 , nbfonc +c +c Pour le triangle NT1 : +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q2t,f1cp) = vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q4t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q7,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q5t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q5,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q6t,f1cp) = vafoen(nrofon,q8,prqucn) +c +c Pour le triangle NT2 : +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = + > trshu*vafoen(nrofon,q3,prqucn)- + > unshu*vafoen(nrofon,q2,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q6t,f2cp) = vafoen(nrofon,q7,prqucn) +c +c Pour le triangle NT3 : +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q4t,f3cp) = vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q5t,f3cp) = + > trshu*vafoen(nrofon,q2,prqucn)- + > unshu*vafoen(nrofon,q3,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2222 continue + +c Pour un decoupage par l'arete numero 3 : + + elseif ( etanp1.eq.33 ) then +c + do 2223 , nrofon = 1 , nbfonc +c +c Pour le triangle NT1 : +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q2t,f1cp) = vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q4t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q8,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q5t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q6,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q6t,f1cp) = vafoen(nrofon,q5,prqucn) +c +c Pour le triangle NT2 : +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = + > trshu*vafoen(nrofon,q4,prqucn)- + > unshu*vafoen(nrofon,q3,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q6t,f2cp) = vafoen(nrofon,q8,prqucn) +c +c Pour le triangle NT3 : +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q4t,f3cp) = vafoen(nrofon,q6,prqucn) +c + vatrtt(nrofon,q5t,f3cp) = + > trshu*vafoen(nrofon,q3,prqucn)- + > unshu*vafoen(nrofon,q4,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2223 continue + +c Pour un decoupage par l'arete numero 4 : + + elseif ( etanp1.eq.34 ) then +c + do 2224 , nrofon = 1 , nbfonc +c +c Pour le triangle NT1 : +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q2t,f1cp) = vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q4t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q5,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q5t,f1cp) = + > -trssz* + > (vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q7,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vatrtt(nrofon,q6t,f1cp) = vafoen(nrofon,q6,prqucn) +c +c Pour le triangle NT2 : +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q2,prqucn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prqucn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = + > trshu*vafoen(nrofon,q1,prqucn)- + > unshu*vafoen(nrofon,q4,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q6t,f2cp) = vafoen(nrofon,q5,prqucn) +c +c Pour le triangle NT3 : +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q3,prqucn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q4,prqucn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q4t,f3cp) = vafoen(nrofon,q7,prqucn) +c + vatrtt(nrofon,q5t,f3cp) = + > trshu*vafoen(nrofon,q4,prqucn)- + > unshu*vafoen(nrofon,q1,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2224 continue +c + endif diff --git a/src/tool/AP_Conversion/pcsqu2_2.h b/src/tool/AP_Conversion/pcsqu2_2.h new file mode 100644 index 00000000..04cdb8fe --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_2.h @@ -0,0 +1,142 @@ +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + + do 223 , nrofon = 1 , nbfonc +c pour le quadrangle Q1 +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prqucn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q5,prqucn) +c + vafott(nrofon,q3,f1cp) = + > -unsqu*(vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > unsde*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q6,prqucn)+ + > vafoen(nrofon,q7,prqucn)+vafoen(nrofon,q8,prqucn)) + vafott(nrofon,q4,f1cp) = vafoen(nrofon,q8,prqucn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*vafoen(nrofon,q2,prqucn)+ + > trshu*vafoen(nrofon,q1,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vafott(nrofon,q6,f1cp) = + > -trssz*(vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q7,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c + vafott(nrofon,q7,f1cp) = + > -trssz*(vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q6,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vafott(nrofon,q8,f1cp) = + > -unshu*vafoen(nrofon,q4,prqucn)+ + > trshu*vafoen(nrofon,q1,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c +c pour le quadrangle Q2 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q2,prqucn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q6,prqucn) +c + vafott(nrofon,q3,f2cp) = vafott(nrofon,q3,f1cp) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q5,prqucn) +c + vafott(nrofon,q5,f2cp) = + > -unshu*vafoen(nrofon,q3,prqucn)+ + > trshu*vafoen(nrofon,q2,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vafott(nrofon,q6,f2cp) = + > -trssz*(vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q5,prqucn)+vafoen(nrofon,q7,prqucn))+ + > unsqu*vafoen(nrofon,q8,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c + vafott(nrofon,q7,f2cp) =vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q8,f2cp) = + > -unshu*vafoen(nrofon,q1,prqucn)+ + > trshu*vafoen(nrofon,q2,prqucn)+ + > trsqu*vafoen(nrofon,q5,prqucn) +c +c pour le quadrangle Q3 +c + vafott(nrofon,q1,f3cp) = vafoen(nrofon,q3,prqucn) +c + vafott(nrofon,q2,f3cp) = vafoen(nrofon,q7,prqucn) +c + vafott(nrofon,q3,f3cp) = vafott(nrofon,q3,f1cp) +c + vafott(nrofon,q4,f3cp) = vafoen(nrofon,q6,prqucn) +c + vafott(nrofon,q5,f3cp) = + > -unshu*vafoen(nrofon,q4,prqucn)+ + > trshu*vafoen(nrofon,q3,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vafott(nrofon,q6,f3cp) = + > -trssz*(vafoen(nrofon,q1,prqucn)+vafoen(nrofon,q2,prqucn)+ + > vafoen(nrofon,q3,prqucn)+vafoen(nrofon,q4,prqucn))+ + > trshu*(vafoen(nrofon,q6,prqucn)+vafoen(nrofon,q8,prqucn))+ + > unsqu*vafoen(nrofon,q5,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + vafott(nrofon,q7,f3cp) =vafott(nrofon,q6,f2cp) +c + vafott(nrofon,q8,f3cp) = + > -unshu*vafoen(nrofon,q2,prqucn)+ + > trshu*vafoen(nrofon,q3,prqucn)+ + > trsqu*vafoen(nrofon,q6,prqucn) +c +c pour le quadrangle Q4 +c + vafott(nrofon,q1,f4cp) = vafoen(nrofon,q4,prqucn) +c + vafott(nrofon,q2,f4cp) = vafoen(nrofon,q8,prqucn) +c + vafott(nrofon,q3,f4cp) = vafott(nrofon,q3,f1cp) +c + vafott(nrofon,q4,f4cp) = vafoen(nrofon,q7,prqucn) +c + vafott(nrofon,q5,f4cp) = + > -unshu*vafoen(nrofon,q1,prqucn)+ + > trshu*vafoen(nrofon,q4,prqucn)+ + > trsqu*vafoen(nrofon,q8,prqucn) +c + vafott(nrofon,q6,f4cp) = vafott(nrofon,q7,f1cp) +c + vafott(nrofon,q7,f4cp) = vafott(nrofon,q6,f3cp) +c + vafott(nrofon,q8,f4cp) = + > -unshu*vafoen(nrofon,q3,prqucn)+ + > trshu*vafoen(nrofon,q4,prqucn)+ + > trsqu*vafoen(nrofon,q7,prqucn) +c + 223 continue + diff --git a/src/tool/AP_Conversion/pcsqu2_3.h b/src/tool/AP_Conversion/pcsqu2_3.h new file mode 100644 index 00000000..4fce59e9 --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_3.h @@ -0,0 +1,109 @@ +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . . . ===> . . +c . . . . . . +c . . . . . . +c .. .. . . +c ................. ................. +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c +c quadrangle predecoupe en 3 triangles par l'arete A1 +c + if ( etan.eq.31 ) then +c + do 2311 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,qucnp1) = vatren(nrofon,q2t,prf3cn) + vafott(nrofon,q2,qucnp1) = vatren(nrofon,q3t,prf2cn) + vafott(nrofon,q3,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf2cn) + > + vatren(nrofon,q3t,prf1cn) ) + vafott(nrofon,q4,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf3cn) + > + vatren(nrofon,q1t,prf1cn) ) + vafott(nrofon,q5,qucnp1) = + > unstr * ( vatren(nrofon,q2t,prf1cn) + > + vatren(nrofon,q2t,prf2cn) + > + vatren(nrofon,q3t,prf3cn)) + vafott(nrofon,q6,qucnp1) = vatren(nrofon,q6t,prf2cn) + vafott(nrofon,q7,qucnp1) = vatren(nrofon,q6t,prf1cn) + vafott(nrofon,q8,qucnp1) = vatren(nrofon,q4t,prf3cn) +c + 2311 continue +c +c quadrangle predecoupe en 3 triangles par l'arete A2 +c + elseif ( etan.eq.32 ) then +c + do 2312 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf3cn) + > + vatren(nrofon,q1t,prf1cn) ) + vafott(nrofon,q2,qucnp1) = vatren(nrofon,q2t,prf3cn) + vafott(nrofon,q3,qucnp1) = vatren(nrofon,q3t,prf2cn) + vafott(nrofon,q4,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf2cn) + > + vatren(nrofon,q3t,prf1cn) ) + vafott(nrofon,q5,qucnp1) = vatren(nrofon,q4t,prf3cn) + vafott(nrofon,q6,qucnp1) = + > unstr * ( vatren(nrofon,q2t,prf1cn) + > + vatren(nrofon,q2t,prf2cn) + > + vatren(nrofon,q3t,prf3cn)) + vafott(nrofon,q7,qucnp1) = vatren(nrofon,q6t,prf2cn) + vafott(nrofon,q8,qucnp1) = vatren(nrofon,q6t,prf1cn) +c + 2312 continue +c +c quadrangle predecoupe en 3 triangles par l'arete A3 +c + elseif ( etan.eq.33 ) then +c + do 2313 , nrofon = 1 , nbfonc + + vafott(nrofon,q1,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf2cn) + > + vatren(nrofon,q3t,prf1cn) ) + vafott(nrofon,q2,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf3cn) + > + vatren(nrofon,q1t,prf1cn) ) + vafott(nrofon,q3,qucnp1) = vatren(nrofon,q2t,prf3cn) + vafott(nrofon,q4,qucnp1) = vatren(nrofon,q3t,prf2cn) + vafott(nrofon,q5,qucnp1) = vatren(nrofon,q6t,prf1cn) + vafott(nrofon,q6,qucnp1) = vatren(nrofon,q4t,prf3cn) + vafott(nrofon,q7,qucnp1) = + > unstr * ( vatren(nrofon,q2t,prf1cn) + > + vatren(nrofon,q2t,prf2cn) + > + vatren(nrofon,q3t,prf3cn)) + vafott(nrofon,q8,qucnp1) = vatren(nrofon,q6t,prf2cn) +c + 2313 continue +c +c quadrangle predecoupe en 3 triangles par l'arete A4 +c + elseif ( etan.eq.34 ) then +c + do 2314 , nrofon = 1 , nbfonc + vafott(nrofon,q1,qucnp1) = vatren(nrofon,q3t,prf2cn) + vafott(nrofon,q2,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf2cn) + > + vatren(nrofon,q3t,prf1cn) ) + vafott(nrofon,q3,qucnp1) = + > unsde * ( vatren(nrofon,q1t,prf3cn) + > + vatren(nrofon,q1t,prf1cn) ) + vafott(nrofon,q4,qucnp1) = vatren(nrofon,q2t,prf3cn) + vafott(nrofon,q5,qucnp1) = vatren(nrofon,q6t,prf2cn) + vafott(nrofon,q6,qucnp1) = vatren(nrofon,q6t,prf1cn) + vafott(nrofon,q7,qucnp1) = vatren(nrofon,q4t,prf3cn) + vafott(nrofon,q8,qucnp1) = + > unstr * ( vatren(nrofon,q2t,prf1cn) + > + vatren(nrofon,q2t,prf2cn) + > + vatren(nrofon,q3t,prf3cn)) +c + 2314 continue +c + endif diff --git a/src/tool/AP_Conversion/pcsqu2_4.h b/src/tool/AP_Conversion/pcsqu2_4.h new file mode 100644 index 00000000..ae44cb2d --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_4.h @@ -0,0 +1,804 @@ +c ................. ................. +c . . . . .. .. +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. . . . . +c ................. ................. +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + q1tp = 1 + q2tp = 2 + q3tp = 3 + q4tp = 4 + q5tp = 5 + q6tp = 6 +c +c decoupage en 3 par l'arete a2 d'un triangle predecoupe en a1 +c + if ((etan.eq.31).and.( etanp1.eq.32)) then +c + do 23311 , nrofon = 1 , nbfonc + +c dans le triangle NT1 + + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f1cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) =vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf1cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f2cp) =vatren(nrofon,q6t,prf1cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4tp,f3cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23311 continue +c +c decoupage en 3 par l'arete a3 d'un triangle predecoupe en a1 +c + elseif ((etan.eq.31).and.( etanp1.eq.33)) then +c + do 23312 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vatrtt(nrofon,q5tp,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vatrtt(nrofon,q6tp,f1cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) + +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f2cp) =vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +23312 continue +c +c decoupage en 3 par l'arete a4 d'un triangle predecoupe en a1 +c + elseif ((etan.eq.31).and.( etanp1.eq.34)) then +c + do 23313 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn)) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f2cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf1cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +23313 continue +c +c decoupage en 3 par l'arete a3 d'un triangle predecoupe en a2 +c + elseif ((etan.eq.32).and.( etanp1.eq.33)) then +c + do 23321 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f1cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf1cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4tp,f3cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23321 continue +c +c decoupage en 3 par l'arete a4 d'un triangle predecoupe en a2 +c + elseif ((etan.eq.32).and.( etanp1.eq.34)) then +c + do 23322 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vatrtt(nrofon,q5tp,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vatrtt(nrofon,q6tp,f1cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f2cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f3cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +23322 continue +c +c decoupage en 3 par l'arete a1 d'un triangle predecoupe en a2 +c + elseif ((etan.eq.32).and.( etanp1.eq.31)) then +c + do 23323 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f2cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf1cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23323 continue +c +c decoupage en 3 par l'arete a4 d'un triangle predecoupe en a3 +c + elseif ((etan.eq.33).and.( etanp1.eq.34)) then +c + do 23331 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f1cp) = unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) +c + vatrtt(nrofon,q4tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf1cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q6t,prf1cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4tp,f3cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23331 continue +c +c decoupage en 3 par l'arete a1 d'un triangle predecoupe en a3 +c + elseif ((etan.eq.33).and.( etanp1.eq.31)) then +c + do 23332 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vatrtt(nrofon,q5tp,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vatrtt(nrofon,q6tp,f1cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23332 continue +c +c decoupage en 3 par l'arete a2 d'un triangle predecoupe en a3 +c + elseif ((etan.eq.33).and.( etanp1.eq.32)) then +c + do 23333 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn)) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f2cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf1cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +23333 continue +c +c decoupage en 3 par l'arete a1 d'un triangle predecoupe en a4 +c + elseif ((etan.eq.34).and.( etanp1.eq.31)) then +c + do 23341 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f1cp) = unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) +c + vatrtt(nrofon,q4tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q1t,prf1cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f2cp) = vatrtt(nrofon,q6t,f1cp) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4tp,f3cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) + +23341 continue +c +c decoupage en 3 par l'arete a2 d'un triangle predecoupe en a4 +c + elseif ((etan.eq.34).and.( etanp1.eq.32)) then +c + do 23342 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vatrtt(nrofon,q5tp,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vatrtt(nrofon,q6tp,f1cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q3tp,f2cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6t,f2cp) = vatren(nrofon,q4t,prf3cn) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +23342 continue +c +c decoupage en 3 par l'arete a3 d'un triangle predecoupe en a4 +c + elseif ((etan.eq.34).and.( etanp1.eq.33)) then +c + do 23343 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1tp,f1cp) = unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn)) +c + vatrtt(nrofon,q2tp,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4tp,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q6tp,f1cp) = vatren(nrofon,q6t,prf2cn) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1tp,f2cp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q2tp,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q3tp,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vatrtt(nrofon,q4tp,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5tp,f2cp) = -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f2cp) = unstr*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1tp,f3cp) = vatren(nrofon,q3t,prf1cn) +c + vatrtt(nrofon,q2tp,f3cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vatrtt(nrofon,q3tp,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q4tp,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vatrtt(nrofon,q5tp,f3cp) = -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vatrtt(nrofon,q6tp,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +23343 continue + endif diff --git a/src/tool/AP_Conversion/pcsqu2_5.h b/src/tool/AP_Conversion/pcsqu2_5.h new file mode 100644 index 00000000..382454d6 --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_5.h @@ -0,0 +1,1539 @@ +c ATTENTION : les formules meriteraient d'etre verifiees ... +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c + f1hp = filqua(quhnp1) +cgn print *,'f1hp =',f1hp + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) +cgn print *,'ficp =',f1cp,f2cp,f3cp,f4cp +c + f1hn = -anfiqu(quhn) +cgn print *,'f1hn =',f1hn + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) +cgn print *,'ficn =',f1cn,f2cn,f3cn + prf1cn = prftrn(f1cn) + prf2cn = prftrn(f2cn) + prf3cn = prftrn(f3cn) +cgn print *,'prf1cn =',prf1cn +cgn print *,'prf2cn =',prf2cn +cgn print *,'prf3cn =',prf3cn +c + q1t = 1 + q2t = 2 + q3t = 3 + q4t = 4 + q5t = 5 + q6t = 6 +cgn print *,'qit =',q1t,q2t,q3t,q4t,q5t,q6t +c +c decoupage en 4 quadrangles d'un quadrangle +c predecoupe en 3 triangles par l arete a1 + + if ( etan.eq.31 ) then +c + do 2341 , nrofon = 1 , nbfonc +c +c pour le quadrangle Q1 (eventuellement redecoupe en 3 triangles) +c + if ( mod(hetqua(f1hp),100).eq.0 ) then +c + prfcap(f1cp) = 1 +c +cgn print *,'vatren(nrofon,q1t,prf1cn)',vatren(nrofon,q1t,prf1cn) +cgn print *,'vatren(nrofon,q2t,prf1cn)',vatren(nrofon,q2t,prf1cn) +cgn print *,'vatren(nrofon,q3t,prf1cn)',vatren(nrofon,q3t,prf1cn) +cgn print *,'vatren(nrofon,q4t,prf1cn)',vatren(nrofon,q4t,prf1cn) +cgn print *,'vatren(nrofon,q5t,prf1cn)',vatren(nrofon,q5t,prf1cn) +cgn print *,'vatren(nrofon,q6t,prf1cn)',vatren(nrofon,q6t,prf1cn) +c +cgn print *,'vatren(nrofon,q1t,prf2cn)',vatren(nrofon,q1t,prf2cn) +cgn print *,'vatren(nrofon,q2t,prf2cn)',vatren(nrofon,q2t,prf2cn) +cgn print *,'vatren(nrofon,q3t,prf2cn)',vatren(nrofon,q3t,prf2cn) +cgn print *,'vatren(nrofon,q4t,prf2cn)',vatren(nrofon,q4t,prf2cn) +cgn print *,'vatren(nrofon,q5t,prf2cn)',vatren(nrofon,q5t,prf2cn) +cgn print *,'vatren(nrofon,q6t,prf2cn)',vatren(nrofon,q6t,prf2cn) +c +cgn print *,'vatren(nrofon,q1t,prf3cn)',vatren(nrofon,q1t,prf3cn) +cgn print *,'vatren(nrofon,q2t,prf3cn)',vatren(nrofon,q2t,prf3cn) +cgn print *,'vatren(nrofon,q3t,prf3cn)',vatren(nrofon,q3t,prf3cn) +cgn print *,'vatren(nrofon,q4t,prf3cn)',vatren(nrofon,q4t,prf3cn) +cgn print *,'vatren(nrofon,q5t,prf3cn)',vatren(nrofon,q5t,prf3cn) +cgn print *,'vatren(nrofon,q6t,prf3cn)',vatren(nrofon,q6t,prf3cn) +c + vafott(nrofon,q1,f1cp) = vatren(nrofon,q2t,prf3cn) +c + vafott(nrofon,q2,f1cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q3,f1cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q5,f1cp) = vatren(nrofon,q5t,prf3cn) +c + vafott(nrofon,q6,f1cp) =trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q8,f1cp) = + > -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + elseif ( mod(hetqua(f1hp+1),100).ge.31 .and. + > mod(hetqua(f1hp+1),100).le.34 ) then +c + + f1fhp = -filqua(f1hp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f3fcp) = vatren(nrofon,q2t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q1t,prf3cn) + > +trsqu*vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q5t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q3t,prf3cn) + > +trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf3cn)+vatren(nrofon,q3t,prf3cn)) + > +unsde*(vatren(nrofon,q4t,prf3cn)+vatren(nrofon,q5t,prf3cn)) + > +unsqu*vatren(nrofon,q6t,prf3cn) +c +c Pour le fils f1fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f1fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f1fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f1fcp) = + > -unshu*(vatren(nrofon,q1t,prf3cn)+vatren(nrofon,q3t,prf3cn)) + > +unsde*(vatren(nrofon,q4t,prf3cn)+vatren(nrofon,q5t,prf3cn)) + > +unsqu*vatren(nrofon,q6t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) + > +trshu*unsde*(vatren(nrofon,q3t,prf3cn)+ + > vatren(nrofon,q2t,prf1cn)) + > +trsqu*unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q6t,prf3cn)) +c +c Pour le fils f2fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f2fcp) = vatrtt(nrofon,q3t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q2t,f2fcp) = vatrtt(nrofon,q2t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q3t,f2fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q4t,f2fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) + > +trshu*unsde*(vatren(nrofon,q3t,prf3cn)+ + > vatren(nrofon,q2t,prf1cn)) + > +trsqu*unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf3cn)- + > unshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f2fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) +c +c + else +c + codret = codret + 1 +c + endif +c +c pour le quadrangle Q2 (eventuellement redecoupe en 3 triangles) +c + if ( mod(hetqua(f1hp+1),100).eq.0 ) then + + prfcap(f2cp) = 1 + + vafott(nrofon,q1,f2cp) = vatren(nrofon,q3t,prf2cn) +c + vafott(nrofon,q2,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q3,f2cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f2cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q5,f2cp) = + > -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q6,f2cp) = unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) +c + vafott(nrofon,q7,f2cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f2cp) = vatren(nrofon,q5t,prf2cn) +c + elseif ( mod(hetqua(f1hp+1),100).ge.31 .and. + > mod(hetqua(f1hp+1),100).le.34 ) then +c + f1fhp = -filqua(f1hp+1) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f1fcp) = 1 + prftrp(f3fcp) = 1 + prftrp(f2fcp) = 1 +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) + +c +c qi --> qit + vatrtt(nrofon,q2t,f3fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf2cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q5t,f3fcp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > trshu*unsde*(vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q2t,prf1cn))+ + > trsqu*unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c +c Pour le fils f1fcp +c + vatrtt(nrofon,q1t,f1fcp) = vatrtt(nrofon,q1t,f3fcp) + +c + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f1fcp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) +c +c Pour le fils f2fcp +c + vatrtt(nrofon,q1t,f2fcp) = vatren(nrofon,q6t,prf2cn) + +c + vatrtt(nrofon,q2t,f2fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f2fcp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4t,f2fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c +c + else +c + codret = codret + 1 +c + endif + +c pour le quadrangle Q3 +c + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn)) +c + vafott(nrofon,q2,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q3,f3cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q5,f3cp) = + > -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q6,f3cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f3cp) =unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) +c + vafott(nrofon,q8,f3cp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c +c pour le quadrangle Q4 +c + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vafott(nrofon,q2,f4cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q3,f4cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f4cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q5,f4cp) = + > -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q6,f4cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q7,f4cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f4cp) = + > -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + 2341 continue +c +c decoupage en 4 quadrangles d'un quadrangle +c predecoupe en 3 triangles par l arete a2 +c + elseif (etan .eq. 32) then +c + do 2342 , nrofon = 1 , nbfonc + +c pour le quadrangle Q1 +c + prfcap(f1cp) = 1 +c + vafott(nrofon,q1,f1cp) = unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) +c + vafott(nrofon,q2,f1cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q3,f1cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q6,f1cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q7,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f1cp) = + > -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c +c pour le quadrangle Q2 +c + if ( mod(hetqua(f1hp+1),100).eq.0 ) then + + prfcap(f2cp) = 1 + + vafott(nrofon,q1,f2cp) = vatren(nrofon,q2t,prf3cn) +c + vafott(nrofon,q2,f2cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q3,f2cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q5,f2cp) = vatren(nrofon,q5t,prf3cn) +c + vafott(nrofon,q6,f2cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f2cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q8,f2cp) = + > -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + elseif ( mod(hetqua(f1hp+1),100).ge.31 .and. + > mod(hetqua(f1hp+1),100).le.34 ) then +c + f1fhp = -filqua(f1hp+1) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) + + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f3fcp) = vatren(nrofon,q2t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q1t,prf3cn) + > +trsqu*vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q5t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q3t,prf3cn) + > +trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf3cn)+vatren(nrofon,q3t,prf3cn)) + > +unsde*(vatren(nrofon,q4t,prf3cn)+vatren(nrofon,q5t,prf3cn)) + > +unsqu*vatren(nrofon,q6t,prf3cn) +c +c Pour le fils f1fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f1fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f1fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) + > +trshu*unsde*(vatren(nrofon,q3t,prf3cn)+ + > vatren(nrofon,q2t,prf1cn)) + > +trsqu*unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q6t,prf3cn)) +c +c Pour le fils f2fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f2fcp) = vatrtt(nrofon,q3t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q2t,f2fcp) = vatrtt(nrofon,q2t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q3t,f2fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q4t,f2fcp) = vatrtt(nrofon,q5t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf3cn)- + > unshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f2fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) +c +c + else +c + codret = codret + 1 +c + endif + +c pour le quadrangle Q3 +c + if ( mod(hetqua(f1hp+2),100).eq.0 ) then + + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = vatren(nrofon,q3t,prf2cn) +c + vafott(nrofon,q2,f3cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q3,f3cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f3cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q5,f3cp) = + > -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q6,f3cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q7,f3cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f3cp) = vatren(nrofon,q5t,prf2cn) +c + elseif ( mod(hetqua(f1hp+2),100).ge.31 .and. + > mod(hetqua(f1hp+2),100).le.34 ) then +c + f1fhp = -filqua(f1hp+2) + f3fcp = ntrsca(f1fhp+2) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q2t,f3fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf2cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q5t,f3fcp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > trshu*unsde*(vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q2t,prf1cn))+ + > trsqu*unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) + +c Pour le fils f1fcp +c + vatrtt(nrofon,q1t,f1fcp) = vatrtt(nrofon,q1t,f3fcp) + +c + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f1fcp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) + +c +c Pour le fils f2fcp +c + vatrtt(nrofon,q1t,f2fcp) = vatren(nrofon,q6t,prf2cn) + +c + vatrtt(nrofon,q2t,f2fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f2fcp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4t,f2fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) + + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + else +c + codret = codret + 1 +c + endif +c pour le quadrangle Q4 +c + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vafott(nrofon,q2,f4cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q3,f4cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f4cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q5,f4cp) = + > -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q6,f4cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f4cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q8,f4cp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + 2342 continue +c +c decoupage en 4 quadrangles d'un quadrangle +c predecoupe en 3 triangles par l arete a3 +c + elseif (etan .eq. 33) then + do 2343 , nrofon = 1 , nbfonc +c +c pour le quadrangle Q1 +c + prfcap(f1cp) = 1 +c + vafott(nrofon,q1,f1cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vafott(nrofon,q2,f1cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q3,f1cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q6,f1cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q8,f1cp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c +c pour le quadrangle Q2 +c + prfcap(f2cp) = 1 +c + vafott(nrofon,q1,f2cp) = unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) +c + vafott(nrofon,q2,f2cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q3,f2cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q5,f2cp) = + > -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q6,f2cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q7,f2cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f2cp) = + > -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c +c pour le quadrangle Q3 +c + if ( mod(hetqua(f1hp+2),100).eq.0 ) then + + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = vatren(nrofon,q2t,prf3cn) +c + vafott(nrofon,q2,f3cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q3,f3cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q5,f3cp) = vatren(nrofon,q5t,prf3cn) +c + vafott(nrofon,q6,f3cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f3cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q8,f3cp) = + > -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + elseif ( mod(hetqua(f1hp+2),100).ge.31 .and. + > mod(hetqua(f1hp+2),100).le.34 ) then +c + f1fhp = -filqua(f1hp+2) + f3fcp = ntrsca(f1fhp+2) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f3fcp) = vatren(nrofon,q2t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q1t,prf3cn) + > +trsqu*vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q5t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q3t,prf3cn) + > +trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf3cn)+vatren(nrofon,q3t,prf3cn)) + > +unsde*(vatren(nrofon,q4t,prf3cn)+vatren(nrofon,q5t,prf3cn)) + > +unsqu*vatren(nrofon,q6t,prf3cn) +c +c Pour le fils f1fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f1fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f1fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) + > +trshu*unsde*(vatren(nrofon,q3t,prf3cn)+ + > vatren(nrofon,q2t,prf1cn)) + > +trsqu*unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q6t,prf3cn)) +c +c Pour le fils f2fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f2fcp) = vatrtt(nrofon,q3t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q2t,f2fcp) = vatrtt(nrofon,q2t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q3t,f2fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q4t,f2fcp) = vatrtt(nrofon,q5t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf3cn)- + > unshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f2fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) +c + else +c + codret = codret + 1 +c + endif +c +c pour le quadrangle Q4 +c + if ( mod(hetqua(f1hp+3),100).eq.0 ) then + + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = vatren(nrofon,q3t,prf2cn) +c + vafott(nrofon,q2,f4cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q3,f4cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f4cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q5,f4cp) = + > -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q6,f4cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q7,f4cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f4cp) = vatren(nrofon,q5t,prf2cn) +c + elseif ( mod(hetqua(f1hp+3),100).ge.31 .and. + > mod(hetqua(f1hp+3),100).le.34 ) then +c + f1fhp = -filqua(f1hp+3) + f3fcp = ntrsca(f1fhp+2) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q2t,f3fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf2cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q5t,f3fcp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > trshu*unsde*(vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q2t,prf1cn))+ + > trsqu*unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c +c Pour le fils f1fcp +c + vatrtt(nrofon,q1t,f1fcp) = vatrtt(nrofon,q1t,f3fcp) + +c + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f1fcp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) +c +c Pour le fils f2fcp +c + vatrtt(nrofon,q1t,f2fcp) = vatren(nrofon,q6t,prf2cn) + +c + vatrtt(nrofon,q2t,f2fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f2fcp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4t,f2fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) + + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + else +c + codret = codret + 1 +c + endif + 2343 continue +c +c decoupage en 4 quadrangles d'un quadrangle +c predecoupe en 3 triangles par l arete a4 +c + elseif (etan .eq. 34) then + + do 2344 , nrofon = 1 , nbfonc +c +c pour le quadrangle Q1 +c + if ( mod(hetqua(f1hp),100).eq.0 ) then + + prfcap(f1cp) = 1 +c + vafott(nrofon,q1,f1cp) = vatren(nrofon,q3t,prf2cn) +c + vafott(nrofon,q2,f1cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q3,f1cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f1cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q5,f1cp) = + > -unshu*vatren(nrofon,q1t,prf2cn)+ + > trshu*vatren(nrofon,q3t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q6,f1cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q7,f1cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f1cp) = vatren(nrofon,q5t,prf2cn) +c + elseif ( mod(hetqua(f1hp),100).ge.31 .and. + > mod(hetqua(f1hp),100).le.34 ) then +c + + f1fhp = -filqua(f1hp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) + + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f3fcp) = vatren(nrofon,q2t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q1t,prf3cn) + > +trsqu*vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q5t,f3fcp) = + > trshu*vatren(nrofon,q2t,prf3cn) + > -unshu*vatren(nrofon,q3t,prf3cn) + > +trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf3cn)+vatren(nrofon,q3t,prf3cn)) + > +unsde*(vatren(nrofon,q4t,prf3cn)+vatren(nrofon,q5t,prf3cn)) + > +unsqu*vatren(nrofon,q6t,prf3cn) +c +c Pour le fils f1fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f1fcp) = vatren(nrofon,q4t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q3t,f1fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf3cn)+ + > vatren(nrofon,q1t,prf1cn)) + > +trshu*unsde*(vatren(nrofon,q3t,prf3cn)+ + > vatren(nrofon,q2t,prf1cn)) + > +trsqu*unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q6t,prf3cn)) +c +c Pour le fils f2fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f2fcp) = vatrtt(nrofon,q3t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q2t,f2fcp) = vatrtt(nrofon,q2t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q3t,f2fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q4t,f2fcp) = vatrtt(nrofon,q5t,f1fcp) +c +c qi --> qit + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf3cn)- + > unshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q5t,prf3cn) +c +c qi --> qit + vatrtt(nrofon,q6t,f2fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) +c +c + else +c + codret = codret + 1 +c + endif +c +c pour le quadrangle Q2 +c + prfcap(f2cp) = 1 +c + vafott(nrofon,q1,f2cp) = unsde*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf2cn)) +c + vafott(nrofon,q2,f2cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q3,f2cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f2cp) = vatren(nrofon,q6t,prf2cn) +c + vafott(nrofon,q5,f2cp) = + > -unshu*vatren(nrofon,q1t,prf1cn)+ + > trshu*vatren(nrofon,q3t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q6,f2cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f2cp) = unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c + vafott(nrofon,q8,f2cp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c +c pour le quadrangle Q3 +c + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = unsde*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q1t,prf3cn)) +c + vafott(nrofon,q2,f3cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q3,f3cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f3cp) = vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q5,f3cp) = + > -unshu*vatren(nrofon,q2t,prf3cn)+ + > trshu*vatren(nrofon,q1t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q6,f3cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q7,f3cp) = -unshu*vatren(nrofon,q2t,prf1cn)- + > trstr2*(vatren(nrofon,q3t,prf1cn)+ + > vatren(nrofon,q1t,prf1cn))+ + > trshu*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))+ + > nessz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q8,f3cp) = + > -unshu*vatren(nrofon,q3t,prf1cn)+ + > trshu*vatren(nrofon,q1t,prf1cn)+ + > trsqu*vatren(nrofon,q6t,prf1cn) +c +c pour le quadrangle Q4 +c + if ( mod(hetqua(f1hp+3),100).eq.0 ) then + + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = vatren(nrofon,q3t,prf2cn) +c + vafott(nrofon,q2,f4cp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c + vafott(nrofon,q3,f4cp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn))+ + > unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn))+ + > unsqu*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q4,f4cp) = vatren(nrofon,q4t,prf3cn) +c + vafott(nrofon,q5,f4cp) = vatren(nrofon,q5t,prf3cn) +c + vafott(nrofon,q6,f4cp) = trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q5t,prf1cn))- + > trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > unssz*vatren(nrofon,q6t,prf1cn) +c + vafott(nrofon,q7,f4cp) = unsde*(vatren(nrofon,q4t,prf1cn)+ + > vatren(nrofon,q6t,prf3cn)) +c + vafott(nrofon,q8,f4cp) = + > -unshu*vatren(nrofon,q1t,prf3cn)+ + > trshu*vatren(nrofon,q2t,prf3cn)+ + > trsqu*vatren(nrofon,q4t,prf3cn) +c +c + elseif ( mod(hetqua(f1hp+3),100).ge.31 .and. + > mod(hetqua(f1hp+3),100).le.34 ) then +c + f1fhp = -filqua(f1hp+3) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + f3fcp = ntrsca(f1fhp+2) +c + prftrp(f3fcp) = 1 + prftrp(f1fcp) = 1 + prftrp(f2fcp) = 1 +c +c +c Pour le fils f3fcp +c +c qi --> qit + vatrtt(nrofon,q1t,f3fcp) = + > -unshu*(vatren(nrofon,q1t,prf1cn)+vatren(nrofon,q3t,prf1cn)) + > +unsde*(vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > +unsqu*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q2t,f3fcp) = + > unstr *( vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q3t,prf3cn)) +c +c qi --> qit + vatrtt(nrofon,q3t,f3fcp) = vatrtt(nrofon,q5t,prf2cn) +c +c qi --> qit + vatrtt(nrofon,q4t,f3fcp) = + > trshu*(vatren(nrofon,q2t,prf1cn)+ + > vatren(nrofon,q4t,prf1cn)+vatren(nrofon,q5t,prf1cn)) + > -trstr2*(vatren(nrofon,q1t,prf1cn)+ + > vatren(nrofon,q3t,prf1cn)) + > +unssz*vatren(nrofon,q6t,prf1cn) + +c + vatrtt(nrofon,q5t,f3fcp) = + > -unshu*vatren(nrofon,q3t,prf2cn)+ + > trshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f3fcp) = + > -unshu*unsde*(vatren(nrofon,q1t,prf2cn)+ + > vatren(nrofon,q3t,prf1cn))+ + > trshu*unsde*(vatren(nrofon,q2t,prf2cn)+ + > vatren(nrofon,q2t,prf1cn))+ + > trsqu*unsde*(vatren(nrofon,q5t,prf1cn)+ + > vatren(nrofon,q4t,prf2cn)) +c +c Pour le fils f1fcp +c + vatrtt(nrofon,q1t,f1fcp) = vatrtt(nrofon,q1t,f3fcp) + +c + vatrtt(nrofon,q2t,f1fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f1fcp) = vatren(nrofon,q6t,prf2cn) +c + vatrtt(nrofon,q4t,f1fcp) = vatrtt(nrofon,q6t,f3fcp) +c + vatrtt(nrofon,q5t,f1fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q6t,f1fcp) = + > unsde*(vatren(nrofon,q4t,prf2cn)+ + > vatren(nrofon,q5t,prf1cn)) +c +c Pour le fils f2fcp +c + vatrtt(nrofon,q1t,f2fcp) = vatren(nrofon,q6t,prf2cn) + +c + vatrtt(nrofon,q2t,f2fcp) = vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q3t,f2fcp) = vatren(nrofon,q3t,prf2cn) +c + vatrtt(nrofon,q4t,f2fcp) = + > -unshu*(vatren(nrofon,q2t,prf2cn)+vatren(nrofon,q1t,prf2cn)) + > +unsde*(vatren(nrofon,q5t,prf2cn)+vatren(nrofon,q6t,prf2cn)) + > +unsqu*vatren(nrofon,q4t,prf2cn) +c + vatrtt(nrofon,q5t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q2t,prf2cn)+ + > trsqu*vatren(nrofon,q5t,prf2cn) +c + vatrtt(nrofon,q6t,f2fcp) = + > trshu*vatren(nrofon,q3t,prf2cn)- + > unshu*vatren(nrofon,q1t,prf2cn)+ + > trsqu*vatren(nrofon,q6t,prf2cn) +c + else +c + codret = codret + 1 +c + endif + 2344 continue +c + endif diff --git a/src/tool/AP_Conversion/pcsqu2_6.h b/src/tool/AP_Conversion/pcsqu2_6.h new file mode 100644 index 00000000..162b1299 --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_6.h @@ -0,0 +1,256 @@ +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + q1t = 1 + q2t = 2 + q3t = 3 + q4t = 4 + q5t = 5 + q6t = 6 +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a1 + + if ( etanp1.eq.31 ) then + + do 2511 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf2cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf1cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf1cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + 2511 continue +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a2 +c + elseif ( etanp1.eq.32 ) then +c + do 2512 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf3cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf3cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf2cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf2cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + 2512 continue +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a3 +c + elseif ( etanp1.eq.33 ) then +c + do 2513 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf4cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf4cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf3cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf3cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2513 continue +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a4 +c + elseif ( etanp1.eq.34 ) then +c + do 2514 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf1cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf1cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf4cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf4cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c + 2514 continue +c + endif diff --git a/src/tool/AP_Conversion/pcsqu2_7.h b/src/tool/AP_Conversion/pcsqu2_7.h new file mode 100644 index 00000000..43d4ea5b --- /dev/null +++ b/src/tool/AP_Conversion/pcsqu2_7.h @@ -0,0 +1,1181 @@ +c + if ( etanp1.ge.31 .and. etanp1.le.34 ) then +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a1 +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prftrp(f1cp) = 1 + prftrp(f2cp) = 1 + prftrp(f3cp) = 1 +c + q1t = 1 + q2t = 2 + q3t = 3 + q4t = 4 + q5t = 5 + q6t = 6 + + if (etanp1 .eq. 31) then +c + f3cn = nqueca(f1hn+2) + prf3cn = prfcan(f3cn) + f4cn = nqueca(f1hn+3) + prf4cn = prfcan(f4cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'f1hn+2=',f1hn+2, +cgn > 'mod(anhetr(f1hn+2),10)',mod(anhetr(f1hn+2),10) + if ( mod(anhequ(f1hn),10).eq.0 ) then + f1cn = nqueca(f1hn) + prf1cn = prfcan(f1cn) + elseif ( mod(anhequ(f1hn),10).eq.etanp1 ) then + pf = anfiqu(f1hn) + g1 = nqueca(pf) + prfg1n = prfcan(g1) + g2 = nqueca(pf+1) + prfg2n = prfcan(g2) + g3 = nqueca(pf+2) + prfg3n = prfcan(g3) + else + codret = codret + 1 +cgn write(ulsort,*) '_7h A codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+3),10)',mod(anhetr(f1hn+3),10) + if ( mod(anhequ(f1hn+1),10).eq.0 ) then + f2cn = nqueca(f1hn+1) + prf2cn = prfcan(f2cn) + elseif ( mod(anhequ(f1hn+1),10).eq.etanp1 ) then + pf = anfiqu(f1hn+1) + d1 = nqueca(pf) + prfd1n = prfcan(d1) + d2 = nqueca(pf+1) + prfd2n = prfcan(d2) + d3 = nqueca(pf+2) + prfd3n = prfcan(d3) + else + codret = codret + 1 +cgn write (ulsort,*) '_5h B codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c + do 2611 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q2,prf4cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf2cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf1cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf1cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c +2611 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then + do 26111 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf4cn) + > +vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q2,prf4cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf2cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vatren(nrofon,q1,prfg1n) + > +vatren(nrofon,q1,prfg3n) + > +vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q2,prfg1n) + > +vatren(nrofon,q2,prfg2n) + > +vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vatren(nrofon,q6,prfg1n) + > +vafoen(nrofon,q6,prf4cn)) +c +26111 continue +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then + do 26112 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn) + > +vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn) + > +vatren(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf3cn) + > +vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vatren(nrofon,q6,prfd1n) + > +vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfd1n) + > +vatren(nrofon,q5,prfd2n) + > +vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf3cn) + > +vatren(nrofon,q3,prfd1n) + > +vatren(nrofon,q1,prfd2n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf1cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf1cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c +26112 continue +c + elseif ( g1.ne.0 .and. d1.ne.0 ) then + do 26113 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n) + > +vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf4cn) + > +vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf3cn) + > +vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vatren(nrofon,q6,prfd1n) + > +vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfd1n) + > +vatren(nrofon,q2,prfd2n) + > +vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf3cn) + > +vatren(nrofon,q3,prfd1n) + > +vatren(nrofon,q1,prfd2n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vatren(nrofon,q1,prfg1n) + > +vatren(nrofon,q1,prfg3n) + > +vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q2,prfg1n) + > +vatren(nrofon,q2,prfg2n) + > +vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vatren(nrofon,q6,prfg1n) + > +vafoen(nrofon,q6,prf4cn)) +c +26113 continue + endif + +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a2 +c + elseif (etanp1 .eq. 32) then +c + f1cn = nqueca(f1hn) + prf1cn = prfcan(f1cn) + f4cn = nqueca(f1hn+3) + prf4cn = prfcan(f4cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'f1hn+2=',f1hn+2, +cgn > 'mod(anhetr(f1hn+1),10)',mod(anhetr(f1hn+1),10) + if ( mod(anhequ(f1hn+1),10).eq.0 ) then + f2cn = nqueca(f1hn+1) + prf2cn = prfcan(f2cn) + elseif ( mod(anhequ(f1hn+1),10).eq.etanp1 ) then + pf = anfiqu(f1hn+1) + g1 = nqueca(pf) + prfg1n = prfcan(g1) + g2 = nqueca(pf+1) + prfg2n = prfcan(g2) + g3 = nqueca(pf+2) + prfg3n = prfcan(g3) + else + codret = codret + 1 +cgn write(ulsort,*) '_7h A codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+2),10)',mod(anhetr(f1hn+2),10) + if ( mod(anhequ(f1hn+2),10).eq.0 ) then + f3cn = nqueca(f1hn+2) + prf3cn = prfcan(f3cn) + elseif ( mod(anhequ(f1hn+2),10).eq.etanp1 ) then + pf = anfiqu(f1hn+2) + d1 = nqueca(pf) + prfd1n = prfcan(d1) + d2 = nqueca(pf+1) + prfd2n = prfcan(d2) + d3 = nqueca(pf+2) + prfd3n = prfcan(d3) + else + codret = codret + 1 +cgn write (ulsort,*) '_5h B codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c + do 2612 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf3cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf3cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf2cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf2cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c +2612 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then + do 26121 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vatren(nrofon,q6,prfg1n)+ + > vafoen(nrofon,q6,prf1cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf3cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf3cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf1cn) + > +vatren(nrofon,q1,prfg3n) + > +vatren(nrofon,q1,prfg1n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q3,prfg3n) + > +vatren(nrofon,q2,prfg2n) + > +vatren(nrofon,q1,prfg1n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q6,prfg1n)) +cc +26121 continue +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then + do 26122 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q7,prf2cn)+ + > vafoen(nrofon,q6,prf1cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vatren(nrofon,q6,prfd1n)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vatren(nrofon,q6,prfd1n)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vafoen(nrofon,q4,prf4cn) + > +vatren(nrofon,q3,prfd1n) + > +vatren(nrofon,q1,prfd2n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q3,prfd3n) + > +vatren(nrofon,q2,prfd2n) + > +vatren(nrofon,q2,prfd1n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf2cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf2cn) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c +26122 continue +c + elseif ( g1.ne.0 .and. d1.ne.0 ) then + do 26123 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vatren(nrofon,q6,prfg1n)+ + > vafoen(nrofon,q6,prf1cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vatren(nrofon,q6,prfd1n)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vatren(nrofon,q6,prfd1n)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vafoen(nrofon,q3,prfd3n) + > +vatren(nrofon,q2,prfd2n) + > +vatren(nrofon,q2,prfd1n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf4cn) + > +vatren(nrofon,q3,prfd1n) + > +vatren(nrofon,q1,prfd2n)) +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf1cn) + > +vatren(nrofon,q1,prfg3n) + > +vatren(nrofon,q1,prfg1n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q3,prfg3n) + > +vatren(nrofon,q2,prfg2n) + > +vatren(nrofon,q1,prfg1n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q6,prfg1n)) +c +26123 continue + endif +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a3 +c + elseif (etanp1 .eq. 33) then +c + f1cn = nqueca(f1hn) + prf1cn = prfcan(f1cn) + f2cn = nqueca(f1hn+1) + prf2cn = prfcan(f2cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'f1hn+2=',f1hn+2, +cgn > 'mod(anhetr(f1hn+2),10)',mod(anhetr(f1hn+2),10) + if ( mod(anhequ(f1hn+2),10).eq.0 ) then + f3cn = nqueca(f1hn+2) + prf3cn = prfcan(f3cn) + elseif ( mod(anhequ(f1hn+2),10).eq.etanp1 ) then + pf = anfiqu(f1hn+2) + g1 = nqueca(pf) + prfg1n = prfcan(g1) + g2 = nqueca(pf+1) + prfg2n = prfcan(g2) + g3 = nqueca(pf+2) + prfg3n = prfcan(g3) + else + codret = codret + 1 +cgn write(ulsort,*) '_7h A codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+3),10)',mod(anhetr(f1hn+3),10) + if ( mod(anhequ(f1hn+3),10).eq.0 ) then + f4cn = nqueca(f1hn+3) + prf4cn = prfcan(f4cn) + elseif ( mod(anhequ(f1hn+3),10).eq.etanp1 ) then + pf = anfiqu(f1hn+3) + d1 = nqueca(pf) + prfd1n = prfcan(d1) + d2 = nqueca(pf+1) + prfd2n = prfcan(d2) + d3 = nqueca(pf+2) + prfd3n = prfcan(d3) + else + codret = codret + 1 +cgn write (ulsort,*) '_5h B codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c + do 2613 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf4cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf4cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf3cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf3cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +2613 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then + do 26131 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q3t,f1cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f1cp) = unstr*(vafoen(nrofon,q2,prf2cn)+ + > vatren(nrofon,q1,prfg1n)+ + > vatren(nrofon,q1,prfg3n)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vafoen(nrofon,q6,prf4cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf4cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf4cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf2cn)+ + > vatren(nrofon,q1,prfg1n)+ + > vatren(nrofon,q1,prfg3n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)+ + > vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c +26131 continue +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then + do 26132 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q7,prf3cn)) +c + vatrtt(nrofon,q5t,f1cp) = unstr*(vatren(nrofon,q3,prfg3n)+ + > vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfd2n)+ + > vatren(nrofon,q2,prfd1n)+ + > vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf1cn)+ + > vatren(nrofon,q3,prfd1n)+ + > vatren(nrofon,q1,prfd2n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf3cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf3cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +26132 continue +c + elseif ( g1.ne.0 .and. d1.ne.0 ) then + do 26133 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f1cp) = unstr*(vafoen(nrofon,q2,prf2cn)+ + > vatren(nrofon,q1,prfg1n)+ + > vatren(nrofon,q1,prfg3n)) +c + vatrtt(nrofon,q5t,f1cp) = unstr*(vatren(nrofon,q3,prfg3n)+ + > vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q7,prf1cn)+ + > vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfd2n)+ + > vatren(nrofon,q2,prfd1n)+ + > vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf1cn)+ + > vatren(nrofon,q3,prfd1n)+ + > vatren(nrofon,q1,prfd2n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf2cn)+ + > vatren(nrofon,q1,prfg1n)+ + > vatren(nrofon,q1,prfg3n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)+ + > vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c +26133 continue + endif +c +c quadrangle predecoupe en 4 quad et decoupe en trois triangles +c a l'arete a4 +c + elseif (etanp1 .eq. 34) then +c + f2cn = nqueca(f1hn+1) + prf2cn = prfcan(f2cn) + f3cn = nqueca(f1hn+2) + prf3cn = prfcan(f3cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'f1hn+2=',f1hn+2, +cgn > 'mod(anhetr(f1hn),10)',mod(anhetr(f1hn),10) + if ( mod(anhequ(f1hn),10).eq.0 ) then + f1cn = nqueca(f1hn) + prf1cn = prfcan(f1cn) + elseif ( mod(anhequ(f1hn),10).eq.etanp1 ) then + pf = anfiqu(f1hn) + g1 = nqueca(pf) + prfg1n = prfcan(g1) + g2 = nqueca(pf+1) + prfg2n = prfcan(g2) + g3 = nqueca(pf+2) + prfg3n = prfcan(g3) + else + codret = codret + 1 +cgn write(ulsort,*) '_7h A codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+3),10)',mod(anhetr(f1hn+3),10) + if ( mod(anhequ(f1hn+3),10).eq.0 ) then + f4cn = nqueca(f1hn+3) + prf4cn = prfcan(f4cn) + elseif ( mod(anhequ(f1hn+3),10).eq.etanp1 ) then + pf = anfiqu(f1hn+3) + d1 = nqueca(pf) + prfd1n = prfcan(d1) + d2 = nqueca(pf+1) + prfd2n = prfcan(d2) + d3 = nqueca(pf+2) + prfd3n = prfcan(d3) + else + codret = codret + 1 +cgn write (ulsort,*) '_5h B codret', codret +cgn write (ulsort,texte(langue,4)) 'n ', trhn +cgn write (ulsort,texte(langue,5)) 'n ', etan +cgn write (ulsort,texte(langue,4)) 'n+1', trhnp1 +cgn write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c + do 2614 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q2,prf4cn)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf1cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf1cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf4cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf4cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +2614 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then + do 26141 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q2,prf4cn)+ + > vatren(nrofon,q2,prfg3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vafoen(nrofon,q7,prf4cn)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfg3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfg2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q7,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)+ + > vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf2cn)+ + > vatren(nrofon,q1,prfg2n)+ + > vatren(nrofon,q3,prfg1n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f3cp) = vafoen(nrofon,q1,prf4cn) +c + vatrtt(nrofon,q3t,f3cp) = vafoen(nrofon,q2,prf4cn) +c + vatrtt(nrofon,q4t,f3cp) = unsde*(vafoen(nrofon,q2,prf3cn)+ + > vafoen(nrofon,q4,prf4cn)) +c + vatrtt(nrofon,q5t,f3cp) = vafoen(nrofon,q5,prf4cn) +c + vatrtt(nrofon,q6t,f3cp) = vatrtt(nrofon,q4t,f1cp) +c +26141 continue +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then + do 26142 , nrofon = 1 , nbfonc +c +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vatren(nrofon,q3,prfd2n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q7,prf2cn)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f2cp) = vafoen(nrofon,q4,prf1cn) +c + vatrtt(nrofon,q3t,f2cp) = vafoen(nrofon,q1,prf1cn) +c + vatrtt(nrofon,q4t,f2cp) = vatrtt(nrofon,q5t,f1cp) +c + vatrtt(nrofon,q5t,f2cp) = vafoen(nrofon,q8,prf1cn) +c + vatrtt(nrofon,q6t,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q4,prf2cn)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf3cn)+ + > vatren(nrofon,q1,prfd1n)+ + > vatren(nrofon,q1,prfd3n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vafoen(nrofon,q2,prfd1n)+ + > vatren(nrofon,q2,prfd2n)+ + > vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vatren(nrofon,q6,prfd1n)) +c +26142 continue +c + elseif ( g1.ne.0 .and. d1.ne.0 ) then + do 26143 , nrofon = 1 , nbfonc +c dans le triangle NT1 +c + vatrtt(nrofon,q1t,f1cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f1cp) = unsde*(vatren(nrofon,q3,prfg2n)+ + > vatren(nrofon,q2,prfd3n)) +c + vatrtt(nrofon,q3t,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q4t,f1cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q5t,f1cp) = unsde*(vafoen(nrofon,q7,prf2cn)+ + > vatren(nrofon,q6,prfd1n)) +c + vatrtt(nrofon,q6t,f1cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q4,prf3cn)) +c +c dans le triangle NT2 +c + vatrtt(nrofon,q1t,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vatrtt(nrofon,q2t,f2cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f2cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f2cp) = unsde*(vafoen(nrofon,q7,prf2cn)+ + > vatren(nrofon,q6,prfg1n)) +c + vatrtt(nrofon,q5t,f2cp) = unstr*(vatren(nrofon,q2,prfg1n)+ + > vatren(nrofon,q2,prfg2n)+ + > vatren(nrofon,q3,prfg3n)) +c + vatrtt(nrofon,q6t,f2cp) = unstr*(vafoen(nrofon,q4,prf2cn)+ + > vatren(nrofon,q1,prfg2n)+ + > vatren(nrofon,q3,prfg1n)) +c +c dans le triangle NT3 +c + vatrtt(nrofon,q1t,f3cp) = vafoen(nrofon,q1,prf3cn) +c + vatrtt(nrofon,q2t,f3cp) = vatren(nrofon,q2,prfd3n) +c + vatrtt(nrofon,q3t,f3cp) = vatren(nrofon,q3,prfd2n) +c + vatrtt(nrofon,q4t,f3cp) = unstr*(vafoen(nrofon,q2,prf3cn)+ + > vatren(nrofon,q1,prfd1n)+ + > vatren(nrofon,q1,prfd3n)) +c + vatrtt(nrofon,q5t,f3cp) = unstr*(vafoen(nrofon,q2,prfd1n)+ + > vatren(nrofon,q2,prfd2n)+ + > vatren(nrofon,q3,prfd3n)) +c + vatrtt(nrofon,q6t,f3cp) = unsde*(vafoen(nrofon,q6,prf3cn)+ + > vatren(nrofon,q6,prfd1n)) +c +26143 continue + endif +c + endif +c + endif diff --git a/src/tool/AP_Conversion/pcsqug.F b/src/tool/AP_Conversion/pcsqug.F new file mode 100644 index 00000000..2ac7658e --- /dev/null +++ b/src/tool/AP_Conversion/pcsqug.F @@ -0,0 +1,652 @@ + subroutine pcsqug ( nbfonc, ngauss, nbnorf, typgeo, deraff, + > prfcan, prfcap, + > hetqua, ancqua, + > filqua, + > nbanqu, anfiqu, anhequ, + > nqueca, nqusca, + > ntreca, ntrsca, + > vafoen, vafott, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c QUadrangles a plusieurs points de Gauss +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . nbnorf . e . 1 . nbre de noeuds de l'element de reference . +c . typgeo . e . 1 . type geometrique au sens MED . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nbanqu . e . 1 . nombre de quadrangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n +c . anhequ . e . nbanqu . tableau hetqua du maillage de l'iteration n +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nqusca . e . rsquto . numero des quadrangles du calcul . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . conorf . e . sdim* . coordonnees des noeuds de l'element de . +c . . . nbnorf . reference . +c . copgrf . e . sdim* . coordonnees des points de Gauss . +c . . . ngauss . de l'element de reference . +c . wipg . a . nbnorf*. fonctions de forme exprimees aux points de . +c . . . ngauss . Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSQUG' ) +c +#include "nblang.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss, nbnorf, typgeo + integer prfcan(*), prfcap(*) + integer hetqua(nbquto), ancqua(*) + integer filqua(nbquto) + integer nbanqu, anfiqu(nbanqu), anhequ(nbanqu) + integer nqueca(requto), nqusca(rsquto) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) + double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss) + double precision wipg(nbnorf,ngauss) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c qucn = QUadrangle courant en numerotation Calcul a l'it. N +c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1 +c quhn = QUadrangle courant en numerotation Homard a l'it. N +c quhnp1 = QUadrangle courant en numerotation Homard a l'it. N+1 +c + integer qucn, qucnp1, quhn, quhnp1 +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du quadrangle en numerotation Calcul a l'it. N+1 +c + integer f1hp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c etan = ETAt du quadrangle a l'iteration N +c etanp1 = ETAt du quadrangle a l'iteration N+1 +c + integer etan, etanp1 +c + integer nrofon, nugaus +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, ngauss, nbquto = ',nbfonc, ngauss, nbquto +#endif +c + texte(1,4) = + >'(/,''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = + >'(/,''Quadrangle decoupe en triangles : on ne sait pas faire.'')' +c + texte(2,4) = + >'(/,''Current quadrangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' + texte(2,6) = + >'(/,''Quadrangle cut into triangles : not available.'')' +c + codret = 0 +c +c==== +c 2. calcul des valeurs des fonctions de forme aux points de Gauss +c Inutile pour le moment +c==== +c +c==== +c 3. on boucle sur tous les quadrangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du quadrangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un quadrangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Boucle ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfonc.ne.0 ) then +c + do 30 , quhnp1 = 1 , nbquto +c +c 3.1. ==> caracteristiques du quadrangle : +c 3.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + quhn = ancqua(quhnp1) + else + quhn = quhnp1 + endif +c +c 3.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le quadrangle etait actif +c etan = 4 : le quadrangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 55 : le quadrangle n'existait pas ; il a ete produit +c par un decoupage. +c etan = 31, 32, 33, 34 : le quadrangle etait coupe en 3 +c quadrangles ; il y a eu deraffinement. +c + etanp1 = mod(hetqua(quhnp1),100) + etan = (hetqua(quhnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Quadrangle', quhn, etan, quhnp1, etanp1 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le quadrangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +c on repere son ancien numero dans le calcul +c + qucn = nqueca(quhn) +c + if ( prfcan(qucn).gt.0 ) then +c +cgn print 1789,(vafoen(nrofon,nugaus,qucn), nugaus = 1 , ngauss) +cgn 1789 format(' Valeurs anciennes : ',5g12.5) +c +c doc.0.0. ===> etanp1 = 0 : le quadrangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du quadrangle. +c +c ................. ................. +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 321 , nrofon = 1 , nbfonc +cgn write(ulsort,7778) +cgn > (vafoen(nrofon,nugaus,prfcan(qucn)),nugaus=1,ngauss) + do 3211 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,qucnp1) = + > vafoen(nrofon,nugaus,prfcan(qucn)) + 3211 continue + 321 continue +cgn write(31,7777) qucnp1 +cgn write(ulsort,7777) qucn,-1,qucnp1 +cgn7777 format(I3) +cgn7778 format(8g14.7) +c +c doc.0.1/2/3 ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle etait actif +c et est decoupe en 3 triangles. +c les trois fils prennent la valeur de la fonction sur +c le pere +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . ===> . . . . +c . . . . . . +c . . . . . . +c . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + write (ulsort,texte(langue,6)) + codret = codret + 1 +c +c doc.0.4/6/7/8. ==> etanp1 = 4 : le quadrangle etait actif et +c est decoupe en 4. +c les quaque fils prennent la valeur de la fonction +c sur le pere +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c . . ===> ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.eq.4 ) then +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + do 323 , nrofon = 1 , nbfonc + do 3231 , nugaus = 1 , ngauss + daux = vafoen(nrofon,nugaus,prfcan(qucn)) + vafott(nrofon,nugaus,f1cp) = daux + vafott(nrofon,nugaus,f2cp) = daux + vafott(nrofon,nugaus,f3cp) = daux + vafott(nrofon,nugaus,f4cp) = daux + 3231 continue + 323 continue +c +c doc.0.erreur. ==> aucun autre etat sur le quadrangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 31, 32, 33 ou 34 : le quadrangle etait coupe +c en 3 triangles +c======================================================================= +c + elseif ( etan.ge.31 .and. etan.le.34 ) then +c +c on repere les numeros dans le calcul pour ses trois fils a +c l'iteration n +c + f1hn = -anfiqu(quhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 ) then +c + write (ulsort,texte(langue,6)) + codret = codret + 1 +c +c doc.1/2/3.0. ===> etanp1 = 0 : le quadrangle est actif. il est +c reactive. +c on lui attribue la valeur moyenne sur les trois +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . +c . . . . . . +c . . . . . . +c . . . . ===> . . +c . . . . . . +c . . . . . . +c .. .. . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le quadrangle est decoupe en +c trois selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c quadrangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdqu), le premier fils +c est toujours le meme, le 2eme et le 3eme egalement. +c on prendra alors la valeur sur le fils de rang identique +c a l'iteration n. +c ................. ................. +c . . . . . . . . +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. .. .. +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 31, 32, 33 ou 34 et different de +c etan : le quadrangle est encore decoupe +c en trois, mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c +c ................. ................. +c . . . . .. .. +c . . . . . . . . +c . . . . . . . . +c . . . . ===> . . . . +c . . . . . . . . +c . . . . . . . . +c .. .. . . . . +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4 : le quadrangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du quadrangle. qui plus est, par +c suite de la regle des ecarts de niveau, on peut avoir +c induit un decoupage de conformite sur l'un des fils. +c +c On donne la valeur moyenne de la fonction sur les trois +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c . . . . ===> ................. +c . . . . . . . +c . . . . . . . +c .. .. . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 ) then +c + f1hp = filqua(quhnp1) + f1cp = nqusca(f1hp) + f2cp = nqusca(f1hp+1) + f3cp = nqusca(f1hp+2) + f4cp = nqusca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le quadrangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', quhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', quhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.4. ==> le quadrangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 ) then +c +c on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfiqu(quhn) + f1cn = nqueca(f1hn) + f2cn = nqueca(f1hn+1) + f3cn = nqueca(f1hn+2) + f4cn = nqueca(f1hn+3) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c doc.4.0. ===> etanp1 = 0 : le quadrangle est actif ; il est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . +c . . . . . +c . . . . . +c ................. ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + qucnp1 = nqusca(quhnp1) + prfcap(qucnp1) = 1 +c + do 341 , nrofon = 1 , nbfonc + do 3411 , nugaus = 1 , ngauss + vafott(nrofon,nugaus,qucnp1) = + > unsqu * ( vafoen(nrofon,nugaus,prfcan(f1cn)) + > + vafoen(nrofon,nugaus,prfcan(f2cn)) + > + vafoen(nrofon,nugaus,prfcan(f3cn)) + > + vafoen(nrofon,nugaus,prfcan(f4cn)) ) + 3411 continue + 341 continue +c +c doc.4.1/2/3. ===> etanp1 = 31, 32, 33 ou 34 : le quadrangle est +c decoupe en trois. +c on attribue la valeur moyenne sur les quatre anciens +c fils a chacune des trois nouveaux fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c ................. ................. +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ===> . . . . +c . . . . . . . +c . . . . . . . +c . . . .. .. +c ................. ................. +c + elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then +c + f1hp = -filqua(quhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + write (ulsort,texte(langue,6)) + codret = codret + 1 +c + endif +c + endif +c +c======================================================================= +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +cgn do 922 , nrofon = 1 , nbfonc +cgn print *,'fonction numero ', nrofon +cgn iaux = 0 +cgn do 9222 , quhnp1 = 1 , nbtrto +cgn if ( mod(hettri(quhnp1),100).eq.0 ) then +cgn iaux = iaux+1 +cgn print 1788,quhnp1, +cgn > (vafott(nrofon,nugaus,iaux), nugaus = 1 , ngauss) +cgn endif +cgn 9222 continue +cgn 922 continue + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsrc0.F b/src/tool/AP_Conversion/pcsrc0.F new file mode 100644 index 00000000..217ebb87 --- /dev/null +++ b/src/tool/AP_Conversion/pcsrc0.F @@ -0,0 +1,91 @@ + subroutine pcsrc0 ( nbtafo, nbento, + > profho, nensho, + > vafoho, vafosc ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - conversion de Solution - +c - - +c Renumeration du Calcul - option 0 +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbento . e . 1 . nombre d'entites homard . +c . profho . e . nbento . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nensho . e . nbento . numero des entites en sortie pour homard . +c . vafoho . e . nbtafo*. variables numerotation homard . +c . . . nbento . . +c . vafosc . s . nbtafo*. variables en sortie pour le calcul . +c . . . * . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtafo, nbento + integer profho(nbento) + integer nensho(nbento) +c + double precision vafoho(nbtafo,*) + double precision vafosc(nbtafo,*) +c +c 0.4. ==> variables locales +c + integer nuv + integer iaux, jaux +c ______________________________________________________________________ +c +c==== +c 1. on trie les valeurs dans la numerotation du calcul en sortie +c==== +c +#include "impr03.h" +c + do 11 , nuv = 1, nbtafo +c + jaux = 0 + do 111 , iaux = 1, nbento + if ( profho(iaux).gt.0 ) then + jaux = jaux + 1 + vafosc(nuv,jaux) = vafoho(nuv,nensho(iaux)) + endif +cgn if ( vafoho(nuv,nensho(iaux)).gt.1.d5 ) then +cgn write(1,90014) iaux,vafoho(nuv,nensho(iaux)) +cgn endif + 111 continue +c + 11 continue +c + end diff --git a/src/tool/AP_Conversion/pcsrho.F b/src/tool/AP_Conversion/pcsrho.F new file mode 100644 index 00000000..2d9fc16d --- /dev/null +++ b/src/tool/AP_Conversion/pcsrho.F @@ -0,0 +1,533 @@ + subroutine pcsrho ( nbfop1, nbfop2, numnp1, numnp2, + > deraff, option, + > hetnoe, ancnoe, + > nnoeho, nnoeca, + > nbvapr, listpr, prfcan, profho, + > vap1ec, vap2ec, + > vap1ho, vap2ho, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - Renumerotation vers +c - - - - +c HOMARD +c ______________________________________________________________________ +c -- +c Remarque : on suppose qu'il y a une valeur de solution aussi +c sur les eventuels noeuds isoles. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfop1 . e . 1 . nombre de fonctions P1 . +c . nbfop2 . e . 1 . nombre de fonctions P2 . +c . numnp1 . e . 1 . nombre de noeuds de la fonction si P1 . +c . numnp2 . e . 1 . nombre de noeuds de la fonction si P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . option . e . 1 . option du traitement . +c . . . . -1 : Pas de changement dans le maillage . +c . . . . 0 : Adaptation complete . +c . . . . 1 : Modification de degre . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . ancnoe . e . nbnoto . ancien numero de noeud si deraffinement . +c . nnoeho . e . renoac . numero des noeuds en entre pour homard . +c . nnoeca . e . renoto . numero des noeuds du code de calcul . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . listpr . e . * . liste des numeros de noeuds ou la fonction . +c . . . . est definie. . +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . profho . es . nbnoto . pour chaque noeud en numerotation homard : . +c . . . . 0 : le noeud est absent du profil . +c . . . . 1 : le noeud est present dans le profil . +c . vap1ec . e . nbfop1*. variables p1 en entree pour le calcul . +c . . . numnp1 . . +c . vap2ec . e . nbfop2*. variables p2 en entree pour le calcul . +c . . . numnp2 . . +c . vap1ho . s . nbfop1*. variables p1 numerotation homard . +c . . . nbnoto . . +c . vap2ho . s . nbfop2*. variables p2 numerotation homard . +c . . . nbnoto . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSRHO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nomber.h" +#include "nombsr.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer nbfop1, nbfop2 + integer numnp1, numnp2 + integer option +c + integer nbvapr, listpr(*) +c + integer hetnoe(nbnoto), ancnoe(nbnoto) + integer prfcan(*), profho(rsnoto) + integer nnoeho(renoac), nnoeca(renoto) +c + double precision vap1ec(nbfop1,renoto), vap2ec(nbfop2,renoto) + double precision vap1ho(nbfop1,*), vap2ho(nbfop2,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nuv, lenoeu + integer iaux +c + integer nbmess + parameter ( nbmess = 120 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Situation impossible ?'')' +c + texte(2,4) = '(''Impossible situation ?'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option + write (ulsort,90002) 'numnp1', numnp1 + write (ulsort,90002) 'numnp2', numnp2 + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nbfop1', nbfop1 + write (ulsort,90002) 'nbfop2', nbfop2 + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'reno1i', reno1i + write (ulsort,90002) 'renoto', renoto + write (ulsort,90002) 'etats',(hetnoe(iaux),iaux=1,4) +#endif +c +c==== +c 2. Cas : +c - d'adaptation complete +c - maillage inchange ou uniquement du raffinement +c Dans ce cas, chaque noeud en entree de HOMARD est encore un noeud +c en sortie. Le numero d'un noeud dans HOMARD reste inchange. +c Il suffit de translater les numeros : +c Numero dans le calcul en entree <---> Numero HOMARD +c lenoeu <---> nnoeho(lenoeu) +c==== +c + if ( .not.deraff .and. option.le.0 ) then +cgn write (ulsort,90002) 'sans deraffinement' +c +c 2.1. ==> valeurs p1 +c + do 21, nuv = 1, nbfop1 +c +c 2.1.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 211 , lenoeu = 1 , numnp1 +cgn write (ulsort,90002) 'lenoeu', lenoeu, nnoeho(lenoeu) +cgn write(*,90004) 'vap1ec(nuv,lenoeu)', vap1ec(nuv,lenoeu) + vap1ho(nuv,nnoeho(lenoeu)) = vap1ec(nuv,lenoeu) + profho(lenoeu) = 1 + 211 continue +c + else +c +c 2.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 212 , iaux = 1 , nbvapr +cgn print 1789,nuv,' --- ',iaux,vap1ec(nuv,iaux),listpr(iaux), +cgn valeurs p2 +c + do 22, nuv = 1, nbfop2 +c +c 2.2.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 221 , lenoeu = 1 , numnp2 + vap2ho(nuv,nnoeho(lenoeu)) = vap2ec(nuv,lenoeu) + profho(lenoeu) = 1 + 221 continue +c + else +c +c 2.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 222 , iaux = 1 , nbvapr +cgn print 1789,nuv,' --- ',iaux,vap2ec(nuv,iaux),listpr(iaux), +cgn Numero HOMARD <---> Numero HOMARD +c calcul en entree en entree en sortie +c nnoeca(ancnoe(lenoeu)) <---> ancnoe(lenoeu) <---> lenoeu +c +c==== +c + elseif ( option.le.0 ) then +cgn write (ulsort,90002) 'avec deraffinement' +c +c 3.1. ==> valeurs p1 +c - un noeud isole a pour etat 0, invariable. +c - un noeud d'une maille ignoree a pour etat 7, invariable. +c - un noeud support de maille-point a pour etat 3 ou 33. +c - un noeud P1 a pour etat 1. +c s'il existait avant, son etat valait : +c . 1, il n'a pas change ; +c . 2, il etait P2 et a change suite a deraffinement, +c mais une fonction P1 n'avait pas de valeur ici. +c Sont donc concernes les noeuds d'historique 0, 3, 7, 11 ou 33 +c +c 3.1.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 311, nuv = 1, nbfop1 + do 3111, lenoeu = 1, nbnoto +cgn write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu) + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.11 .or. + > hetnoe(lenoeu).eq.33 .or. + > hetnoe(lenoeu).eq.7 .or. + > hetnoe(lenoeu).eq.77 ) then +cgn write(*,90004) 'vap1ec(nuv,nnoeca(ancnoe(lenoeu)))', +cgn > vap1ec(nuv,nnoeca(ancnoe(lenoeu))) + vap1ho(nuv,lenoeu) = vap1ec(nuv,nnoeca(ancnoe(lenoeu))) + profho(lenoeu) = 1 + endif + 3111 continue + 311 continue +c + else +c +c 3.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 312, nuv = 1, nbfop1 + do 3121, lenoeu = 1, nbnoto + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.11 .or. + > hetnoe(lenoeu).eq.33 .or. + > hetnoe(lenoeu).eq.7 .or. + > hetnoe(lenoeu).eq.77 ) then + iaux = prfcan(nnoeca(ancnoe(lenoeu))) + if ( iaux.gt.0 ) then + vap1ho(nuv,lenoeu) = vap1ec(nuv,iaux) + profho(lenoeu) = 1 + endif + endif + 3121 continue + 312 continue +c + endif +c +c 3.2. ==> valeurs p2 +c - un noeud isole a pour etat 0, invariable. +c - un noeud d'une maille ignoree a pour etat 7, invariable. +c - un noeud support de maille-point a pour etat 3 ou 33. +c - un noeud P1 ou P2 a pour etat 1. ou 2 +c s'il existait avant, son etat valait : +c . 1, il etait P1 ; +c . 2, il etait P2. +c Sont donc concernes les noeuds d'historique 0, 3, 11, 12, 21, 2 ou 33. +c +c 3.2.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 321, nuv = 1, nbfop2 + do 3211, lenoeu = 1, nbnoto + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.11 .or. + > hetnoe(lenoeu).eq.12 .or. + > hetnoe(lenoeu).eq.21 .or. + > hetnoe(lenoeu).eq.22 .or. + > hetnoe(lenoeu).eq.33 .or. + > hetnoe(lenoeu).eq.7 .or. + > hetnoe(lenoeu).eq.77 ) then + vap2ho(nuv,lenoeu) = vap2ec(nuv,nnoeca(ancnoe(lenoeu))) + profho(lenoeu) = 1 + endif + 3211 continue + 321 continue +c + else +c +c 3.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 322, nuv = 1, nbfop2 + do 3221, lenoeu = 1, nbnoto + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.11 .or. + > hetnoe(lenoeu).eq.12 .or. + > hetnoe(lenoeu).eq.21 .or. + > hetnoe(lenoeu).eq.22 .or. + > hetnoe(lenoeu).eq.33 .or. + > hetnoe(lenoeu).eq.7 .or. + > hetnoe(lenoeu).eq.77 ) then + iaux = prfcan(nnoeca(ancnoe(lenoeu))) + if ( iaux.gt.0 ) then + vap2ho(nuv,lenoeu) = vap2ec(nuv,iaux) + profho(lenoeu) = 1 + endif + endif + 3221 continue + 322 continue +c + endif +c +c==== +c 4. Cas : +c - modification de degre +c En fait c'est seulement du passage de P2 a P1 +c Dans ce cas, il ne faut reporter les valeurs que pour les noeuds +c qui existent encore. La translation est alors : +c +c Numero dans le <---> Numero HOMARD <---> Numero HOMARD +c calcul en entree en entree en sortie +c nnoeca(ancnoe(lenoeu)) <---> ancnoe(lenoeu) <---> lenoeu +c +c==== +c + elseif ( option.eq.1 ) then +cgn write (ulsort,90002) 'modification de degre' +c +c 4.1. ==> passage de degre 2 a degre 1 +c + if ( nbfop1.ne.0 ) then +c +c - un noeud isole a pour etat 0, invariable. +c - un noeud support de maille-point a pour etat 3. +c - un noeud d'une maille ignoree a pour etat 7, invariable. +c - un noeud P1 a pour etat 1. +c Sont donc concernes les noeuds d'historique 0, 1, 3 +c +c 4.1.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 411, nuv = 1, nbfop1 + do 4111, lenoeu = 1, nbnoto +cgn write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu), +cgn > ancnoe(lenoeu), nnoeca(ancnoe(lenoeu)) + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.1 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.7 ) then +cgn write (ulsort,90002) 'lenoeu', lenoeu, ancnoe(lenoeu) +cgn write(*,90004) 'vap1ec(nuv,nnoeca(ancnoe(lenoeu)))', +cgn > vap1ec(nuv,nnoeca(ancnoe(lenoeu))) + vap1ho(nuv,lenoeu)=vap1ec(nuv,nnoeca(ancnoe(lenoeu))) + profho(lenoeu) = 1 + endif + 4111 continue + 411 continue +c + else +c +c 4.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 412, nuv = 1, nbfop1 + do 4121, lenoeu = 1, nbnoto + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.1 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.7 ) then + iaux = prfcan(nnoeca(ancnoe(lenoeu))) + if ( iaux.gt.0 ) then + vap1ho(nuv,lenoeu) = vap1ec(nuv,iaux) + profho(lenoeu) = 1 + endif + endif + 4121 continue + 412 continue +c + endif +c +c 4.2. ==> passage de degre 1 a degre 2 +c + elseif ( nbfop2.ne.0 ) then +c +c - un noeud isole a pour etat 0, invariable. +c - un noeud support de maille-point a pour etat 3. +c - un noeud d'une maille ignoree a pour etat 7, invariable. +c - un noeud P1 a pour etat 1. +c - un noeud P2 a pour etat 2. +c Sont donc concernes les noeuds d'historique 0, 1, 3 +c +c 4.2.1. ==> sans profil : on a des valeurs sur tous les noeuds +c + if ( nbvapr.le.0 ) then +cgn write (ulsort,90002) 'sans profil' +c + do 421, nuv = 1, nbfop2 + do 4211, lenoeu = 1, nbnoto +cgn write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu) + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.1 .or. + > hetnoe(lenoeu).eq.3 .or. + > hetnoe(lenoeu).eq.7 ) then +cgn write (ulsort,90002) 'lenoeu', lenoeu, nnoeca(lenoeu) +cgn write(*,90004) 'vap2ec(nuv,nnoeca(lenoeu))', +cgn > vap2ec(nuv,nnoeca(lenoeu)) + vap2ho(nuv,lenoeu)=vap2ec(nuv,nnoeca(lenoeu)) + profho(lenoeu) = 1 + endif + 4211 continue + 421 continue +c + else +c +c 4.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr +c +cgn write (ulsort,90002) 'profil, nbvapr', nbvapr + do 422, nuv = 1, nbfop2 + do 4221, lenoeu = 1, nbnoto + if ( hetnoe(lenoeu).eq.0 .or. + > hetnoe(lenoeu).eq.1 .or. + > hetnoe(lenoeu).eq.3 ) then + iaux = prfcan(nnoeca(ancnoe(lenoeu))) + if ( iaux.gt.0 ) then + vap2ho(nuv,lenoeu) = vap2ec(nuv,iaux) + profho(lenoeu) = 1 + endif + endif + 4221 continue + 422 continue +c + endif +c +c 4.3. ==> erreur +c + else +c + codret = 43 +c + endif +c +c==== +c 5. Cas inconnu +c==== +c + else +c + codret = 5 +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcste0.F b/src/tool/AP_Conversion/pcste0.F new file mode 100644 index 00000000..f27a0b73 --- /dev/null +++ b/src/tool/AP_Conversion/pcste0.F @@ -0,0 +1,293 @@ + subroutine pcste0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > hettet, anctet, filtet, + > nbante, anfite, + > nteeca, ntesca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c TEtraedres - solution P0 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n. +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSTE0' ) +c +#include "nblang.h" +#include "fracti.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) + integer hettet(nbteto), anctet(*) + integer filtet(nbteto) + integer nbante, anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(*) + double precision vafott(*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c tehn = TEtraedre courant en numerotation Homard a l'it. N +c tehnp1 = TEtraedre courant en numerotation Homard a l'it. N+1 +c + integer tehn, tehnp1 +c +c etan = ETAt du tetraedre a l'iteration N +c etanp1 = ETAt du tetraedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +cgn write (ulsort,*) 'prfcan en entree de '//nompro +cgn write (ulsort,91020) (prfcan(iaux),iaux=1,17) +cgn write (ulsort,*) 'nteeca en entree de '//nompro +cgn write (ulsort,91020) (nteeca(iaux),iaux=1,5) +cgn write (ulsort,*) 'vafoen en entree de '//nompro +cgn write (ulsort,92010) (vafoen(iaux),iaux=1,17) +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 2. on boucle sur tous les tetraedres du maillage HOMARD n+1 +c on trie en fonction de l'etat du tetraedre dans le maillage n +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , tehnp1 = 1 , nbteto +c +c 2.1. ==> caracteristiques du tetraedre : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + tehn = anctet(tehnp1) + else + tehn = tehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etat = 0 : le tetraedre est actif. +c etat = 21, ..., 26 : le tetraedre est coupe en 2 selon +c l'arete 1, ..., 6 ; il y a eu deraffinement. +c etat = 41, ..., 44 : le tetraedre est coupe en 4 selon la +c face 1, ..., 4 ; il y a eu deraffinement. +c etat = 45, 46, 47 : le tetraedre est coupe en 4 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c etat = 55 : le tetraedre n'existait pas ; il a ete produit par +c un decoupage. +c etat = 85, 86, 87 : le tetraedre est coupe en 8 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c + etanp1 = mod(hettet(tehnp1),100) + etan = (hettet(tehnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Tetraedre', tehn, etan, tehnp1, etanp1 +c +c======================================================================= +c 2.1.3. ==> etan = 0 : le tetraedre etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSET0', nompro +#endif +c + call pcset0 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > filtet, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c 2.1.4. ==> etan = 21, ..., 26 : le tetraedre etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.21 .and. etan.le.26 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSET2', nompro +#endif +c + call pcset2 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c 2.1.5. ==> etan = 41, ..., 44 : le tetraedre etait coupe en 4 +c selon la face 1, 2, 3, 4 +c 2.1.6. ==> etan = 45, 46, 47 : le tetraedre etait coupe en 4 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.41 .and. etan.le.47 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSET4', nompro +#endif +c + call pcset4 ( etan, etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c 2.1.7 ==> etan = 85, 86, 87 : le tetraedre etait coupe en 8 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.85 .and. etan.le.87 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSET8', nompro +#endif +c + call pcset8 ( etanp1, tehn, tehnp1, typint, + > prfcan, prfcap, + > filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, vafoen, vafott, + > ulsort, langue, codret ) +c + endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcsteg.F b/src/tool/AP_Conversion/pcsteg.F new file mode 100644 index 00000000..ded67e90 --- /dev/null +++ b/src/tool/AP_Conversion/pcsteg.F @@ -0,0 +1,313 @@ + subroutine pcsteg ( nbfonc, ngauss, nbnorf, typgeo, deraff, + > prfcan, prfcap, + > hettet, anctet, + > filtet, + > nbante, anfite, + > nteeca, ntesca, + > vafoen, vafott, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c TEtraedres a plusieurs points de Gauss +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . nbnorf . e . 1 . nbre de noeuds de l'element de reference . +c . typgeo . e . 1 . type geometrique au sens MED . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . nbante . e . 1 . nombre de tetraedres decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfite . e . nbante . tableau filtet du maillage de l'iteration n. +c . nteeca . e . * . numero des tetraedres dans le calcul entree. +c . ntesca . e . rsteto . numero des tetraedres dans le calcul sortie. +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . conorf . e . sdim* . coordonnees des noeuds de l'element de . +c . . . nbnorf . reference . +c . copgrf . e . sdim* . coordonnees des points de Gauss . +c . . . ngauss . de l'element de reference . +c . wipg . a . nbnorf*. fonctions de forme exprimees aux points de . +c . . . ngauss . Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSTEG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombte.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss, nbnorf, typgeo + integer prfcan(*), prfcap(*) + integer hettet(nbteto), anctet(*) + integer filtet(nbteto) + integer nbante, anfite(nbante) + integer nteeca(reteto), ntesca(rsteto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) + double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss) + double precision wipg(nbnorf,ngauss) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +c tehn = TEtraedre courant en numerotation Homard a l'it. N +c tehnp1 = TEtraedre courant en numerotation Homard a l'it. N+1 +c + integer tehn, tehnp1 +c +c etan = ETAt du tetraedre a l'iteration N +c etanp1 = ETAt du tetraedre a l'iteration N+1 +c + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#include "impr03.h" +cgn write (ulsort,*) 'prfcan en entree de '//nompro +cgn write (ulsort,91020) (prfcan(iaux),iaux=1,17) +cgn write (ulsort,*) 'nteeca en entree de '//nompro +cgn write (ulsort,91020) (nteeca(iaux),iaux=1,5) +cgn write (ulsort,*) 'vafoen en entree de '//nompro +cgn do 111 , etan = 1 , nbfonc +cgn write (ulsort,90002) 'composante',etan +cgn do 1111 , etanp1 = 1 , 8 +cgn write (ulsort,92010) (vafoen(etan,etanp1,iaux),iaux=1,5) +cgn 1111 continue +cgn 111 continue +c + codret = 0 +c +c==== +c 2. on boucle sur tous les tetraedres du maillage HOMARD n+1 +c on trie en fonction de l'etat du tetraedre dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un tetraedre dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c remarque : on a scinde en plusieurs programmes pour pouvoir passer +c les options de compilation optimisees. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Boucle ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfonc.ne.0 ) then +c + do 30 , tehnp1 = 1 , nbteto +c +c 2.1. ==> caracteristiques du tetraedre : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + tehn = anctet(tehnp1) + else + tehn = tehnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le tetraedre etait actif. +c etan = 21, ..., 26 : le tetraedre etait coupe en 2 selon +c l'arete 1, ..., 6 ; il y a eu deraffinement. +c etan = 41, ..., 44 : le tetraedre etait coupe en 4 selon la +c face 1, ..., 4 ; il y a eu deraffinement. +c etan = 45, 46, 47 : le tetraedre etait coupe en 4 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c etan = 55 : le tetraedre n'existait pas ; il a ete produit par +c un decoupage. +c etan = 85, 86, 87 : le tetraedre etait coupe en 8 selon la +c diagonale 1-6, 2-5, 3-4 ; il y a eu +c deraffinement. +c + etanp1 = mod(hettet(tehnp1),100) + etan = (hettet(tehnp1)-etanp1) / 100 +c +cgn write (ulsort,1792) 'Tetraedre', tehn, etan, tehnp1, etanp1 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le tetraedre etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT0', nompro +#endif +c + call pcspt0 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.21-26.p. ==> etan = 21, ..., 26 : le tetraedre etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.21 .and. etan.le.26 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT2', nompro +#endif +c + call pcspt2 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.41-44.p. ==> etan = 41, ..., 44 : le tetraedre etait coupe en 4 +c selon la face 1, 2, 3, 4 +c doc.45-47.p. ==> etan = 45, 46, 47 : le tetraedre etait coupe en 4 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.41 .and. etan.le.47 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT4', nompro +#endif +c + call pcspt4 ( etan, etanp1, tehn, tehnp1, + > prfcan, prfcap, + > hettet, filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c doc.85-87.p. ==> etan = 85, 86, 87 : le tetraedre etait coupe en 8 +c selon une diagonale +c======================================================================= +c + elseif ( etan.ge.85 .and. etan.le.87 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPT8', nompro +#endif +c + call pcspt8 ( etanp1, tehn, tehnp1, + > prfcan, prfcap, + > filtet, nbante, anfite, + > nteeca, ntesca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcstr0.F b/src/tool/AP_Conversion/pcstr0.F new file mode 100644 index 00000000..82555900 --- /dev/null +++ b/src/tool/AP_Conversion/pcstr0.F @@ -0,0 +1,898 @@ + subroutine pcstr0 ( nbfonc, typint, deraff, + > prfcan, prfcap, + > hettri, anctri, + > filtri, + > nbantr, anfitr, + > ntreca, ntrsca, + > vafoen, vafott, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c TRiangles - solution P0 +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions elements de volume . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . * . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . * . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSTR0' ) +c +#include "nblang.h" +#include "fracta.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +#include "demitr.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typint + integer prfcan(*), prfcap(*) + integer hettri(nbtrto), anctri(*) + integer filtri(nbtrto) + integer nbantr, anfitr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,*) + double precision vafott(nbfonc,*) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c trcn = TRiangle courant en numerotation Calcul a l'iteration N +c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1 +c trhn = TRiangle courant en numerotation Homard a l'iteration N +c trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1 +c + integer trcn, trcnp1, trhn, trhnp1 +c +c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1 +c fihp = Fils ieme du triangle en numerotation Homard a l'it. N+1 +c f1cp = Fils 1er du triangle en numerotation Calcul a l'it. N+1 +c f2cp = Fils 2eme du triangle en numerotation Calcul a l'it. N+1 +c f3cp = Fils 3eme du triangle en numerotation Calcul a l'it. N+1 +c f4cp = Fils 4eme du triangle en numerotation Calcul a l'it. N+1 +c + integer f1hp, fihp + integer f1cp, f2cp, f3cp, f4cp +c +c f1hn = Fils 1er du triangle en numerotation Homard a l'it. N +c f1cn = Fils 1er du triangle en numerotation Calcul a l'it. N +c f2cn = Fils 2eme du triangle en numerotation Calcul a l'it. N +c f3cn = Fils 3eme du triangle en numerotation Calcul a l'it. N +c f4cn = Fils 4eme du triangle en numerotation Calcul a l'it. N +c + integer f1hn + integer f1cn, f2cn, f3cn, f4cn +c +c f1fhp = Fils 1er du Fils en numerotation Homard a l'it. N+1 +c f1fcp = Fils 1er du Fils en numerotation Calcul a l'it. N+1 +c f2fcp = Fils 2eme du Fils en numerotation Calcul a l'it. N+1 +c + integer f1fhp, f1fcp, f2fcp +c +c etan = ETAt du triangle a l'iteration N +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etan, etanp1 +c + integer nrofon + integer iaux +c + double precision daux + double precision daux1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,90002) 'nbfonc', nbfonc + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'retrto, rstrto', retrto, rstrto +#endif +c + texte(1,4) = + > '(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i8)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' + texte(1,6) = '( ''==> Aucune interpolation'')' +c + texte(2,4) = + > '(/,''Current triangle : # at iteration '',a3,'' : '',i8)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' + texte(2,6) = '( ''==> No interpolation'')' +c + codret = 0 +cgn write(ulsort,*) 'ntreca' +cgn write(ulsort,91020) ntreca +cgn write(ulsort,*) 'prfcan' +cgn write(ulsort,91020)(prfcan(iaux),iaux=1,74) +cgn 9999 format(1I5,g14.7,3i10) +c +c==== +c 2. on boucle sur tous les triangles du maillage HOMARD n+1 +c on trie en fonction de l'etat du triangle dans le maillage n +c on numerote les paragraphes en fonction de la documentation, a +c savoir : le paragraphe doc.n.p traite de la mise a jour de solution +c pour un triangle dont l'etat est passe de n a p. +c les autres paragraphes sont numerotes classiquement +c==== +c + if ( nbfonc.ne.0 ) then +c + do 20 , trhnp1 = 1 , nbtrto +c +c 2.1. ==> caracteristiques du triangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + trhn = anctri(trhnp1) + else + trhn = trhnp1 + endif +c +c 2.1.2. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le triangle etait actif +c etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete +c 1, 2, 3 ; il y a eu deraffinement. +c etan = 4 : le triangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 5 : le triangle n'existait pas ; il a ete produit par +c un decoupage. +c etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule +c de l'arete etan-5 pour le suivi de +c frontiere ; il y a eu deraffinement. +c etan = 9 : le triangle etait coupe en 4 et un de ses fils +c est inactif +c + etanp1 = mod(hettri(trhnp1),10) + etan = (hettri(trhnp1)-etanp1) / 10 +c +cgn write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1 +c +c======================================================================= +c doc.0.p. ==> etan = 0 : le triangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +cgn print *,'le triangle etait actif' +c +c on repere son ancien numero dans le calcul +c + trcn = ntreca(trhn) +cgn write (ulsort,1790) trcn,prfcan(trcn) +cgn 1790 format('Numero du calcul precedent = ',i3,', de profil = ',i3) +c + if ( prfcan(trcn).gt.0 ) then +c +cgn write (ulsort,90004)'Valeurs anciennes', +cgn > (vafoen(nrofon,prfcan(trcn)),nrofon=1,nbfonc) +c +c doc.0.0. ===> etanp1 = 0 : le triangle etait actif et l'est encore ; +c il est inchange +c c'est le cas le plus simple : on prend la valeur de la +c fonction associee a l'ancien numero du triangle. +c . . +c . . . . +c . . . . +c . . . . +c . . ===> . . +c . . . . +c . . . . +c . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 221 , nrofon = 1 , nbfonc + vafott(nrofon,trcnp1) = vafoen(nrofon,prfcan(trcn)) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(trcn)) + 221 continue +cgn write(21,9999) trcnp1,vafott(15,trcnp1),0,trcn,prfcan(trcn) +cgn write(ulsort,91020) trcn,-1,trcnp1 +c +c doc.0.1/2/3 ==> etanp1 = 1, 2 ou 3 : le triangle etait actif et est +c decoupe en 2. +c les deux fils prennent la valeur de la fonction sur +c le pere +c . . +c . . ... +c . . . . . +c . . . . . +c . . ===> . . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + do 2220 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(trcn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) vafoen(nrofon,prfcan(trcn)) + 2220 continue + else + do 2221 , nrofon = 1 , nbfonc + daux = unsde*vafoen(nrofon,prfcan(trcn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) vafoen(nrofon,prfcan(trcn)) + 2221 continue + endif +cgn write(22,9999) f1cp,vafott(15,f1cp),2,trcn,prfcan(trcn) +cgn write(22,9999) f2cp,vafott(15,f1cp),2,trcn,prfcan(trcn) +cgn write(22,91020) f1cp,f2cp +cgn write(ulsort,91020) trcn,-1, +cgn > f1cp,f2cp +c +c doc.0.4/6/7/8. ==> etanp1 = 4, 6, 7 ou 8 : le triangle etait actif et +c est decoupe en 4. +c les quatre fils prennent la valeur de la fonction +c sur le pere +c . . +c . . . . +c . . . . +c . . . . +c . . ===> ......... +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 + if ( typint.eq.0 ) then + do 2230 , nrofon = 1 , nbfonc + daux = vafoen(nrofon,prfcan(trcn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux +cgn write(ulsort,92010) daux + 2230 continue + else + do 2231 , nrofon = 1 , nbfonc + daux = unsqu*vafoen(nrofon,prfcan(trcn)) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux + vafott(nrofon,f3cp) = daux + vafott(nrofon,f4cp) = daux +cgn write(ulsort,92010) daux + 2231 continue + endif +cgn write(23,9999) f1cp,vafott(15,f1cp),4,trcn,prfcan(trcn) +cgn write(23,9999) f2cp,vafott(15,f1cp),4,trcn,prfcan(trcn) +cgn write(23,9999) f3cp,vafott(15,f1cp),4,trcn,prfcan(trcn) +cgn write(23,9999) f4cp,vafott(15,f1cp),4,trcn,prfcan(trcn) +cgn write(23,91020) f1cp,f2cp,f3cp,f4cp +cgn write(ulsort,91020) trcn,-1, +cgn > f1cp,f2cp,f3cp,f4cp +c +c doc.0.erreur. ==> aucun autre etat sur le triangle courant n'est +c possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.1/2/3.p. ==> etan = 1, 2 ou 3 : le triangle etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.1 .and. etan.le.3 ) then +c +cgn print *,'le triangle etait coupe en 2' +c on repere les numeros dans le calcul pour ses deux fils a +c l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 ) then +c +c doc.1/2/3.0. ===> etanp1 = 0 : le triangle est actif. il est reactive. +c on lui attribue la valeur moyenne sur les deux +c anciens fils. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + if ( typint.eq.0 ) then + do 2310 , nrofon = 1 , nbfonc + vafott(nrofon,trcnp1) = + > unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 2310 continue + else + do 2311 , nrofon = 1 , nbfonc + vafott(nrofon,trcnp1) = + > vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 2311 continue + endif +cgn write(31,91020) trcnp1 +cgn write(ulsort,91020) f1cn,f2cn,-1,trcnp1 +c +c doc.1/2/3.1/2/3. ===> etanp1 = etan : le triangle est decoupe en deux +c selon le meme decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation, +c puis reproduit a la creation du maillage car les +c triangles autour n'ont pas change entre les deux +c iterations. +c le fils prend la valeur de la fonction sur l'ancien +c fils qui etait au meme endroit. comme la procedure de +c numerotation est la meme (voir cmcdtr), le premier fils +c est toujours le meme, le second egalement. on prendra +c alors la valeur sur le fils de rang identique a +c l'iteration n. +c . . +c ... ... +c . . . . . . +c . . . . . . +c . . . ===> . . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.eq.etan ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 232 , nrofon = 1 , nbfonc + vafott(nrofon,f1cp) = vafoen(nrofon,prfcan(f1cn)) + vafott(nrofon,f2cp) = vafoen(nrofon,prfcan(f2cn)) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 232 continue +cgn write(32,91020) f1cp,f2cp +cgn write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp +c +c doc.1/2/3.perm(1/2/3). ===> etanp1 = 1, 2 ou 3 et different de etan : +c le triangle est encore decoupe en deux +c mais par un autre decoupage. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a du deraffinement dans la zone qui induisait le decoupage +c de conformite et raffinement sur une autre zone. +c on donne la valeur moyenne de la fonction sur les deux +c anciens fils a chaque nouveau fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 233 , nrofon = 1 , nbfonc + daux = unsde * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 233 continue +cgn write(33,91020) f1cp,f2cp +cgn write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp +c +c doc.1/2/3.4/6/7/8. ===> etanp1 = 4, 6, 7 ou 8 : le triangle est +c decoupe en quatre. +c c'est ce qui se passe quand un decoupage de conformite +c est supprime au debut des algorithmes d'adaptation. il y +c a ensuite raffinement du triangle. qui plus est, par suite +c de la regle des ecarts de niveau, on peut avoir induit +c un decoupage de conformite sur l'un des fils. +c remarque : c'est toujours un des fils du cote qui etait +c decoupe qui subit le decoupage, et c'est toujours par +c une subdivision du dit cote. +c +c . pour le triangle central et le triangle dans le coin +c oppose a l'arete initialement decoupee, on attribue la +c valeur moyenne de la fonction sur les deux anciens fils. +c . pour les deux autres triangles, on repere dans lequel +c des deux fils ils se trouvent. si un de ces triangles est +c decoupe, c'est en 2 et par la meme arete que le triangle +c courant ; on affecte la valeur du fils du maillage n +c a ces deux fils. si un des triangles est actif, on lui +c attribue la valeur. +c +c . on pose i, j et k comme etant les numeros locaux des +c aretes du triangle courant. +c si etan vaut i, c'est que la i-eme arete du triangle +c etait coupee. les numerotations des 2 fils sont obtenues +c par la fonction nutrde : a = nutrde(i,j), b = nutrde(i,k) +c les numerotations des 4 fils sont +0, +i, +j et +k. +c on voit donc que : +c . les fils +O et +i doivent recevoir la moyenne +c . le fils +k, ou ses fils, doit recevoir la valeur +c de +nutrde(i,j) +c . le fils +j, ou ses fils, doit recevoir la valeur +c de +nutrde(i,k) +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . . . +c . +a . +b . . .+0 . . +c . . . . +k . . +j . +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . ... +c . +a . +b . . .+0 . . . +c . . . . +k . .+j.+j. +c ................. ................. +c i i +c +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . ... ... +c . +a . +b . . . .+0 . . . +c . . . .+k.+k. .+j.+j. +c ................. ................. +c i i +c +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +c +c ==> les deux triangles central et opposee +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+etan) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + if ( typint.eq.0 ) then + daux1 = unsde + else + daux1 = unsqu + endif + do 2341 , nrofon = 1 , nbfonc + daux = daux1 * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)) + 2341 continue +cgn write(34,91020) f1cp,f2cp +cgn write(ulsort,91020) f1cn,f2cn,-1,f1cp,f2cp +c +c ==> le triangle d'un des cotes +c + iaux = prfcan(ntreca(f1hn+nutrde(etan,per1a3( 1,etan)))) + fihp = f1hp+per1a3(-1,etan) + if ( mod(hettri(fihp),10).eq.0 ) then + f3cp = ntrsca(fihp) + prfcap(f3cp) = 1 + if ( typint.eq.0 ) then + do 23420 , nrofon = 1 , nbfonc + vafott(nrofon,f3cp) = vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23420 continue + else + do 23421 , nrofon = 1 , nbfonc + vafott(nrofon,f3cp) = unsde * vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23421 continue + endif +cgn write(35,91020) f3cp +cgn write(ulsort,91020) f1hn+nutrde(etan,per1a3( 1,etan)),-1,f3cp + elseif ( mod(hettri(fihp),10).eq.etan ) then + f1fhp = filtri(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + if ( typint.eq.0 ) then + do 23430 , nrofon = 1 , nbfonc + vafott(nrofon,f1fcp) = vafoen(nrofon,iaux) + vafott(nrofon,f2fcp) = vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23430 continue + else + do 23431 , nrofon = 1 , nbfonc + vafott(nrofon,f1fcp) = unsqu * vafoen(nrofon,iaux) + vafott(nrofon,f2fcp) = unsqu * vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23431 continue + endif +cgn write(36,91020) f1fcp,f2fcp +cgn write(ulsort,91020) f1hn+nutrde(etan,per1a3( 1,etan)),-1, +cgn > f1fcp,f2fcp + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hettri(fihp) + endif +c +c ==> le triangle de l'autre cote +c + iaux = prfcan(ntreca(f1hn+nutrde(etan,per1a3(-1,etan)))) + fihp = f1hp+per1a3( 1,etan) + if ( mod(hettri(fihp),10).eq.0 ) then + f3cp = ntrsca(fihp) + prfcap(f3cp) = 1 + if ( typint.eq.0 ) then + do 23440 , nrofon = 1 , nbfonc + vafott(nrofon,f3cp) = vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23440 continue + else + do 23441 , nrofon = 1 , nbfonc + vafott(nrofon,f3cp) = unsde * vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23441 continue + endif +cgn write(37,91020) f3cp +cgn write(ulsort,91020) f1hn+nutrde(etan,per1a3(-1,etan)),-1,f3cp + elseif ( mod(hettri(fihp),10).eq.etan ) then + f1fhp = filtri(fihp) + f1fcp = ntrsca(f1fhp) + f2fcp = ntrsca(f1fhp+1) + prfcap(f1fcp) = 1 + prfcap(f2fcp) = 1 + if ( typint.eq.0 ) then + do 23450 , nrofon = 1 , nbfonc + vafott(nrofon,f1fcp) = vafoen(nrofon,iaux) + vafott(nrofon,f2fcp) = vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23450 continue + else + do 23451 , nrofon = 1 , nbfonc + vafott(nrofon,f1fcp) = unsqu * vafoen(nrofon,iaux) + vafott(nrofon,f2fcp) = unsqu * vafoen(nrofon,iaux) +cgn write(ulsort,92010) vafoen(nrofon,iaux) +23451 continue + endif +cgn write(38,91020) f1fcp,f2fcp +cgn write(ulsort,91020) f1hn+nutrde(etan,per1a3(-1,etan)),-1, +cgn > f1fcp,f2fcp + else + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', fihp + write (ulsort,texte(langue,5)) 'n+1', hettri(fihp) + endif +c +c doc.1/2/3.erreur. ==> aucun autre etat sur le triangle courant +c n'est possible +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 +c + endif +c + endif +c +c======================================================================= +c doc.4. ==> le triangle etait coupe en 4 : +c======================================================================= +c + elseif ( etan.eq.4 .or. + > etan.eq.6 .or. etan.eq.7 .or. etan.eq.8 ) then +c +cgn print *,'le triangle etait coupe en 4' +c on repere les numeros dans le calcul pour ses quatre fils +c a l'iteration n +c + f1hn = anfitr(trhn) + f1cn = ntreca(f1hn) + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) + f4cn = ntreca(f1hn+3) +cgn print *,'Les 4 fils :' +cgn print 1790,f1cn,prfcan(f1cn) +cgn print 1790,f2cn,prfcan(f2cn) +cgn print 1790,f3cn,prfcan(f3cn) +cgn print 1790,f4cn,prfcan(f4cn) +c + if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and. + > prfcan(f3cn).gt.0 .and. prfcan(f4cn).gt.0 ) then +c +c doc.4.0. ===> etanp1 = 0 : le triangle est actif ; il est reactive. +c on lui attribue la valeur moyenne sur les quatre anciens +c fils. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c . . . . +c . . . . +c . . . . +c ......... ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +c + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 +c + do 241 , nrofon = 1 , nbfonc + vafott(nrofon,trcnp1) = + > unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)), +cgn > vafoen(nrofon,prfcan(f3cn)), +cgn > vafoen(nrofon,prfcan(f4cn)) + 241 continue +cgn write (41,91020) trcnp1 +cgn write (ulsort,91020) f1cn,f2cn,f3cn,f4cn,-1,trcnp1 +c +c doc.4.1/2/3. ===> etanp1 = 1, 2 ou 3 : le triangle est decoupe en +c deux. +c on attribue la valeur moyenne sur les quatre anciens +c fils a chacune des deux nouveaux fils. +c remarque : on pourrait certainement faire mieux, avec des +c moyennes ponderees en fonction du recouvrement +c des anciens et nouveaux fils. c'est trop +c complique pour que cela vaille le coup. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) +cgn print *,f1hp,f1cp,f2cp + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + do 242 , nrofon = 1 , nbfonc + daux = unsqu * ( vafoen(nrofon,prfcan(f1cn)) + > + vafoen(nrofon,prfcan(f2cn)) + > + vafoen(nrofon,prfcan(f3cn)) + > + vafoen(nrofon,prfcan(f4cn)) ) + vafott(nrofon,f1cp) = daux + vafott(nrofon,f2cp) = daux +cgn write(ulsort,92010) vafoen(nrofon,prfcan(f1cn)), +cgn > vafoen(nrofon,prfcan(f2cn)), +cgn > vafoen(nrofon,prfcan(f3cn)), +cgn > vafoen(nrofon,prfcan(f4cn)) + 242 continue +cgn write(42,91020) f1cp,f2cp +cgn write(ulsort,91020) f1cn,f2cn,f3cn,f4cn,-1, +cgn > f1cp,f2cp +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c======================================================================= +c doc.4. ==> le triangle n'existait pas +c======================================================================= +c + else +c +cgn print *,'le triangle n''existait pas' + write (ulsort,texte(langue,6)) +c +#endif +c +c======================================================================= +c + endif +c + 20 continue +c + endif +c +cgn write(ulsort,91020)(prfcap(iaux),iaux=1,nbtrto) +cgn print *,'nbfonc = ',nbfonc +cgn etan = 1 +cgn etanp1 = nbtrto +cgn do 30001 , iaux=etan,etanp1 +cgn if ( mod(hettri(iaux),10).eq.0 ) then +cgn print 11790, +cgn > ntrsca(iaux),prfcap(ntrsca(iaux)),vafott(1,ntrsca(iaux)) +cgn endif +cgn30001 continue +cgn11790 format(i4,' : ',i2,' / ',g15.7) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AP_Conversion/pcstr2_1.h b/src/tool/AP_Conversion/pcstr2_1.h new file mode 100644 index 00000000..2d7291a8 --- /dev/null +++ b/src/tool/AP_Conversion/pcstr2_1.h @@ -0,0 +1,171 @@ +c . . +c . . ... +c . . . . . +c . . . . . +c . . ===> . . . +c . . . . . +c . . . . . +c . . . . . +c ................. ................. +c +c Pour un decoupage selon l'arete numero 1 : +c + elseif ( etanp1.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_1 etanp1=1' +#endif +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2221 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prtrcn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prtrcn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*(vafoen(nrofon,q2,prtrcn)+vafoen(nrofon,q3,prtrcn))+ + > unsde*(vafoen(nrofon,q4,prtrcn)+vafoen(nrofon,q6,prtrcn))+ + > unsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*vafoen(nrofon,q2,prtrcn)+ + > trshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f1cp) = vafoen(nrofon,q6,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prtrcn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f2cp) = + > trshu*vafoen(nrofon,q2,prtrcn)- + > unshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c + 2221 continue +c +c Pour un decoupage selon l'arete numero 2 : +c + elseif ( etanp1.eq.2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_1 etanp1=2' +#endif +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2222 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prtrcn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prtrcn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*(vafoen(nrofon,q1,prtrcn)+vafoen(nrofon,q3,prtrcn))+ + > unsde*(vafoen(nrofon,q4,prtrcn)+vafoen(nrofon,q5,prtrcn))+ + > unsqu*vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f1cp) = + > -unshu*vafoen(nrofon,q1,prtrcn)+ + > trshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q6,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prtrcn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = + > trshu*vafoen(nrofon,q1,prtrcn)- + > unshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q6,prtrcn) +c + 2222 continue +c +c Pour un decoupage selon l'arete numero 3 : +c + elseif ( etanp1.eq.3 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_1 etanp1=3' +#endif +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c + do 2223 , nrofon = 1 , nbfonc +c +c Pour le fils aine : +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prtrcn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prtrcn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*vafoen(nrofon,q1,prtrcn)+ + > trshu*vafoen(nrofon,q2,prtrcn)+ + > trsqu*vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f1cp) = + > -unshu*(vafoen(nrofon,q1,prtrcn)+vafoen(nrofon,q2,prtrcn))+ + > unsde*(vafoen(nrofon,q5,prtrcn)+vafoen(nrofon,q6,prtrcn))+ + > unsqu*vafoen(nrofon,q4,prtrcn) +c +c Pour le triangle fils NF+1 : +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prtrcn) +c + vafott(nrofon,q4,f2cp) = + > trshu*vafoen(nrofon,q1,prtrcn)- + > unshu*vafoen(nrofon,q2,prtrcn)+ + > trsqu*vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = vafoen(nrofon,q6,prtrcn) +c + 2223 continue diff --git a/src/tool/AP_Conversion/pcstr2_2.h b/src/tool/AP_Conversion/pcstr2_2.h new file mode 100644 index 00000000..0db4a933 --- /dev/null +++ b/src/tool/AP_Conversion/pcstr2_2.h @@ -0,0 +1,127 @@ +c . . +c . . . . +c . . . . +c . . . . +c . . ===> ......... +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_2' + write (ulsort,*) 'avec etanp1=',etanp1 +#endif +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + prfcap(f3cp) = 1 + prfcap(f4cp) = 1 +c + do 223 , nrofon = 1 , nbfonc +c +c Pour le fils aine (centre) +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*(vafoen(nrofon,q1,prtrcn)+vafoen(nrofon,q2,prtrcn))+ + > unsde*(vafoen(nrofon,q5,prtrcn)+vafoen(nrofon,q6,prtrcn))+ + > unsqu*vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*(vafoen(nrofon,q2,prtrcn)+vafoen(nrofon,q3,prtrcn))+ + > unsde*(vafoen(nrofon,q4,prtrcn)+vafoen(nrofon,q6,prtrcn))+ + > unsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f1cp) = + > -unshu*(vafoen(nrofon,q1,prtrcn)+vafoen(nrofon,q3,prtrcn))+ + > unsde*(vafoen(nrofon,q4,prtrcn)+vafoen(nrofon,q5,prtrcn))+ + > unsqu*vafoen(nrofon,q6,prtrcn) +c +cgn print 1788,f1cp, +cgn > (vafott(nrofon,iaux,f1cp), iaux = 1 , nbnoel) +c +c Pour le triangle fils f1hp+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prtrcn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q4,f2cp) = + > trshu*vafoen(nrofon,q1,prtrcn)- + > unshu*vafoen(nrofon,q2,prtrcn)+ + > trsqu*vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q5,f1cp) +c + vafott(nrofon,q6,f2cp) = + > trshu*vafoen(nrofon,q1,prtrcn)- + > unshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q6,prtrcn) +cgn print 1788,f2cp, +cgn > (vafott(nrofon,iaux,f2cp), iaux = 1 , nbnoel) +c +c Pour le triangle fils f1hp+2 +c + vafott(nrofon,q1,f3cp) = vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q2,f3cp) = vafoen(nrofon,q2,prtrcn) +c + vafott(nrofon,q3,f3cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q4,f3cp) = + > -unshu*vafoen(nrofon,q1,prtrcn)+ + > trshu*vafoen(nrofon,q2,prtrcn)+ + > trsqu*vafoen(nrofon,q4,prtrcn) +c + vafott(nrofon,q5,f3cp) = + > trshu*vafoen(nrofon,q2,prtrcn)- + > unshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f3cp) = vafott(nrofon,q6,f1cp) +cgn print 1788,f3cp, +cgn > (vafott(nrofon,iaux,f3cp), iaux = 1 , nbnoel) +c +c Pour le triangle fils f1hp+3 +c + vafott(nrofon,q1,f4cp) = vafoen(nrofon,q6,prtrcn) +c + vafott(nrofon,q2,f4cp) = vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q3,f4cp) = vafoen(nrofon,q3,prtrcn) +c + vafott(nrofon,q4,f4cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q5,f4cp) = + > -unshu*vafoen(nrofon,q2,prtrcn)+ + > trshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q5,prtrcn) +c + vafott(nrofon,q6,f4cp) = + > -unshu*vafoen(nrofon,q1,prtrcn)+ + > trshu*vafoen(nrofon,q3,prtrcn)+ + > trsqu*vafoen(nrofon,q6,prtrcn) +cgn print 1788,f4cp, +cgn > (vafott(nrofon,iaux,f4cp), iaux = 1 , nbnoel) +c + 223 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', 'pcstr2_2' +#endif diff --git a/src/tool/AP_Conversion/pcstr2_3.h b/src/tool/AP_Conversion/pcstr2_3.h new file mode 100644 index 00000000..1e557f4c --- /dev/null +++ b/src/tool/AP_Conversion/pcstr2_3.h @@ -0,0 +1,734 @@ +c . . +c ... . . +c . . . . . +c . . . . +i . +c j . . . k ===> j ......... k +c . . . . . . . +c . +a . +b . . .+0 . . +c . . . . +k . . +j . +c ................. ................. +c i i +c + elseif ( etanp1.eq.4 .or. + > etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_3' + write (ulsort,*) 'etanp1 = ',etanp1 + write (ulsort,*) 'etan = ',etan +#endif + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + f3cp = ntrsca(f1hp+2) + f4cp = ntrsca(f1hp+3) + prfcap(f1cp) = 1 +cgn print *,'triangle fils NF = ',f1hp +cgn print *,'triangle fils en calcul 1 = ',f1cp +cgn print *,'triangle fils en calcul 2 = ',f2cp +cgn print *,'triangle fils en calcul 3 = ',f3cp +cgn print *,'triangle fils en calcul 4 = ',f4cp + +c Decoupage en 4 d'un triangle predecoupe en 2 par l'arete a1 +c + if ( etan.eq.1 ) then +c + do 23411 , nrofon = 1 , nbfonc +c +c Pour le fils aine (centre) +c + vafott(nrofon,q1,f1cp) = + > unsde*(vafoen(nrofon,q2,prf1cn)+vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q3,prf1cn))+ + > unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q5,prf1cn))+ + > unsqu*vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q5,f1cp) = + > unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q6,prf2cn)) +c + vafott(nrofon,q6,f1cp) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+ + > vafoen(nrofon,q2,prf2cn))+ + > unsde*(vafoen(nrofon,q5,prf2cn)+ + > vafoen(nrofon,q6,prf2cn))+ + > unsqu*vafoen(nrofon,q4,prf2cn) +c +c Pour le triangle fils NF+1 +c + prfcap(f2cp) = 1 +c + vafott(nrofon,q1,f2cp) = + > unsde*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q1,prf2cn)) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q4,f2cp) = + > trshu*vafoen(nrofon,q1,prf2cn)- + > unshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q5,f1cp) +c + vafott(nrofon,q6,f2cp) = + > trshu*vafoen(nrofon,q1,prf1cn)- + > unshu*vafoen(nrofon,q3,prf1cn)+ + > trsqu*vafoen(nrofon,q6,prf1cn) +c +c Pour le triangle fils NF+2 (eventuellement redecoupe en 2) +c + if ( mod(hettri(f1hp+2),10).eq.0 ) then +c + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,f3cp) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,f3cp) = vafoen(nrofon,q3,prf2cn) +c + vafott(nrofon,q4,f3cp) = + > -unshu*vafoen(nrofon,q1,prf2cn)+ + > trshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f3cp) = vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q6,f3cp) = vafott(nrofon,q6,f1cp) +c + elseif ( mod(hettri(f1hp+2),10).eq.etan ) then +c + fihp = filtri(f1hp+2) + g2 = ntrsca(fihp) + g1 = ntrsca(fihp+1) + prfcap(g1) = 1 + prfcap(g2) = 1 +cgn print *,'triangle petit-fils en calcul g1 = ',g1 +cgn print *,'triangle petit-fils en calcul g2 = ',g2 +c +c Pour le fils G1 +c + vafott(nrofon,q1,g1) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,g1) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,g1) = vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q4,g1) = + > trshu*vafoen(nrofon,q2,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn) + > +trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,g1) = + > trshu*vafoen(nrofon,q2,prf2cn) + > -unshu*vafoen(nrofon,q3,prf2cn) + > +trsqu*vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q6,g1) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+vafoen(nrofon,q3,prf2cn)) + > +unsde*(vafoen(nrofon,q4,prf2cn)+vafoen(nrofon,q5,prf2cn)) + > +unsqu*vafoen(nrofon,q6,prf2cn) +c +c Pour le fils G2 +c + vafott(nrofon,q1,g2) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,g2) = vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q3,g2) = vafoen(nrofon,q3,prf2cn) +c + vafott(nrofon,q4,g2) = vafott(nrofon,q6,g1) +c + vafott(nrofon,q5,g2) = + > trshu*vafoen(nrofon,q3,prf2cn) + > -unshu*vafoen(nrofon,q2,prf2cn) + > +trsqu*vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q6,g2) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+vafoen(nrofon,q2,prf2cn)) + > +unsde*(vafoen(nrofon,q5,prf2cn)+vafoen(nrofon,q6,prf2cn)) + > +unsqu*vafoen(nrofon,q4,prf2cn) +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+2 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+2) +c + endif +c +c Pour le triangle fils NF+3 (eventuellement redecoupe en 2) +c +cgn print *,'triangle fils NF+3 = ',f1hp+3 +cgn print *,' Etat = ',hettri(f1hp+3) + if ( mod(hettri(f1hp+3),10).eq.0 ) then +c + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q2,f4cp) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,f4cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f4cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q5,f4cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f4cp) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q1,prf1cn)+ + > trsqu*vafoen(nrofon,q6,prf1cn) +c + elseif ( mod(hettri(f1hp+3),10).eq.etan ) then +c + fihp = filtri(f1hp+3) + d2 = ntrsca(fihp) + d1 = ntrsca(fihp+1) + prfcap(d1) = 1 + prfcap(d2) = 1 +cgn print *,' Fils HOMARD = ',fihp, ' et ',fihp+1 +cgn print *,' Fils Calcul = ',d2, ' et ',d1 +cgn print *,' q1, q2, q3, q4, q5, q6 = ',q1,q2,q3,q4,q5,q6 +c +c Pour le fils D1 +c + vafott(nrofon,q1,d1) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q2,d1) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,d1) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,d1) = + > -unshu*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q3,prf1cn)) + > +unsde*(vafoen(nrofon,q4,prf1cn)+vafoen(nrofon,q5,prf1cn)) + > +unsqu*vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q5,d1) = + > trshu*vafoen(nrofon,q2,prf1cn) + > -unshu*vafoen(nrofon,q3,prf1cn) + > +trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,d1) = + > -unshu*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q2,prf1cn)) + > +unsde*(vafoen(nrofon,q5,prf1cn)+vafoen(nrofon,q6,prf1cn)) + > +unsqu*vafoen(nrofon,q4,prf1cn) +cgn print *,'vafott(nrofon,',q1,',',d1,')=',vafott(nrofon,q1,d1) +cgn print *,'vafott(nrofon,',q2,',',d1,')=',vafott(nrofon,q2,d1) +cgn print *,'vafott(nrofon,',q3,',',d1,')=',vafott(nrofon,q3,d1) +cgn print *,'vafott(nrofon,',q4,',',d1,')=',vafott(nrofon,q4,d1) +cgn print *,'vafott(nrofon,',q5,',',d1,')=',vafott(nrofon,q5,d1) +cgn print *,'vafott(nrofon,',q6,',',d1,')=',vafott(nrofon,q6,d1) +c +c Pour le fils D2 +c + vafott(nrofon,q1,d2) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q2,d2) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,d2) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,d2) = vafott(nrofon,q6,d1) +c + vafott(nrofon,q5,d2) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn) + > +trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,d2) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q1,prf1cn) + > +trsqu*vafoen(nrofon,q6,prf1cn) +cgn print *,'vafott(nrofon,',q1,',',d2,')=',vafott(nrofon,q1,d2) +cgn print *,'vafott(nrofon,',q2,',',d2,')=',vafott(nrofon,q2,d2) +cgn print *,'vafott(nrofon,',q3,',',d2,')=',vafott(nrofon,q3,d2) +cgn print *,'vafott(nrofon,',q4,',',d2,')=',vafott(nrofon,q4,d2) +cgn print *,'vafott(nrofon,',q5,',',d2,')=',vafott(nrofon,q5,d2) +cgn print *,'vafott(nrofon,',q6,',',d2,')=',vafott(nrofon,q6,d2) +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+3 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+3) +c + endif +c +23411 continue +c + elseif ( etan.eq.2 ) then +c + do 23412 , nrofon = 1 , nbfonc +c +c Decoupage en 4 d'un triangle predecoupe en 2 par l'arete a2 +c +c Pour le fils aine NF (centre) +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q2,f1cp) = + > unsde*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q4,f1cp) = + > -unshu*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q3,prf1cn))+ + > unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q6,prf1cn))+ + > unsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q5,f1cp) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+ + > vafoen(nrofon,q2,prf2cn))+ + > unsde*(vafoen(nrofon,q5,prf2cn)+ + > vafoen(nrofon,q6,prf2cn))+ + > unsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q6,f1cp) = + > unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c +c Pour le triangle fils NF+1 (eventuellement redecoupe en 2) +c + if ( mod(hettri(f1hp+1),10).eq.0 ) then +c + prfcap(f2cp) = 1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf2cn) +c + vafott(nrofon,q4,f2cp) = + > trshu*vafoen(nrofon,q1,prf2cn)- + > unshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q5,f1cp) +c + vafott(nrofon,q6,f2cp) = vafoen(nrofon,q6,prf2cn) +c + elseif ( mod(hettri(f1hp+1),10).eq.etan ) then +c + fihp = filtri(f1hp+1) + d2 = ntrsca(fihp+1) + d1 = ntrsca(fihp) + prfcap(d1) = 1 + prfcap(d2) = 1 +c +c +c Pour le fils D1 +c + vafott(nrofon,q1,d1) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q2,d1) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,d1) = vafoen(nrofon,q3,prf2cn) +c + vafott(nrofon,q4,d1) = + > -unshu*(vafoen(nrofon,q2,prf2cn)+vafoen(nrofon,q3,prf2cn)) + > +unsde*(vafoen(nrofon,q4,prf2cn)+vafoen(nrofon,q6,prf2cn)) + > +unsqu*vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q5,d1) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+vafoen(nrofon,q2,prf2cn)) + > +unsde*(vafoen(nrofon,q5,prf2cn)+vafoen(nrofon,q6,prf2cn)) + > +unsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q6,d1) = + > trshu*vafoen(nrofon,q3,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn) + > +trsqu*vafoen(nrofon,q6,prf2cn) +c +c Pour le fils D2 +c + vafott(nrofon,q1,d2) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,d2) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,d2) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q4,d2) = + > trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q2,prf2cn) + > +trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,d2) = vafott(nrofon,q4,d1) +c + vafott(nrofon,q6,d2) = + > trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q3,prf2cn) + > +trsqu*vafoen(nrofon,q6,prf2cn) +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+1 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+1) +c + endif + +c Pour le triangle fils NF+2 +c + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,f3cp) = + > unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q2,prf2cn)) +c + vafott(nrofon,q3,f3cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,f3cp) = + > -unshu*vafoen(nrofon,q1,prf2cn)+ + > trshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f3cp) = + > -unshu*vafoen(nrofon,q3,prf1cn)+ + > trshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f3cp) = vafott(nrofon,q6,f1cp) +c +c Pour le triangle fils NF+3 (eventuellement redecoupe en 2) +c + if ( mod(hettri(f1hp+3),10).eq.0 ) then +c + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = vafoen(nrofon,q1,prf1cn) +c + vafott(nrofon,q2,f4cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,f4cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f4cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q5,f4cp) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f4cp) = vafoen(nrofon,q6,prf1cn) +c + elseif ( mod(hettri(f1hp+3),10).eq.etan ) then +c + fihp = filtri(f1hp+3) + g2 = ntrsca(fihp+1) + g1 = ntrsca(fihp) + prfcap(g1) = 1 + prfcap(g2) = 1 +c +c Pour le fils G1 +c + vafott(nrofon,q1,g1) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q2,g1) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,g1) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,g1) = + > -unshu*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q2,prf1cn)) + > +unsde*(vafoen(nrofon,q5,prf1cn)+vafoen(nrofon,q6,prf1cn)) + > +unsqu*vafoen(nrofon,q4,prf1cn) +c + vafott(nrofon,q5,g1) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn) + > +trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,g1) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q1,prf1cn) + > +trsqu*vafoen(nrofon,q6,prf1cn) +c +c Pour le fils G2 +c + vafott(nrofon,q1,g2) = vafoen(nrofon,q1,prf1cn) +c + vafott(nrofon,q2,g2) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,g2) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q4,g2) = + > -unshu*(vafoen(nrofon,q2,prf1cn)+vafoen(nrofon,q3,prf1cn)) + > +unsde*(vafoen(nrofon,q4,prf1cn)+vafoen(nrofon,q6,prf1cn)) + > +unsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q5,g2) = vafott(nrofon,q4,g1) +c + vafott(nrofon,q6,g2) = + > trshu*vafoen(nrofon,q1,prf1cn) + > -unshu*vafoen(nrofon,q3,prf1cn) + > +trsqu*vafoen(nrofon,q6,prf1cn) +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+3 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+3) +c + endif + +23412 continue +c + elseif ( etan.eq.3 ) then +c + do 23413 , nrofon = 1 , nbfonc +c +c +c Decoupage en 4 d'un triangle predecoupe en 2 par l'arete a3 +c +c Pour le fils aine (centre) +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q3,f1cp) = + > unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q2,prf2cn)) +c + vafott(nrofon,q4,f1cp) = + > unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+ + > vafoen(nrofon,q3,prf2cn))+ + > unsde*(vafoen(nrofon,q4,prf2cn)+ + > vafoen(nrofon,q5,prf2cn))+ + > unsqu*vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q6,f1cp) = + > -unshu*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q3,prf1cn))+ + > unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q6,prf1cn))+ + > unsqu*vafoen(nrofon,q5,prf1cn) +c +c Pour le triangle fils NF+1 (eventuellement redecoupe en 2) +cgn print *,'triangle fils NF+1 = ',f1hp+1 +cgn print *,' Etat = ',hettri(f1hp+1) +cgn print *,' q1, q2, q3, q4, q5, q6 = ',q1,q2,q3,q4,q5,q6 +c + if ( mod(hettri(f1hp+1),10).eq.0 ) then +c + prfcap(f2cp) = 1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q5,f1cp) +c + vafott(nrofon,q6,f2cp) = + > -unshu*vafoen(nrofon,q3,prf2cn)+ + > trshu*vafoen(nrofon,q1,prf2cn)+ + > trsqu*vafoen(nrofon,q6,prf2cn) +c + elseif ( mod(hettri(f1hp+1),10).eq.etan ) then +c + fihp = filtri(f1hp+1) + g2 = ntrsca(fihp) + g1 = ntrsca(fihp+1) + prfcap(g1) = 1 + prfcap(g2) = 1 +cgn print *,' --> fils g1 = ',g1 +cgn print *,' --> fils g2 = ',g2 +c +c Pour le fils G1 +c + vafott(nrofon,q1,g1) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,g1) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,g1) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q4,g1) = + > trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q2,prf2cn) + > +trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,g1) = + > -unshu*(vafoen(nrofon,q2,prf2cn)+vafoen(nrofon,q3,prf2cn)) + > +unsde*(vafoen(nrofon,q4,prf2cn)+vafoen(nrofon,q6,prf2cn)) + > +unsqu*vafoen(nrofon,q5,prf2cn) +c + vafott(nrofon,q6,g1) = + > trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q3,prf2cn) + > +trsqu*vafoen(nrofon,q6,prf2cn) +cgn print *,'vafott(nrofon,',q1,',',g1,')=',vafott(nrofon,q1,g1) +cgn print *,'vafott(nrofon,',q2,',',g1,')=',vafott(nrofon,q2,g1) +cgn print *,'vafott(nrofon,',q3,',',g1,')=',vafott(nrofon,q3,g1) +cgn print *,'vafott(nrofon,',q4,',',g1,')=',vafott(nrofon,q4,g1) +cgn print *,'vafott(nrofon,',q5,',',g1,')=',vafott(nrofon,q5,g1) +cgn print *,'vafott(nrofon,',q6,',',g1,')=',vafott(nrofon,q6,g1) +c +c Pour le fils G2 +c + vafott(nrofon,q1,g2) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,g2) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,g2) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q4,g2) = + > trshu*vafoen(nrofon,q2,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn) + > +trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,g2) = + > -unshu*(vafoen(nrofon,q1,prf2cn)+vafoen(nrofon,q3,prf2cn)) + > +unsde*(vafoen(nrofon,q4,prf2cn)+vafoen(nrofon,q5,prf2cn)) + > +unsqu*vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q6,g2) = vafott(nrofon,q5,g1) +cgn print *,'vafott(nrofon,',q1,',',g2,')=',vafott(nrofon,q1,g2) +cgn print *,'vafott(nrofon,',q2,',',g2,')=',vafott(nrofon,q2,g2) +cgn print *,'vafott(nrofon,',q3,',',g2,')=',vafott(nrofon,q3,g2) +cgn print *,'vafott(nrofon,',q4,',',g2,')=',vafott(nrofon,q4,g2) +cgn print *,'vafott(nrofon,',q5,',',g2,')=',vafott(nrofon,q5,g2) +cgn print *,'vafott(nrofon,',q6,',',g2,')=',vafott(nrofon,q6,g2) +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+1 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+1) +c + endif +c +c Pour le triangle fils NF+2 (eventuellement redecoupe en 2) +cgn print *,'triangle fils NF+2 = ',f1hp+2 +cgn print *,' Etat = ',hettri(f1hp+2) +c + if ( mod(hettri(f1hp+2),10).eq.0 ) then +c + prfcap(f3cp) = 1 +c + vafott(nrofon,q1,f3cp) = vafoen(nrofon,q1,prf1cn) +c + vafott(nrofon,q2,f3cp) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,f3cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,f3cp) = vafoen(nrofon,q4,prf1cn) + + vafott(nrofon,q5,f3cp) = + > -unshu*vafoen(nrofon,q3,prf1cn)+ + > trshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) + + vafott(nrofon,q6,f3cp) = vafott(nrofon,q6,f1cp) +c + elseif ( mod(hettri(f1hp+2),10).eq.etan ) then +c + fihp = filtri(f1hp+2) + d2 = ntrsca(fihp) + d1 = ntrsca(fihp+1) + prfcap(d1) = 1 + prfcap(d2) = 1 +c +c Pour le fils D1 +c + vafott(nrofon,q1,d1) = vafoen(nrofon,q1,prf1cn) +c + vafott(nrofon,q2,d1) = vafoen(nrofon,q4,prf1cn) +c + vafott(nrofon,q3,d1) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,d1) = + > trshu*vafoen(nrofon,q1,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn) + > +trsqu*vafoen(nrofon,q4,prf1cn) +c + vafott(nrofon,q5,d1) = + > -unshu*(vafoen(nrofon,q1,prf1cn)+vafoen(nrofon,q3,prf1cn)) + > +unsde*(vafoen(nrofon,q4,prf1cn)+vafoen(nrofon,q5,prf1cn)) + > +unsqu*vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q6,d1) = + > -unshu*(vafoen(nrofon,q2,prf1cn)+vafoen(nrofon,q3,prf1cn)) + > +unsde*(vafoen(nrofon,q4,prf1cn)+vafoen(nrofon,q6,prf1cn)) + > +unsqu*vafoen(nrofon,q5,prf1cn) +c +c Pour le fils D2 +c + vafott(nrofon,q1,d2) = vafoen(nrofon,q4,prf1cn) +c + vafott(nrofon,q2,d2) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,d2) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,d2) = + > trshu*vafoen(nrofon,q2,prf1cn) + > -unshu*vafoen(nrofon,q1,prf1cn) + > +trsqu*vafoen(nrofon,q4,prf1cn) +c + vafott(nrofon,q5,d2) = + > trshu*vafoen(nrofon,q2,prf1cn) + > -unshu*vafoen(nrofon,q3,prf1cn) + > +trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,d2) = vafott(nrofon,q5,d1) +c +c + else +c + codret = codret + 1 + write (ulsort,texte(langue,4)) 'n+1', f1hp+2 + write (ulsort,texte(langue,5)) 'n+1', hettri(f1hp+2) +c + endif +c +c Pour le triangle fils NF+3 +c + prfcap(f4cp) = 1 +c + vafott(nrofon,q1,f4cp) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q2,f4cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,f4cp) = + > unsde*(vafoen(nrofon,q3,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q4,f4cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q5,f4cp) = + > trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f4cp) = + > trshu*vafoen(nrofon,q3,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn)+ + > trsqu*vafoen(nrofon,q6,prf2cn) +c +23413 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', 'pcstr2_3' +#endif diff --git a/src/tool/AP_Conversion/pcstr2_4.h b/src/tool/AP_Conversion/pcstr2_4.h new file mode 100644 index 00000000..856f5d5a --- /dev/null +++ b/src/tool/AP_Conversion/pcstr2_4.h @@ -0,0 +1,288 @@ +c . . +c ... . . +c . . . . . +c . . . . . +c . . . ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c +c Pour un decoupage selon l'arete numero 1 : +c + elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_4' + write (ulsort,*) 'etanp1=',etanp1 +#endif +c + f1hp = filtri(trhnp1) + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 +c +c decoupage en 2 par l'arete numero 2 d'un triangle predecoupe en a1 +c + if ( etan.eq.1 .and. etanp1.eq.2) then +c + do 23311 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q6,prf2cn)) +c + vafott(nrofon,q5,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q6,f1cp) =-unshu*vafoen(nrofon,q1,prf1cn)+ + > trshu*vafoen(nrofon,q3,prf1cn)+ + > trsqu*vafoen(nrofon,q6,prf1cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q1,prf2cn)) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prf1cn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) =-unshu*vafoen(nrofon,q3,prf1cn)+ + > trshu*vafoen(nrofon,q1,prf1cn)+ + > trsqu*vafoen(nrofon,q6,prf1cn) +c +23311 continue +c +c decoupage en 2 par l'arete numero 3 d'un triangle predecoupe en a1 +c + elseif ( etan.eq.1 .and. etanp1.eq.3) then +c + do 23312 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf2cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f1cp) = -unshu*vafoen(nrofon,q1,prf2cn)+ + > trshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q6,prf2cn)+ + > vafoen(nrofon,q4,prf1cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q1,prf2cn)) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f2cp) = trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = vafoen(nrofon,q6,prf1cn) +c +23312 continue +c +c decoupage en 2 par l'arete numero 1 d'un triangle predecoupe en a2 +c + elseif ( etan.eq.2 .and. etanp1.eq.1) then +c + do 23313 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q3,prf2cn)+ + > vafoen(nrofon,q1,prf1cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = unsde*(vafoen(nrofon,q2,prf2cn)+ + > vafoen(nrofon,q2,prf1cn)) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = trshu*vafoen(nrofon,q2,prf2cn) + > -unshu*vafoen(nrofon,q3,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +23313 continue +c +c decoupage en 2 par l'arete numero 3 d'un triangle predecoupe en a2 +c + elseif ( etan.eq.2 .and. etanp1.eq.3) then +c + do 23314 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q2,f1cp) = unsde*(vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q2,prf2cn)) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f1cp) = trshu*vafoen(nrofon,q2,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q5,prf2cn)+ + > vafoen(nrofon,q4,prf1cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q4,f2cp) = trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q2,prf2cn)+ + > trsqu*vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c +23314 continue +c +c decoupage en 2 par l'arete numero 1 d'un triangle predecoupe en a3 +c + elseif ( etan.eq.3 .and. etanp1.eq.1) then +c + + do 23315 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q3,f1cp) = unsde*(vafoen(nrofon,q3,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = trshu*vafoen(nrofon,q3,prf1cn) + > -unshu*vafoen(nrofon,q2,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f1cp) = vafoen(nrofon,q6,prf2cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q4,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q2,prf2cn)) +c + vafott(nrofon,q5,f2cp) = trshu*vafoen(nrofon,q2,prf1cn) + > -unshu*vafoen(nrofon,q3,prf1cn)+ + > trsqu*vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +23315 continue +c +c decoupage en 2 par l'arete numero 2 d'un triangle predecoupe en a3 +c + elseif ( etan.eq.3 .and. etanp1.eq.2) then +c + do 23316 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,f1cp) = unsde*(vafoen(nrofon,q3,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prf1cn) +c + vafott(nrofon,q6,f1cp) = trshu*vafoen(nrofon,q3,prf2cn) + > -unshu*vafoen(nrofon,q1,prf2cn)+ + > trsqu*vafoen(nrofon,q6,prf2cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q6,prf2cn) +c + vafott(nrofon,q4,f2cp) = unsde*(vafoen(nrofon,q1,prf1cn)+ + > vafoen(nrofon,q2,prf2cn)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = trshu*vafoen(nrofon,q1,prf2cn) + > -unshu*vafoen(nrofon,q3,prf2cn)+ + > trsqu*vafoen(nrofon,q6,prf2cn) +c +23316 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', 'pcstr2_4' +#endif diff --git a/src/tool/AP_Conversion/pcstr2_5.h b/src/tool/AP_Conversion/pcstr2_5.h new file mode 100644 index 00000000..ed6e2327 --- /dev/null +++ b/src/tool/AP_Conversion/pcstr2_5.h @@ -0,0 +1,878 @@ +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', 'pcstr2_5' +#endif +c +c on repere le numero dans le calcul pour le fils aine +c a l'iteration n +c + f1hn = anfitr(trhn) + f1hp = filtri(trhnp1) + f1cn = ntreca(f1hn) + prf1cn = prfcan(f1cn) +cgn print 17893, prf1cn +cgn17893 format('prf1cn = ',i8) +c + if ( etanp1.eq.0 ) then + trcnp1 = ntrsca(trhnp1) + prfcap(trcnp1) = 1 + elseif ( etanp1.eq.1 .or. etanp1.eq.2 .or. etanp1.eq.3 ) then + f1cp = ntrsca(f1hp) + f2cp = ntrsca(f1hp+1) +cgn print 17894, f1cp,f2cp +cgn17894 format('f1cp = ',i8,', f2cp = ',i8) + prfcap(f1cp) = 1 + prfcap(f2cp) = 1 + endif +c +c doc.4.0. ===> etanp1 = 0 : le triangle est actif ; il est reactive. +c remarque : cela arrive seulement avec du deraffinement. +c . . +c . . . . +c . . . . +c . . . . +c ......... ===> . . +c . . . . . . +c . . . . . . +c . . . . . . +c ................. ................. +c + if ( etanp1.eq.0 ) then +cgn print *,'Passage par etanp1.eq.0' +c + f2cn = ntreca(f1hn+1) + f3cn = ntreca(f1hn+2) + f4cn = ntreca(f1hn+3) + prf2cn = prfcan(f2cn) + prf3cn = prfcan(f3cn) + prf4cn = prfcan(f4cn) +c + do 241 , nrofon = 1 , nbfonc +c + vafott(nrofon,q1,trcnp1) = vafoen(nrofon,q1,prf2cn) + vafott(nrofon,q2,trcnp1) = vafoen(nrofon,q2,prf3cn) + vafott(nrofon,q3,trcnp1) = vafoen(nrofon,q3,prf4cn) + vafott(nrofon,q4,trcnp1) = + > unstr * ( vafoen(nrofon,q1,prf3cn) + > + vafoen(nrofon,q2,prf2cn) + > + vafoen(nrofon,q3,prf1cn) ) + vafott(nrofon,q5,trcnp1) = + > unstr * ( vafoen(nrofon,q1,prf1cn) + > + vafoen(nrofon,q2,prf4cn) + > + vafoen(nrofon,q3,prf3cn) ) + vafott(nrofon,q6,trcnp1) = + > unstr * ( vafoen(nrofon,q1,prf4cn) + > + vafoen(nrofon,q2,prf1cn) + > + vafoen(nrofon,q3,prf2cn) ) +c + 241 continue +c +c doc.4.1/2/3. ===> etanp1 = 1 : le triangle est decoupe en deux selon +c l'arete 1 +c remarque : il y a 4 cas de figure selon les decoupages +c eventuels des fils a l'iteration n +c remarque : cela arrive seulement avec du +c deraffinnement. +c + elseif ( etanp1.eq.1 ) then +cgn print *,'Passage par etanp1.eq.1' +c + f2cn = ntreca(f1hn+1) + prf2cn = prfcan(f2cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'f1hn+2=',f1hn+2, +cgn > 'mod(anhetr(f1hn+2),10)',mod(anhetr(f1hn+2),10) + if ( mod(anhetr(f1hn+2),10).eq.0 ) then + f3cn = ntreca(f1hn+2) + prf3cn = prfcan(f3cn) + elseif ( mod(anhetr(f1hn+2),10).eq.etanp1 ) then + pf = anfitr(f1hn+2) + g2 = ntreca(pf) + prfg2n = prfcan(g2) + g1 = ntreca(pf+1) + prfg1n = prfcan(g1) + else + codret = codret + 1 + write(ulsort,*) '_5h A codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+3),10)',mod(anhetr(f1hn+3),10) + if ( mod(anhetr(f1hn+3),10).eq.0 ) then + f4cn = ntreca(f1hn+3) + prf4cn = prfcan(f4cn) + elseif ( mod(anhetr(f1hn+3),10).eq.etanp1 ) then + pf = anfitr(f1hn+3) + d2 = ntreca(pf) + prfd2n = prfcan(d2) + d1 = ntreca(pf+1) + prfd1n = prfcan(d1) + else + codret = codret + 1 + write (ulsort,*) '_5h B codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c A1 A1 +c +c + do 24210 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = unstr*vafoen(nrofon,q1,prf1cn) + > +destr*vafoen(nrofon,q2,prf4cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q5,prf1cn) + > +vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prf4cn) +c + vafott(nrofon,q6,f1cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn) + > +vafoen(nrofon,q3,prf2cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q3,prf3cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q2,prf2cn) + > +vafoen(nrofon,q3,prf1cn)) +c + vafott(nrofon,q5,f2cp) = vafoen(nrofon,q5,prf3cn) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +24210 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... . . . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A1 A1 +c + do 24211 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q2,prf4cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q5,prf1cn) + > +vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = vafoen(nrofon,q5,prf4cn) +c + vafott(nrofon,q6,f1cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn) + > +vafoen(nrofon,q3,prf2cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prfg1n) +c + vafott(nrofon,q3,f2cp) = unstr*vafoen(nrofon,q1,prf1cn) + > +destr*vafoen(nrofon,q3,prfg2n) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q3,prf1cn) + > +vafoen(nrofon,q2,prf2cn))+ + > unsqu*destr*(vafoen(nrofon,q1,prfg1n) + > +vafoen(nrofon,q2,prfg2n)) +c + vafott(nrofon,q5,f2cp) = unsde*(vafoen(nrofon,q5,prfg1n)+ + > vafoen(nrofon,q5,prfg2n)) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +24211 continue +c +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . ... . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A1 A1 +c + do 24212 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q2,prfd1n) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prfd2n) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q5,prf1cn) + > +vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp) = unsde*(vafoen(nrofon,q3,prfd1n) + > +vafoen(nrofon,q2,prfd2n)) +c + vafott(nrofon,q6,f1cp) = unstr*(vafoen(nrofon,q3,prf2cn) + > +vafoen(nrofon,q2,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q1,prfd1n) + > +vafoen(nrofon,q1,prfd2n)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q3,prf3cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q2,prf2cn) + > +vafoen(nrofon,q3,prf1cn)) +c + vafott(nrofon,q5,f2cp) = vafoen(nrofon,q5,prf3cn) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +24212 continue +c + + else +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... ... . . . +c . . . . . . . . . +c . . . . . . . . . +c ................. ................. +c A1 A1 +c + do 24213 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f1cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q2,prfd1n) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prfd2n) +c + vafott(nrofon,q4,f1cp)=unsde*(vafoen(nrofon,q5,prf1cn)+ + > vafoen(nrofon,q5,prf2cn)) +c + vafott(nrofon,q5,f1cp)=unsde*(vafoen(nrofon,q3,prfd1n)+ + > vafoen(nrofon,q2,prfd2n)) +c + vafott(nrofon,q6,f1cp) = unstr*(vafoen(nrofon,q3,prf2cn) + > +vafoen(nrofon,q2,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q1,prfd1n) + > +vafoen(nrofon,q1,prfd2n)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prfg1n) +c + vafott(nrofon,q3,f2cp) = unstr*vafoen(nrofon,q1,prf1cn)+ + > destr*vafoen(nrofon,q3,prfg2n) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q3,prf1cn) + > +vafoen(nrofon,q2,prf2cn))+ + > unsqu*destr*(vafoen(nrofon,q1,prfg1n) + > +vafoen(nrofon,q2,prfg2n)) +c + vafott(nrofon,q5,f2cp) = unsde*(vafoen(nrofon,q5,prfg1n) + > +vafoen(nrofon,q5,prfg2n)) +c + vafott(nrofon,q6,f2cp) = vafott(nrofon,q4,f1cp) +c +24213 continue +c + endif +c +c doc.4.1/2/3. ===> etanp1 = 2 : le triangle est decoupe en deux selon +c l'arete 2 +c + elseif ( etanp1.eq.2 ) then +cgn print *,'Passage par etanp1.eq.2' +c + f3cn = ntreca(f1hn+2) + prf3cn = prfcan(f3cn) + g1 = 0 + d1 = 0 + if ( mod(anhetr(f1hn+1),10).eq.0 ) then + f2cn = ntreca(f1hn+1) + prf2cn = prfcan(f2cn) + elseif ( mod(anhetr(f1hn+1),10).eq.etanp1 ) then + pf = anfitr(f1hn+1) + d2 = ntreca(pf+1) + prfd2n = prfcan(d2) + d1 = ntreca(pf) + prfd1n = prfcan(d1) + else + codret = codret + 1 + write (ulsort,*) '_5h C codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif + if ( mod(anhetr(f1hn+3),10).eq.0 ) then + f4cn = ntreca(f1hn+3) + prf4cn = prfcan(f4cn) + elseif ( mod(anhetr(f1hn+3),10).eq.etanp1 ) then + pf = anfitr(f1hn+3) + g2 = ntreca(pf+1) + prfg2n = prfcan(g2) + g1 = ntreca(pf) + prfg1n = prfcan(g1) + else + codret = codret + 1 + write (ulsort,*) '_5h D codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c A2 A2 +c +c +c + do 24220 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prf4cn)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn) + > +vafoen(nrofon,q6,prf3cn)) + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn) + > +vafoen(nrofon,q3,prf3cn)) +c + vafott(nrofon,q6,f1cp) = vafoen(nrofon,q6,prf4cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = destr*vafoen(nrofon,q3,prf2cn)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q2,prf2cn) + > +vafoen(nrofon,q3,prf1cn)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = vafoen(nrofon,q6,prf2cn) +c +24220 continue +c +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... . . . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A2 A2 +c +c + do 24221 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prf4cn)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn) + > +vafoen(nrofon,q6,prf3cn)) + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn) + > +vafoen(nrofon,q3,prf3cn)) +c + vafott(nrofon,q6,f1cp) = vafoen(nrofon,q6,prf4cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prfd2n) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = destr*vafoen(nrofon,q3,prfd1n)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q3,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q2,prfd1n)+ + > vafoen(nrofon,q2,prfd2n)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = unsde*(vafoen(nrofon,q1,prfd1n) + > +vafoen(nrofon,q3,prfd2n)) +c +24221 continue +c + elseif ( g1.eq.0 .and. d1.ne.0 ) then +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . ... . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A2 A2 +c +c + do 24222 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q3,prfg2n)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prfg1n) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn) + > +vafoen(nrofon,q6,prf3cn)) + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q3,prf3cn))+ + > unsqu*destr*(vafoen(nrofon,q2,prfg1n) + > +vafoen(nrofon,q2,prfg2n)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q3,prfg1n) + > +vafoen(nrofon,q3,prfg2n)) +c +c Pour le triangle fils NF+1 + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = destr*vafoen(nrofon,q3,prf2cn)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q2,prf2cn) + > +vafoen(nrofon,q3,prf1cn)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = vafoen(nrofon,q6,prf2cn) +24222 continue +c + else +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... ... . . . +c . . . . . . . . . +c . . . . . . . . . +c ................. ................. +c A2 A2 +c +c + do 24223 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q3,prfg2n)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prfg1n) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q6,prf1cn) + > +vafoen(nrofon,q6,prf3cn)) + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q3,prf3cn))+ + > unsqu*destr*(vafoen(nrofon,q2,prfg1n) + > +vafoen(nrofon,q2,prfg2n)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q3,prfg1n) + > +vafoen(nrofon,q3,prfg2n)) +c + vafott(nrofon,q6,f1cp) = vafoen(nrofon,q6,prf4cn) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prfd2n) +c + vafott(nrofon,q2,f2cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f2cp) = destr*vafoen(nrofon,q3,prfd1n)+ + > unstr*vafoen(nrofon,q2,prf1cn) +c + vafott(nrofon,q4,f2cp) = unstr*(vafoen(nrofon,q1,prf3cn) + > +vafoen(nrofon,q3,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q2,prfd1n)+ + > vafoen(nrofon,q2,prfd2n)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q4,f1cp) +c + vafott(nrofon,q6,f2cp) = unsde*(vafoen(nrofon,q1,prfd1n) + > +vafoen(nrofon,q3,prfd2n)) +c +24223 continue + endif +c doc.4.1/2/3. ===> etanp1 = 3 : le triangle est decoupe en deux selon +c l'arete 3 +c + elseif ( etanp1.eq.3 ) then +cgn print *,'Passage par etanp1.eq.3' +c + f4cn = ntreca(f1hn+3) + prf4cn = prfcan(f4cn) + g1 = 0 + d1 = 0 +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+1),10)',mod(anhetr(f1hn+1),10) + if ( mod(anhetr(f1hn+1),10).eq.0 ) then + f2cn = ntreca(f1hn+1) + prf2cn = prfcan(f2cn) + elseif ( mod(anhetr(f1hn+1),10).eq.etanp1 ) then + pf = anfitr(f1hn+1) + g1 = ntreca(pf+1) + prfg1n = prfcan(g1) + g2 = ntreca(pf) + prfg2n = prfcan(g2) + else + codret = codret + 1 + write (ulsort,*) '_5h E codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +cgn write(6,*) 'etanp1', etanp1 +cgn write(6,*) 'mod(anhetr(f1hn+2),10)',mod(anhetr(f1hn+2),10) + if ( mod(anhetr(f1hn+2),10).eq.0 ) then + f3cn = ntreca(f1hn+2) + prf3cn = prfcan(f3cn) + elseif ( mod(anhetr(f1hn+2),10).eq.etanp1 ) then + pf = anfitr(f1hn+2) + d1 = ntreca(pf+1) + prfd1n = prfcan(d1) + d2 = ntreca(pf) + prfd2n = prfcan(d2) + else + codret = codret + 1 + write (ulsort,*) '_5h F codret', codret + write (ulsort,texte(langue,4)) 'n ', trhn + write (ulsort,texte(langue,5)) 'n ', etan + write (ulsort,texte(langue,4)) 'n+1', trhnp1 + write (ulsort,texte(langue,5)) 'n+1', etanp1 + endif +c + if ( g1.eq.0 .and. d1.eq.0 ) then +c +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . . . . . . +c . . . . . . . +c . . . . . . . +c ................. ................. +c A3 A3 +c +c + do 24230 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prf3cn)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = vafoen(nrofon,q4,prf3cn) +c + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn) + > +vafoen(nrofon,q3,prf3cn)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = destr*vafoen(nrofon,q2,prf2cn)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn) + > +vafoen(nrofon,q3,prf2cn)) +c +24230 continue +c + elseif ( g1.ne.0 .and. d1.eq.0 ) then +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... . . . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A3 A3 +c +c + do 24231 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prf3cn)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prf3cn) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = vafoen(nrofon,q4,prf3cn) +c + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn) + > +vafoen(nrofon,q3,prf3cn)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prfg1n) +c + vafott(nrofon,q2,f2cp) = destr*vafoen(nrofon,q2,prfg2n)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f2cp) = unsde*(vafoen(nrofon,q1,prfg1n) + > +vafoen(nrofon,q1,prfg2n)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q3,prfg1n)+ + > vafoen(nrofon,q3,prfg2n)) +c +24231 continue + elseif ( g1.eq.0 .and. d1.ne.0 ) then +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c . . ... . . . +c . . . . . . . . +c . . . . . . . . +c ................. ................. +c A3 A3 +c + do 24232 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prfd1n)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prfd2n) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q1,prfd2n) + > +vafoen(nrofon,q2,prfd1n)) +c + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn))+ + > unsqu*destr*(vafoen(nrofon,q3,prfd1n)+ + > vafoen(nrofon,q3,prfd2n)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prf2cn) +c + vafott(nrofon,q2,f2cp) = destr*vafoen(nrofon,q2,prf2cn)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f2cp) = vafoen(nrofon,q4,prf2cn) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn)+ + > vafoen(nrofon,q3,prf2cn)) +c +24232 continue + else +c +c . . +c . . ... +c . . . . . +c . . . . . +c ......... ===> . . . +c ... ... . . . +c . . . . . . . . . +c . . . . . . . . . +c ................. ................. +c A3 A3 +c + do 24233 , nrofon = 1 , nbfonc +c +c Pour le triangle fils aine NF +c + vafott(nrofon,q1,f1cp) = destr*vafoen(nrofon,q1,prfd1n)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q2,f1cp) = vafoen(nrofon,q2,prfd2n) +c + vafott(nrofon,q3,f1cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f1cp) = unsde*(vafoen(nrofon,q1,prfd2n) + > +vafoen(nrofon,q2,prfd1n)) +c + vafott(nrofon,q5,f1cp) = unstr*(vafoen(nrofon,q1,prf1cn) + > +vafoen(nrofon,q2,prf4cn))+ + > unsqu*destr*(vafoen(nrofon,q3,prfd1n)+ + > vafoen(nrofon,q3,prfd2n)) +c + vafott(nrofon,q6,f1cp) = unsde*(vafoen(nrofon,q4,prf1cn) + > +vafoen(nrofon,q4,prf4cn)) +c +c Pour le triangle fils NF+1 +c + vafott(nrofon,q1,f2cp) = vafoen(nrofon,q1,prfg1n) +c + vafott(nrofon,q2,f2cp) = destr*vafoen(nrofon,q2,prfg2n)+ + > unstr*vafoen(nrofon,q3,prf1cn) +c + vafott(nrofon,q3,f2cp) = vafoen(nrofon,q3,prf4cn) +c + vafott(nrofon,q4,f2cp) = unsde*(vafoen(nrofon,q1,prfg1n) + > +vafoen(nrofon,q1,prfg2n)) +c + vafott(nrofon,q5,f2cp) = vafott(nrofon,q6,f1cp) +c + vafott(nrofon,q6,f2cp) = unstr*(vafoen(nrofon,q1,prf4cn) + > +vafoen(nrofon,q2,prf1cn))+ + > unsqu*destr*(vafoen(nrofon,q3,prfg1n)+ + > vafoen(nrofon,q3,prfg2n)) +c +24233 continue + endif +cgn else +cgn print *,'Passage tout droit !' + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', 'pcstr2_5' +#endif diff --git a/src/tool/AP_Conversion/pcstrg.F b/src/tool/AP_Conversion/pcstrg.F new file mode 100644 index 00000000..df0aaa07 --- /dev/null +++ b/src/tool/AP_Conversion/pcstrg.F @@ -0,0 +1,289 @@ + subroutine pcstrg ( nbfonc, ngauss, nbnorf, typgeo, deraff, + > prfcan, prfcap, + > hettri, anctri, + > filtri, + > nbantr, anfitr, + > ntreca, ntrsca, + > vafoen, vafott, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aPres adaptation - Conversion de Solution - +c - - - +c TRiangles a plusieurs points de Gauss +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions aux points de Gauss . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . nbnorf . e . 1 . nbre de noeuds de l'element de reference . +c . typgeo . e . 1 . type geometrique au sens MED . +c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en . +c . . . . passant de l'iteration n a n+1 ; faux sinon. +c . prfcan . e . * . En numero du calcul a l'iteration n : . +c . . . . 0 : l'entite est absente du profil . +c . . . . i : l'entite est au rang i dans le profil . +c . prfcap . es . * . En numero du calcul a l'iteration n+1 : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nbantr . e . 1 . nombre de triangles decoupes par . +c . . . . conformite sur le maillage avant adaptation. +c . anfitr . e . nbantr . tableau filtri du maillage de l'iteration n. +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . ntrsca . e . rstrto . numero des triangles du calcul . +c . vafoen . e . nbfonc*. variables en entree de l'adaptation . +c . . . ngauss . . +c . vafott . a . nbfonc*. tableau temporaire de la solution . +c . . . ngauss . . +c . conorf . e . sdim* . coordonnees des noeuds de l'element de . +c . . . nbnorf . reference . +c . copgrf . e . sdim* . coordonnees des points de Gauss . +c . . . ngauss . de l'element de reference . +c . wipg . a . nbnorf*. fonctions de forme exprimees aux points de . +c . . . ngauss . Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PCSTRG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombsr.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer ngauss, nbnorf, typgeo + integer prfcan(*), prfcap(*) + integer hettri(nbtrto), anctri(*) + integer filtri(nbtrto) + integer nbantr, anfitr(nbantr) + integer ntreca(retrto), ntrsca(rstrto) +c + double precision vafoen(nbfonc,ngauss,*) + double precision vafott(nbfonc,ngauss,*) + double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss) + double precision wipg(nbnorf,ngauss) +c + logical deraff +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +c trhn = TRiangle courant en numerotation Homard a l'iteration N +c trhnp1 = TRiangle courant en numerotation Homard a l'iteration N+1 +c + integer trhn, trhnp1 +c +c etan = ETAt du triangle a l'iteration N +c etanp1 = ETAt du triangle a l'iteration N+1 +c + integer etan, etanp1 +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "pcimp0.h" +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write(ulsort,*) 'nbfonc, ngauss, nbtrto = ',nbfonc, ngauss, nbtrto +#endif +c + texte(1,4) = + >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)' + texte(1,5) = + > '( '' etat a l''''iteration '',a3,'' : '',i4)' +c + texte(2,4) = + >'(/,''Current triangle : # at iteration '',a3,'' : '',i10)' + texte(2,5) = + > '( '' status at iteration '',a3,'' : '',i4)' +c +#include "impr03.h" +c +cgn write (ulsort,90002) 'nbfonc, ngauss, nbnorf', +cgn > nbfonc,ngauss,nbnorf +c +c==== +c 2. on boucle sur tous les triangles actifs du maillage HOMARD n+1 +c . soit il etait deja actif dans le maillage precedent : c'est un +c transfert direct des valeurs +c . soit il ne l'etait pas : il est donc issu d'un decoupage et on va +c calculer les valeurs aux points de Gauss en fonction des valeurs +c sur les noeuds. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Boucle ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfonc.ne.0 ) then +c + do 30 , trhnp1 = 1 , nbtrto +c +c 2.1. ==> caracteristiques du triangle : +c 2.1.1. ==> son numero homard dans le maillage precedent +c + if ( deraff ) then + trhn = anctri(trhnp1) + else + trhn = trhnp1 + endif +c +c 2.1.3. ==> l'historique de son etat +c On rappelle que l'etat vaut : +c etan = 0 : le triangle etait actif +c etan = 1, 2, 3 : le triangle etait coupe en 2 selon l'arete +c 1, 2, 3 ; il y a eu deraffinement. +c etan = 4 : le triangle etait coupe en 4 ; il y a eu +c deraffinement. +c etan = 5 : le triangle n'existait pas ; il a ete produit par +c un decoupage. +c etan = 6, 7, 8 : le triangle etait coupe en 4 avec bascule +c de l'arete etan-5 pour le suivi de +c frontiere ; il y a eu deraffinement. +c + etanp1 = mod(hettri(trhnp1),10) + etan = (hettri(trhnp1)-etanp1) / 10 +cgn write (ulsort,1792) 'Triangle', trhn, etan, trhnp1, etanp1 +c +c======================================================================= +c etan = 0 : le triangle etait actif +c======================================================================= +c + if ( etan.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPTZ', nompro +#endif +c + call pcsptz ( etan, etanp1, trhn, trhnp1, + > prfcan, prfcap, + > filtri, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c etan = 1, 2, 3 : le triangle etait coupe en 2 +c======================================================================= +c + elseif ( etan.ge.1 .and. etan.le.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPTD', nompro +#endif +c + call pcsptd ( etan, etanp1, trhn, trhnp1, + > prfcan, prfcap, + > hettri, filtri, nbantr, anfitr, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c +c======================================================================= +c etan = 4, 6, 7, 8 : le triangle etait coupe en 4 +c======================================================================= +c + elseif ( etan.eq.4 .or. + > ( etan.ge.6 .and. etan.le.8 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSPTQ', nompro +#endif +c + call pcsptq ( etanp1, trhn, trhnp1, + > prfcan, prfcap, + > filtri, nbantr, anfitr, + > ntreca, ntrsca, + > nbfonc, ngauss, vafoen, vafott, + > ulsort, langue, codret ) +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/CMakeLists.txt b/src/tool/AV_Conversion/CMakeLists.txt new file mode 100644 index 00000000..56dbfb37 --- /dev/null +++ b/src/tool/AV_Conversion/CMakeLists.txt @@ -0,0 +1,113 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de AV_Conversion + +SET(AV_Conversion_SOURCES + ./vccfam.F + ./vccfca.F + ./vccfcf.F + ./vccfnc.F + ./vcequ1.F + ./vcequ2.F + ./vcequ3.F + ./vcequ4.F + ./vcequ5.F + ./vcequ6.F + ./vcequ7.F + ./vcequa.F + ./vcequi.F + ./vcequn.F + ./vcfia0.F + ./vcfia1.F + ./vcfia2.F + ./vcfia3.F + ./vcfia4.F + ./vcfiad.F + ./vcind0.F + ./vcind1.F + ./vcind2.F + ./vcind3.F + ./vcindi.F + ./vcinr1.F + ./vcinr2.F + ./vcinrr.F + ./vcmaco.F + ./vcmafa.F + ./vcmaig.F + ./vcmail.F + ./vcmar0.F + ./vcmare.F + ./vcme21.F + ./vcme22.F + ./vcme23.F + ./vcme24.F + ./vcme25.F + ./vcme26.F + ./vcme27.F + ./vcme28.F + ./vcme29.F + ./vcme30.F + ./vcme31.F + ./vcme32.F + ./vcmex0.F + ./vcmex1.F + ./vcmex2.F + ./vcmexa.F + ./vcmexb.F + ./vcmexd.F + ./vcmext.F + ./vcmfac.F + ./vcmmen.F + ./vcmmpo.F + ./vcmnc1.F + ./vcmnc2.F + ./vcmnc3.F + ./vcmnc4.F + ./vcmnco.F + ./vcmnoe.F + ./vcmre0.F + ./vcmren.F + ./vcms20.F + ./vcms21.F + ./vcms22.F + ./vcms2d.F + ./vcmver.F + ./vcori1.F + ./vcori2.F + ./vcorie.F + ./vcsfal.F + ./vcsfas.F + ./vcsfin.F + ./vcsfl0.F + ./vcsflg.F + ./vcsfli.F + ./vcsfll.F + ./vcvar1.F + ./vcvar2.F + ./vcvos1.F + ./vcvos2.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/AV_Conversion ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (AV_Conversion ${AV_Conversion_SOURCES}) + +INSTALL(TARGETS AV_Conversion EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/AV_Conversion/vccfam.F b/src/tool/AV_Conversion/vccfam.F new file mode 100644 index 00000000..051281f3 --- /dev/null +++ b/src/tool/AV_Conversion/vccfam.F @@ -0,0 +1,535 @@ + subroutine vccfam ( typenh, + > nbento, nctfen, nbfenm, + > codext, cfaent, tbaux1, tbaux2, + > fament, nbfent, + > nctfe1, nbfen1, cfaen1, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Creation des FAMilles +c - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . variantes . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbento . e . 1 . nombre d'entites total . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfenm . e . 1 . nombre maximum de familles . +c . codext . e . nbento*. codes externes des entites . +c . . . nctfen . . +c . cfaent . s . nctfen*. codes des familles des entites . +c . . . nbfent . . +c .tbaux1,2. t . * . tableaux auxiliaires . +c . fament . s . nbento . famille des entites . +c . nbfent . s . 1 . nombre de familles d'entites . +c . nctfe1 . e . 1 . nombre total de caracteristiques annexes . +c . nbfen1 . e . 1 . nombre maximum de familles annexes . +c . cfaen1 . e . nctfe1*. codes des familles des entites annexes . +c . . . nbfen1 . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCCFAM' ) +c +#include "nblang.h" +c +#include "cofamp.h" +#include "cofaar.h" +#include "cofina.h" +#include "cofatq.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nbento, nctfen, nbfenm + integer codext(nbento,nctfen) + integer cfaent(nctfen,nbfenm) + integer fament(nbento) + integer tbaux1(*), tbaux2(*) + integer nctfe1, nbfen1 + integer cfaen1(nctfe1,nbfen1) + integer nbfent + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lafami, famien + integer entite, nucode, nufami + integer nbfar1, nbfar2, nbfar3, nbfar4, nbfar5 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a14,'' : nombre de familles creees : '',i8,/)' + texte(1,5) = '(a14,'' : creation de la famille '',i8,/)' + texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,7) = '(''Modifier les programmes UTINCG et/ou VCCFAM'')' +c + texte(2,4) = '(a14,'' : number of created families: '',i8,/)' + texte(2,5) = '(a14,'' : creation of the family '',i8,/)' + texte(2,6) = '(''This number is greater than maximum:'',i8)' + texte(2,7) = '(''Modify the programs UTINCG and/or VCCFAM'')' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'nbento', nbento + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfenm', nbfenm +#endif +c +c==== +c 1. initialisations +c==== +c 1.1. ==> on initialise tous les codes des familles : +c + do 11, nucode = 1, nctfen + do 10, nufami = 1, nbfenm + cfaent(nucode,nufami) = 0 + 10 continue + 11 continue +c +c 1.2. ==> on cree la premiere famille, dite 'famille libre' : +c 1.2.1. ==> le compteur +c + nbfent = 1 +c +c 1.2.2. ==> pour les aretes, on gere les orientations inverses de +c cette famille libre : c'est elle-meme car aucune +c orientation n'est definie +c + if ( typenh.eq.1 ) then +c + cfaent(cofifa,nbfent) = 1 + cfaent(cosfin,nbfent) = 0 +c + endif +c +c 1.2.3. ==> Pour une face, la famille des aretes qui seront tracees +c dessus au cours du raffinement est la famille +c libre par defaut +c + if ( typenh.eq.2 .or. typenh.eq.4 ) then +c + cfaent(cofafa,nbfent) = 1 +c + endif +c +c==== +c 2. creation des autres familles +c==== +c + do 20 , entite = 1, nbento +c +c 2.1. ==> ajout conditionne +c 2.1.1. ==> pour une maille-point, on ajoute le code de la famille du +c noeud sous-jacent +c + if ( typenh.eq.0 ) then +c + codext(entite,cofaso) = tbaux2(tbaux1(entite)) +c +c 2.1.2. ==> Pour une face, numero de famille des aretes qui seront +c tracees dessus au cours du raffinement +c . Par defaut, c'est la famille libre +c . Pour une surface, prise en compte du suivi de frontiere +c on cherche la famille des aretes : +c . non elements du calcul (i.e. type = 0) +c . tracees sur la meme surface que la face en cours +c + elseif ( typenh.eq.2 .or. typenh.eq.4 ) then +c + jaux = 1 + kaux = codext(entite,cosfsu) + if ( kaux.ne.0 ) then + do 212 , iaux = 1 , nbfen1 + if ( cfaen1(cotyel,iaux).eq.0 ) then + if ( cfaen1(cosfsa,iaux).eq.kaux ) then + jaux = iaux + endif + endif + 212 continue + endif + codext(entite,cofafa) = jaux +c + endif +c +c 2.2. ==> on recherche si une famille avec les memes codes existe deja +c . si oui, on stocke son numero pour l'entite en cours. +c . si non, on cree une famille avec les codes de l'entite +c + famien = 0 + 2200 continue +c +c 2.2.1. ==> Comparaison des codes de la famille 'famien' et +c de ceux de l'entite en cours +c + famien = famien + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. examen de la famille famien', famien +#endif +c + if ( famien.le.nbfent ) then +c + nucode = 0 + 2210 continue + nucode = nucode + 1 +c +c - dans le cas des aretes, on saute les codes : +c . de l'orientation inverse +c . de la frontiere inactive +c + if ( typenh.eq.1 ) then + if ( nucode.eq.cofifa .or. nucode.eq.cosfin ) then + goto 2210 + endif +c +c - dans le cas des quadrangles, on saute les codes : +c . de la frontiere inactive +c + elseif ( typenh.eq.4 ) then + if ( nucode.eq.cosfin ) then + goto 2210 + endif + endif +c + if ( nucode.le.nctfen ) then + if ( codext(entite,nucode).eq. + > cfaent(nucode,famien) ) then +c le code est le meme : on passe au suivant + goto 2210 + else +c le code est different : on passe a la famille suivante + goto 2200 + endif + else +c tous les codes sont les memes : la famille existe deja + lafami = famien + endif +c + else +c +c 2.2.2. ==> la famille n'existe pas encore : on la cree +c + nbfent = nbfent + 1 + lafami = nbfent +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,4,typenh), lafami +#endif + do 222, nucode = 1, nctfen + cfaent(nucode,nbfent) = codext(entite,nucode) + 222 continue +c +c 2.2.3. ==> Cas particulier des aretes : +c a. prise en compte de l'orientation : il faut la famille +c d'orientation inverse +c b. prise en compte du suivi de frontiere +c si l'arete est concernee par le suivi de frontiere, il +c faut creer egalement la famille inactive, ie celle pour +c laquelle le suivi de frontiere est inactif : toutes les +c caracteristiques sont les memes a l'exception du numero +c de ligne/surface que l'on met negatif. On memorise +c l'association entre les deux familles dans la case +c cosfin +c + if ( typenh.eq.1 ) then +c +c 2.2.3.1. ==> l'arete n'a pas d'orientation : la famille +c d'orientation inverse est elle meme (cofifa) +c + if ( codext(entite,coorfa).eq.0 ) then +c + cfaent(cofifa,nbfent) = nbfent +c +c 2.2.3.1.1. ==> l'arete est concernee par une surface de sf +c + if ( codext(entite,cosfsa).ne.0 ) then +c + nbfar1 = nbfent + 1 +c + do 2231, nucode = 1, nctfen + cfaent(nucode,nbfar1) = codext(entite,nucode) + 2231 continue +c + cfaent(coorfa,nbfar1) = 0 +c + cfaent(cofifa,nbfar1) = nbfar1 +c + cfaent(cosfin,nbfent) = nbfar1 + cfaent(cosfin,nbfar1) = nbfent +c + cfaent(cosfsa,nbfar1) = - codext(entite,cosfsa) +c + nbfent = nbfar1 +c +c 2.2.3.1.2. ==> l'arete est concernee par une ligne de sf +c remarque : cela ne devrait jamais arriver car si une +c arete est sur une ligne de SF c'est qu'elle +c est un element du calcul, donc avec une +c orientation +c + elseif ( codext(entite,cosfli).ne.0 ) then +c + codret = 22312 +c + endif +c +c 2.2.3.2. ==> l'arete possede une orientation : on cree la famille +c d'orientation inverse : toutes les +c caracteristiques sont les memes a l'exception du code +c d'orientation, coorfa. On memorise l'association entre +c les deux familles dans la case cofifa +c + else +c +c 2.2.3.2.1. ==> la famille n'est pas liee a une frontiere +c + if ( codext(entite,cosfli).eq.0 .and. + > codext(entite,cosfsa).eq.0 ) then +c + cfaent(cosfin,nbfent) = 0 +c + cfaent(cofifa,nbfent) = nbfent + 1 + nbfent = nbfent + 1 + do 2232, nucode = 1, nctfen + cfaent(nucode,nbfent) = codext(entite,nucode) + 2232 continue + cfaent(coorfa,nbfent) = - codext(entite,coorfa) + cfaent(cofifa,nbfent) = nbfent - 1 + cfaent(cosfin,nbfent) = 0 +c +c 2.2.3.2.2. ==> l'arete est concernee par une ligne de sf +c + elseif ( codext(entite,cosfli).ne.0 ) then +c + nbfar1 = nbfent + 1 + nbfar2 = nbfar1 + 1 + nbfar3 = nbfar2 + 1 +c + do 2233, nucode = 1, nctfen + cfaent(nucode,nbfar1) = codext(entite,nucode) + cfaent(nucode,nbfar2) = codext(entite,nucode) + cfaent(nucode,nbfar3) = codext(entite,nucode) + 2233 continue +c + cfaent(coorfa,nbfar1) = - codext(entite,coorfa) + cfaent(coorfa,nbfar3) = - codext(entite,coorfa) +c + cfaent(cofifa,nbfent) = nbfar1 + cfaent(cofifa,nbfar1) = nbfent + cfaent(cofifa,nbfar2) = nbfar3 + cfaent(cofifa,nbfar3) = nbfar2 +c + cfaent(cosfli,nbfar2) = - codext(entite,cosfli) + cfaent(cosfli,nbfar3) = - codext(entite,cosfli) +c + cfaent(cosfin,nbfent) = nbfar2 + cfaent(cosfin,nbfar1) = nbfar3 + cfaent(cosfin,nbfar2) = nbfent + cfaent(cosfin,nbfar3) = nbfar1 +c + nbfent = nbfar3 +c +c 2.2.3.2.3. ==> l'arete est concernee par une surface de sf +c + elseif ( codext(entite,cosfsa).ne.0 ) then +c + nbfar1 = nbfent + 1 + nbfar2 = nbfar1 + 1 + nbfar3 = nbfar2 + 1 + nbfar4 = nbfar3 + 1 + nbfar5 = nbfar4 + 1 +c + do 2234, nucode = 1, nctfen + cfaent(nucode,nbfar1) = codext(entite,nucode) + cfaent(nucode,nbfar2) = codext(entite,nucode) + cfaent(nucode,nbfar3) = codext(entite,nucode) + cfaent(nucode,nbfar4) = codext(entite,nucode) + cfaent(nucode,nbfar5) = codext(entite,nucode) + 2234 continue +c + cfaent(cofamd,nbfar4) = 0 + cfaent(cofamd,nbfar5) = 0 +c + cfaent(cotyel,nbfar4) = 0 + cfaent(cotyel,nbfar5) = 0 +c + cfaent(coorfa,nbfar1) = - codext(entite,coorfa) + cfaent(coorfa,nbfar3) = - codext(entite,coorfa) + cfaent(coorfa,nbfar4) = 0 + cfaent(coorfa,nbfar5) = 0 +c + cfaent(cofifa,nbfent) = nbfar1 + cfaent(cofifa,nbfar1) = nbfent + cfaent(cofifa,nbfar2) = nbfar3 + cfaent(cofifa,nbfar3) = nbfar2 + cfaent(cofifa,nbfar4) = nbfar4 + cfaent(cofifa,nbfar5) = nbfar5 +c + cfaent(cosfsa,nbfar2) = - codext(entite,cosfsa) + cfaent(cosfsa,nbfar3) = - codext(entite,cosfsa) + cfaent(cosfsa,nbfar5) = - codext(entite,cosfsa) +c + cfaent(cosfin,nbfent) = nbfar2 + cfaent(cosfin,nbfar1) = nbfar3 + cfaent(cosfin,nbfar2) = nbfent + cfaent(cosfin,nbfar3) = nbfar1 + cfaent(cosfin,nbfar4) = nbfar5 + cfaent(cosfin,nbfar5) = nbfar4 +c + nbfent = nbfar5 +c + else +c + codret = 2232 +c + endif +c + endif +c +c 2.2.4. ==> Cas particulier des quadrangles pour le suivi de frontiere +c si le quadrangle est concerne par le suivi de frontiere, +c il faut creer egalement la famille inactive, ie celle +c pour laquelle le suivi de frontiere est inactif : toutes +c les caracteristiques sont les memes a l'exception du +c numero de surface que l'on met negatif. On memorise +c l'association entre les deux familles dans la case +c cosfin +c + elseif ( typenh.eq.4 ) then +c +c 2.2.4.1. ==> le quadrangle est concerne par le suivi de frontiere +c + if ( codext(entite,cosfsu).ne.0 ) then +c + nbfar1 = nbfent + 1 +c + do 2241, nucode = 1, nctfen + cfaent(nucode,nbfar1) = codext(entite,nucode) + 2241 continue +c + cfaent(cosfin,nbfent) = nbfar1 + cfaent(cosfin,nbfar1) = nbfent + cfaent(cosfsu,nbfar1) = -cfaent(cosfsu,nbfent) +c + nbfent = nbfar1 +c + endif +c + endif +c + endif +c +c 2.3. ==> on affecte le numero de famille a l'entite +c + fament(entite) = lafami +c + 20 continue +c +c 2.4. ==> controle +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,typenh), nbfent +#endif +c + if ( nbfent.gt.nbfenm ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbento', nbento + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfenm', nbfenm +#endif + write (ulsort,texte(langue,4)) mess14(langue,4,typenh), nbfent + write (ulsort,texte(langue,6)) nbfenm + write (ulsort,texte(langue,7)) nompro + codret = 1 + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vccfca.F b/src/tool/AV_Conversion/vccfca.F new file mode 100644 index 00000000..bee03569 --- /dev/null +++ b/src/tool/AV_Conversion/vccfca.F @@ -0,0 +1,282 @@ + subroutine vccfca ( nbfare, cfaare, + > nbfqua, cfaqua, + > nbftri, cfatri, + > faminf, famsup, + > nbfme0, numfam, nomfam, + > grfmpo, grfmta, grfmtb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Creation des Familles - CArmel +c - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfare . es . 1 . nombre de familles d'aretes . +c . cfaare . es . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . nbfqua . e . 1 . nombre de familles de quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . nbftri . e . 1 . nombre de familles de triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftrm . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . faminf . e . 1 . famille med des quad de la face inferieure . +c . famsup . e . 1 . famille med des quad de la face superieure . +c . nbfme0 . e . 1 . nombre initial de familles med . +c . numfam . es . nbfmed . numero des familles . +c . nomfam . es .10nbfmed. nom des familles . +c . grfmpo . s .nbfmed+1. pointeur des groupes des familles . +c . grfmta . s .10ngrouc. taille des groupes des familles . +c . grfmtb . s .10ngrouc. table des groupes des familles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCCFCA' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "cofaar.h" +#include "coftfq.h" +#include "cofatq.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbutil.h" +#include "nbfamm.h" +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbfare + integer cfaare(nctfar,nbfarm) + integer nbfqua + integer cfaqua(nctfqu,nbfqum) + integer nbftri + integer cfatri(nctftr,nbftrm) +c + integer faminf, famsup + integer nbfme0 + integer numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmta(10*ngrouc) +c + character*8 nomfam(10,nbfmed) + character*8 grfmtb(10*ngrouc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nufamd(3) +c + character*8 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a14,'' : nombre de familles HOMARD : '',i8)' + texte(1,5) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,6) = '(''Modifier le programme UTINCG'')' +c + texte(2,4) = '(a14,'' : number of HOMARD families:'',i8)' + texte(2,5) = '(''This number is greater than maximum:'',i8)' + texte(2,6) = '(''Modify UTINCG program.'')' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare + if ( nbtria.ne.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri + endif + if ( nbquad.ne.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua + endif + write (ulsort,*) ' ' +#endif +c +c==== +c 2. On ajoute deux nouvelles familles d'aretes internes : +c - le type des autres aretes +c - aucune autre caracteristique +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Ajout fam. aretes ; codret', codret +#endif +c +c 2.1. ==> a priori, aucune caracteristique particuliere +c + do 21 , iaux = 1 , nctfar + cfaare(iaux,nbfare+1) = 0 + cfaare(iaux,nbfare+2) = 0 + 21 continue +c +c 2.2. ==> Le type des elements est le meme que celui d'une +c autre famille +c + kaux = 0 +c + do 22 , iaux = 1 , nbfare +c + if ( cfaare(cotyel,iaux).ne.0 ) then + kaux = cfaare(cotyel,iaux) + goto 220 + endif +c + 22 continue +c + 220 continue +c + cfaare(cotyel,nbfare+1) = kaux + cfaare(cotyel,nbfare+2) = kaux +c +c 2.3. ==> les orientations +c + cfaare(coorfa,nbfare+1) = 1 + cfaare(coorfa,nbfare+2) = -1 +c + cfaare(cofifa,nbfare+1) = nbfare+2 + cfaare(cofifa,nbfare+2) = nbfare+1 +c +c 2.4. ==> total des familles +c + nbfare = nbfare + 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare +#endif +c + if ( nbfare.gt.nbfarm ) then + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare + write (ulsort,texte(langue,5)) nbfarm + write (ulsort,texte(langue,6)) + codret = 1 + endif +c +c==== +c 3. On reporte cette famille chez les familles des triangles +c et quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Report tria/quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbftri +c + if ( cfatri(cofafa,iaux).eq.1 ) then + cfatri(cofafa,iaux) = nbfare + endif +c + 31 continue +c + do 32 , iaux = 1 , nbfqua +c + if ( cfaqua(cofafa,iaux).eq.1 ) then + cfaqua(cofafa,iaux) = nbfare + endif +c + 32 continue +c + endif +c +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vccfcf.F b/src/tool/AV_Conversion/vccfcf.F new file mode 100644 index 00000000..180c98f0 --- /dev/null +++ b/src/tool/AV_Conversion/vccfcf.F @@ -0,0 +1,311 @@ + subroutine vccfcf ( typdep, nctfde, nbfdem, nbfdep, + > typfin, nctffi, nbffim, nbffin, ncfffi, + > cofafd, + > cfadep, cfafin, + > eddep1, edfin1, + > eddep2, edfin2, + > eddep3, edfin3, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Creation des Familles +c - - +c - gestion de la ConFormite +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typdep . e . 1 . type de l'entite de depart . +c . nctfde . e . 1 . nombre de codes pour les familles de depart. +c . nbfdem . e . 1 . nombre de familles de depart au maximum . +c . nbfdep . e . 1 . nombre de familles de depart . +c . typfin . e . 1 . type de l'entite finale . +c . nctffi . e . 1 . nombre de codes pour les familles finales . +c . nbffim . e . 1 . nombre de familles finales au maximum . +c . nbffin . e . 1 . nombre de familles finales . +c . ncfffi . e . 1 . nombre fige de carac. de familles finales . +c . cofafd . e . 1 . code depart contenant la famille d'arrivee . +c . cfadep . e . nctfde*. codes des familles des depart . +c . . . nbfdep . 1 : famille MED . +c . . . . 2 : type . +c . . . . si quadrangle : . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si hexaedre ou pentaedre : . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . cfafin . e . nctffi*. codes des familles finales . +c . . . nbffim . 1 : famille MED . +c . . . . 2 : type . +c . . . . si triangle : . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . . . . si tetraedre ou pyramide : . +c . eddep1 . e . 1 . type med numero 1 au depart . +c . edfin1 . e . 1 . type med numero 1 au final . +c . eddep2 . e . 1 . type med numero 2 au depart . +c . edfin2 . e . 1 . type med numero 2 au final . +c . eddep3 . e . 1 . type med numero 3 au depart . +c . edfin3 . e . 1 . type med numero 3 au final . +c . tabaux . a . nctffi . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCCFCF' ) +c +#include "nblang.h" +c +#include "coftex.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typdep, nctfde, nbfdem, nbfdep + integer typfin, nctffi, nbffim, nbffin, ncfffi + integer cofafd + integer cfadep(nctfde,nbfdem) + integer cfafin(nctffi,nbffim) + integer eddep1, edfin1 + integer eddep2, edfin2 + integer eddep3, edfin3 + integer tabaux(nctffi) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nufdep, nucode +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a14,'' : nombre de familles :'',i8)' + texte(1,5) = '(''. Creation de la famille '',i8,/)' + texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,7) = '(''Modifier les programmes UTINCG et/ou VCCFAM'')' +c + texte(2,4) = '(a14,'' : number of families :'',i8)' + texte(2,5) = '(''. Creation of family '',i8,/)' + texte(2,6) = '(''This number is greater than maximum:'',i8)' + texte(2,7) = '(''Modify the programs UTINCG and/or VCCFAM'')' +c + codret = 0 +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,typdep), nbfdep + write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin +#endif +c +c==== +c 2. La famille libre de depart est liee a la famille libre d'arrivee +c==== +c + cfadep(cofafd,1) = 1 +c +c==== +c 3. Creation des familles finales a partir de celles de depart +c==== +c +cgn write (ulsort,90002)'cofamd, cotyel',cofamd,cotyel +cgn write (ulsort,90002)'nctfde',nctfde +cgn write (ulsort,90002)'ncfffi, nctffi',ncfffi,nctffi +cgn write (ulsort,90002)'nbffin initial',nbffin +cgn write (ulsort,1788) +cgn do 3333 , iaux = 1,nbffin +cgn write (ulsort,90012)'famille ',iaux, +cgn >(cfafin(nucode,iaux),nucode=1,nctffi) +cgn 3333 continue +cgn 1788 format(' MED type surf ar.su') +c +cgn write (ulsort,90002)'... eddep1, edfin1', eddep1, edfin1 +cgn write (ulsort,90002)'... eddep2, edfin2', eddep2, edfin2 +cgn write (ulsort,90002)'... eddep3, edfin3', eddep3, edfin3 + do 30 , nufdep = 2 , nbfdep +c +cgn write (ulsort,*) ' ' +cgn write (ulsort,1788) +cgn write (ulsort,90012)'famille ',nufdep, +cgn >(cfadep(nucode,nufdep),nucode=1,nctfde) +c +c 3.1. ==> Etablissement des futurs codes dans tabaux +c 3.1.1. ==> La famille MED doit etre la meme +c + tabaux(cofamd) = cfadep(cofamd,nufdep) +c +c 3.1.2. ==> definition du type d'element +c +cgn write (ulsort,90002)'typel depart', cfadep(cotyel,nufdep) + if ( cfadep(cotyel,nufdep).eq.eddep1 ) then + tabaux(cotyel) = edfin1 + elseif ( cfadep(cotyel,nufdep).eq.eddep2 ) then + tabaux(cotyel) = edfin2 + elseif ( cfadep(cotyel,nufdep).eq.eddep3 ) then + tabaux(cotyel) = edfin3 + else + tabaux(cotyel) = 0 + endif +cgn write (ulsort,90002)'typel arrivee', tabaux(cotyel) +c +c 3.1.3. ==> Surfaces frontieres +c +cgn write (ulsort,90002)'... cosfsu depart', cfadep(cosfsu,nufdep) +cgn write (ulsort,90002)'... cofafa depart', cfadep(cofafa,nufdep) + if ( typdep.eq.4 ) then + tabaux(cosfsu) = cfadep(cosfsu,nufdep) + tabaux(cofafa) = cfadep(cofafa,nufdep) + endif +c +c 3.1.4. ==> Les groupes et equivalences doivent etre les memes +c le decalage est de 2 (cf. UTINCG/UTECF0) +c + do 314, nucode = ncfffi+1, nctffi + tabaux(nucode) = cfadep(nucode+2,nufdep) + 314 continue +c +cgn write (ulsort,1788) +cgn write (ulsort,90012)'tabaux a',315, +cgn > (tabaux(nucode),nucode=1,nctffi) +c +c 3.2. ==> Existe-t-il une famille finale avec ces caracteristiques ? +c Dans les nbffin familles deja definies, recherche d'une +c dont les codes sont les memes. +c Si on l'a, on note son numero (jaux) et on continue (33). +c Si aucune ne correspond, on en cree une nouvelle. +c + do 32 , iaux = 1 , nbffin +cgn write (ulsort,90002)'. Famille', iaux + do 321 , nucode = 1, nctffi +cgn write (ulsort,90012)'.. code',nucode, +cgn > cfafin(nucode,iaux),tabaux(nucode) + if ( cfafin(nucode,iaux).ne.tabaux(nucode) ) then + goto 32 + endif + 321 continue + jaux = iaux +cgn write (ulsort,90002)'ok Famille ', iaux + goto 33 + 32 continue +c + nbffin = nbffin + 1 +cgn write (ulsort,*)'Creation de la famille ', nbffin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbffin +#endif + do 322, nucode = 1, nctffi + cfafin(nucode,nbffin) = tabaux(nucode) + 322 continue + jaux = nbffin +cgn write (ulsort,1788) +cgn do 3221 , iaux = 1,nbffin +cgn write (ulsort,90012)'famille ',iaux, +cgn > (cfafin(nucode,iaux),nucode=1,nctffi) +cgn 3221 continue +c +c 3.3. ==> memorisation du type de famille finale +c + 33 continue +c +cgn write (ulsort,*)'Stockage de ', jaux, +cgn > ' dans la famille de depart',nufdep + cfadep(cofafd,nufdep) = jaux +c + 30 continue +c +c==== +c 4. Controle +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin +#endif +c + if ( nbffin.gt.nbffim ) then + write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin + write (ulsort,texte(langue,6)) nbffim + write (ulsort,texte(langue,7)) + codret = 1 + endif +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vccfnc.F b/src/tool/AV_Conversion/vccfnc.F new file mode 100644 index 00000000..413965e5 --- /dev/null +++ b/src/tool/AV_Conversion/vccfnc.F @@ -0,0 +1,498 @@ + subroutine vccfnc ( nbfare, cfaare, + > nbfqua, cfaqua, + > nbftri, cfatri, + > faminf, famsup, + > nbfme0, numfam, nomfam, + > grfmpo, grfmta, grfmtb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Creation des Familles - Non Conforme +c - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfare . es . 1 . nombre de familles d'aretes . +c . cfaare . es . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . nbfqua . e . 1 . nombre de familles de quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . nbftri . e . 1 . nombre de familles de triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftrm . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . faminf . e . 1 . famille med des quad de la face inferieure . +c . famsup . e . 1 . famille med des quad de la face superieure . +c . nbfme0 . e . 1 . nombre initial de familles med . +c . numfam . es . nbfmed . numero des familles . +c . nomfam . es .10nbfmed. nom des familles . +c . grfmpo . s .nbfmed+1. pointeur des groupes des familles . +c . grfmta . s .10ngrouc. taille des groupes des familles . +c . grfmtb . s .10ngrouc. table des groupes des familles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCCFNC' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "cofaar.h" +#include "coftfq.h" +#include "cofatq.h" +#include "coftex.h" +c +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nbutil.h" +#include "nbfamm.h" +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbfare + integer cfaare(nctfar,nbfarm) + integer nbfqua + integer cfaqua(nctfqu,nbfqum) + integer nbftri + integer cfatri(nctftr,nbftrm) +c + integer faminf, famsup + integer nbfme0 + integer numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmta(10*ngrouc) +c + character*8 nomfam(10,nbfmed) + character*8 grfmtb(10*ngrouc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nufamd(3) +c + character*8 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a14,'' : nombre de familles HOMARD : '',i8)' + texte(1,5) = '(''Ce nombre est superieur au maximum :'',i8)' + texte(1,6) = '(''Modifier le programme UTINCG'')' + texte(1,7) = '(''. Famille MED supplementaire'',i2,'' :'',i6)' + texte(1,8) = '(/,a14,'' : ajout de la famille MED'',i8)' + texte(1,9) = '(''Aucun type n''''a ete trouve pour les '',a)' +c + texte(2,4) = '(a14,'' : number of HOMARD families:'',i8)' + texte(2,5) = '(''This number is greater than maximum:'',i8)' + texte(2,6) = '(''Modify UTINCG program.'')' + texte(2,7) = '(''. Additional MED family #'',i2,'':'',i6)' + texte(2,8) = '(/,a14,'' : addition of MED family #'',i8)' + texte(2,9) = '(''No type was found for the '',a)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare + if ( nbtria.ne.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri + endif + if ( nbquad.ne.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua + endif + write (ulsort,*) ' ' +#endif +c +c==== +c 2. On recherche trois nouveaux numeros de famille MED +c==== +c 2.1. ==> on cherche le minimum entre tous les numeros de familles MED +c deja existant et ceux des faces inf/sup +c + iaux = min (faminf, famsup) +c + do 21 , jaux = 1 , nbfmed-3 +c + iaux = min (iaux,numfam(jaux)) +c + 21 continue +c + nufamd(1) = iaux - 1 + nufamd(2) = iaux - 2 + nufamd(3) = iaux - 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 1, nufamd(1) + write (ulsort,texte(langue,7)) 2, nufamd(2) + write (ulsort,texte(langue,7)) 3, nufamd(3) +#endif +c +c==== +c 3. On ajoute deux nouvelles familles d'aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Ajout fam. aretes ; codret', codret +#endif +c +c 3.1. ==> a priori, aucune caracteristique particuliere +c + do 31 , iaux = 1 , nctfar + cfaare(iaux,nbfare+1) = 0 + cfaare(iaux,nbfare+2) = 0 + 31 continue +c +c 3.2. ==> La famille MED +c + cfaare(cofamd,nbfare+1) = nufamd(1) + cfaare(cofamd,nbfare+2) = nufamd(1) +c +c 3.3. ==> le type des elements est le meme que celui d'une +c autre famille +c si aucun n'est trouve, on l'impose +c + kaux = 0 +c + do 33 , iaux = 1 , nbfare +c + if ( cfaare(cotyel,iaux).ne.0 ) then + kaux = cfaare(cotyel,iaux) + goto 330 + endif +c + 33 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,1) +#endif +c + if ( degre.eq.1 ) then + kaux = edseg2 + else + kaux = edseg3 + endif +c + 330 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Type des '//mess14(langue,3,1), kaux +#endif +c + cfaare(cotyel,nbfare+1) = kaux + cfaare(cotyel,nbfare+2) = kaux +c +c 3.4. ==> les orientations +c + cfaare(coorfa,nbfare+1) = 1 + cfaare(coorfa,nbfare+2) = -1 +c + cfaare(cofifa,nbfare+1) = nbfare+2 + cfaare(cofifa,nbfare+2) = nbfare+1 +c +c 3.5. ==> total des familles +c + nbfare = nbfare + 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,4,1), nufamd(1) + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare +#endif +c + if ( nbfare.gt.nbfarm ) then + write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare + write (ulsort,texte(langue,5)) nbfarm + write (ulsort,texte(langue,6)) + codret = 1 + endif +c +c==== +c 4. On ajoute une nouvelle famille de quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Ajout fam. quadrangles ; codret', codret +#endif +c + if ( nbquad.ne.0 .or. nbhexa.ne.0 .or. nbpent.ne.0 ) then +c +c 4.1. ==> a priori, aucune caracteristique particuliere +c + do 41 , iaux = 1 , nctfqu + cfaqua(iaux,nbfqua+1) = 0 + 41 continue +c +c 4.2. ==> La famille MED +c + cfaqua(cofamd,nbfqua+1) = nufamd(2) +c +c 4.3. ==> le type des elements est le meme que celui d'une +c autre famille +c si aucun n'est trouve, on l'impose +c + kaux = 0 +c + do 43 , iaux = 1 , nbfqua +c + if ( cfaqua(cotyel,iaux).ne.0 ) then + kaux = cfaqua(cotyel,iaux) + goto 430 + endif +c + 43 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,4) +#endif +c + if ( degre.eq.1 ) then + kaux = edqua4 + else + kaux = edqua8 + endif +c + 430 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Type des '//mess14(langue,3,4), kaux +#endif +c + cfaqua(cotyel,nbfqua+1) = kaux +c +c 4.4. ==> la famille des aretes tracees : la famille libre +c + cfaqua(cofafa,nbfqua+1) = 1 +c +c 4.5. ==> total des familles +c + nbfqua = nbfqua + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,4,4), nufamd(2) + write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua +#endif +c + if ( nbfqua.gt.nbfqum ) then + write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua + write (ulsort,texte(langue,5)) nbfqum + write (ulsort,texte(langue,6)) + codret = 1 + endif +c + endif +c +c==== +c 5. On ajoute une nouvelle famille de triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Ajout fam. triangles; codret', codret +#endif +c + if ( nbtria.ne.0 .or. nbtetr.ne.0 .or. nbpent.ne.0 ) then +c +c 5.1. ==> a priori, aucune caracteristique particuliere +c + do 51 , iaux = 1 , nctftr + cfatri(iaux,nbftri+1) = 0 + 51 continue +c +c 5.2. ==> La famille MED +c + cfatri(cofamd,nbftri+1) = nufamd(3) +c +c 5.3. ==> le type des elements est le meme que celui d'une +c autre famille +c si aucun n'est trouve, on l'impose +c + kaux = 0 +c + do 53 , iaux = 1 , nbftri +c + if ( cfatri(cotyel,iaux).ne.0 ) then + kaux = cfatri(cotyel,iaux) + goto 530 + endif +c + 53 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,2) +#endif +c + if ( degre.eq.1 ) then + kaux = edtri3 + else + kaux = edtri6 + endif +c + 530 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Type des '//mess14(langue,3,2), kaux +#endif +c + cfatri(cotyel,nbftri+1) = kaux +c +c 5.4. ==> la famille des aretes tracees : la famille libre +c + cfatri(cofafa,nbftri+1) = 1 +c +c 5.5. ==> total des familles +c + nbftri = nbftri + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,4,2), nufamd(3) + write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri +#endif +c + if ( nbftri.gt.nbftrm ) then + write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri + write (ulsort,texte(langue,5)) nbftrm + write (ulsort,texte(langue,6)) + codret = 1 + endif +c + endif +c +c==== +c 6. modification des structures des familles MED +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. modification ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 61 , iaux = 1 , 3 +c + if ( codret.eq.0 ) then +c + jaux = nbfme0+iaux +c + do 611 , kaux = 1 , 10 + nomfam(kaux,jaux) = blan08 + 611 continue +c + numfam(jaux) = nufamd(iaux) + call utench ( nufamd(iaux), '_', kaux, saux08, + > ulsort, langue, codret ) +c 12345678 + nomfam(1,jaux) = 'HOMARD__' + nomfam(2,jaux)(1:kaux) = saux08(1:kaux) +c +c un groupe dont le nom est 'HOMARD', mais que l'on astreint a +c une longueur totale de 80 caracteres pour etre coherent avec MED +c + grfmpo(jaux) = grfmpo(jaux-1) + 10 + do 610 , kaux = grfmpo(jaux-1)+1 , grfmpo(jaux) + grfmta(kaux) = 8 + grfmtb(kaux) = blan08 + 610 continue +c 12345678 + grfmtb(grfmpo(jaux-1)+1) = 'HOMARD ' +c + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ1.F b/src/tool/AV_Conversion/vcequ1.F new file mode 100644 index 00000000..fc1b53c2 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ1.F @@ -0,0 +1,279 @@ + subroutine vcequ1 ( nunoex, nuelex, + > noehom, nnosho, eqnoeu, + > arehom, narsho, eqaret, + > trihom, ntrsho, eqtria, + > quahom, nqusho, eqquad, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 1 +c - - --- - +c +c remarque : ce traitement suppose qu'une entite ne possede pas plus +c d'un homologue. Si des cas plus compliques apparaissent, +c il faudra modifier la structure des equivalences +c +c on fait une traduction bete des donnees en entree. +c pour chaque couple d'entite (e1,e2) donnees comme homologue, on +c note entequ(e1)=+-e2 et entequ(e2)=+-e1 +c on fait evidemment les changements de numerotation appropries. +c +c remarque importante : reperage des elements homologues +c on prend la convention de reperage suivante : lorsque +c l'on a deux faces periodiques 1 et 2, on attribue un signe a +c chacune des faces. pour un noeud "i", noehom(i) est alors egal +c a la valeur suivante : +c - "le numero du noeud correspondant par periodicite +c si i est sur la face 2" +c - "l'oppose du numero du noeud correspondant par periodicite +c si i est sur la face 1" +c +c Donc, on etend cette convention a toutes les entites noeuds, +c aretes, triangles et quadrangles : +c enthom(i) = abs(homologue(i)) ssi i est sur la face 2 +c enthom(i) = -abs(homologue(i)) ssi i est sur la face 1 +c +c pour une entite situee sur l'axe, on prend la convention positive +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . nunoex . e . nbnoto . numerotation des noeuds en exterieur . +c . noehom . s . nbnoto . liste etendue des homologues par noeuds . +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . eqnoeu . e .2*nbeqno. ensemble des noeuds homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . arehom . s . nbarto . liste etendue des homologues par aretes . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . eqaret . e .2*nbeqar. ensemble des aretes homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . trihom . s . nbtrto . ensemble des triangles homologues . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . eqtria . e .2*nbeqtr. ensemble des triangles homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . quahom . s . nbquto . ensemble des quadrangles homologues . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . eqquad . e .2*nbeqqu. ensemble des quadrangles homologues ; leurs. +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer nunoex(nbnoto), nuelex(nbelem) + integer noehom(nbnoto), nnosho(rsnoac), eqnoeu(2*nbeqno) + integer arehom(nbarto), narsho(rsarac), eqaret(2*nbeqar) + integer trihom(nbtrto), ntrsho(rstrac), eqtria(2*nbeqtr) + integer quahom(nbquto), nqusho(rsquac), eqquad(2*nbeqqu) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. prise en compte des donnees sur les noeuds homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. noeuds ; codret = ', codret +#endif +c + if ( nbeqar.ne.0 .or. nbeqtr.ne.0 .or. nbeqqu.ne.0 ) then + do 21 , iaux = 1 , nbnoto + noehom(iaux) = 0 + 21 continue + endif +c + iaux = -1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU3_no', nompro +#endif + call vcequ3 ( iaux, + > nbnoto, nbeqno, jaux, + > nunoex, noehom, nnosho, eqnoeu, + > ulsort, langue, codret ) +cgn print *,nompro,' apres 2' +cgn print *,'noehom' +cgn print 1789,(noehom(iaux),iaux=1,27) +cgn 1787 format(4I4) +cgn 1788 format(8I4) +cgn 1789 format(10I4) +c +c==== +c 3. prise en compte des donnees sur les aretes homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. aretes ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbeqtr.ne.0 .or. nbeqqu.ne.0 ) then + do 31 , iaux = 1 , nbarto + arehom(iaux) = 0 + 31 continue + endif +c + iaux = 1 + jaux = nbtetr + nbtria +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU3_ar', nompro +#endif + call vcequ3 ( iaux, + > nbarto, nbeqar, jaux, + > nuelex, arehom, narsho, eqaret, + > ulsort, langue, codret ) +c + endif +cgn print *,nompro,' apres 3' +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) +c +c==== +c 4. prise en compte des donnees sur les triangles homologues +c on complete la liste, en verifiant que si il y a deja un +c homologue, c'est le bon ! +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. triangles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = nbtetr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU3_tr', nompro +#endif + call vcequ3 ( iaux, + > nbtrto, nbeqtr, jaux, + > nuelex, trihom, ntrsho, eqtria, + > ulsort, langue, codret ) +c + endif +cgn print *,nompro,' apres 4' +cgn print *,'trihom' +cgn print 1788,(trihom(iaux),iaux=1,16) +c +c==== +c 5. prise en compte des donnees sur les quadrangles homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. quadrangles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = nbtetr + nbtria + nbsegm + nbmapo +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU3_qu', nompro +#endif + call vcequ3 ( iaux, + > nbquto, nbeqqu, jaux, + > nuelex, quahom, nqusho, eqquad, + > ulsort, langue, codret ) +c + endif +cgn print *,nompro,' apres 5' +cgn print *,'quahom' +cgn print 1787,(quahom(iaux),iaux=1,8) +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ2.F b/src/tool/AV_Conversion/vcequ2.F new file mode 100644 index 00000000..2534ae5a --- /dev/null +++ b/src/tool/AV_Conversion/vcequ2.F @@ -0,0 +1,468 @@ + subroutine vcequ2 ( noehom, arehom, + > trihom, quahom, + > somare, np2are, + > aretri, arequa, + > posifa, facare, + > povoso, voisom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 2 +c - - --- - +c +c remarque : ce traitement suppose qu'une entite ne possede pas plus +c d'un homologue. Si des cas plus compliques apparaissent, +c il faudra modifier la structure des equivalences +c +c on enrichit la structure pour pouvoir passer l'algorithme et la +c reconstruction future. pour chaque triangle homologue, on repere +c les trois aretes et on les declare homologues. Idem pour les +c aretes des quadrangles. Idem pour les noeuds des aretes. +c si on ne fait pas cette operation, on est incapable d'associer les +c filles des entites homologues. On ne saura pas apparier dans le +c bon sens. +c attention, on ne fait pas le processus dans l'autre sens : deduire +c des equivalences sur des aretes a partir d'equivalences sur les +c noeuds reviendrait a extrapoler les informations donnees en entree. +c +c remarque importante : reperage des elements homologues +c on prend la convention de reperage suivante : lorsque +c l'on a deux faces periodiques 1 et 2, on attribue un signe a +c chacune des faces. pour un noeud "i", noehom(i) est alors egal +c a la valeur suivante : +c - "le numero du noeud correspondant par periodicite +c si i est sur la face 2" +c - "l'oppose du numero du noeud correspondant par periodicite +c si i est sur la face 1" +c +c Donc, on etend cette convention a toutes les entites noeuds, +c aretes et triangles : +c enthom(i) = abs(homologue(i)) ssi i est sur la face 2 +c enthom(i) = -abs(homologue(i)) ssi i est sur la face 1 +c pour une entite situee sur l'axe, on prend la convention positive. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noehom . es . nbnoto . liste etendue des homologues par noeuds . +c . arehom . es . nbarto . liste etendue des homologues par aretes . +c . trihom . es . nbtrto . ensemble des triangles homologues . +c . quahom . es . nbquto . ensemble des quadrangles homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud milieu de l'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . elements 1d, 2d ou 3d voisins par sommet . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nbutil.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto), arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer somare(2,nbarto), np2are(nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer posifa(0:nbarto), facare(nbfaar) + integer povoso(0:nbnoto), voisom(nvosom) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entlo1, entlo2 + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''Infos donnees en numerotation HOMARD'')' + texte(1,6) = '(a,i10,'' est homologue de'',i10)' + texte(1,7) = '(/,''Equivalence sur les '',a)' + texte(1,8) = + > '(''. Nombre de '',a,''homologues enregistres :'',i2)' + texte(1,9) = '(/,''. Analyse des '',a,i10,'' et'',i10)' +c + texte(2,5) = '(''Infos given with HOMARD #'')' + texte(2,6) = '(a,i10,'' is homologous with'',i10)' + texte(2,7) = '(/,''Equivalence for '',a)' + texte(2,8) = '(''. Number of known homologous '',a,'' :'',i2)' + texte(2,9) = '(/,''. Analysis of '',a,i10,'' and'',i10)' +c + codret = 0 +c +c==== +c 2. enrichissement de la structure sur les aretes a partir de la +c donnee des triangles et quadrangles homologues +c==== +c + if ( homolo.ge.3 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( nbeqtr.gt.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,2) + write (ulsort,texte(langue,5)) + do 20001 , iaux = 1 , nbtrto + if ( trihom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,2), + > iaux, trihom(iaux) + endif +20001 continue + endif + if ( nbeqqu.gt.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,4) + write (ulsort,texte(langue,5)) + do 20002 , iaux = 1 , nbquto + if ( quahom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,4), + > iaux, quahom(iaux) + endif +20002 continue + endif +#endif +c +c 2.1. ==> on commence par traiter les triangles et les quadrangles +c qui ne sont pas dans un coin de maillage. Autrement dit, il +c ne faut pas que deux de leurs aretes soient au bord +c +c 2.1.1. ==> les triangles +c + if ( nbeqtr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU4_tr', nompro +#endif + call vcequ4 ( iaux, + > arehom, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret ) +cgn print *,nompro,' apres 2.1.1' +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) +c + endif +c + endif +cgn 1787 format(4I4) +cgn 1788 format(8I4) +cgn 1789 format(10I4) +c +c 2.1.2. ==> les quadrangles +c + if ( nbeqqu.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU4_qu', nompro +#endif + call vcequ4 ( iaux, + > arehom, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret ) +c +cgn print *,nompro,' apres 2.1.2' +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,1) + write (ulsort,texte(langue,5)) + do 21000 , iaux = 1 , nbarto + if ( arehom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,1), + > iaux, arehom(iaux) + endif +21000 continue +#endif +c +c 2.2. ==> a partir de cette premiere mise en equivalence des aretes, +c on reporte l'information sur les noeuds +c on boucle uniquement sur les aretes de la face periodique 2 +c + if ( codret.eq.0 ) then +c + do 22 , entlo2 = 1 , nbarto +c + if ( codret.eq.0 ) then +c + entlo1 = arehom(entlo2) +c + if ( entlo1.gt.0 ) then +c + jaux = entlo2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU5', nompro +#endif + call vcequ5 ( entlo1, jaux, + > noehom, arehom, + > somare, np2are, + > povoso, voisom, + > ulsort, langue, codret ) +c + endif +c + endif +c + 22 continue +cgn print *,nompro,' apres 2.2' +cgn print *,'noehom' +cgn print 1789,(noehom(iaux),iaux=1,27) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,-1) + write (ulsort,texte(langue,5)) + do 22000 , iaux = 1 , nbnoto + if ( noehom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,-1), + > iaux, noehom(iaux) + endif +22000 continue +#endif +c +c 2.3. ==> maintenant que l'on a transfere l'information sur les noeuds, +c on s'occupe des triangles ou quadrangles de coin +c +c 2.3.1. ==> les triangles +c + if ( nbeqtr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU6_tr', nompro +#endif + call vcequ6 ( iaux, + > noehom, arehom, + > trihom, quahom, + > somare, aretri, arequa, + > ulsort, langue, codret ) +c +cgn print *,nompro,' apres 2.3.1' +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) +c + endif +c + endif +c +c 2.3.2. ==> les quadrangles +c + if ( nbeqqu.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU6_qu', nompro +#endif + call vcequ6 ( iaux, + > noehom, arehom, + > trihom, quahom, + > somare, aretri, arequa, + > ulsort, langue, codret ) +c +cgn print *,nompro,' apres 2.3.2' +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,1) + write (ulsort,texte(langue,5)) + do 23000 , iaux = 1 , nbarto + if ( arehom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,1), + > iaux, arehom(iaux) + endif +23000 continue +#endif +c +c 2.4. ==> on verifie que toutes les aretes bordant des triangles +c ou des quadrangles ont bien ete enregistrees +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU7', nompro +#endif + call vcequ7 ( arehom, + > trihom, quahom, + > aretri, arequa, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. enrichissement de la structure sur les noeuds a partir de la +c donnee des aretes homologues. cette donnee est soit issue du +c maillage a analyser, soit creee/enrichie par le traitement des +c triangles et des quadrangles homologues. +c il faut faire cette etape apres celle sur les triangles et les +c quadrangles, sinon on oublie de l'information +c==== +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.2 ) then +c + do 31 , entlo2 = 1 , nbarto +c + entlo1 = arehom(entlo2) +c + if ( entlo1.gt.0 ) then +c + jaux = entlo2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU5', nompro +#endif + call vcequ5 ( entlo1, jaux, + > noehom, arehom, + > somare, np2are, + > povoso, voisom, + > ulsort, langue, codret ) +c + endif +c + 31 continue +c +cgn print *,nompro,' apres 3' +cgn print *,'noehom' +cgn print 1789,(noehom(iaux),iaux=1,27) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,-1) + write (ulsort,texte(langue,5)) + do 30000 , iaux = 1 , nbnoto + if ( noehom(iaux).ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,2,-1), + > iaux, noehom(iaux) + endif +30000 continue +#endif +c + endif +c + endif +c +c==== +c 4. decompte du nombre de paires d'entites homologues +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTHONH', nompro +#endif + call uthonh ( noehom, arehom, + > trihom, quahom, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ3.F b/src/tool/AV_Conversion/vcequ3.F new file mode 100644 index 00000000..9bef3d04 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ3.F @@ -0,0 +1,247 @@ + subroutine vcequ3 ( option, + > nbento, nbeqen, ibenti, + > nuenex, enthom, nensho, eqenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 3 +c - - --- - +c +c remarque : ce traitement suppose qu'une entite ne possede pas plus +c d'un homologue. Si des cas plus compliques apparaissent, +c il faudra modifier la structure des equivalences +c +c on fait une traduction bete des donnees en entree. +c pour chaque couple d'entite (e1,e2) donnees comme homologue, on +c note entequ(e1)=+-e2 et entequ(e2)=+-e1 +c on fait evidemment les changements de numerotation appropries. +c +c remarque importante : reperage des elements homologues +c on prend la convention de reperage suivante : lorsque +c l'on a deux faces periodiques 1 et 2, on attribue un signe a +c chacune des faces. pour un noeud "i", noehom(i) est alors egal +c a la valeur suivante : +c - "le numero du noeud correspondant par periodicite +c si i est sur la face 2" +c - "l'oppose du numero du noeud correspondant par periodicite +c si i est sur la face 1" +c +c Donc, on etend cette convention a toutes les entites noeuds, +c aretes, triangles et quadrangles : +c enthom(i) = abs(homologue(i)) ssi i est sur la face 2 +c enthom(i) = -abs(homologue(i)) ssi i est sur la face 1 +c +c pour une entite situee sur l'axe, on prend la convention positive +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . -1 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . nbento . e . 1 . nombre d'entites total . +c . nbeqen . e . 1 . nombre d'equivalence pour cette entite . +c . ibenti . e . 1 . reperage dans la numerotation contigue . +c . . . . des entites . +c . nuenex . e . * . numerotation des entites en exterieur . +c . enthom . s . nbento . liste etendue des entites homologues . +c . . . . enthom(i) = abs(hom(i)) ssi i sur face 2 . +c . . . . enthom(i) = -abs(hom(i)) ssi i sur face 1 . +c . nensho . e . rstrac . numero des entites dans HOMARD . +c . eqenti . e .2*nbeqen. ensemble des entites homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer nbento, nbeqen, ibenti + integer nuenex(*) + integer enthom(nbento), nensho(*), eqenti(2*nbeqen) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entlo1, entlo2 + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Il/Elle devrait l''''etre aussi de'',i10,'' ?'')' + texte(1,5) = '(''Infos donnees en numerotation calcul'',/)' + texte(1,6) = '(''Infos donnees en numerotation HOMARD :'')' + texte(1,7) = '(a,i10,'' : est homologue de'',i10)' + texte(1,8) = '(''Equivalence sur les '',a)' + texte(1,9) = + >'(''Raffinement impossible pour des equivalences multiples.'')' +c + texte(2,4) = '(''It also should be with #'',i10)' + texte(2,5) = '(''Infos given with calculation #'',/)' + texte(2,6) = '(''Infos given with HOMARD # :'')' + texte(2,7) = '(a,i10,'' : is homologous with'',i10)' + texte(2,8) = '(''Equivalence for '',a)' + texte(2,9) = '(''Refinement cannot be done.'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,8)) mess14(langue,3,option) +#endif +c +c==== +c 2. prise en compte des donnees sur les entites homologues +c on complete la liste, en verifiant que si il y a deja un +c homologue, c'est le bon ! +c==== +c +c 2.1. ==> tableaux etendus des entites homologues +c a priori aucun pour le moment +c remarque : on n'initialise les tableaux a 0 que si ils seront +c utilises. comme cela, s'ils le sont sans etre +c passes par ici, il y aura carton. Youpi. +c + if ( nbeqen.ne.0 ) then + do 21 , iaux = 1 , nbento + enthom(iaux) = 0 + 21 continue + endif +c +c 2.2. ==> prise en compte des donnees sur les entites homologues +c on complete la liste, en verifiant que si il y a deja un +c homologue, c'est le bon ! +c pour une entite situee sur l'axe, c'est-a-dire homologues +c d'elle-meme, on prend la convention positive +c + do 22 , iaux = 1 , 2*nbeqen , 2 +c + entlo1 = nensho(nuenex(ibenti+eqenti(iaux))) + entlo2 = nensho(nuenex(ibenti+eqenti(iaux+1))) +c + if ( enthom(entlo1).eq.0 ) then + if ( entlo1.eq.entlo2 ) then + enthom(entlo1) = entlo2 + else + enthom(entlo1) = - entlo2 + endif + else + if ( abs(enthom(entlo1)).ne.entlo2 ) then + write(ulsort,texte(langue,7)) mess14(langue,1,option), + > entlo1, abs(enthom(entlo1)) + write(ulsort,texte(langue,4)) entlo2 + write(ulsort,texte(langue,5)) + codret = 5 + endif + endif +c + if ( enthom(entlo2).eq.0 ) then + enthom(entlo2) = entlo1 + else + if ( abs(enthom(entlo2)).ne.entlo1 ) then + write(ulsort,texte(langue,7)) mess14(langue,1,option), + > entlo2, enthom(entlo2) + write(ulsort,texte(langue,4)) entlo1 + write(ulsort,texte(langue,5)) + codret = 5 + endif + endif +c + 22 continue +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( nbeqen.ne.0 ) then + write(ulsort,texte(langue,6)) + do 31 , iaux = 1 , nbento + if ( enthom(iaux).ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,1,option), + > iaux, enthom(iaux) + endif + 31 continue + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,9)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ4.F b/src/tool/AV_Conversion/vcequ4.F new file mode 100644 index 00000000..8bce0057 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ4.F @@ -0,0 +1,534 @@ + subroutine vcequ4 ( option, + > arehom, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 4 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . arehom . es . nbarto . liste etendue des homologues par aretes . +c . trihom . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer posifa(0:nbarto), facare(nbfaar) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entlo2, entlo1 + integer nbento, nbaret + integer iaux, jaux, kaux, nbrhom + integer iaux1, iaux2 + integer nombre(4) +c + logical coin +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''. Analyse des '',a,i10,'' et'',i10)' + texte(1,5) = '(a,i10,'' : est dans un coin.'')' + texte(1,6) = + > '(''.. Nombre de voisins des aretes de '',i10, '' :'',4i10)' + texte(1,7) = '(a,i10,'' est homologue de'',i10)' + texte(1,8) = '(''... ==> Arete homologue de'',i10,'' :'',i10)' + texte(1,9) = + > '(/,a,i10,'' : les homologues de ses aretes sont incorrectes'')' + texte(1,10) = + > '(''.. Nombre de '',a,''homologues enregistres :'',i2,''/'',i2)' +c + texte(2,4) = '(/,''. Analysis of '',a,i10,'' and'',i10)' + texte(2,5) = '(a,i10,'' : is in an angle.'')' + texte(2,6) = + > '(''.. Number of neighbours of edges of '',i10, '':'',4i10)' + texte(2,7) = + > '(a,''#'',i10,'' is homologous with '',a,''#'',i10)' + texte(2,8) = '(''... ==> Homologous edge of'',i10,'':'',i10)' + texte(2,9) = + > '(/,a,i10,'' : homologous of its edges are uncorrect.'')' + texte(2,10) = + > '(''.. Number of known homologous '',a,'':'',i2,''/'',i2)' +c + codret = 0 +c +c==== +c 2. enrichissement de la structure sur les aretes a partir de la +c donnee des faces homologues +c pour les faces qui sont dans un coin de maillage, on ne pourra +c regler ici que le cas des aretes qui ne sont pas du coin. +c==== +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 21 , entlo2 = 1 , nbento +c + if ( codret.eq.0 ) then +c + if ( option.eq.2 ) then + entlo1 = trihom(entlo2) + else + entlo1 = quahom(entlo2) + endif +c +c on boucle uniquement sur les faces de la face periodique 2 +c + if ( entlo1.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,option), + > entlo2, entlo1 +#endif +c +c 2.1. ==> decompte du nombre de faces voisines pour chacune des +c aretes de la face +c si deux aretes ne possedent qu'un voisin, c'est que la face +c est dans un coin. On le note pour ne traiter que les aretes +c qui ne sont pas du bord. +c + if ( codret.eq.0 ) then +c + coin = .false. +c + if ( option.eq.2 ) then + iaux = entlo2 + else + iaux = -entlo2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNVAF', nompro +#endif + call utnvaf ( nombre, iaux, + > aretri, arequa, posifa, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6))entlo2,(nombre(iaux),iaux=1,nbaret) +#endif + jaux = 0 + do 211 , iaux = 1 , nbaret + if ( nombre(iaux).eq.1 ) then + jaux = jaux + 1 + endif + 211 continue + if ( jaux.ge.2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,2,option), + > entlo2 +#endif + coin = .true. + endif +c + endif +c +c 2.2. ==> decompte du nombre d'aretes deja enregistrees comme +c homologues +c + if ( codret.eq.0 ) then +c + nbrhom = 0 + do 221 , iaux = 1 , nbaret + do 222 , jaux = 1 , nbaret +c + if ( option.eq.2 ) then + if ( arehom(aretri(entlo2,iaux)).eq. + > aretri(entlo1,jaux) ) then + nbrhom = nbrhom + 1 + endif + else + if ( arehom(arequa(entlo2,iaux)).eq. + > arequa(entlo1,jaux) ) then + nbrhom = nbrhom + 1 + endif + endif +c + 222 continue + 221 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,1), + > nbrhom, nbaret +#endif +c + endif +c +c 2.3. ==> si aucune arete n'a d'homologue : on met en relation +c la derniere des aretes qui a au moins deux faces voisines +c avec celle qui lui correspond dans la face homologue. +c pour les autres, on le fera apres. +c si on ne peut pas en trouver une, c'est que la face est +c toute seule, ce qui est impossible pour un maillage normal. +c donc au cas ou iaux1 vaudrait 0, on arrete. +c + if ( codret.eq.0 ) then +c + if ( nbrhom.eq.0 ) then +c + iaux1 = 0 + do 231 , iaux = 1 , nbaret + if ( nombre(iaux).ge.2 ) then + iaux1 = iaux + endif + 231 continue +c + if ( iaux1.ne.0 ) then + if ( option.eq.2 ) then + jaux = aretri(entlo2,iaux1) + else + jaux = arequa(entlo2,iaux1) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQUA', nompro +#endif + call vcequa ( option, + > arehom, + > jaux, entlo2, entlo1, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret) + else + codret = 23 + endif +c + endif +c + endif +c +c 2.4. ==> si au plus une arete a une homologue : on met en relation +c l'une des aretes restantes avec celle qui lui correspond +c dans la face homologue, a condition qu'elle ait au moins +c deux faces voisines. +c si on ne peut pas en trouver une, c'est que la face est +c toute seule, ce qui est impossible pour un maillage normal. +c donc au cas ou iaux1 vaudrait 0, on arrete. +c + if ( codret.eq.0 ) then +c + if ( nbrhom.le.1 ) then +c +c si c'est un triangle de coin, on ne peut plus rien faire ici. +c + if ( option.eq.2 .and. coin ) then + goto 21 + endif +c + iaux1 = 0 + do 241 , iaux = 1 , nbaret + if ( option.eq.2 ) then + if ( arehom(aretri(entlo2,iaux)).eq.0 .and. + > nombre(iaux).ge.2 ) then + iaux1 = iaux + jaux = aretri(entlo2,iaux1) + endif + else + if ( arehom(arequa(entlo2,iaux)).eq.0 .and. + > nombre(iaux).ge.2 ) then + iaux1 = iaux + jaux = arequa(entlo2,iaux1) + endif + endif + 241 continue +c + if ( iaux1.ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQUA', nompro +#endif + call vcequa ( option, + > arehom, + > jaux, entlo2, entlo1, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret) + else + codret = 24 + endif +c + endif +c + endif +c +c 2.5. ==> cas particulier aux quadrangles. On rappelle qu'ils ont 4 +c aretes alors que les triangles n'en ont que 3 ;=) +c s'il reste deux aretes sans homologue : on met en relation +c l'une des aretes avec celle qui lui correspond dans le +c quadrangle homologue, a condition qu'elle ait au moins deux +c faces voisines. pour l'autre, on le fera apres. +c on doit toujours en trouver une, sinon c'est que le test +c du 2.1 a eu un probleme. donc au cas ou iaux1 vaudrait 0, +c on arrete. +c + if ( codret.eq.0 ) then +c + if ( option.eq.4) then +c + if ( nbrhom.le.2 ) then +c +c si c'est un quadrangle de coin, on ne peut plus rien +c faire ici. +c + if ( coin ) then + goto 21 + endif +c + iaux1 = 0 + do 251 , iaux = 1 , nbaret + if ( arehom(arequa(entlo2,iaux)).eq.0 .and. + > nombre(iaux).ge.2 ) then + iaux1 = iaux + jaux = arequa(entlo2,iaux1) + endif + 251 continue +c + if ( iaux1.ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQUA', nompro +#endif + call vcequa ( option, + > arehom, + > jaux, entlo2, entlo1, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret) + else + codret = 25 + endif +c + endif +c + endif +c + endif +c +c 2.6. ==> s'il reste une seule arete sans homologue : on la met +c en equivalence avec sa semblable sur l'autre face +c + if ( codret.eq.0 ) then +c + if ( nbrhom.le.nbaret-1 ) then +c + iaux1 = 0 + iaux2 = 0 + do 261 , iaux = 1 , nbaret + if ( option.eq.2 ) then + if ( arehom(aretri(entlo2,iaux)).eq.0 ) then + iaux1 = iaux + endif + if ( arehom(aretri(entlo1,iaux)).eq.0 ) then + iaux2 = iaux + endif + else + if ( arehom(arequa(entlo2,iaux)).eq.0 ) then + iaux1 = iaux + endif + if ( arehom(arequa(entlo1,iaux)).eq.0 ) then + iaux2 = iaux + endif + endif + 261 continue +c +c par construction, entlo1 est sur la face 1 et entlo2 sur +c la face 2 ; d'ou les signes dans arehom +c + if ( iaux1.ne.0 .and. iaux2.ne.0 ) then + if ( option.eq.2 ) then + iaux = aretri(entlo2,iaux1) + jaux = aretri(entlo1,iaux2) + else + iaux = arequa(entlo2,iaux1) + jaux = arequa(entlo1,iaux2) + endif + arehom(iaux) = jaux + arehom(jaux) = - iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) iaux, jaux +#endif + else + codret = 26 + endif +c + endif +c + endif +c +c 2.7. ==> on verifie que les homologues des aretes sont correctes +c + if ( codret.eq.0 ) then +c + if ( nbrhom.ne.nbaret ) then +c + nbrhom = 0 + do 271 , iaux = 1 , nbaret + do 272 , jaux = 1 , nbaret +c + if ( option.eq.2 ) then + if ( arehom(aretri(entlo2,iaux)).eq. + > aretri(entlo1,jaux) ) then + nbrhom = nbrhom + 1 + endif + else + if ( arehom(arequa(entlo2,iaux)).eq. + > arequa(entlo1,jaux) ) then + nbrhom = nbrhom + 1 + endif + endif +c + 272 continue + 271 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,1), + > nbrhom, nbaret +#endif +c + if ( nbrhom.ne.nbaret ) then +c + do 273 , kaux = 1 , 2 +c + if ( kaux.eq.1 ) then + iaux1 = entlo2 + else + iaux1 = entlo1 + endif + write (ulsort,texte(langue,9)) mess14(langue,2,option), + > iaux1 + do 2731 , iaux = 1 , nbaret + if ( option.eq.2 ) then + jaux = aretri(iaux1,iaux) + else + jaux = arequa(iaux1,iaux) + endif + write (ulsort,texte(langue,7)) mess14(langue,1,1), + > jaux, arehom(jaux) + 2731 continue +c + 273 continue +c + codret = 27 +c + endif +c + endif +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ5.F b/src/tool/AV_Conversion/vcequ5.F new file mode 100644 index 00000000..e9eb9e89 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ5.F @@ -0,0 +1,279 @@ + subroutine vcequ5 ( entlo1, entlo2, + > noehom, arehom, + > somare, np2are, + > povoso, voisom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 5 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . entlo1 . e . 1 . numero de l'arete sur la face 1 . +c . entlo2 . e . 1 . numero de l'arete sur la face 2 . +c . noehom . es . nbnoto . liste etendue des homologues par noeuds . +c . arehom . es . nbarto . liste etendue des homologues par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud milieu de l'arete . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . elements 1d, 2d ou 3d voisins par sommet . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nbutil.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer entlo1, entlo2 + integer noehom(nbnoto), arehom(nbarto) + integer somare(2,nbarto), np2are(nbarto) + integer povoso(0:nbnoto), voisom(nvosom) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entab2 + integer iaux, jaux, nbrhom, ndaux + integer iaux1, iaux2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Il devrait l''''etre aussi de'',i10,'' ?'')' + texte(1,5) = '(''Infos donnees en numerotation HOMARD :'')' + texte(1,6) = '(a,i10,'' : est homologue de'',i10)' + texte(1,7) = + > '(''. Noeuds homologues de l''''arete'',i10,'' :'',i2,''/2'')' +c + texte(2,4) = '(''It also should be with #'',i10)' + texte(2,5) = '(''Infos given with HOMARD # :'')' + texte(2,6) = '(a,i10,'' : is homologous with'',i10)' + texte(2,7) = + > '(''. Homologous nodes of edge'',i10,'' :'',i2,''/2'')' +c + codret = 0 +c +c==== +c 2. definir ou completer les relations d'equivalence entre les noeuds +c lies a une paire d'aretes +c==== +c + entab2 = abs(entlo2) +c +c 2.1. ==> decompte du nombre de noeuds homologues eventuels deja +c enregistrees +c + if ( codret.eq.0 ) then +c + nbrhom = 0 + do 211 , iaux = 1 , 2 + ndaux = abs(noehom(somare(iaux,entlo1))) + do 212 , jaux = 1 , 2 +c + if ( ndaux.eq.somare(jaux,entab2) ) then + nbrhom = nbrhom + 1 + endif +c + 212 continue + 211 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) entlo1, nbrhom +#endif +c + endif +c +c 2.2. ==> si aucun noeud n'a d'homologue : on met en relation celui qui +c limite une autre arete homologue avec celui qui lui +c correspond dans l'arete homologue. +c le second noeud est traite en 2.3. +c + if ( codret.eq.0 ) then +c + if ( nbrhom.eq.0 ) then +c + call vcequn ( entlo1, entlo2, + > noehom, arehom, + > somare, povoso, voisom, + > ulsort, langue, codret) +c + nbrhom = 1 +c + endif +c + endif +c +c 2.3. ==> s'il reste un seul noeud sans homologue : on le met +c en equivalence avec son semblable sur l'autre arete +c + if ( codret.eq.0 ) then +c + if ( nbrhom.le.1 ) then +c + iaux1 = 0 + iaux2 = 0 + do 231 , iaux = 1 , 2 + if ( noehom(somare(iaux,entlo1)).eq.0 ) then + iaux1 = iaux + endif + if ( noehom(somare(iaux,entab2)).eq.0 ) then + iaux2 = iaux + endif + 231 continue +c + if ( iaux1.ne.0 .and. iaux2.ne.0 ) then + noehom(somare(iaux1,entlo1)) = - somare(iaux2,entab2) + noehom(somare(iaux2,entab2)) = somare(iaux1,entlo1) + else + codret = 3 + endif +c + endif +c + endif +c +c 2.4. ==> on verifie qu'il ne reste plus aucun noeud sans son +c homologue +c + if ( codret.eq.0 ) then +c + if ( nbrhom.ne.2 ) then +c + nbrhom = 0 + do 241 , iaux = 1 , 2 + ndaux = abs(noehom(somare(iaux,entlo1))) + do 242 , jaux = 1 , 2 +c + if ( ndaux.eq.somare(jaux,entab2) ) then + nbrhom = nbrhom + 1 + endif +c + 242 continue + 241 continue +c + if ( nbrhom.ne.2 ) then + codret = 3 + endif +c + endif +c + endif +c +c 2.5. ==> en degre 2, on associe les deux noeuds milieux si ce n'est +c pas deja fait +c + if ( codret.eq.0 ) then +c + if ( degre.eq.2 ) then +c + if ( noehom(np2are(entlo1)).eq.0 ) then + noehom(np2are(entlo1)) = np2are(entab2) + else + if ( abs(noehom(np2are(entlo1))).ne.np2are(entab2) ) then + write (ulsort,texte(langue,6)) mess14(langue,2,-1), + > np2are(entlo1), noehom(np2are(entlo1)) + write (ulsort,texte(langue,4)) np2are(entab2) + write (ulsort,texte(langue,5)) + codret = 5 + endif + endif +c + if ( noehom(np2are(entab2)).eq.0 ) then + noehom(np2are(entab2)) = np2are(entlo1) + else + if ( abs(noehom(np2are(entab2))).ne.np2are(entlo1) ) then + write (ulsort,texte(langue,6)) mess14(langue,2,-1), + > np2are(entab2), noehom(np2are(entab2)) + write (ulsort,texte(langue,4)) np2are(entlo1) + write (ulsort,texte(langue,5)) + codret = 5 + endif + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ6.F b/src/tool/AV_Conversion/vcequ6.F new file mode 100644 index 00000000..eb0b7f73 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ6.F @@ -0,0 +1,384 @@ + subroutine vcequ6 ( option, + > noehom, arehom, + > trihom, quahom, + > somare, aretri, arequa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 6 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . noehom . es . nbnoto . liste etendue des homologues par noeuds . +c . arehom . es . nbarto . liste etendue des homologues par aretes . +c . trihom . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer noehom(nbnoto), arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer somare(2,nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entlo2, entlo1 + integer aretea(2), areteb(2) + integer na(2), nb(2), nc(2) + integer nbento, nbaret + integer iaux, jaux, kaux + integer iaux1, iaux2, iaux3, iaux4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Cote'',i2,'' : aretes'',i10,'' et'',i10)' + texte(1,5) = '(''Arete'',i10,'' de'',i10,'' a'',i10)' + texte(1,6) = '(''Noeud'',i10,'' sans homologue ?'')' + texte(1,7) = '(a,i10,'' : est homologue de'',i10)' + texte(1,8) = + > '(''Les noeuds'',i10,'' et'',i10,'' devraient etre homologues'')' + texte(1,9) = '(''.. Aretes du '',a,i10,'' :'',4i10)' + texte(1,10) = '(/,''. Analyse des '',a,i10,'' et'',i10)' +c + texte(2,4) = '(''Face'',i2,'' : edges'',i10,'' and'',i10)' + texte(2,5) = '(''Edge'',i10,'' from'',i10,'' to'',i10)' + texte(2,6) = '(''Node'',i10,'' without any homologous ?'')' + texte(2,7) = '(a,i10,'' : is homologous with'',i10)' + texte(2,8) = + > '(''Nodes'',i10,'' and'',i10,'' should be homologous'')' + texte(2,9) = '(''.. Edges of '',a,i10,'' :'',4i10)' + texte(2,10) = '(/,''. Analysis of '',a,i10,'' and'',i10)' +c + codret = 0 +c +c==== +c 2. enrichissement de la structure sur les aretes a partir de la +c donnee des faces homologues +c ici, on traite les faces qui sont dans un coin de maillage. +c Autrement dit, il doit leur rester deux aretes sans homologues et +c qui se suivent : +c +c X X----------------O +c .. . . +c . . . . +c . . . . +c . . ou . . OK +c . . . . +c . . . . +c . . . . +c O-------O O----------------O +c OK OK +c on va rapprocher les aretes en comparant les noeuds homologues O. +c on en profitera pour enregistrer le dernier noeud X. +c==== +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 21 , entlo2 = 1 , nbento +c + if ( codret.eq.0 ) then +c + if ( option.eq.2 ) then + entlo1 = trihom(entlo2) + else + entlo1 = quahom(entlo2) + endif +c +c on boucle uniquement sur les faces de la face periodique 2 +c + if ( entlo1.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,option), + > entlo2, entlo1 +#endif +c +c 2.1. ==> reperage des deux aretes non encore enregistrees, sur +c chacun des cotes. +c + if ( codret.eq.0 ) then +c + do 211 , iaux = 1 , 2 +c + aretea(iaux) = 0 + areteb(iaux) = 0 + if ( iaux.eq.1 ) then + kaux = entlo1 + else + kaux = entlo2 + endif +#ifdef _DEBUG_HOMARD_ + if ( option.eq.2 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,option), + > kaux, (aretri(kaux,jaux), jaux = 1 , nbaret) + else + write (ulsort,texte(langue,9)) mess14(langue,1,option), + > kaux, (arequa(kaux,jaux), jaux = 1 , nbaret) + endif +#endif +c + do 212 , jaux = 1 , nbaret +c + iaux2 = 0 + if ( option.eq.2 ) then + if ( arehom(aretri(kaux,jaux)).eq.0 ) then + iaux2 = aretri(kaux,jaux) + endif + else + if ( arehom(arequa(kaux,jaux)).eq.0 ) then + iaux2 = arequa(kaux,jaux) + endif + endif + if ( iaux2.ne.0 ) then + if ( aretea(iaux).eq.0 ) then + aretea(iaux) = iaux2 + else + areteb(iaux) = iaux2 + endif + endif +c + 212 continue +c + 211 continue +c + if ( areteb(1).eq.0 .and. areteb(2).eq.0 ) then + goto 21 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 1, aretea(1), areteb(1) + write (ulsort,texte(langue,4)) 2, aretea(2), areteb(2) +#endif +c + endif +c +c 2.2. ==> pour chaque cote, on repere les deux noeuds extremites +c et le noeud central +c +c 0----------------------X----------------------0 +c NA(i) aretea(i) NB(i) areteb(i) NC(i) +c + if ( codret.eq.0 ) then +c + do 221 , iaux = 1 , 2 +c + iaux1 = somare(1,aretea(iaux)) + iaux2 = somare(2,aretea(iaux)) + iaux3 = somare(1,areteb(iaux)) + iaux4 = somare(2,areteb(iaux)) +c + if ( iaux1.eq.iaux3 ) then + na(iaux) = iaux2 + nb(iaux) = iaux1 + nc(iaux) = iaux4 + elseif ( iaux1.eq.iaux4 ) then + na(iaux) = iaux2 + nb(iaux) = iaux1 + nc(iaux) = iaux3 + elseif ( iaux2.eq.iaux3 ) then + na(iaux) = iaux1 + nb(iaux) = iaux2 + nc(iaux) = iaux4 + elseif ( iaux2.eq.iaux4 ) then + na(iaux) = iaux1 + nb(iaux) = iaux2 + nc(iaux) = iaux3 + else + write (ulsort,texte(langue,5)) aretea(iaux), iaux1, iaux2 + write (ulsort,texte(langue,5)) areteb(iaux), iaux3, iaux4 + codret = 3 + endif +c + 221 continue +c + endif +c +c 2.3. ==> on repere les homologues +c +c 0----------------------X----------------------0 +c NA(i) aretea(i) NB(i) areteb(i) NC(i) +c + if ( codret.eq.0 ) then +c +c 2.3.1. ==> mise en equivalence des aretes +c + if ( abs(noehom(na(1))).eq.na(2) ) then +c + if ( abs(noehom(nc(1))).eq.nc(2) ) then + iaux1 = aretea(2) + iaux2 = areteb(2) + else + write (ulsort,texte(langue,7)) mess14(langue,2,-1), + > na(1), na(2) + write (ulsort,texte(langue,8)) nc(1), nc(2) + codret = 5 + endif +c + elseif ( abs(noehom(na(1))).eq.nc(2) ) then +c + if ( abs(noehom(nc(1))).eq.na(2) ) then + iaux1 = areteb(2) + iaux2 = aretea(2) + else + write (ulsort,texte(langue,7)) mess14(langue,2,-1), + > na(1), nc(2) + write (ulsort,texte(langue,8)) nc(1), na(2) + codret = 5 + endif +c + else +c + write (ulsort,texte(langue,6)) na(1) + codret = 5 +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + arehom(aretea(1)) = -iaux1 + arehom(areteb(1)) = -iaux2 + arehom(iaux1) = aretea(1) + arehom(iaux2) = areteb(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,2,1), + > iaux1, aretea(1) + write (ulsort,texte(langue,7)) mess14(langue,2,1), + > iaux2, areteb(1) +#endif +c + endif +c +c 2.3.2. ==> mise en equivalence du noeud central +c + if ( codret.eq.0 ) then +c + if ( noehom(nb(1)).eq.0 .and. noehom(nb(2)).eq.0 ) then +c + noehom(nb(1)) = -nb(2) + noehom(nb(2)) = nb(1) +c + else +c + if ( noehom(nb(1)).ne.-nb(2) ) then + write (ulsort,texte(langue,7)) mess14(langue,2,-1), + > nb(1), noehom(nb(1)) + write (ulsort,texte(langue,8)) nb(1), nb(2) + codret = 5 + endif +c + endif +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequ7.F b/src/tool/AV_Conversion/vcequ7.F new file mode 100644 index 00000000..e4f6dc38 --- /dev/null +++ b/src/tool/AV_Conversion/vcequ7.F @@ -0,0 +1,183 @@ + subroutine vcequ7 ( arehom, + > trihom, quahom, + > aretri, arequa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - phase 7 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arehom . e . nbarto . liste etendue des homologues par aretes . +c . trihom . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQU7' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer entlo1, entlo2 + integer nbento, nbaret + integer iaux, jaux + integer option +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(a,i10,'' : l''''arete'',i10,'' est sans homologue.'')' + texte(1,9) = '(/,''. Analyse des '',a,i10,'' et'',i10)' +c + texte(2,4) = '(a,i10,'' : edge'',i10,'' has not homologous'')' + texte(2,9) = '(/,''. Analysis of '',a,i10,'' and'',i10)' +c + codret = 0 +c +c==== +c 2. controle des aretes des triangles puis des quadrangles +c==== +c + do 2 , option = 2, 4, 2 +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 21 , entlo1 = 1 , nbento +c + if ( option.eq.2 ) then + entlo2 = trihom(entlo1) + else + entlo2 = quahom(entlo1) + endif +c + if ( entlo2.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,option), + > entlo1, entlo2 +#endif +c + do 211 , iaux = 1 , nbaret +c + jaux = 0 + if ( option.eq.2 ) then + if ( arehom(aretri(entlo1,iaux)).eq.0 ) then + jaux = aretri(entlo1,iaux) + endif + else + if ( arehom(arequa(entlo1,iaux)).eq.0 ) then + jaux = arequa(entlo1,iaux) + endif + endif + if ( jaux.ne.0 ) then + codret = codret + 1 + write (ulsort,texte(langue,4)) mess14(langue,1,option), + > entlo1, jaux + endif +c + 211 continue +c + endif +c + 21 continue +c + 2 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequa.F b/src/tool/AV_Conversion/vcequa.F new file mode 100644 index 00000000..0e2b414e --- /dev/null +++ b/src/tool/AV_Conversion/vcequa.F @@ -0,0 +1,397 @@ + subroutine vcequa ( option, + > arehom, + > laret2, face2, face1, + > trihom, quahom, + > aretri, arequa, + > posifa, facare, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - Arete +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . arehom . es . nbarto . liste etendue des homologues par aretes . +c . laret2 . e . 1 . numero global de l'arete de la face face2 . +c . face2 . e . 1 . numero global de la face sur la face 2 . +c . face1 . e . 1 . numero global de la face sur la face 1 . +c . trihom . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQUA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer arehom(nbarto) + integer laret2, face2, face1 + integer trihom(nbtrto), quahom(nbquto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer posifa(0:nbarto), facare(nbfaar) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, laret1, araux + integer letria, lequad + integer ideb, ifin + integer iaux, jaux, kaux +c + logical afaire +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Examen de l''''arete'',i10,'' du '',a,i10)' + texte(1,5) = + >'(''Impossible de trouver l''''homologue de l''''arete'',i10)' + texte(1,6) = + >'(''... Examen de la face '',i10,'', voisine de l''''arete'',i10)' + texte(1,7) = '(''... ==> Arete homologue de'',i10,'' :'',i10)' + texte(1,8) = '(''.. Aretes du '',a,i10,'' :'',4i10)' + texte(1,9) = '(/,''. Analyse des '',a,i10,'' et'',i10)' + texte(1,10) = '(''.. L''''arete'',i10,'' est sur l''''axe.'')' + texte(1,11) = '(''..... Rien a faire.'')' + texte(1,20) = '(a,i10,'' est homologue du '',a,i10)' +c + texte(2,4) = '(''.. Examination of edge '',i10,'' of '',a,i10)' + texte(2,5) = + > '(''Homologous for edge #'',i10,''cannot be found.'')' + texte(2,6) = + > '(''... Examination of face '',i10,'', of edge '',i10)' + texte(2,7) = '(''... ==> Homologous edge of'',i10,'' :'',i10)' + texte(2,8) = '(''.. Edges of '',a,i10,'' :'',4i10)' + texte(2,9) = '(/,''. Analysis of '',a,i10,'' and'',i10)' + texte(2,10) = '(''.. Edge'',i10,'' is on the axis.'')' + texte(2,11) = '(''..... No interest.'')' + texte(2,20) = + > '(a,''#'',i10,'' is homologous with '',a,''#'',i10)' +c +#ifdef _DEBUG_HOMARD_ +cc write (ulsort,texte(langue,9)) mess14(langue,3,option), +cc > face2, face1 + write (ulsort,texte(langue,4)) laret2, mess14(langue,1,option), + > face2 + if ( option.eq.2 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face2, (aretri(face2,kaux), kaux = 1 , 3) + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face1, (aretri(face1,kaux), kaux = 1 , 3) + else + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face2, (arequa(face2,kaux), kaux = 1 , 4) + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face1, (arequa(face1,kaux), kaux = 1 , 4) + endif +#endif +c +c 1.2. ==> on recherche l'arete laret1 de la face face1 qui est +c homologue de l'arete numero laret2 dans la face face2 +c a priori, on n'a rien trouve +c + laret1 = 0 +c +c==== +c 2. on commence par voir si l'arete laret2 n'appartiendrait pas +c aux deux faces. Cela veut dire qu'elle est sur l'axe +c si c'est le cas, on l'enregistre et c'est bon +c==== +c + if ( codret.eq.0 ) then +c + if ( option.eq.2 ) then + do 21 , kaux = 1 , 3 + if ( laret2.eq.aretri(face1,kaux) ) then + laret1 = laret2 + endif + 21 continue + else + do 22 , kaux = 1 , 4 + if ( laret2.eq.arequa(face1,kaux) ) then + laret1 = laret2 + endif + 22 continue + endif +c + if ( laret1.ne.0 ) then + arehom(laret1) = laret1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) laret2 + write (ulsort,texte(langue,7)) laret2, laret1 +#endif + endif +c + endif +c +c==== +c 3. quand l'arete laret2 n'est pas sur l'axe, on boucle sur toutes les +c faces qui possedent l'arete laret2 et on s'interesse a celles qui : +c . ne sont pas la face courante +c . ont une homologue +c +c on cherche alors l'arete commune entre cette homologue et la +c face face1 : c'est celle a mettre en equivalence +c cela part du principe que les voisinages sont obligatoirement les +c memes sur les deux faces. +c +c==== +c + if ( codret.eq.0 ) then +c + if ( laret1.eq.0 ) then +c + ideb = posifa(laret2-1)+1 + ifin = posifa(laret2) +c + do 30 , iaux = ideb , ifin +c + laface = facare(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) laface, laret2 +#endif +c + afaire = .false. +c + if ( laface.gt.0 ) then +c +c 3.1. ==> laface est un triangle +c on poursuit s'il a un homologue et si ce n'est pas le +c triangle courant +c + letria = trihom(laface) + if ( letria.ne.0 ) then + if ( option.eq.4 ) then + afaire = .true. + else + if ( laface.ne.face2 ) then + afaire = .true. + endif + endif + endif +c + if ( afaire ) then +c +c on cherche parmi les aretes de letria, situe sur la face 1, +c celle qui est commune au triangle homologue face1. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) '... '//mess14(langue,2,2), + > letria, mess14(langue,1,2), laface + write (ulsort,texte(langue,8)) mess14(langue,1,2), + > letria, (aretri(letria,kaux), kaux = 1 , 3) +#endif + do 311 , jaux = 1 , 3 + araux = aretri(letria,jaux) + if ( option.eq.2 ) then + do 312 , kaux = 1 , 3 + if ( araux.eq.aretri(face1,kaux) ) then + if ( laret1.eq.0 ) then + laret1 = aretri(face1,kaux) + else + codret = 312 + endif + endif + 312 continue + else + do 313 , kaux = 1 , 4 + if ( araux.eq.arequa(face1,kaux) ) then + if ( laret1.eq.0 ) then + laret1 = arequa(face1,kaux) + else + codret = 313 + endif + endif + 313 continue + endif + 311 continue +c + endif +c +c 3.2. ==> laface est un quadrangle +c on poursuit s'il a un homologue et si ce n'est pas le +c quadrangle courant +c + else +c + lequad = abs(quahom(abs(laface))) + if ( lequad.ne.0 ) then + if ( option.eq.2 ) then + afaire = .true. + else + if ( abs(laface).ne.face2 ) then + afaire = .true. + endif + endif + endif +c + if ( afaire ) then +c +c on cherche parmi les aretes de lequad, situe sur la face 1, +c celle qui est commune au quadrangle homologue face1. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) '... '//mess14(langue,2,4), + > lequad, mess14(langue,1,4), abs(laface) + write (ulsort,texte(langue,8)) mess14(langue,1,4), + > lequad, (arequa(lequad,kaux), kaux = 1 , 4) +#endif + do 321 , jaux = 1 , 4 + araux = arequa(lequad,jaux) + if ( option.eq.2 ) then + do 322 , kaux = 1 , 3 + if ( araux.eq.aretri(face1,kaux) ) then + if ( laret1.eq.0 ) then + laret1 = aretri(face1,kaux) + else + codret = 322 + endif + endif + 322 continue + else + do 323 , kaux = 1 , 4 + if ( araux.eq.arequa(face1,kaux) ) then + if ( laret1.eq.0 ) then + laret1 = arequa(face1,kaux) + else + codret = 323 + endif + endif + 323 continue + endif + 321 continue +c +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,11)) +#endif + endif +c + endif +c + 30 continue +c +c 3.3. ==> enregistrement +c par construction, laret1 est sur la face 1 et laret2 sur +c la face 2 ; d'ou les signes dans arehom +c + if ( laret1.ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) laret2, laret1 +#endif + arehom(laret2) = laret1 + arehom(laret1) = - laret2 + else + codret = 5 + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,20)) mess14(langue,2,option), face1, + > mess14(langue,1,option), face2 + if ( option.eq.2 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face2, (aretri(face2,kaux), kaux = 1 , 3) + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face1, (aretri(face1,kaux), kaux = 1 , 3) + else + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face2, (arequa(face2,kaux), kaux = 1 , 4) + write (ulsort,texte(langue,8)) mess14(langue,1,option), + > face1, (arequa(face1,kaux), kaux = 1 , 4) + endif + write (ulsort,texte(langue,5)) laret2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequi.F b/src/tool/AV_Conversion/vcequi.F new file mode 100644 index 00000000..74a0a8e6 --- /dev/null +++ b/src/tool/AV_Conversion/vcequi.F @@ -0,0 +1,321 @@ + subroutine vcequi ( nunoex, nuelex, + > coexno, nnosho, eqnoeu, + > coexar, narsho, eqaret, + > coextr, ntrsho, eqtria, + > coexqu, nqusho, eqquad, + > eqpntr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUIvalence +c - - ---- +c ______________________________________________________________________ +c +c but : prise en compte pour chaque entite de l'appartenance a une +c equivalence +c on a 1 si l'entite appartient a l'equivalence, 0 sinon. +c +c les numeros d'entites stockes dans les listes des equivalences +c de noeuds ou d'elements sont exprimes dans la numerotation +c originale du maillage et non pas la numerotation compactee +c de 1 a N de la structure Maillage de Calcul. on doit donc faire +c appel aux renumerotations pour etablir les codes des familles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . nunoex . e . nbnoto . numerotation des noeuds en exterieur . +c . coexno . es . nbnoto*. codes de conditions aux limites portants . +c . . . nctfno . sur les noeuds . +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . eqnoeu . e .2*nbeqno. ensemble des noeuds homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . eqaret . e .2*nbeqar. ensemble des aretes homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . coextr . es . nbtrto*. codes de conditions aux limites portants . +c . . . nctftr . sur les triangles . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . eqtria . e .2*nbeqtr. ensemble des triangles homologues ; leurs . +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . eqquad . e .2*nbeqqu. ensemble des quadrangles homologues ; leurs. +c . . . . numeros sont dans la numerotation du code . +c . . . . de calcul . +c . eqpntr . e .5*nbequi. 5i-4 : nombre de paires de noeuds pour . +c . . . . l'equivalence i . +c . . . . 5i-3 : idem pour les mailles-points . +c . . . . 5i-2 : idem pour les aretes . +c . . . . 5i-1 : idem pour les triangles . +c . . . . 5i : idem pour les quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQUI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nbutil.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nunoex(nbnoto), nuelex(nbelem) + integer coexno(nbnoto,nctfno), nnosho(rsnoac), eqnoeu(2*nbeqno) + integer coexar(nbarto,nctfar), narsho(rsarac), eqaret(2*nbeqar) + integer coextr(nbtrto,nctftr), ntrsho(rstrac), eqtria(2*nbeqtr) + integer coexqu(nbquto,nctfqu), nqusho(rsquac), eqquad(2*nbeqqu) + integer eqpntr(5*nbequi) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer ibtria, ibsegm, ibquad + integer ideb, ifin + integer iaux, jaux, kaux, laux + integer iaux1, iaux2, iaux3, iaux4 + integer debcon, debcoa, debcot, debcoq +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Equivalence numero '',i4)' + texte(1,5) = '(''. il y a'',i10,'' paires de '',a)' +c + texte(1,4) = '(/,''Equivalence # '',i4)' + texte(2,5) = '(''. with'',i10,'' pairs of '',a)' +c + codret = 0 +c +c 1.2. ==> reperage dans la numerotation contigue des elements +c + ibtria = nbtetr + ibsegm = nbtetr + nbtria + ibquad = nbtetr + nbtria + nbsegm + nbmapo +c +c==== +c 3. a priori, les entites ne font partie d'aucune equivalence +c==== +c +c 3.1. ==> noeuds +c + ifin = nctfno + debcon = ifin - ncefno + 1 + do 31 , iaux = debcon , ifin + do 311 , jaux = 1 , nbnoto + coexno(jaux,iaux) = 0 + 311 continue + 31 continue +c +c 3.2. ==> aretes +c + ifin = nctfar + debcoa = ifin - ncefar + 1 + do 32 , iaux = debcoa, ifin + do 321 , jaux = 1 , nbarto + coexar(jaux,iaux) = 0 + 321 continue + 32 continue +c +c 3.3. ==> triangles +c + ifin = nctftr + debcot = ifin - nceftr + 1 +cgn print *,debcot, ifin + do 33 , iaux = debcot, ifin + do 331 , jaux = 1 , nbtrto + coextr(jaux,iaux) = 0 + 331 continue + 33 continue +c +c 3.4. ==> quadrangles +c + ifin = nctfqu + debcoq = ifin - ncefqu + 1 +cgn print *,debcoq, ifin + do 34 , iaux = debcoq, ifin + do 341 , jaux = 1 , nbquto + coexqu(jaux,iaux) = 0 + 341 continue + 34 continue +c +c==== +c 4. on passe en revue toutes les equivalences +c==== +c + iaux1 = -1 + iaux2 = -1 + iaux3 = -1 + iaux4 = -1 +c + do 40 , jaux = 1 , nbequi +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) jaux +#endif +c +c 4.1. ==> les noeuds +c + laux = eqpntr(5*jaux-4) +c + if ( laux.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) laux, mess14(langue,3,-1) +#endif + ideb = iaux1 + 2 + iaux1 = iaux1 + 2*laux + kaux = debcon - 1 + jaux + do 401 , iaux = ideb, iaux1, 2 + coexno(nnosho(nunoex(eqnoeu(iaux))),kaux) = 1 + coexno(nnosho(nunoex(eqnoeu(iaux+1))),kaux) = 1 + 401 continue +c + endif +c +c 4.2. ==> les aretes +c + laux = eqpntr(5*jaux-2) +c + if ( laux.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) laux, mess14(langue,3,1) +#endif + ideb = iaux2 + 2 + iaux2 = iaux2 + 2*laux + kaux = debcoa - 1 + jaux + do 402 , iaux = ideb, iaux2, 2 + coexar(narsho(nuelex(ibsegm+eqaret(iaux))),kaux) = 1 + coexar(narsho(nuelex(ibsegm+eqaret(iaux+1))),kaux) = 1 + 402 continue +c + endif +c +c 4.3. ==> les triangles +c + laux = eqpntr(5*jaux-1) +c + if ( laux.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) laux, mess14(langue,3,2) +#endif + ideb = iaux3 + 2 + iaux3 = iaux3 + 2*laux + kaux = debcot - 1 + jaux + do 403 , iaux = ideb, iaux3, 2 + coextr(ntrsho(nuelex(ibtria+eqtria(iaux))),kaux) = 1 + coextr(ntrsho(nuelex(ibtria+eqtria(iaux+1))),kaux) = 1 + 403 continue +c + endif +c +c 4.4. ==> les quadrangles +c + laux = eqpntr(5*jaux) +c + if ( laux.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) laux, mess14(langue,3,4) +#endif + ideb = iaux4 + 2 + iaux4 = iaux4 + 2*laux + kaux = debcoq - 1 + jaux + do 404 , iaux = ideb, iaux4, 2 + coexqu(nqusho(nuelex(ibquad+eqquad(iaux))),kaux) = 1 + coexqu(nqusho(nuelex(ibquad+eqquad(iaux+1))),kaux) = 1 + 404 continue +c + endif +c + 40 continue +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcequn.F b/src/tool/AV_Conversion/vcequn.F new file mode 100644 index 00000000..a2979648 --- /dev/null +++ b/src/tool/AV_Conversion/vcequn.F @@ -0,0 +1,264 @@ + subroutine vcequn ( laret1, laret2, + > noehom, arehom, + > somare, povoso, voisom, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation Conversion - EQUivalence - Noeud +c - - --- - +c Cela permet de mettre en association les noeuds lies a une +c paire d'aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . laret1 . e . 1 . numero global de l'arete de depart . +c . laret2 . e . 1 . numero global de l'arete d'arrivee . +c . noehom . es . nbnoto . liste etendue des homologues par noeuds . +c . arehom . e . nbarto . liste etendue des homologues par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . elements 1d, 2d ou 3d voisins par sommet . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCEQUN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nbutil.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto) + integer laret1, laret2 + integer arehom(nbarto) + integer somare(2,nbarto), povoso(0:nbnoto), voisom(nvosom) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete, noeud, ndaux + integer noeud1, noeud2 + integer ideb, ifin + integer iaux, jaux, kaux, laux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Impossible de trouver l''''homologue du noeud'',i10)' +#ifdef _DEBUG_HOMARD_ + texte(1,5) = '(''. Recherche de l''''homologue du noeud'',i10)' + texte(1,6) = '(''Aretes'',i10,'' et'',i10)' + texte(1,7) = + > '(''.. Examen de l''''arete'',i10,'' (homologue'',i10,'')'')' + texte(1,8) = '(''... Noeud'',i10,'' (ndaux)'')' + texte(1,9) = '(''.... Noeud'',i10,'' (somare)'')' +#endif + texte(1,10) = '(a,i10,'' : est homologue de'',i10)' +c + texte(2,4) = + > '(''Homologous for node #'',i10,''cannot be found.'')' +#ifdef _DEBUG_HOMARD_ + texte(2,5) = '(''. Search for the homologous for node # '',i10)' + texte(2,6) = '(''Edges'',i10,'' and'',i10)' + texte(2,7) = + > '(''.. Check for edge #'',i10,'' (homologous'',i10,'')'')' + texte(2,8) = '(''... Node'',i10,'' (ndaux)'')' + texte(2,9) = '(''.... Node'',i10,'' (somare)'')' +#endif + texte(2,10) = '(a,i10,'' : is homologous with'',i10)' +c +c==== +c 2. explication : +c en entre, nous avons deux aretes (laret1 et laret2) dont on sait +c qu'elles sont homologues l'une de l'autre, mais dont aucune des 2 +c paires de noeuds n'a ete declaree homologue. Le but de ce programme +c est de trouver une de ces deux paires. +c +c larete1 +c O-----------------O +c +c O-----------------O +c larete2 +c +c On part du premier noeud de l'arete laret1. On passe en revue +c toutes les aretes dont il est un des sommets. +c Quand on tombe sur une arete differente de laret1 et qui possede +c une homologue (aaa sur le croquis ci-dessous), on est bon. On +c cherche quel est le noeud commun a son homologue (bbb) et laret2. +c Logiquement, ce noeud commun (noeud2) est l'homologue du noeud de +c depart (noeud1). +c Si cela echoue, c'est que le noeud de depart etait l'extremite de +c la zone en equivalence. On recommence avec l'autre noeud de +c l'arete laret1. +c Si cela echoue encore, c'est un probleme. Vraisemblablement parce +c que l'arete en equivalence est seule dans son coin. On ne peut rien +c faire ! Il faut que la donnee des noeuds homologues soit presente +c dans le maillage de depart. +c +c O O O +c \ | / +c \ | / +c \ | / +c laret1 \|/ aaa +c O-----------------O--------------------0 +c noeud1 +c +c O-----------------O--------------------0 +c laret2 noeud2 bbb +c +c A la sortie, on aura donc repere une paire de noeuds homologues +c pour la paire d'aretes desirees. La seconde paire sera reperee +c dans l'algorithme suivant dans le programme appelant. +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) laret1, laret2 +#endif +c + noeud1 = 0 +c + do 21 , iaux = 1 , 2 +c + noeud = somare(iaux,laret1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) noeud +#endif +c + ideb = povoso(noeud-1)+1 + ifin = povoso(noeud) +c + do 211 , jaux = ideb , ifin +c + larete = voisom(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) larete, arehom(larete) +#endif +c + if ( larete.ne.laret1 .and. arehom(larete).ne.0 ) then +c + do 212 , kaux = 1 , 2 + ndaux = somare(kaux,abs(arehom(larete))) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) ndaux +#endif + do 213 , laux = 1 , 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) somare(laux,abs(laret2)) +#endif + if ( ndaux.eq.somare(laux,abs(laret2)) ) then + noeud1 = noeud + noeud2 = somare(laux,abs(laret2)) + goto 22 + endif +c + 213 continue + 212 continue +c + endif +c + 211 continue +c + 21 continue +c + endif +c +c 2.2. ==> enregistrement +c + 22 continue +c + if ( noeud1.ne.0 ) then + noehom(noeud1) = - noeud2 + noehom(noeud2) = noeud1 + else + codret = 5 + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) mess14(langue,2,1), + > laret1, laret2 + write (ulsort,texte(langue,4)) noeud +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/AV_Conversion/vcfia0.F b/src/tool/AV_Conversion/vcfia0.F new file mode 100644 index 00000000..41be7754 --- /dev/null +++ b/src/tool/AV_Conversion/vcfia0.F @@ -0,0 +1,861 @@ + subroutine vcfia0 ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > option, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'ADaptation +c - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . es . lgoptr . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . option . e . 1 . option de filtrage . +c . . . . 1 : par des groupes . +c . . . . 2 : par un diametre minimal . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIA0' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envca1.h" +#include "impr02.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "dicfen.h" +#include "nbfamm.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava +c + integer ngrofi, adgfpt, adgftb + integer nbfmed, pnumfa, pgrpo, pgrtab + integer nbfamd + integer pcoono, psomar + integer paretr, parequ + integer ptrite, pcotrt, parete + integer pquahe, pcoquh, parehe + integer pfacpy, pcofay, parepy + integer pfacpe, pcofap, parepe + integer adhist, adcode, adcoar + integer adfami, adcofa + integer adinsu + integer advotr, advoqu + integer pvolfa + integer typenh, nbento, nbencf, nbenca, nctfen, nbfenm + integer typend + integer admemo, admema, admemt, admemq + integer adtra1, adtra2 +c + integer codre1, codre2 + integer codre0 + integer iaux, jaux, kaux + integer ideb, ifin +c + logical afaire +c + double precision diammi +c + character*6 saux + character*8 nhenti + character*8 typobs, obfiad, nomail + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Filtrage par des groupes'',/,24(''-''))' + texte(1,5) = '(''Filtrage par un diametre minimal'',/,32(''-''))' + texte(1,6) = '(/,''Influence sur les'',i10,1x,a)' + texte(1,7) = '('' Diametre minimal :'',g15.6)' + texte(1,8) = + > '(/,''Aucun groupe n''''est present dans le maillage.'')' + texte(1,9) = '(''L''''adaptation est supprimee.'')' + texte(1,10) = '(''Nombre de '',a,'' filtres :'',i10,'' sur'',i10)' +c + texte(2,4) = '(''Filtering among groups'',/,22(''-''))' + texte(2,5) = + > '(''Filtering with a minimal diameter'',/,33(''-''))' + texte(2,6) = '(/,''Influence over the'',i10,1x,a)' + texte(2,7) = '('' Minimal diameter:'',g15.6)' + texte(2,8) = '(/,''No group is present in the mesh.'')' + texte(2,9) = '(''Adaptation is cancelled.'')' + texte(2,10) = + > '(''Number of filtered '',a,'':'',i10,'' over'',i10)' +c + if ( option.ge.1 .and. option.le.2 ) then + write (ulsort,texte(langue,3+option)) + else + codret = 1 + endif +c +#include "impr03.h" +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage homard a l'iteration n +c + if ( codret.eq.0 ) then +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) +c + endif +c +c 2.2. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> voisinages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 1 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif +c + call utad04 ( iaux, nhvois, + > jaux, jaux, jaux, jaux, + > advotr, advoqu, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx (nompro,obfiad) +cgn call gmprsx (nompro,obfiad//'.Pointeur') +cgn call gmprsx (nompro,obfiad//'.Taille') +cgn call gmprsx (nompro,obfiad//'.Table') +c +c==== +c 3. Prealables +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Prealables ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + afaire = .true. +c +c 3.1. ==> Prealable pour le filtrage par des groupes +c + if ( option.eq.1 ) then +c +c 3.1. ==> Decodage des adresses des groupes de filtrage +c + if ( codret.eq.0 ) then +c + obfiad = taopts(15) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA1', nompro +#endif + call vcfia1 ( obfiad, nhsupe, nhsups, + > ngrofi, adgfpt, adgftb, + > nbfmed, pnumfa, pgrpo, pgrtab, + > ntrav1, adtra1, ntrav2, adtra2, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Reperage des numeros de familles MED concernees +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA2', nompro +#endif + call vcfia2 ( ngrofi, imem(adgfpt), smem(adgftb), + > nbfmed, imem(pnumfa), + > imem(pgrpo), smem(pgrtab), + > nbfamd, + > imem(adtra1), imem(adtra2), + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Si aucun groupe n'est present, on ne fait plus ni +c raffinement ni deraffinement car aucune entite n'appartient +c aux groupes voulus +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. Suppression ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfamd.eq.0 ) then + taopti(27) = 0 + taopti(31) = 0 + taopti(32) = 0 + write (ulsort,texte(langue,8)) + write (ulsort,texte(langue,9)) + afaire = .false. + endif +c + endif +c +c 3.4. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmsgoj ( obfiad, codre1 ) + call gmlboj ( ntrav1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 3.2. ==> Prealable pour le filtrage par le diametre minimal +c + elseif ( option.eq.2 ) then +c + diammi = taoptr(3) + write (ulsort,texte(langue,7)) diammi +c + endif +c + endif +c +c==== +c 4. Allocation du tableau de memorisation +c Par defaut, il est vide. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Allocation ; codret', codret +#endif +c + if ( afaire ) then +c + if ( codret.eq.0 ) then +c + call gmalot ( obfiad, '10TabEnt', 0, iaux, codret ) + iaux = 30 - option + taopts(iaux) = obfiad +cgn write (ulsort,90002) nompro, ', obfiad = ', obfiad,', iaux =', iaux +c + endif +c + if ( codret.eq.0 ) then +c + jaux = 0 + do 41 , iaux = 1 , 10 + if ( codret.eq.0 ) then + call gmecat ( obfiad, iaux, jaux, codret ) + endif + 41 continue +c + endif +c + endif +c +c==== +c 5. Boucle sur tous les types d'entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Boucle ; codret', codret +#endif +c + if ( afaire ) then +c +c 5.1. ==> Type d'entites concernees +c . Pour les groupes : toutes +c . Pour le diametres : au moins des aretes +c + if ( codret.eq.0 ) then +c + if ( option.eq.1 ) then + typend = -1 + else + typend = 1 + endif +c + do 51 , typenh = typend , 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Boucle pour les ', mess14(langue,3,typenh) +#endif +c +c 5.2. ==> Nombre d'entites concernees +c + if ( codret.eq.0 ) then +c + nbencf = 0 + nbenca = 0 +c + if ( typenh.eq.-1 ) then + nbento = nbnoto + nctfen = nctfno + nbfenm = nbfnom + nhenti = nhnoeu + elseif ( typenh.eq.0 ) then + nbento = nbmpto + nctfen = nctfmp + nbfenm = nbfmpm + nhenti = nhmapo + elseif ( typenh.eq.1 ) then + nbento = nbarto + nctfen = nctfar + nbfenm = nbfarm + nhenti = nharet + elseif ( typenh.eq.2 ) then + nbento = nbtrto + nctfen = nctftr + nbfenm = nbftrm + nhenti = nhtria + elseif ( typenh.eq.3 ) then + nbento = nbteto + nbencf = nbtecf + nbenca = nbteca + nctfen = nctfte + nbfenm = nbftem + nhenti = nhtetr + elseif ( typenh.eq.4 ) then + nbento = nbquto + nctfen = nctfqu + nbfenm = nbfqum + nhenti = nhquad + elseif ( typenh.eq.5 ) then + nbento = nbpyto + nbencf = nbpycf + nbenca = nbpyca + nctfen = nctfpy + nbfenm = nbfpym + nhenti = nhpyra + elseif ( typenh.eq.6 ) then + nbento = nbheto + nbencf = nbhecf + nbenca = nbheca + nctfen = nctfhe + nbfenm = nbfhem + nhenti = nhhexa + elseif ( typenh.eq.7 ) then + nbento = nbpeto + nbencf = nbpecf + nbenca = nbpeca + nctfen = nctfpe + nbfenm = nbfpem + nhenti = nhpent + endif +c + if ( nbento.ne.0 ) then +c +c 5.3. ==> Allocation de la branche de memorisation +c Pour les aretes, triangles, quadrangles, on s'en souvient +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbento, mess14(langue,3,typenh) +#endif +c + iaux = typenh + 2 + call utench ( iaux, 'g', jaux, saux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + saux = '.Tab'//saux(1:1) +c + call gmecat ( obfiad, iaux, nbento, codre1 ) + call gmaloj ( obfiad//saux, ' ', nbento, admemo, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( typenh.eq.1 ) then + admema = admemo + elseif ( typenh.eq.2 ) then + admemt = admemo + elseif ( typenh.eq.4 ) then + admemq = admemo + endif +c + endif +c +c 5.4. ==> Adresses des caracteristiques des entites +c On prend les adresses de l'entite courante et ce qu'il faut +c pour calculer le diametre dans l'option 2 +c +c 5.4.1. ==> Les noeuds +c + if ( codret.eq.0 ) then +c + iaux = 1 + if ( typenh.eq.-1 ) then +c fami, cofa + iaux = 7 + elseif ( option.eq.2 ) then +c coordonnnes + iaux = 3 + endif +c + if ( iaux.ne.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'iaux', iaux + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > jaux, + > adfami, adcofa, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4.2. ==> Entite courante, si ce n'est pas un noeud : +c . 2*7*37 : famille et l'historique +c . 13 : codes pour les volumes (182 au final) +c . 31 : eventuelle connectivite par aretes (5462 au final) +c + if ( typenh.ne.-1 ) then +c + if ( codret.eq.0 ) then +c + iaux = 518 + if ( typenh.eq.3 .or. typenh.ge.5 ) then + iaux = 13*iaux + endif + if ( nbenca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'iaux', iaux + write (ulsort,texte(langue,3)) 'UTAD02-courant', nompro +#endif + call utad02 ( iaux, nhenti, + > adhist, adcode, jaux, jaux, + > adfami, adcofa, jaux, + > jaux , adinsu, jaux, + > jaux, jaux, adcoar, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.1 ) then + psomar = adcode + elseif ( typenh.eq.2 ) then + paretr = adcode + elseif ( typenh.eq.3 ) then + ptrite = adcode + pcotrt = adinsu + parete = adcoar + elseif ( typenh.eq.4 ) then + parequ = adcode + elseif ( typenh.eq.5 ) then + pfacpy = adcode + pcofay = adinsu + parepy = adcoar + elseif ( typenh.eq.6 ) then + pquahe = adcode + pcoquh = adinsu + parehe = adcoar + elseif ( typenh.eq.7 ) then + pfacpe = adcode + pcofap = adinsu + parepe = adcoar + endif +c + endif +c + endif +c +c 5.4.3. ==> Complements pour les diametres +c + if ( option.eq.2 ) then +c +c 5.4.3.1. ==> Les aretes : toujours +c + if ( codret.eq.0 ) then +c + if ( typenh.ne.1 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02-arete', nompro +#endif + call utad02 ( iaux, nharet, + > kaux , psomar, jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4.3.2. ==> Les triangles : pour les tetraedres ou les pyramides +c + if ( typenh.eq.3 .or. typenh.eq.5 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02-triangles', nompro +#endif + call utad02 ( iaux, nhtria, + > kaux , paretr, jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4.3.3. ==> Les quadrangles : pour les hexaedres ou les pentaedres +c + if ( typenh.ge.6 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02-quadrangles', nompro +#endif + call utad02 ( iaux, nhquad, + > kaux , parequ, jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > jaux , jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4.3.4. ==> Les voisinages : pour les faces ou les aretes +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.2 ) then +c + pvolfa = advotr +c + elseif ( typenh.eq.4 ) then +c + pvolfa = advoqu +c + endif +c + endif +c + endif +c +c 5.5. ==> Traitement +c 5.5.1. ==> Traitement pour le filtrage par des groupes +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA3', nompro +#endif + call vcfia3 ( nbfamd, imem(adtra2), + > typenh, nbento, nctfen, nbfenm, + > imem(adfami), imem(adcofa), + > imem(admemo), + > ulsort, langue, codret ) +c + endif +c +c 5.5.2. ==> Traitement pour le diametre minimal +c + elseif ( option.eq.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA4', nompro +#endif + call vcfia4 ( diammi, + > typenh, nbento, nctfen, nbfenm, + > imem(adfami), imem(adcofa), + > rmem(pcoono), imem(psomar), + > imem(paretr), imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(pvolfa), + > imem(admemo), + > imem(admema), imem(admemt), imem(admemq), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + 51 continue +c + endif +c +cgn if ( codret.eq.0 ) then +cgn if ( option.eq.2 ) then +cgn call gmprsx (nompro,obfiad) +cgn call gmprot (nompro,obfiad//'.Tab3', 1, nbarto) +cgn call gmprot (nompro,obfiad//'.Tab4', 1, nbtrto) +cgn call gmprot (nompro,obfiad//'.Tab5', 1, nbteto) +cgn endif +cgn endif +c + endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c==== +c 6. Si toutes les entites sont retenues, on inhibe le filtrage +c==== +c + do 61 , typenh = -1 , 7 +c +c 6.1. ==> Nombre de valeurs +c + if ( codret.eq.0 ) then +c + iaux = typenh + 2 + call gmliat ( obfiad, iaux, nbento, codret ) +c + endif +c +c 6.2. ==> Adresse des valeurs s'il y en a +c + if ( codret.eq.0 ) then +c + if ( nbento.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbento, mess14(langue,3,typenh) +#endif +c + if ( codret.eq.0 ) then +c + iaux = typenh + 2 + call utench ( iaux, 'g', jaux, saux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + saux = '.Tab'//saux(1:1) + call gmadoj ( obfiad//saux, admemo, iaux, codret ) +c + endif +c +c 6.3. ==> Si toutes les entites sont retenues, on inhibe le filtrage +c + if ( codret.eq.0 ) then +c + ideb = admemo + ifin = ideb + nbento - 1 + jaux = 0 + do 63 , iaux = ideb, ifin + if ( imem(iaux).ne.0 ) then + jaux = jaux + 1 + endif + 63 continue +cc +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,typenh), + > jaux, nbento +#endif +c + if ( jaux.eq.0 ) then +c + iaux = typenh + 2 + jaux = 0 + call gmecat ( obfiad, iaux, jaux, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + endif + + endif +c + endif +c + 61 continue +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AV_Conversion/vcfia1.F b/src/tool/AV_Conversion/vcfia1.F new file mode 100644 index 00000000..87434d00 --- /dev/null +++ b/src/tool/AV_Conversion/vcfia1.F @@ -0,0 +1,178 @@ + subroutine vcfia1 ( lisgro, nhsupe, nhsups, + > ngrofi, adgfpt, adgftb, + > nbfmed, pnumfa, pgrpo, pgrtab, + > ntrav1, adtra1, ntrav2, adtra2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'Adaptation - phase 1 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lisgro . e . ch8 . nom de l'objet de type PtTabC08 qui . +c . . . . definit la liste des groupes de filtrage . +c . nhsupe . e . char8 . informations supplementaires entieres . +c . nhsups . e . char8 . informations supplementaires caracteres 8 . +c . ngrofi . s . 1 . nombre de groupes de filtrage . +c . adgfpt . s . 1 . adresse de groupes de filtrage - pointeur . +c . adgftb . s . 1 . adresse de groupes de filtrage - table . +c . nbfmed . s . 1 . nombre de familles MED dans le maillage . +c . pnumfa . s . 1 . adresse des numeros MED des familles . +c . pgrpo . s . 1 . adresse de groupes calcul - pointeur . +c . pgrtab . s . 1 . adresse de groupes calcul - table . +c . ntravk . s . 1 . nom du tableau de travail k . +c . adtrak . s . 1 . adresse du tableau de travail k . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIA1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer ngrofi, adgfpt, adgftb + integer nbfmed, pnumfa, pgrpo, pgrtab + integer adtra1, adtra2 +c + character*8 lisgro + character*8 nhsupe, nhsups + character*8 ntrav1, ntrav2 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre0, codre1, codre2, codre3, codre4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. Decodage des adresses pour les groupes de filtrage +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,lisgro) + call gmprsx (nompro,lisgro//'.Pointeur') + call gmprsx (nompro,lisgro//'.Table') +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRPTC', nompro +#endif + call utrptc ( lisgro, + > ngrofi, iaux, + > adgfpt, jaux, adgftb, + > ulsort, langue, codret ) +c +c==== +c 3. Decodage des caracteristiques des groupes dans les familles MED +c du maillage +c==== +ccc call gmprsx (nompro,nhsupe//'.Tab5') +ccc call gmprsx (nompro,nhsupe//'.Tab6') +ccc call gmprsx (nompro,nhsups//'.Tab2') +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 9, nbfmed, codre1 ) + call gmadoj ( nhsupe//'.Tab9', pnumfa, iaux, codre2 ) + call gmadoj ( nhsupe//'.Tab5', pgrpo, iaux, codre3 ) + call gmadoj ( nhsups//'.Tab2', pgrtab, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 4. Tableaux de travail +c==== +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', ngrofi, adtra1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbfmed, adtra2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcfia2.F b/src/tool/AV_Conversion/vcfia2.F new file mode 100644 index 00000000..d95e83cb --- /dev/null +++ b/src/tool/AV_Conversion/vcfia2.F @@ -0,0 +1,309 @@ + subroutine vcfia2 ( ngrofi, grfipt, grfitb, + > nbfmed, numfam, grfmpo, grfmtb, + > nbfamd, + > tbxgro, tbxfam, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'Adaptation - phase 2 +c - -- - - +c +c Retourne les numeros des familles MED correspondant +c aux groupes demandes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ngrofi . e . 1 . nombre de groupes de filtrage . +c . grfipt . e .0:ngrofi. groupes de filtrage - pointeur . +c . grfitb . e . * . groupes de filtrage - table . +c . nbfmed . e . 1 . nombre de familles MED dans le maillage . +c . numfam . e . nbfmed . numero MED des familles . +c . grfmpo . e .0:nbfmed. groupes calcul - pointeur . +c . grfmtb . e . * . groupes calcul - table . +c . nbfamd . s . 1 . nombre de familles MED concernees . +c . tbxgro . - . ngrofi . tableau de travail . +c . tbxfam . s . nbfmed . tableau de travail . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIA2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer ngrofi, grfipt(0:ngrofi) + integer nbfmed, numfam(nbfmed), grfmpo(0:nbfmed) + integer nbfamd + integer tbxgro(ngrofi), tbxfam(nbfmed) +c + character*8 grfitb(*) + character*8 grfmtb(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer fam, nbgr, gr + integer lgngrf, lggrfi + integer nugrfi +c + character*80 groupf + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Famille MED numero'',i10)' + texte(1,5) = '(''. Groupe'',i5,'' : '',a)' + texte(1,6) = '(a,''Groupe de filtrage : '',a)' + texte(1,7) = + >'(5x,''Attention : ce groupe est inconnu dans le maillage.'')' + texte(1,8) = '(''Nombre de familles MED concernees :'',i10)' + texte(1,9) = '(''Numero de ces familles :'')' + texte(1,10) = '(''... Le groupe a ete trouve dans la famille.'')' +c + texte(2,4) = '(/,''MED family #'',i10)' + texte(2,5) = '(''. Group'',i5,'': '',a)' + texte(2,6) = '(a,''Filtering group: '',a)' + texte(2,7) = + >'(5x,''Warning : this group is not known in the mesh.'')' + texte(2,8) = '(''Number of MED families in cause:'',i10)' + texte(2,9) = '(''# of those families:'')' + texte(2,10) = '(''... The group was found into the family.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. a priori, aucun groupe n'a ete repere +c==== +c + do 21 , nugrfi = 1 , ngrofi + tbxgro(nugrfi) = 0 + 21 continue +c +c==== +c 3. Recherche des familles MED concernees +c Remarque : le decodage est analogue a celui de vcsffl +c==== +c + if ( codret.eq.0 ) then +c + nbfamd = 0 +c +c 3.1. ==> on parcourt toutes les familles MED du maillage +c + do 31 , fam = 1 , nbfmed +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) fam +#endif +c + nbgr = (grfmpo(fam)-grfmpo(fam-1))/10 +c +c 3.1.1. ==> on parcourt tous les groupes entrant dans la +c definition de la famille +c + do 311 , gr = 1, nbgr +c +c 3.1.1.1. ==> nom du groupe associe +c adresse du debut du groupe numero gr de la famille fam + iaux = grfmpo(fam-1)+1+10*(gr-1) +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe numero gr dans la famille +c numero fam + call uts8ch ( grfmtb(iaux), 80, groupf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrf, groupf, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) gr, groupf(1:lgngrf) +#endif + endif +c +c 3.1.1.2. ==> on parcourt tous les groupes designes pour le filtrage +c + if ( codret.eq.0 ) then +c + do 3112 , nugrfi = 1 , ngrofi +c +c 3.1.1.2.1. ==> nom du groupe associe +c + if ( codret.eq.0 ) then +c + jaux = grfipt(nugrfi-1) + 1 + call uts8ch ( grfitb(jaux), 200, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( lggrfi, sau200, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) '.. ', sau200(1:lggrfi) +#endif +c + endif +c +c 3.1.1.2.2. ==> est-ce le meme ? +c si oui on memorise le numero de cette famille MED +c + if ( codret.eq.0 ) then +c + if ( lgngrf.eq.lggrfi ) then +c + if ( groupf(1:lgngrf).eq.sau200(1:lggrfi) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) +#endif + tbxgro(nugrfi) = tbxgro(nugrfi) + 1 + do 3113 , jaux = 1 , nbfamd + if ( tbxfam(jaux).eq.numfam(fam) ) then + goto 3112 + endif + 3113 continue + nbfamd = nbfamd + 1 + tbxfam(nbfamd) = numfam(fam) + endif +c + endif +c + endif +c + 3112 continue +c + endif +c + 311 continue +c + 31 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbfamd + write (ulsort,texte(langue,9)) + write (ulsort,91020) (tbxfam(iaux), iaux=1,nbfamd) +#endif +c + endif +c +c==== +c 4. Information +c==== +c + do 41 , nugrfi = 1 , ngrofi +c + if ( codret.eq.0 ) then +c + jaux = grfipt(nugrfi-1) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nugrfi, grfitb(jaux)//' ...' +#endif +c + call uts8ch ( grfitb(jaux), 200, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( lggrfi, sau200, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,6)) ' ', sau200(1:lggrfi) + if ( tbxgro(nugrfi).eq.0 ) then + write (ulsort,texte(langue,7)) + endif +c + endif +c + 41 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcfia3.F b/src/tool/AV_Conversion/vcfia3.F new file mode 100644 index 00000000..d815da71 --- /dev/null +++ b/src/tool/AV_Conversion/vcfia3.F @@ -0,0 +1,155 @@ + subroutine vcfia3 ( nbfamd, numfam, + > typenh, nbento, nctfen, nbfenm, + > fament, cfaent, + > tabmem, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'Adaptation - phase 3 +c - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfamd . e . 1 . nombre de familles MED concernees . +c . numfam . e . 1 . liste des familles MED concernees . +c . typenh . e . 1 . code des entites au sens homard . +c . nbento . e . 1 . nombre d'entites . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfenm . e . 1 . nombre maximum de familles . +c . fament . e . nbento . famille des entites . +c . cfaent . e . nctfen*. codes des familles des entites . +c . . . nbfent . . +c . tabmem . s . nbento . memorisation du filtrage . +c . . . . Pour l'entite i : . +c . . . . 0 : l'entite est retiree . +c . . . . 1 : l'entite est gardee pour l'adaptation. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "coftex.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbfamd + integer numfam(nbfamd) + integer typenh, nbento, nctfen, nbfenm + integer cfaent(nctfen,nbfenm), fament(nbento) + integer tabmem(nbento) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Prise en compte du filtrage sur les '',a)' + texte(1,5) = '(''Famille(s) de la zone a adapter :'')' +c + texte(2,4) = '(''Influence over '',a)' + texte(2,5) = '(''Familie(s) of refined zone :'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) + write (ulsort,1000) (numfam(iaux), iaux = 1 , nbfamd ) + 1000 format(10i5) +#endif +c +c==== +c 2. Reperage des entites soumises a adaptation +c A priori, aucune +c==== +c + do 21 , iaux = 1 , nbento +c + tabmem(iaux) = 0 + jaux = cfaent(cofamd,fament(iaux)) +cgn write (ulsort,*) 'Famille de', iaux, ' :', jaux + do 211 , kaux = 1 , nbfamd + if ( numfam(kaux).eq.jaux ) then + tabmem(iaux) = 1 + goto 21 + endif + 211 continue +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcfia4.F b/src/tool/AV_Conversion/vcfia4.F new file mode 100644 index 00000000..e5296ab5 --- /dev/null +++ b/src/tool/AV_Conversion/vcfia4.F @@ -0,0 +1,546 @@ + subroutine vcfia4 ( diammi, + > typenh, nbento, nctfen, nbfenm, + > fament, cfaent, + > coonoe, somare, + > aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > facpen, cofape, arepen, + > volfac, + > tabmem, + > tabmea, tabmet, tabmeq, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'Adaptation - phase 4 +c - -- - - +c On ne s'interesse qu'aux mailles : +c . qui sont des elements de calcul +c . qui sont actives +c . qui ne sont pas des mailles de bord +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . diammi . e . 1 . diametre minimal voulu . +c . typenh . e . 1 . code des entites au sens homard . +c . nbento . e . 1 . nombre d'entites . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfenm . e . 1 . nombre maximum de familles . +c . fament . e . nbento . famille des entites . +c . cfaent . e . nctfen*. codes des familles des entites . +c . . . nbfent . . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . volfac . e .2*nbfato. numeros des 2 volumes par face) . +c . . . . volfac(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre/tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypefa(1/2,j). +c . tabmem . s . nbento . memorisation du filtrage . +c . . . . Pour l'entite i : . +c . . . . 0 : l'entite est retiree . +c . . . . 1 : l'entite est gardee pour l'adaptation. +c . tabmea . e . nbarto . memorisation du filtrage pour les aretes . +c . tabmet . e . nbtrto . memorisation du filtrage pour les triangles. +c . tabmeq . e . nbquto . memorisation du filtrage pour les quads. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIA4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "coftex.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision diammi +c + integer typenh, nbento, nctfen, nbfenm + integer cfaent(nctfen,nbfenm), fament(nbento) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer volfac(2,*) + integer tabmem(nbento) + integer tabmea(nbarto), tabmet(nbtrto), tabmeq(nbquto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nument + integer listar(12) +c + double precision daux, vn(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Prise en compte du filtrage sur les '',i10,1x,a)' + texte(1,5) = '(''Diametre minimal :'',g15.6)' +c + texte(2,4) = '(''Influence over the'',i10,1x,a)' + texte(2,5) = '(''Minimal diameter:'',g15.6)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbento, mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) diammi +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Reperage des entites soumises a adaptation +c A priori, aucune entite n'est retiree +c==== +c + do 21 , iaux = 1 , nbento +c + tabmem(iaux) = 0 +c + 21 continue +c +c==== +c 3. Prise en compte du diametre minimal selon le type de mailles +c On ne s'interesse qu'aux mailles qui sont des elements de calcul +c et qui sont actives +c==== +c 3.1.==> Aretes, longueur minimale +c + if ( typenh.eq.1 ) then +c + do 31 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + jaux = somare(1,iaux) + kaux = somare(2,iaux) + vn(1) = coonoe(kaux,1) - coonoe(jaux,1) + vn(2) = coonoe(kaux,2) - coonoe(jaux,2) + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) ) +c +cgn write(ulsort,*)'.. arete', iaux, daux + if ( daux.le.diammi ) then + tabmem(iaux) = 1 +cgn write(ulsort,*)' .. pas glop' + endif +c + endif +c + 31 continue +c +c 3.2. ==> Triangles +c + elseif ( typenh.eq.2 ) then +c +c 3.2.1. ==> En l'absence de mailles volumiques +c + if ( nbteto.eq.0 .and. nbheto.eq.0 .and. + > nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 321 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdtri ( nument, daux, coonoe, somare, aretri ) +cgn write(ulsort,*)'.. triangle', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + do 3211 , jaux = 1 , 3 + tabmea(aretri(iaux,jaux)) = 1 + 3211 continue +cgn write(ulsort,*)'.... aretes', (aretri(iaux,jaux),jaux=1,3) +cgn write(ulsort,*)' .. pas glop' + endif +c + endif +c + 321 continue +c +c 3.2.2. ==> Avec au moins une maille volumique +c + else +c + do 322 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + if ( volfac(1,iaux).eq.0 ) then +c + nument = iaux + call utdtri ( nument, daux, coonoe, somare, aretri ) +cgn write(ulsort,*)'.. triangle', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + do 3221 , jaux = 1 , 3 + tabmea(aretri(iaux,jaux)) = 1 + 3221 continue + endif +c + endif +c + endif +c + 322 continue +c + endif +c +c 3.3. ==> Tetraedres +c + elseif ( typenh.eq.3 ) then +c + do 33 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdtet ( nument, daux, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +cgn write(ulsort,*)'.. tetraedre', iaux, daux +c + if ( daux.le.diammi ) then +cgn write(ulsort,*)'.... enregistrement pour tr =', +cgn >(tritet(iaux,jaux), jaux = 1 , 4) + tabmem(iaux) = 1 + if ( nument.le.nbtecf ) then + do 331 , jaux = 1 , 4 + tabmet(tritet(iaux,jaux)) = 1 + 331 continue + call utarte ( nument, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) + else + do 332 , jaux = 1 , 6 + listar(jaux) = aretet(nument-nbtecf,jaux) + 332 continue + endif + do 333 , jaux = 1 , 6 + tabmea(listar(jaux)) = 1 + 333 continue + endif +c + endif +c + 33 continue +c +c 3.4. ==> Quadrangles +c + elseif ( typenh.eq.4 ) then +c +c 3.4.1. ==> En l'absence de mailles volumiques +c + if ( nbteto.eq.0 .and. nbheto.eq.0 .and. + > nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 341 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdqua ( nument, daux, coonoe, somare, arequa ) +c +cgn write(ulsort,*)'.. quadrangle', iaux, daux + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + do 3411 , jaux = 1 , 4 + tabmea(arequa(iaux,jaux)) = 1 + 3411 continue + endif +c + endif +c + 341 continue +c +c 3.4.2. ==> Avec au moins une maille volumique +c + else +c + do 342 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + if ( volfac(1,iaux).eq.0 ) then +c + nument = iaux + call utdqua ( nument, daux, coonoe, somare, arequa ) +cgn write(ulsort,*)'.. quadrangle', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + do 3421 , jaux = 1 , 4 + tabmea(arequa(iaux,jaux)) = 1 + 3421 continue + endif +c + endif +c + endif +c + 342 continue +c + endif +c +c 3.5. ==> Pyramides +c + elseif ( typenh.eq.5 ) then +c + do 35 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdpyr ( nument, daux, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +cgn write(ulsort,*)'.. pyramide', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + if ( nument.le.nbpycf ) then + do 351 , jaux = 1 , 4 + tabmet(facpyr(iaux,jaux)) = 1 + 351 continue + tabmeq(facpyr(iaux,5)) = 1 + call utarpy ( nument, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) + else + do 352 , jaux = 1 , 8 + listar(jaux) = arepyr(nument-nbpycf,jaux) + 352 continue + endif + do 353 , jaux = 1 , 8 + tabmea(listar(jaux)) = 1 + 353 continue + endif +c + endif +c + 35 continue +c +c 3.6. ==> Hexaedres +c + elseif ( typenh.eq.6 ) then +c + do 36 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdhex ( nument, daux, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +cgn write(ulsort,*)'.. hexaedre', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + if ( nument.le.nbhecf ) then + do 361 , jaux = 1 , 6 + tabmeq(quahex(iaux,jaux)) = 1 + 361 continue + call utarhe ( nument, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) + else + do 362 , jaux = 1 , 12 + listar(jaux) = arehex(nument-nbhecf,jaux) + 362 continue + endif + do 363 , jaux = 1 , 12 + tabmea(listar(jaux)) = 1 + 363 continue + endif +c + endif +c + 36 continue +c +c 3.7. ==> Pentaedres +c + elseif ( typenh.eq.7 ) then +c + do 37 , iaux = 1 , nbento +c + if ( cfaent(cotyel,fament(iaux)).ne.0 ) then +c + nument = iaux + call utdpen ( nument, daux, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +cgn write(ulsort,*)'.. pentaedre', iaux, daux +c + if ( daux.le.diammi ) then + tabmem(iaux) = 1 + if ( nument.le.nbpecf ) then + do 3711 , jaux = 1 , 3 + tabmeq(facpen(iaux,jaux)) = 1 + 3711 continue + do 3712 , jaux = 4 , 5 + tabmet(facpen(iaux,jaux)) = 1 + 3712 continue + call utarpe ( nument, + > nbquto, nbpeto, + > arequa, facpen, cofape, + > listar ) + else + do 372 , jaux = 1 , 9 + listar(jaux) = arepen(nument-nbpecf,jaux) + 372 continue + endif + do 373 , jaux = 1 , 9 + tabmea(listar(jaux)) = 1 + 373 continue + endif +c + endif +c + 37 continue +c + endif +c +c==== +c 4. Sauvegarde du tableau pour les aretes, les triangles, +c les quadrangles +c==== +c + if ( typenh.eq.1 ) then +c + do 41 , iaux = 1 , nbarto +c + tabmea(iaux) = tabmem(iaux) +c + 41 continue +c + elseif ( typenh.eq.2 ) then +c + do 42 , iaux = 1 , nbtrto +c + tabmet(iaux) = tabmem(iaux) +c + 42 continue +c + elseif ( typenh.eq.4 ) then +c + do 43 , iaux = 1 , nbquto +c + tabmeq(iaux) = tabmem(iaux) +c + 43 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcfiad.F b/src/tool/AV_Conversion/vcfiad.F new file mode 100644 index 00000000..a5a928a6 --- /dev/null +++ b/src/tool/AV_Conversion/vcfiad.F @@ -0,0 +1,206 @@ + subroutine vcfiad ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - FIltrage de l'ADaptation +c - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . es . lgoptr . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCFIAD' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava +c + integer nretap, nrsset + integer iaux +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' FILTRAGE DE L''''ADAPTATION'')' + texte(1,5) = '(31(''=''),/)' + texte(1,6) = '(/,''Influence sur les '',a)' +c + texte(2,4) = '(/,a6,'' ADAPTATION FILTERING'')' + texte(2,5) = '(27(''=''),/)' + texte(2,6) = '(/,''Influence over '',a)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. filtrage par les groupes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. groupes ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(19).gt.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA0', nompro +#endif + call vcfia0 ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. filtrage par un diametre minimal +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. diametre minimal ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taoptr(3).gt.0.d0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIA0', nompro +#endif + call vcfia0 ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AV_Conversion/vcind0.F b/src/tool/AV_Conversion/vcind0.F new file mode 100644 index 00000000..7444c0d6 --- /dev/null +++ b/src/tool/AV_Conversion/vcind0.F @@ -0,0 +1,209 @@ + subroutine vcind0 ( nocind, + > nocham, nbcomp, nbtvch, adnocp, adcaca, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INDicateur - phase 0 +c - - --- - +c recuperation des caracteristiques du champ contenant l'indicateur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrpass . e . 1 . numero du passage . +c . nocind . e . char*8 . nom de la structure contenant l'indicateur . +c . nocham . s . char*8 . nom de la structure du champ . +c . nbcomp . s . 1 . nombre de composantes . +c . nbtvch . s . 1 . nombre de tableaux du champ . +c . adnocp . s . 1 . adresse des noms des champ et composantes . +c . adcaca . s . 1 . adresse des caracteristiques caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCIND0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbcomp, nbtvch + integer adnocp, adcaca +c + character*8 nocind + character*8 nocham +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg + integer typcha + integer adcaen, adcare +c + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''On a '',i5,'' champs dans l''''indicateur'')' + texte(1,5) = '(''Il en faut au moins 1 !'')' + texte(1,6) = '(''1 suffirait !'')' + texte(1,7) = '(/,''Objet du champ : '',a)' + texte(1,8) = '(''Nombre de composantes :'',i8)' + texte(1,9) = '(''Nombre de tableaux :'',i8,//)' +c + texte(2,4) = '(i5,'' fields are included in indicator.'')' + texte(2,5) = '(''At least 1 is required !'')' + texte(2,6) = '(''One would be enoUGh !'')' + texte(2,7) = '(/,''Field object : '',a)' + texte(2,8) = '(''Number of components :'',i8)' + texte(2,9) = '(''Number of arrays :'',i8,//)' +c +c==== +c 2. analyse de la structure 'Solution' qui contient l'indicateur +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocind ) + call gmprsx (nompro, nocind//'.InfoCham' ) + call gmprsx (nompro, nocind//'.InfoPaFo' ) +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro +#endif + call utcaso ( nocind, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbcham.ne.1 ) then + write (ulsort,texte(langue,4)) nbcham + if ( nbcham.eq.0 ) then + write (ulsort,texte(langue,5)) + else + write (ulsort,texte(langue,6)) + endif + codret = 2 + endif +c + endif +c +c==== +c 3. caracteristiques du champ associe +c==== +c + if ( codret.eq.0 ) then +c + nocham = smem(adinch) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nocham + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Nom_Comp' ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Ree') + call gmprsx (nompro, nocham//'.Cham_Car') +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( nocham, + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8)) nbcomp + write (ulsort,texte(langue,9)) nbtvch +c + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcind1.F b/src/tool/AV_Conversion/vcind1.F new file mode 100644 index 00000000..c9f316fb --- /dev/null +++ b/src/tool/AV_Conversion/vcind1.F @@ -0,0 +1,270 @@ + subroutine vcind1 ( nbcomp, nomcmp, + > ncmpin, pointe, taille, table, + > nucomp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INDicateur - phase 1 +c - - --- - +c recuperation des composantes a prendre en compte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcomp . e . 1 . nombre de composantes du champ examine . +c . nomcmp . e . nbtvch . nom des composantes du champ examine . +c . ncmpin . es . 1 . nombre de composantes retenues . +c . pointe . e .0:ncmpin. pointeurs dans taille et table . +c . taille . e . * . longueur de chacune des composantes . +c . table . e . char*8 . nom des composantes a utiliser . +c . nucomp . s . ncmpin . numeros des composantes retenues . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCIND1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbcomp + integer ncmpin + integer pointe(0:*), taille(*) + integer nucomp(*) +c + character*8 nomcmp(*) + character*8 table(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nombco + integer ideb, ifin + integer jdeb, jfin +c + character*16 nocmpi +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Le champ examine a'',i14,'' composante(s).'')' + texte(1,5) = '(''Impossible de trouver la composante '',a)' + texte(1,6) = + > '(''dans le champ examine, dont les composantes sont :'')' + texte(1,7) = '(a,''Composante'',i3,'' : '',a)' + texte(1,8) = '(''Composante retenue : '',a)' +c + texte(2,4) = '(''Examined field has got'',i14,'' component(s).'')' + texte(2,5) = '(''Component '',a,'' cannot be found in the'')' + texte(2,6) = '(''field, the components of which are :'')' + texte(2,7) = '(a,''Component #'',i3,'' : '',a)' + texte(2,8) = '(''Component : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbcomp +#endif +c +c==== +c 2. Si le champ d'indicateur n'a qu'une composante, on retient celle-la +c==== +c + if ( nbcomp.eq.1 ) then +c + if ( codret.eq.0 ) then +c + ncmpin = 1 + nucomp(1) = 1 +c + endif +c +c==== +c 3. Si le champ d'indicateur a plusieurs composantes : +c==== +c + else +c + nombco = ncmpin +c +c 3.1. ==> Si au moins une composante a ete choisie ; on retient celles +c qui l'ont ete +c + if ( nombco.gt.0 ) then +c + ncmpin = 0 +c + jfin = pointe(0) +c + do 31 , iaux = 1 , nombco +c +c 3.1.1. ==> Reconstitution du nom de la composante +c + nocmpi = ' ' +c 1234567890123456 + jdeb = jfin + 1 + jfin = pointe(iaux) + ifin = 0 + do 311 , jaux = jdeb, jfin +c + ideb = ifin + 1 + ifin = ifin + taille(jaux) + if ( taille(jaux).eq.8 ) then + nocmpi(ideb:ifin) = table(jaux) + elseif ( taille(jaux).gt.0 ) then + nocmpi(ideb:ifin) = table(jaux)(1:taille(jaux)) + else + goto 3111 + endif +c + 311 continue +c + 3111 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) ' ', iaux, nocmpi +#endif +c +c 3.1.2. ==> Reherche +c + if ( codret.eq.0 ) then +c + do 312 , jaux = 1 , nbcomp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) '.. ', jaux, + > nomcmp(2*jaux-1)//nomcmp(2*jaux) +#endif + if ( nocmpi.eq.nomcmp(2*jaux-1)//nomcmp(2*jaux) ) then + do 3121 , kaux = 1 , ncmpin + if ( nucomp(kaux).eq.jaux ) then + goto 3129 + endif + 3121 continue + ncmpin = ncmpin + 1 + nucomp(ncmpin) = jaux + goto 3129 + endif +c + 312 continue +c + codret = 2 + write (ulsort,texte(langue,5)) nocmpi + write (ulsort,texte(langue,6)) + do 3122 , jaux = 1 , nbcomp + write (ulsort,texte(langue,7)) ' ', jaux, + > nomcmp(2*jaux-1)//nomcmp(2*jaux) + 3122 continue +c + 3129 continue +c + endif +c + 31 continue +c +c 3.2. ==> Si aucune n'a ete choisie, on les prend toutes +c + elseif ( nombco.eq.0 ) then +c + if ( codret.eq.0 ) then +c + ncmpin = nbcomp + do 32 , iaux = 1 , nbcomp + nucomp(iaux) = iaux + 32 continue +c + endif +c +c 3.3. ==> Sinon, probleme +c + else +c + codret = 1 +c + endif +c + endif +c +c==== +c 4. Impressions +c==== +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , ncmpin + jaux = nucomp(iaux) + write (ulsort,texte(langue,8)) nomcmp(2*jaux-1)//nomcmp(2*jaux) + 41 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcind2.F b/src/tool/AV_Conversion/vcind2.F new file mode 100644 index 00000000..2468e25d --- /dev/null +++ b/src/tool/AV_Conversion/vcind2.F @@ -0,0 +1,237 @@ + subroutine vcind2 ( nrfonc, + > caraca, + > advalr, nbtafo, nbenmx, nbpg, tyelho, + > adlipr, nbvapr, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INDicateur - phase 2 +c - - --- - +c recuperation des caracteristiques du n-eme tableau de valeurs +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrfonc . e . 1 . numero de la fonction en cours . +c . caraca . e . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbsqch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . advalr . s . 1 . adresse des valeurs reelles . +c . nbtafo . s . 1 . nombre de tableaux dans la fonction . +c . nbenmx . s . 1 . nombre d'entites maximum . +c . nbpg . s . 1 . nombre de points de Gauss . +c . tyelho . s . 1 . type d'element au sens HOMARD . +c . nbvapr . s . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . adlipr . s . 1 . adresse de la liste du profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCIND2' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer nrfonc + integer advalr, nbtafo, nbenmx, nbpg + integer adlipr, nbvapr + integer tyelho +c + character*8 caraca(nbincc,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer typgeo, ngauss, nbtyas, carsup, typint + integer iaux, jaux + integer advale, adobch, adprpg, adtyas +c + character*8 nofonc, noprof + character*200 profil +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de points de Gauss : '',i5)' + texte(1,5) = '(''On ne sait pas faire.'')' + texte(1,6) = '(/,''Type d''''element HOMARD associe :'',i3)' + texte(1,7) = '(''Pas de profil associe.'')' + texte(1,8) = '(''Nombre de valeurs du profil :'',i10)' +c + texte(2,4) = '(''Number of Gauss points : '',i5)' + texte(2,5) = '(''We cannot do it.'')' + texte(2,6) = '(/,''HOMARD element :'',i3)' + texte(2,7) = '(''No profile connected to the field.'')' + texte(2,8) = '(''Number of values in profile :'',i10)' +c +c==== +c 2. caracteristiques de la fonction associee +c==== +c + if ( codret.eq.0 ) then +c + nofonc = caraca(1,nrfonc) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nofonc ) +cgn call gmprsx (nompro, nofonc//'.ValeursR' ) + call gmprot (nompro, nofonc//'.ValeursR', 1, 30 ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nofonc, + > iaux, + > typgeo, ngauss, nbenmx, jaux, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( ngauss.eq.ednopg ) then + nbpg = 1 + elseif ( ngauss.gt.0 ) then + nbpg = ngauss + else + write (ulsort,texte(langue,4)) ngauss + write (ulsort,texte(langue,5)) + codret = 2 + endif +c + tyelho = medtrf(typgeo) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) tyelho +#endif +c + endif +cgn print *,medtrf(102),medtrf(103) +cgn print *,medtrf(203),medtrf(206) +cgn print *,medtrf(304),medtrf(310) +cgn print *,'nrfonc, typgeo, tyelho = ',nrfonc, typgeo, tyelho +c +c==== +c 3. caracteristiques du profil associe +c==== +c + if ( codret.eq.0 ) then +c + noprof = caraca(2,nrfonc) +cgn print *,'noprof = ',noprof +c + if ( noprof.eq.' ' ) then +c + nbvapr = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) +#endif +c + else +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, noprof ) + call gmprsx (nompro, noprof//'.NomProfi' ) + call gmprot (nompro, noprof//'.ListEnti', 1, 10 ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( noprof, + > nbvapr, profil, adlipr, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbvapr +#endif +c + endif +c + endif +cgn print *,'nbvapr = ',nbvapr +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcind3.F b/src/tool/AV_Conversion/vcind3.F new file mode 100644 index 00000000..b47bc37d --- /dev/null +++ b/src/tool/AV_Conversion/vcind3.F @@ -0,0 +1,207 @@ + subroutine vcind3 ( nbtafo, nbvind, indica, nbpg, + > ncmpin, nucomp, + > adindi, ntrava, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INDicateur - phase 3 +c - - --- - +c Pour un indicateur exprime aux points de Gauss, on met sur la +c maille la valeur la plus grande en valeur absolue, en respectant +c son signe. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux dans la fonction . +c . nbvind . e . 1 . nombre d'entites maximum . +c . indica . e . nbtafo . valeurs de l'indicateur . +c . . .*nbvind . . +c . nbpg . e . 1 . nombre de points de Gauss . +c . ncmpin . e . 1 . nombre de composantes retenues . +c . nucomp . e . ncmpin . numeros des composantes retenues . +c . adindi . s . 1 . adresse du tableau d'indicateur filtre . +c . ntrava . s . char*8 . nom de l'objet de l'indicateur filtre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCIND3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +c +c 0.3. ==> arguments +c + integer nbvind, nbtafo, nbpg + integer ncmpin, nucomp(ncmpin) + integer adindi +c + double precision indica(nbtafo,nbpg,nbvind) +c + character*8 ntrava +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer nrcomp +c + double precision dauxmi, dauxma, daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +cgn write(ulsort,*) 'dans ',nompro +cgn write(ulsort,*) indica +cgn write(ulsort,*) 'nbtafo,nbpg,nbvind = ',nbtafo,nbpg,nbvind +cgn do 111 , iaux = 1 , nbtafo +cgn do 111 , jaux = 1 , nbpg +cgn do 111 , kaux = 1 , nbvind +cgn write(ulsort,*)'indica(',iaux,',',jaux,',',kaux,') = ', +cgn > indica(iaux,jaux,kaux) +cgn 111 continue +c +c==== +c 2. Allocation du tableau filtre +c==== +c + iaux = nbtafo*nbvind + call gmalot ( ntrava, 'reel ', iaux, adindi, codret ) +c +c==== +c 3. Transfert +c On ne transfere que la ou les composantes retenues +c==== +c + if ( codret.eq.0 ) then +c + do 31 , laux = 1 , ncmpin +c + nrcomp = nucomp(laux) + kaux = adindi + nrcomp - 1 +c + do 311 , iaux = 1 , nbvind +c +c 3.1. ==> Recherche des mini et maxi +c + dauxmi = indica(nrcomp,1,iaux) + dauxma = dauxmi +cgn if ( iaux.eq.5.or.iaux.eq.21) then +cgn write(ulsort,*)iaux,dauxmi +cgn endif + do 3111 , jaux = 2 , nbpg +cgn if ( iaux.eq.5.or.iaux.eq.21) then +cgn write(ulsort,*)jaux, indica(nrcomp,jaux,iaux) +cgn endif + dauxmi = min (dauxmi , indica(nrcomp,jaux,iaux) ) + dauxma = max (dauxma , indica(nrcomp,jaux,iaux) ) + 3111 continue +c +c +c 3.2. ==> Tri selon les signes +c +c .....0.....mi.......ma...... ==> ma + if ( dauxmi.ge.0.d0 ) then + daux = dauxma + else +c .........mi.......ma....0... ==> mi + if ( dauxma.le.0.d0 ) then + daux = dauxmi + else +c ...mi..........0...ma........ ==> mi + if ( abs(dauxmi).gt.dauxma ) then + daux = dauxmi +c ...mi...0..........ma........ ==> ma + else + daux = dauxma + endif + endif + endif +cgn if ( iaux.le.5.or.iaux.ge.0) then +cgn write(ulsort,*)'mini : ',dauxmi,', maxi : ',dauxma,'==> ',daux +cgn endif +c + rmem(kaux+nbtafo*(iaux-1)) = daux +c + 311 continue +c + 31 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro,ntrava,1,30) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcindi.F b/src/tool/AV_Conversion/vcindi.F new file mode 100644 index 00000000..fe998329 --- /dev/null +++ b/src/tool/AV_Conversion/vcindi.F @@ -0,0 +1,1095 @@ + subroutine vcindi ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INDIcateur +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCINDI' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +#include "gmenti.h" +#include "gmstri.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "refert.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava +c + integer rvnoac, adnohn, adnoin, adnosu + integer rvarac, adarhn, adarin, adarsu + integer rvtrac, adtrhn, adtrin, adtrsu + integer rvquac, adquhn, adquin, adqusu + integer rvteac, adtehn, adtein, adtesu + integer rvheac, adhehn, adhein, adhesu + integer rvpyac, adpyhn, adpyin, adpysu + integer rvpeac, adpehn, adpein, adpesu + integer typenh + integer adinca, adindi, nbtafo, nbenmx, nbpg, tyelho + integer ncmpin, nucomp(100) + integer adlipr, nbvapr + integer nrpass + integer nbcomp, nbtvch + integer adnocp, adcaca + integer nrotv + integer nbelig +c + integer codre1, codre2 + integer codre0 + integer nretap, nrsset + integer iaux, jaux, kaux + integer nbvent(-1:7) + integer nbvpen, nbvpyr, nbvhex, nbvtet + integer nbvqua, nbvtri, nbvare, nbvnoe + integer adpoin, adtail, adtabl +c + character*6 saux + character*8 typobs, nocind, nohind, nomail + character*8 oblist + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 motaux + character*8 nocham + character*8 ntrava +c + logical nomaut, afaire +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data motaux / 'ValeursR' / +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONVERSION DE L''''INDICATEUR'')' + texte(1,5) = '(33(''=''),/)' + texte(1,6) = '(''Impossible de trouver le nom de la composante'')' + texte(1,7) = '(''Nombre de composantes dans le champ :'',i4)' + texte(1,8) = '(''Nombre de tableaux dans le champ :'',i4)' + texte(1,9) = '(/,''Examen du tableau numero'',i4)' + texte(1,10) = '(''. Norme L2 des composantes.'')' + texte(1,11) = '(''. Norme infinie des composantes.'')' + texte(1,12) = '(''. Valeur relative de la composante.'')' + texte(1,13) = '(''. Valeur absolue de la composante.'')' + texte(1,15) = '(''Cette combinaison est impossible.'')' + texte(1,17) = '(''Plusieurs champs sont presents pour les '',a)' + texte(1,18) = '(''Il faut choisir un instant unique.'')' +c + texte(2,4) = '(/,a6,'' INDICATOR CONVERSION'')' + texte(2,5) = '(27(''=''),/)' + texte(2,6) = '(''The name of the component cannot be found.'')' + texte(2,7) = '(''Number of components in the field:'',i4)' + texte(2,8) = '(''Number of arrays in the field :'',i4)' + texte(2,9) = '(/,''Exam of array #'',i4)' + texte(2,10) = '(''. L2 norm of components.'')' + texte(2,11) = '(''. Infinite norm of components.'')' + texte(2,12) = '(''. Relative value for the component.'')' + texte(2,13) = '(''. Absolute value for the component.'')' + texte(2,15) = '(''This situation cannot be solved.'')' + texte(2,17) = '(''More than one field are defined over the '',a)' + texte(2,18) = '(''A single time-step should be selected.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage homard a l'iteration n +c + if ( codret.eq.0 ) then +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) +c + endif +c +c 2.2. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +cgn call gmprsx ( nompro, nhtria//'.InfoSupp' ) +cgn call gmprsx ( nompro, norenu//'.PeCalcul' ) +cgn call gmprsx ( nompro, nhquad//'.InfoSupp' ) +cgn call gmprsx ( nompro, norenu//'.HeCalcul' ) +c + endif +c +c 2.3. ==> l'indicateur du code de calcul +c + nocind = taopts(7) +c +c 2.4. ==> l'indicateur au format homard +c le nom est donne par l'utilisateur ou il est construit +c en tant qu'objet temporaire +c + if ( codret.eq.0 ) then +c + typobs = mchind + iaux = 0 + call utosno ( typobs, nohind, iaux, ulsort, langue, codre1 ) +c + if ( codre1.eq.0 ) then + nomaut = .false. + elseif ( codre1.eq.2 ) then + nomaut = .true. + else + write (ulsort,texte(langue,6)) + endif +c + endif +C +c 2.5. ==> les eventuels elements elimines +c + if ( codret.eq.0 ) then +c + call gmliat ( nhelig, 1, nbelig, codret ) +c + endif +c +c==== +c 3. recuperation des pointeurs associes a l'indicateur en entree +c et aux renumerotations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c +c 3.1. ==> renumerotation +c + if ( codret.eq.0 ) then +c + iaux = -1 + jaux = 10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvnoac, kaux, adnohn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvarac, kaux, adarhn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( nbtrto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvtrac, kaux, adtrhn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbteto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 3 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_te', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvteac, kaux, adtehn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvquac, kaux, adquhn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbpyto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 5 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_py', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvpyac, kaux, adpyhn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbheto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 6 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_he', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvheac, kaux, adhehn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbpeto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 7 + jaux = -10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > rvpeac, kaux, adpehn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'rvnoac', rvnoac + write (ulsort,90002) 'rvarac', rvarac + write (ulsort,90002) 'rvtrac', rvtrac + write (ulsort,90002) 'rvquac', rvquac + write (ulsort,90002) 'rvteac', rvteac + write (ulsort,90002) 'rvheac', rvheac + write (ulsort,90002) 'rvpeac', rvpeac + write (ulsort,90002) 'rvpyac', rvpyac +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, norenu ) + call gmprot (nompro, norenu//'.NoHOMARD', 1, 30 ) + call gmprot (nompro, norenu//'.ArHOMARD', 1, min(100,rvarac) ) + if ( rvtrac.ne.0 ) then + call gmprot (nompro, norenu//'.TrHOMARD', 1, min(100,rvtrac) ) + endif + if ( rvquac.ne.0 ) then + call gmprot (nompro, norenu//'.QuHOMARD', 1, min(100,rvquac) ) + endif + if ( rvteac.ne.0 ) then + call gmprot (nompro, norenu//'.TeHOMARD', 1, min(100,rvteac) ) + endif + if ( rvpyac.ne.0 ) then + call gmprot (nompro, norenu//'.PYHOMARD', 1, min(100,rvpyac) ) + endif + if ( rvheac.ne.0 ) then + call gmprot (nompro, norenu//'.HeHOMARD', 1, min(100,rvheac) ) + endif + if ( rvpeac.ne.0 ) then + call gmprot (nompro, norenu//'.PeHOMARD', 1, min(100,rvpeac) ) + endif + call gmprsx (nompro, norenu//'.HeHOMARD' ) + call gmprsx (nompro, norenu//'.PeHOMARD' ) + call gmprsx (nompro, norenu//'.InfoSupE' ) + call gmprsx (nompro, norenu//'.InfoSupE.Tab1' ) + call gmprsx (nompro, norenu//'.InfoSupE.Tab3' ) + call gmprsx (nompro, norenu//'.InfoSupE.Tab9' ) +#endif +c +c 3.2. ==> les caracteristiques de l'indicateur +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. caract. indic ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocind ) + call gmprsx (nompro, nocind//'.InfoCham' ) + call gmprsx (nompro, nocind//'.InfoPaFo' ) + call gmprsx (nompro, nocind//'.InfoProf' ) + call gmprsx (nompro, nocind//'.InfoLoPG' ) + call gmprsx (nompro, '%%%%%%11' ) + call gmprsx (nompro, '%%%%%%11.Nom_Comp' ) + call gmprsx (nompro, '%%%%%%11.Cham_Ent' ) + call gmprsx (nompro, '%%%%%%11.Cham_Ree' ) + call gmprsx (nompro, '%%%%%%11.Cham_Car' ) + call gmprsx (nompro, '%%%%%%13' ) + call gmprsx (nompro, '%%%%%%13.ValeursR' ) + call gmprsx (nompro, '%%%%%%14' ) + call gmprsx (nompro, '%%%%%%14.ValeursR' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCIND0', nompro +#endif +c + call vcind0 ( nocind, + > nocham, nbcomp, nbtvch, adnocp, adcaca, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbcomp + write (ulsort,texte(langue,8)) nbtvch +#endif +c + endif +c +c 3.3. ==> allocation de l'objet +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. allocation ; codret', codret + write (ulsort,*) 'nomaut =', nomaut +#endif +c + if ( codret.eq.0 ) then +c + if ( nomaut ) then + call gmalot ( nohind, 'HOM_Indi', 0, iaux, codret ) + else + call gmaloj ( nohind, 'HOM_Indi', 0, iaux, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then + taopts(8) = nohind + endif +c +c 3.4. ==> noms des composantes retenues, si le champ contient +c plus d'une composante +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. nom des composantes ; codret', codret +#endif +c + if ( nbcomp.gt.1 ) then +c + if ( codret.eq.0 ) then +c + typobs = mcccin + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCLS', nompro +#endif + call utmcls ( typobs, iaux, oblist, jaux, + > ulsort, langue, codre0 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, oblist ) + call gmprsx (nompro, oblist//'.Pointeur' ) + call gmprsx (nompro, oblist//'.Taille' ) + call gmprsx (nompro, oblist//'.Table' ) + endif +#endif +c + if ( codret.eq.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( oblist, iaux, + > ncmpin, jaux, + > adpoin, adtail, adtabl, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.5. ==> Controle des composantes dans le champ +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. Controle ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCIND1', nompro +#endif + call vcind1 ( nbcomp, smem(adnocp+8), + > ncmpin, imem(adpoin), imem(adtail), smem(adtabl), + > nucomp, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( ncmpin.gt.1 ) then + write (ulsort,texte(langue,10+taopti(8))) + if ( taopti(8).eq.2 ) then + write (ulsort,texte(langue,7)) ncmpin + write (ulsort,texte(langue,10+taopti(8))) + write (ulsort,texte(langue,15)) + codret = 35 + endif + else + if ( taopti(8).eq.2 ) then + write (ulsort,texte(langue,12)) + else + write (ulsort,texte(langue,13)) + endif + endif +c + endif +c +c==== +c 4. conversion +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. conversion ; codret', codret +#endif +c 4.0. ==> Au depart, on fait comme si aucune indicateur n'etait present +c a priori, on met des adresses valant 1 pour que quand il n'y +c a pas de tableaux on garde la coherence de passage +c d'arguments avec imem + + nbvnoe = 0 + nbvare = 0 + nbvtri = 0 + nbvqua = 0 + nbvtet = 0 + nbvpyr = 0 + nbvhex = 0 + nbvpen = 0 +c + adnosu = 1 + adnoin = 1 + adarsu = 1 + adarin = 1 + adtrsu = 1 + adtrin = 1 + adqusu = 1 + adquin = 1 + adtesu = 1 + adtein = 1 + adpysu = 1 + adpyin = 1 + adhesu = 1 + adhein = 1 + adpesu = 1 + adpein = 1 +c + do 40 , nrotv = 1 , nbtvch +c + afaire = .false. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) nrotv +#endif +c +c 4.1 ==> adresse de l'indicateur du code de calcul +c type de l'element au sens HOMARD +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCIND2', nompro +#endif + nrpass = nrotv + call vcind2 ( nrpass, + > smem(adcaca), + > adinca, nbtafo, nbenmx, nbpg, tyelho, + > adlipr, nbvapr, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyelho', tyelho +#endif +c +c 4.2. ==> allocation de l'objet +c remarque : on ne traite que les reels +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. Allocation ; codret', codret +#endif +c +c 4.2.0. ==> prealable +c + if ( codret.eq.0 ) then +c + do 420 , iaux = -1 , 7 + nbvent(iaux) = 0 + 420 continue +c + endif +c +c 4.2.1. ==> noeuds +c + if ( codret.eq.0 ) then + if ( rvnoac.ne.0 .and. + > tyelho.eq.tyhnoe ) then +c + typenh = -1 + if ( nbvnoe.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_no', nompro +#endif + call utalih ( nohind, typenh, nbnoto, ncmpin, motaux, + > adnoin, adnosu, + > ulsort, langue, codret) + nbvent(typenh) = rvnoac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.2. ==> aretes +c + if ( codret.eq.0 ) then + if ( rvarac.ne.0 .and. + > ( tyelho.eq.tyhse1 .or. tyelho.eq.tyhse2 ) ) then +c + typenh = 1 + if ( nbvare.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_ar', nompro +#endif + call utalih ( nohind, typenh, nbarto, ncmpin, motaux, + > adarin, adarsu, + > ulsort, langue, codret) + nbvent(typenh) = rvarac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.3. ==> triangles +c + if ( codret.eq.0 ) then + if ( rvtrac.ne.0 .and. + > ( tyelho.eq.tyhtr1 .or. tyelho.eq.tyhtr2 .or. + > tyelho.eq.tyhtr3 ) ) then +c + typenh = 2 + if ( nbvtri.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_tr', nompro +#endif + call utalih ( nohind, typenh, nbtrto, ncmpin, motaux, + > adtrin, adtrsu, + > ulsort, langue, codret) + nbvent(typenh) = rvtrac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.4. ==> quadrangles +c + if ( codret.eq.0 ) then + if ( rvquac.ne.0 .and. + > ( tyelho.eq.tyhqu1 .or. tyelho.eq.tyhqu2 .or. + > tyelho.eq.tyhqu3 ) ) then +c + typenh = 4 + if ( nbvqua.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_qu', nompro +#endif + call utalih ( nohind, typenh, nbquto, ncmpin, motaux, + > adquin, adqusu, + > ulsort, langue, codret) + nbvent(typenh) = rvquac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.5. ==> tetraedres +c + if ( codret.eq.0 ) then + if ( rvteac.ne.0 .and. + > ( tyelho.eq.tyhte1 .or. tyelho.eq.tyhte2 ) ) then +c + typenh = 3 + if ( nbvtet.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_te', nompro +#endif + call utalih ( nohind, typenh, nbteto, ncmpin, motaux, + > adtein, adtesu, + > ulsort, langue, codret) + nbvent(typenh) = rvteac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.6. ==> pyramides +c + if ( codret.eq.0 ) then + if ( rvpyac.ne.0 .and. nbelig.eq.0 .and. + > ( tyelho.eq.tyhpy1 .or. tyelho.eq.tyhpy2 ) ) then +c + typenh = 5 + if ( nbvpyr.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_py', nompro +#endif + call utalih ( nohind, typenh, nbpyto, ncmpin, motaux, + > adpyin, adpysu, + > ulsort, langue, codret) +c + nbvent(typenh) = rvpyac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.7. ==> hexaedres +c + if ( codret.eq.0 ) then + if ( rvheac.ne.0 .and. + > ( tyelho.eq.tyhhe1 .or. tyelho.eq.tyhhe2 .or. + > tyelho.eq.tyhhe3 ) ) then +c + typenh = 6 + if ( nbvhex.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_he', nompro +#endif + call utalih ( nohind, typenh, nbheto, ncmpin, motaux, + > adhein, adhesu, + > ulsort, langue, codret) +c + nbvent(typenh) = rvheac + afaire = .true. +c + endif +c + endif + endif +c +c 4.2.8. ==> pentaedres +c + if ( codret.eq.0 ) then + if ( rvpeac.ne.0 .and. + > ( tyelho.eq.tyhpe1 .or. tyelho.eq.tyhpe2 ) ) then +c + typenh = 7 + if ( nbvpen.ne.0 ) then + codret = 1000 + typenh + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_pe', nompro +#endif + call utalih ( nohind, typenh, nbpeto, ncmpin, motaux, + > adpein, adpesu, + > ulsort, langue, codret) +c + nbvent(typenh) = rvpeac + afaire = .true. +c + endif +c + endif + endif +c +c 4.3. ==> Si l'indicateur est exprime par points de Gauss, on le +c rapporte par maille +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. points de Gauss ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpg.gt.1 ) then +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCIND3', nompro +#endif + call vcind3 ( nbtafo, nbenmx, rmem(adinca), nbpg, + > ncmpin, nucomp, + > adindi, ntrava, + > ulsort, langue, codret) +c + endif +c + else +c + adindi = adinca +c + endif +c + endif +c +c 4.4. ==> conversion de l'indicateur en fonction de son type +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. en fct du type ; codret', codret + write (ulsort,99001) 'afaire', afaire +#endif +c + if ( codret.eq.0 ) then +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINRR', nompro +#endif + call vcinrr ( nbvent, + > imem(adnosu), rmem(adnoin), + > imem(adarsu), rmem(adarin), + > imem(adtrsu), rmem(adtrin), + > imem(adqusu), rmem(adquin), + > imem(adtesu), rmem(adtein), + > imem(adhesu), rmem(adhein), + > imem(adpysu), rmem(adpyin), + > imem(adpesu), rmem(adpein), + > nbvapr, imem(adlipr), + > nbtafo, nbenmx, rmem(adindi), + > ncmpin, nucomp, + > imem(adnohn), + > imem(adarhn), + > imem(adtrhn), + > imem(adquhn), + > imem(adtehn), + > imem(adhehn), + > imem(adpyhn), + > imem(adpehn), + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.5. ==> menage eventuel +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.5. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpg.gt.1 .and. afaire ) then +c + call gmlboj ( ntrava , codret ) +c + endif +c + endif +c + nbvnoe = nbvnoe + nbvent(-1) + nbvare = nbvare + nbvent(1) + nbvtri = nbvtri + nbvent(2) + nbvqua = nbvqua + nbvent(4) + nbvtet = nbvtet + nbvent(3) + nbvpyr = nbvpyr + nbvent(5) + nbvhex = nbvhex + nbvent(6) + nbvpen = nbvpen + nbvent(7) +c + 40 continue +c +c==== +c 5. menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmsgoj ( nocind, codre1 ) + if ( nbcomp.gt.1 ) then + call gmsgoj ( oblist, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + call gmprsx(nompro, nohind) +c + call gmprsx(nompro, nohind//'.Noeud') + call gmprot (nompro, nohind//'.Noeud.Support' , 1, 10 ) + call gmprot (nompro, nohind//'.Noeud.'//motaux , 1, 10 ) + if ( nbnoto.gt.10 ) then + call gmprot (nompro, nohind//'.Noeud.Support',nbnoto-9,nbnoto) + call gmprot (nompro, nohind//'.Noeud.'//motaux,nbnoto-9,nbnoto) + endif +c + call gmprot (nompro, nohind//'.Arete.'//motaux , 1, 10 ) + if ( nbarto.gt.10 ) then + call gmprot (nompro, nohind//'.Arete.'//motaux,nbarto-9,nbarto) + endif +c + if ( nbtrto.gt.0 ) then + call gmprot (nompro, nohind//'.Trian.'//motaux , 1, 10 ) + if ( nbtrto.gt.10 ) then + call gmprot (nompro, nohind//'.Trian.'//motaux,nbtrto-9,nbtrto) + endif + endif +c + if ( nbquto.gt.0 ) then + if ( nbquto.gt.50 ) then + call gmprot (nompro, nohind//'.Quadr.'//motaux , 1, 50 ) + call gmprot (nompro, nohind//'.Quadr.'//motaux,nbquto-49,nbquto) + else + call gmprsx (nompro, nohind//'.Quadr.Support' ) + call gmprsx (nompro, nohind//'.Quadr.'//motaux ) + endif + endif +c + if ( nbteto.gt.0 ) then + call gmprot (nompro, nohind//'.Tetra.'//motaux , 1, 10 ) + if ( nbteto.gt.10 ) then + call gmprot (nompro, nohind//'.Tetra.'//motaux,nbteto-9,nbteto) + endif + endif +c + if ( nbelig.eq.0 .and. nbpyto.gt.0 ) then + call gmprot (nompro, nohind//'.Pyram.'//motaux , 1, 10 ) + if ( nbpyto.gt.10 ) then + call gmprot (nompro, nohind//'.Pyram.'//motaux,nbpyto-9,nbpyto) + endif + endif +c + if ( nbheto.gt.0 ) then + call gmprot (nompro, nohind//'.Hexae.'//motaux , 1, 10 ) + if ( nbheto.gt.10 ) then + call gmprot (nompro, nohind//'.Hexae.'//motaux,nbheto-9,nbheto) + endif + endif +c + if ( nbpeto.gt.0 ) then + call gmprot (nompro, nohind//'.Penta.'//motaux , 1, 10 ) + if ( nbpeto.gt.10 ) then + call gmprot (nompro, nohind//'.Penta.'//motaux,nbpeto-9,nbpeto) + endif + endif +c + endif +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ge.999 ) then + typenh = codret - 1000 + write (ulsort,texte(langue,17)) mess14(langue,3,typenh) + write (ulsort,texte(langue,18)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AV_Conversion/vcinr1.F b/src/tool/AV_Conversion/vcinr1.F new file mode 100644 index 00000000..ac4a5426 --- /dev/null +++ b/src/tool/AV_Conversion/vcinr1.F @@ -0,0 +1,240 @@ + subroutine vcinr1 ( nbento, rvenac, nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, nenvho, listpr, + > ensupp, enindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INdicateur - Reel - etape 1 +c - - -- - - +c but : conversion de l'indicateur d'erreur +c valeurs reelles double precision de l'indicateur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbento . e . 1 . nombre total d'entites . +c . rvenac . e . 1 . taille de la renumerotation des entites . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . nbtafo . e . 1 . nombre de tableaux dans la fonction . +c . nbvind . e . 1 . nombre d'entites maximum . +c . ncmpin . e . 1 . nombre de composantes retenues . +c . nucomp . e . ncmpin . numeros des composantes retenues . +c . indica . e . nbtafo . valeurs de l'indicateur . +c . . .*nbvind . . +c . nenvho . e . rvenac . numero des entites dans HOMARD . +c . listpr . e . * . liste des numeros d'elements ou l'indica- . +c . . . . teur est defini. . +c . ensupp . s . nbento . support pour les entites . +c . enindi . s . nbento . valeurs pour les entites . +c . . .*ncmpin . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCINR1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer nbento, rvenac, nbvapr + integer nbtafo, nbvind + integer ncmpin, nucomp(ncmpin) + integer ensupp(nbento) + integer listpr(*) + integer nenvho(rvenac) +c + double precision enindi(nbento,ncmpin) + double precision indica(nbtafo,nbvind) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbval + integer adtra1 + integer nbenti +c + character*8 ntrav1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''.. Pas de profil'')' + texte(1,6) = '(''.. Profil de longueur :'',i10)' + texte(1,7) = '(''.. Taille de la renumerotation :'',i10)' +c + texte(2,5) = '(''.. No profile'')' + texte(2,6) = '(''.. Profile length:'',i10)' + texte(2,7) = '(''.. Renumbering size:'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( nbvapr.le.0 ) then + write (ulsort,texte(langue,5)) + else + write (ulsort,texte(langue,6)) nbvapr + endif + write (ulsort,texte(langue,7)) rvenac +#endif +c +cgn do 111 , iaux = 1 , nbtafo +cgn do 111 , adtra1 = 1 , nbvind +cgn write (ulsort,90124) 'indica',iaux,adtra1,indica(iaux,adtra1) +cgn 111 continue +cgn do 112 , iaux = 1 , rvenac +cgn write (ulsort,90112) 'nenvho',iaux,nenvho(iaux) +cgn 112 continue +c +c==== +c 2. initialisation : a priori sans support +c attention : on ne fait rien sur la valeur de l'indicateur ; ainsi, +c il aura la valeur par defaut du gestionnaire de memoire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. initialisation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nbento + ensupp(iaux) = 0 + 21 continue + if ( nbvapr.gt.0 ) then + nbenti = nbvapr + else + nbenti = rvenac + endif +c + endif +c +cgn write (ulsort,90002) 'nbvapr,nbenti,rvenac',nbvapr,nbenti,rvenac +c +c==== +c 3. conversion +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. conversion ; codret', codret +#endif +c +c 3.1. ==> tableau de travail +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', rvenac, adtra1, codret ) +c + endif +c +c 3.2. ==> filtrage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCTE3', nompro +#endif + call utcte3 ( 2, rvenac, nenvho, + > nbval, imem(adtra1), + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> transfert +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR2', nompro +#endif + call vcinr2 ( nbento, nbenti, rvenac, nbvapr, + > nbtafo, nbvind, + > ncmpin, nucomp, + > indica, nenvho, listpr, + > ensupp, enindi, imem(adtra1), + > ulsort, langue, codret) +c + endif +c +c 3.4. ==> menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcinr2.F b/src/tool/AV_Conversion/vcinr2.F new file mode 100644 index 00000000..2174fd48 --- /dev/null +++ b/src/tool/AV_Conversion/vcinr2.F @@ -0,0 +1,212 @@ + subroutine vcinr2 ( nbento, nbenti, rvenac, nbvapr, + > nbtafo, nbvind, + > ncmpin, nucomp, + > indica, nuenho, listpr, + > ensupp, enindi, tabaux, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INdicateur - Reel - etape 2 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbento . e . 1 . nombre total d'entites . +c . nbenti . e . 1 . nombre total d'entites selon le profil . +c . rvenac . e . 1 . taille de la renumerotation des entites . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil +c . nbvind . e . 1 . nombre d'entites maximum . +c . nbtafo . e . 1 . nombre de tableaux dans la fonction . +c . ncmpin . e . 1 . nombre de composantes retenues . +c . nucomp . e . ncmpin . numeros des composantes retenues . +c . indica . e . nbtafo . valeurs de l'indicateur . +c . . .*nbvind . . +c . nuenho . e . rvenac . numero des entites dans HOMARD . +c . listpr . e . * . liste des numeros d'elements ou l'indica- . +c . . . . teur est defini. . +c . ensupp . s . nbento . support pour les entites . +c . enindi . s . nbento . valeurs pour les entites . +c . . .*ncmpin . . +c . tabaux . e . rvenac . auxiliaire de filtrage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCINR2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbento, nbenti, rvenac, nbvapr + integer nbtafo, nbvind + integer ncmpin, nucomp(ncmpin) + integer ensupp(nbento) + integer listpr(*) + integer nuenho(rvenac) + integer tabaux(rvenac) +c + double precision enindi(nbento,ncmpin) + double precision indica(nbtafo,nbvind) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbval + integer nrcomp +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Pas de profil'')' + texte(1,5) = '(''.. Profil de longueur :'',i10)' + texte(1,6) = '(''.. Numero de la composante :'',i10)' +c + texte(2,4) = '(''.. No profile'')' + texte(2,5) = '(''.. Profile length :'',i10)' + texte(2,6) = '(''.. Component # :'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( nbvapr.le.0 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) nbvapr + endif + if ( ncmpin.eq.1 ) then + write (ulsort,texte(langue,6)) nucomp(1) + endif + write (ulsort,90002) 'nbenti', nbenti +#endif +c +c==== +c 2. Transfert de 1 ou plusieurs composantes +c==== +c + nbval = 0 +c +c 2.1. ==> sans profil +c + if ( nbvapr.eq.-1 ) then +c + do 21 , iaux = 1 , nbenti +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90112) 'tabaux', iaux, tabaux(iaux) +#endif + jaux = tabaux(iaux) + if ( jaux.ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90112) 'tabaux', iaux, tabaux(iaux),nuenho(jaux) +#endif + nbval = nbval + 1 + ensupp(nuenho(jaux)) = 1 + do 211 , nrcomp = 1, ncmpin + enindi(nuenho(jaux),nrcomp) = indica(nucomp(nrcomp),nbval) +cgn write (ulsort,90004) 'valeur', enindi(nuenho(jaux),nrcomp) + 211 continue + endif +c + 21 continue +c +c 2.2. ==> avec profil +c + else +c + do 22 , iaux = 1 , nbenti +c + jaux = tabaux(listpr(iaux)) + if ( jaux.ne.0 ) then + nbval = nbval + 1 + ensupp(nuenho(jaux)) = 1 + daux = 0.d0 + do 221 , nrcomp = 1, ncmpin + enindi(nuenho(jaux),nrcomp) = indica(nucomp(nrcomp),nbval) + 221 continue + endif +c + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbval', nbval +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcinrr.F b/src/tool/AV_Conversion/vcinrr.F new file mode 100644 index 00000000..57e282a1 --- /dev/null +++ b/src/tool/AV_Conversion/vcinrr.F @@ -0,0 +1,368 @@ + subroutine vcinrr ( nbvent, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, + > hesupp, heindi, + > pysupp, pyindi, + > pesupp, peindi, + > nbvapr, listpr, + > nbtafo, nbvind, indica, + > ncmpin, nucomp, + > nnovho, + > narvho, + > ntrvho, + > nquvho, + > ntevho, + > nhevho, + > npyvho, + > npevho, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion d'INdicateur - REel +c - - -- -- +c but : conversion de l'indicateur d'erreur +c valeurs reelles double precision de l'indicateur +c ======================== +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type . +c . . . . d'element au sens HOMARD avec indicateur . +c . nosupp . s . nbnoto . support pour les noeuds . +c . noindi . s . nbnoto . valeurs pour les noeuds . +c . arsupp . s . nbarto . support pour les aretes . +c . arindi . s . nbarto . valeurs pour les aretes . +c . trsupp . s . nbtrto . support pour les triangles . +c . trindi . s . nbtrto . valeurs pour les triangles . +c . qusupp . s . nbquto . support pour les quadrangles . +c . quindi . s . nbquto . valeurs pour les quadrangles . +c . tesupp . s . nbteto . support pour les tetraedres . +c . teindi . s . nbteto . valeurs pour les tetraedres . +c . hesupp . s . nbheto . support pour les hexaedres . +c . heindi . s . nbheto . valeurs pour les hexaedres . +c . pysupp . s . nbpyto . support pour les pyramides . +c . pyindi . s . nbpyto . valeurs pour les pyramides . +c . pesupp . s . nbpeto . support pour les pentaedres . +c . peindi . s . nbpeto . valeurs pour les pentaedres . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . listpr . e . * . liste des numeros d'elements ou l'indica- . +c . . . . teur est defini. . +c . nbtafo . e . 1 . nombre de tableaux dans la fonction . +c . nbvind . e . 1 . nombre d'entites maximum . +c . indica . e . nbtafo . valeurs de l'indicateur . +c . . .*nbvind . . +c . ncmpin . e . 1 . nombre de composantes retenues . +c . nucomp . e . ncmpin . numeros des composantes retenues . +c . nnovho . e . rvnoto . numero des noeuds dans homard . +c . narvho . e . rvarac . numero des aretes dans homard . +c . ntrvho . e . rvtrac . numero des triangles dans HOMARD . +c . nquvho . e . rvquac . numero des quadrangles dans HOMARD . +c . ntevho . e . rvteac . numero des tetraedres dans HOMARD . +c . nhevho . e . rvheac . numero des hexaedres dans HOMARD . +c . npyvho . e . rvpyac . numero des pyramides dans HOMARD . +c . npevho . e . rvpeac . numero des pentaedres dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCINRR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbvent(-1:7) + integer nosupp(nbnoto) + integer arsupp(nbarto) + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) + integer nbvapr + integer nbtafo, nbvind + integer ncmpin, nucomp(ncmpin) + integer listpr(*) +c + integer nnovho(*) + integer narvho(*) + integer ntrvho(*) + integer nquvho(*) + integer ntevho(*) + integer nhevho(*) + integer npyvho(*) + integer npevho(*) +c + integer ulsort, langue, codret +c + double precision noindi(nbnoto,ncmpin), arindi(nbarto,ncmpin) + double precision trindi(nbtrto,ncmpin), quindi(nbquto,ncmpin) + double precision teindi(nbteto,ncmpin), heindi(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin), peindi(nbpeto,ncmpin) + double precision indica(nbtafo,nbvind) +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Indicateur d''''erreur sur les '',i10,1x,a)' +c + texte(2,4) = '(''. Error indicator over '',i10,1x,a)' +c +#include "impr03.h" +c +cgn do 111 , iaux = 1 , nbtafo +cgn do 111 , jaux = 1 , nbvind +cgn write (ulsort,90124) 'indica',iaux,jaux,indica(iaux,jaux) +cgn 111 continue +cgn do 112 , iaux = 1 , rvtrac +cgn write (ulsort,90112) 'ntrvho',iaux,ntrvho(iaux) +cgn 112 continue +cgn print *, 'dans ',nompro,', tyelho, nbvapr = ',tyelho, nbvapr +cgn print *, 'dans ',nompro,', nbtafo,nbvind = ',nbtafo,nbvind +c +c==== +c 2. conversion selon le type d'entite +c==== +c +c 2.1. ==> au moins un indicateur est exprime sur les tetraedres +c + iaux = 3 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbteto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_te', nompro +#endif + call vcinr1 ( nbteto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, ntevho, listpr, + > tesupp, teindi, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> au moins un indicateur est exprime sur les quadrangles +c + iaux = 4 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbquto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_qu', nompro +#endif + call vcinr1 ( nbquto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, nquvho, listpr, + > qusupp, quindi, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> au moins un indicateur est exprime sur les triangles +c + iaux = 2 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbtrto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_tr', nompro +#endif + call vcinr1 ( nbtrto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, ntrvho, listpr, + > trsupp, trindi, + > ulsort, langue, codret) +c + endif +c +c 2.4. ==> au moins un indicateur est exprime sur les aretes +c + iaux = 1 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbarto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_ar', nompro +#endif + call vcinr1 ( nbarto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, narvho, listpr, + > arsupp, arindi, + > ulsort, langue, codret) +c + endif +c +c 2.5. ==> au moins un indicateur est exprime sur les noeuds +c + iaux = -1 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbnoto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_no', nompro +#endif + call vcinr1 ( nbnoto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, nnovho, listpr, + > nosupp, noindi, + > ulsort, langue, codret) +c + endif +c +c 2.5. ==> au moins un indicateur est exprime sur les pyramides +c + iaux = 5 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpyto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_py', nompro +#endif + call vcinr1 ( nbpyto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, npyvho, listpr, + > pysupp, pyindi, + > ulsort, langue, codret) +c + endif +c +c 2.6. ==> au moins un indicateur est exprime sur les hexaedres +c + iaux = 6 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_he', nompro +#endif + call vcinr1 ( nbheto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, nhevho, listpr, + > hesupp, heindi, + > ulsort, langue, codret) +c + endif +c +c 2.7. ==> au moins un indicateur est exprime sur les pentaedres +c + iaux = 7 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINR1_pe', nompro +#endif + call vcinr1 ( nbpeto, nbvent(iaux), nbvapr, + > nbtafo, nbvind, ncmpin, nucomp, + > indica, npevho, listpr, + > pesupp, peindi, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmaco.F b/src/tool/AV_Conversion/vcmaco.F new file mode 100644 index 00000000..6d362706 --- /dev/null +++ b/src/tool/AV_Conversion/vcmaco.F @@ -0,0 +1,2290 @@ + subroutine vcmaco ( modhom, typcce, eleinc, + > tyconf, maext0, + > nocman, nohman, typnom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de MAillage - COnnectivite +c - - -- -- +c ______________________________________________________________________ +c +c cette conversion suppose que l'on ne garde du maillage +c que les elements suivants : +c . 0D : mailles-points +c . 1D : poutres +c . 2D : triangles, quadrangles +c . 3D : tetraedres, hexaedres, pentaedres, pyramides. +c le degre est 1 ou 2, mais il est le meme pour toutes les mailles. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . -5 : executable du suivi de frontiere . +c . . . . -4 : exec. de l'interface apres adaptation . +c . . . . -3 : exec. de l'interface avant adaptation . +c . . . . -2 : executable de l'information . +c . . . . -1 : executable de l'adaptation . +c . . . . 0 : executable autre . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . typcce . e . 1 . type du code de calcul en entree . +c . eleinc . e . 1 . elements incompatibles . +c . . . . 0 : on bloque s'il y en a . +c . . . . 1 : on les ignore s'il y en a . +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . maext0 . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . nocman . e . char*8 . nom de l'objet maillage calcul iteration n . +c . nohman . es . char*8 . nom de l'objet maillage homard iteration n . +c . typnom . e . 1 . type du nom de l'objet maillage . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMACO' ) +c +#include "nblang.h" +#include "referx.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "dicfen.h" +#include "envca1.h" +#include "envca2.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +#include "nomest.h" +#include "nbfami.h" +c +#include "rfamed.h" +c +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer modhom, typcce, eleinc, tyconf, maext0 + integer typnom +c + character*8 nocman, nohman +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lgnoig + integer adnoig + integer pnoemp, phetmp + integer pcoono, phetno, pareno + integer psomar + integer ppovos, pvoiso + integer pposif, pfacar + integer phetar, pfilar, pmerar, adars2 + integer phettr, pfiltr, ppertr, pnivtr, paretr, adnmtr + integer phetqu, pfilqu, pperqu, pnivqu, parequ, adnmqu + integer ptrite, pcotrt, phette, pfilte, pperte + integer pquahe, pcoquh, phethe, pfilhe, pperhe, adnmhe + integer pfacpy, pcofay, phetpy, pfilpy, pperpy + integer pfacpe, pcofap, phetpe, pfilpe, pperpe + integer pnp2ar + integer hfmdel, hnoeel + integer dimcst + integer nbpqt, pinftb +c + integer pcexno, pcexmp, pcexar + integer pcextr, pcexqu + integer pcexte, pcexhe, pcexpy, pcexpe +c + integer adnbrn + integer adnohn, adnocn, adnoic + integer admphn, admpcn, admpic + integer adarhn, adarcn, adaric + integer adtrhn, adtrcn, adtric + integer adquhn, adqucn, adquic + integer adtehn, adtecn, adteic + integer adhehn, adhecn, adheic + integer adpyhn, adpycn, adpyic + integer adpehn, adpecn, adpeic +c + integer pfamen, pfamee, pnoeel, ptypel, pcoonc + integer pnuele, pnunoe +c + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 +c + integer iaux, jaux, kaux, paux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8, codre0 + integer nbnomb, adnomb + integer voarno, vofaar, vovoar, vovofa + integer decanu(-1:7) + integer nbardb, cpt, nbarne, rbarne +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*9 saux09 +c + logical existe +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +cmdc ---------------- MAILLES DOUBLES DEBUT -------------- +cmd integer nbelnw, nbtenw +cmd character*80 nomfic +cmd logical maildb +cmd integer adpoin, adtail, adtabl +cmd integer adnumf +cmdc ---------------- MAILLES DOUBLES FIN ---------------- +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Estimation du nombre d''''aretes :'')' + texte(1,5) = '(7x,''Passage numero'',i5)' + texte(1,6) = '(5x,''Type de logiciel inconnu :'',i10,/)' + texte(1,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)' + texte(1,8) = + > '(/,5x,i10,'' autres elements.'',/,5x,''Cela est interdit ...'')' + texte(1,10) ='(/,''On '',a,'' les elements incompatibles.'')' +c + texte(2,4) = '(5x,''Estimation of the number of edges:'')' + texte(2,5) = '(7x,''Pass #'',i5)' + texte(2,6) = '(5x,''This kind of software is unknown:'',i10,/)' + texte(2,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)' + texte(2,8) = + > '(/,5x,i10,'' other elements.'',/,5x,''This is forbidden ...'')' + texte(2,10) ='(/,''Incompatible elements are '',a)' +c +#include "impr03.h" +c + typcca = typcce +c +#include "mslve4.h" +c +#ifdef _DEBUG_HOMARD_ + if ( eleinc.eq.0 ) then + write (ulsort,texte(langue,10)) 'bloque' + else + write (ulsort,texte(langue,10)) 'ignore' + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcce', typcce + write (ulsort,90002) 'tyconf', tyconf + write (ulsort,90002) 'maext0', maext0 +#endif +c +c==== +c 2. controle des elements a faces quadrangulaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. faces quadrangulaires ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAURQ', nompro +#endif +c + call utaurq ( modhom, eleinc, + > nocman, + > nbelig, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbelig', nbelig +#endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation donnees ; codret', codret +#endif +c +c 3.1. ==> les noms des structures +#ifdef _DEBUG_HOMARD_ + call gmprsx( nompro, nocman) +cgn call gmprsx( nompro, nocman//'.ConnNoeu') +cgn call gmprsx( nompro, nocman//'.ConnNoeu.Noeuds') +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocman, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c +c 3.2. ==> les principales constantes +c + if ( codret.eq.0 ) then +c + call gmliat ( ncnoeu, 1, nbnoto, codre1 ) + call gmliat ( ncnoeu, 2, nctfno, codre2 ) + call gmliat ( ncnoeu, 3, dimcst, codre3 ) + call gmliat ( nccono, 1, nbelem, codre4 ) + call gmliat ( nccono, 2, nbmane, codre5 ) + call gmadoj ( ncnomb, adnomb, iaux, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMC', nompro +#endif + call utnbmc ( imem(adnomb), + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> les adresses +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 510510 + call utad11 ( iaux, ncnoeu, nccono, + > pcoonc, pfamen, pnunoe, jaux, + > ptypel, pfamee, pnoeel, pnuele, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12', nompro +#endif + iaux = 7 + jaux = -1 + call utad12 ( iaux, jaux, + > nccoex, pcexno, + > ulsort, langue, codret ) +c + endif +c +cmdc ---------------- MAILLES DOUBLES DEBUT -------------- +cmdc 3.4. ==> menage des mailles dupliquees +cmdc +cmdc 3.4.1. ==> Lecture du numero de la couche en cours +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd nomfic = 'nrc.dat' +cmd inquire ( file = nomfic, exist = maildb ) +cmdc +cmd endif +cmdc +cmd if ( maildb ) then +cmdc +cmdcgn#ifdef _DEBUG_HOMARD_ +cmd write (ulsort,*) 'MENAGE' +cmd#endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmadoj ( ncfami//'.Numero', adnumf, iaux, codret ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdcgn call gmprsx(nompro,ncfami) +cmdcgn call gmprsx(nompro,ncfami//'.Numero') +cmdcgn call gmprsx(nompro,ncfami//'.Groupe') +cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Pointeur') +cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Taille') +cmdcgn call gmprsx(nompro,ncfami//'.Groupe.Table') +cmdc +cmdcgn#ifdef _DEBUG_HOMARD_ +cmd write (ulsort,texte(langue,3)) 'UTRPTC', nompro +cmd#endif +cmd call utrptc ( ncfami//'.Groupe', +cmd > iaux, jaux, +cmd > adpoin, adtail, adtabl, +cmd > ulsort, langue, codret ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmalot ( ntrav1, 'entier ', nbelem, ptrav1, codre1 ) +cmd iaux = 2*nbfmed +cmd call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +cmdc +cmd codre0 = min ( codre1, codre2 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2 ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmdcgn call gmprsx ( nompro, nccono//'.Noeuds') +cmdcgn write(ulsort,90003) 'norete', norete +cmdcgn write(ulsort,90002) 'nbeled', nbelem +cmdcgn write(ulsort,90002) 'nbtetd', nbtetr +cmdcgn#ifdef _DEBUG_HOMARD_ +cmd write (ulsort,texte(langue,3)) 'VCMMEN', nompro +cmd#endif +cmd call vcmmen +cmd > ( nbelem, nbelnw, +cmd > nbtetr, nbtenw, +cmd > imem(pnoeel), imem(pfamee), imem(ptypel), imem(pnuele), +cmd > imem(adnumf), +cmd > imem(adpoin), imem(adtail), smem(adtabl), +cmd > imem(ptrav1), imem(ptrav2), imem(ptrav2+nbfmed), +cmd > ulsort, langue, codret ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmmod ( nccono//'.Noeuds', +cmd > pnoeel, nbelem, nbelnw, nbmane, nbmane, codre1 ) +cmd call gmmod ( nccono//'.Type', +cmd > ptypel, nbelem, nbelnw, 1, 1, codre2 ) +cmd call gmmod ( nccono//'.FamilMED', +cmd > pfamee, nbelem, nbelnw, 1, 1, codre3 ) +cmd call gmmod ( nccono//'.NumeExte', +cmd > pnuele, nbelem, nbelnw, 1, 1, codre4 ) +cmd call gmecat ( nccono, 1, nbelnw, codre5 ) +cmdc +cmd codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2, codre3, codre4, codre5 ) +cmdc +cmd endif +cmdc +cmd if ( codret.eq.0 ) then +cmdc +cmd nbelem = nbelnw +cmd numael = numael - nbtetr + nbtenw +cmd imem(adnomb+4) = numael +cmd nbtetr = nbtenw +cmd imem(adnomb+14) = nbtetr +cmdc +cmd endif +cmd if ( codret.eq.0 ) then +cmdc +cmd call gmlboj ( ntrav1 , codre1 ) +cmd call gmlboj ( ntrav2 , codre2 ) +cmdc +cmd codre0 = min ( codre1, codre2 ) +cmd codret = max ( abs(codre0), codret, +cmd > codre1, codre2 ) +cmdc +cmd endif +cmdc +cmd endif +cmdc +cmdc ---------------- MAILLES DOUBLES FIN ---------------- +c +c==== +c 4. preliminaires +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. preliminaires ; codret', codret +#endif +c +c 4.1.==> initialisations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINEI', nompro +#endif + call utinei ( modhom, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> allocation de la tete du maillage HOMARD +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAHMA', nompro +#endif + iaux = 1 + rafdef = 0 + if ( dimcst.eq.0 ) then + sdim = sdimca + else + sdim = sdimca - 1 + endif + if ( (nbtetr+nbhexa+nbpent+nbpyra).gt.0 ) then + mdim = 3 + elseif ( (nbtria+nbquad).gt.0 ) then + mdim = 2 + else + mdim = 1 + endif + typsfr = 0 + maextr = maext0 + call utahma ( nohman, typnom, iaux, + > sdim, mdim, degre, mailet, maconf, + > homolo, hierar, rafdef, + > nbmane, typcca, typsfr, maextr, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c +c 4.3. ==> renumerotation +c + if ( codret.eq.0 ) then +c + iaux = 25 + call gmecat ( norenu, 19, iaux, codre1 ) + call gmaloj ( norenu//'.Nombres', ' ', iaux, adnbrn, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 4.4. ==> les caracteristiques du maillage de calcul +c + if ( codret.eq.0 ) then +c + imem(adnbrn+9) = nbelem + imem(adnbrn+10) = nbmaae + imem(adnbrn+11) = nbmafe + imem(adnbrn+12) = nbmane + imem(adnbrn+13) = nbmapo + imem(adnbrn+14) = nbsegm + imem(adnbrn+15) = nbtetr + imem(adnbrn+16) = nbtria + imem(adnbrn+17) = nbquad + imem(adnbrn+18) = numael + imem(adnbrn+19) = numano + imem(adnbrn+22) = nbhexa + imem(adnbrn+23) = nbpyra + imem(adnbrn+24) = nbpent +c +c 4.5. ==> nombre total de mailles-points, de tetraedres, d'hexaedres, +c de pentaedres, de pyramides +c + nbmpto = nbmapo + nbteto = nbtetr + nbtecf = nbteto + nbteca = 0 + nbheto = nbhexa + nbhecf = nbheto + nbheca = 0 + nbpeto = nbpent + nbpecf = nbpeto + nbpeca = 0 + nbpyto = nbpyra - nbelig + nbpycf = nbpyto + nbpyca = 0 +c +c 4.6. ==> initialisation des nombres reels de familles +c + nbfnoe = 0 + nbfmpo = 0 + nbfare = 0 + nbftri = 0 + nbfqua = 0 + nbftet = 0 + nbfhex = 0 + nbfpyr = 0 + nbfpen = 0 +c + endif +c +c==== +c 5. traitement des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. traitement des noeuds ; codret', codret +#endif +c +c 5.1. ==> nombres +c + if ( codret.eq.0 ) then +c + rsnoac = numano + rsnoto = nbnoto +c + endif +c +c 5.2. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + call gmecat ( nhnoeu, 1, nbnoto, codre1 ) + call gmecat ( nhnoeu, 2, 0, codre2 ) + lgnoig = 4 + call gmecat ( nhnoeu, 3, lgnoig, codre3 ) + call gmecat ( nhnoeu, 4, 0, codre4 ) + call gmaloj ( nhnoeu//'.InfoGene', ' ', lgnoig, adnoig, codre5 ) + call gmaloj ( nhnoeu//'.HistEtat', ' ', nbnoto, phetno, codre6 ) + iaux = sdim * nbnoto + call gmaloj ( nhnoeu//'.Coor', ' ', iaux, pcoono, codre7 ) + call gmaloj ( nhnoeu//'.AretSupp', ' ', nbnoto, pareno, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmalot ( ntrav1, 'entier ', nbnoto, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_no', nompro +#endif + iaux = -1 + kaux = 2310 + call utre01 ( iaux, kaux, norenu, rsnoac, rsnoto, + > adnohn, adnocn, adnoic, + > ulsort, langue, codret) +c + endif +c +c 5.3. ==> les informations generales +c + if ( codret.eq.0 ) then + smem(adnoig) = 'm ' + smem(adnoig+1) = 'x ' + smem(adnoig+2) = 'y ' + smem(adnoig+3) = 'z ' + endif +c +c 5.5. ==> traitement des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.5. traitement noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNOE', nompro +#endif + call vcmnoe ( eleinc, imem(pfamen), imem(pnoeel), imem(ptypel), + > dimcst, rmem(pcoonc), + > imem(adnohn), imem(adnocn), + > rmem(pcoono), imem(phetno), imem(pcexno), + > imem(ptrav1), imem(ptrav2), + > ulsort, langue, codret ) +c + endif +cgn call gmprsx ( nompro , norenu//'.NoHOMARD' ) +cgn call gmprsx ( nompro , norenu//'.NoCalcul' ) +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codret ) +c + imem(adnbrn) = nbnois + imem(adnbrn+1) = nbnoei + imem(adnbrn+2) = nbnomp + imem(adnbrn+3) = nbnop1 + imem(adnbrn+4) = nbnop2 + imem(adnbrn+5) = nbnoim +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhnoeu, 2, dimcst, codre1 ) + call gmcpoj ( ncnoeu//'.CoorCons', nhnoeu//'.CoorCons', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 6. determination des elements 0d, 1d, 2d ou 3d voisins des sommets +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. traitement mailles ; codret', codret +#endif +c +c 6.1. ==> comptage du nombre d'elements pour chaque sommet +c et determination des pointeurs par sommets sur "voisom", +c ranges dans la structure "povoso" +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'PtTabEnt', 0, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = nbnoto + 1 + call gmaloj ( ntrav1//'.Pointeur', ' ', iaux, ppovos, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVOS1', nompro +#endif + call vcvos1 ( imem(pnoeel), imem(ptypel), imem(ppovos), + > nvosom, nbelem, nbmane, nbnoto ) + imem(adnbrn+21) = nvosom +c + endif +c +c 6.2. ==> reperage des voisins : la structure voisom contient la +c liste des elements 1d, 2d ou 3d voisins de chaque sommet +c (allocation du tableau des voisins a une taille egale +c au nombre cumule de voisins des sommets) +c + if ( codret.eq.0 ) then +c + call gmaloj ( ntrav1//'.Table', ' ', nvosom, pvoiso, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVOS2', nompro +#endif + call vcvos2 ( imem(pnoeel), imem(ptypel), imem(ppovos), + > imem(pvoiso), nvosom, nbelem, nbmane, nbnoto ) +c + endif +cgn call gmprsx ( nompro, ntrav1 ) +cgn call gmprsx ( nompro, ntrav1//'.Pointeur' ) +cgn call gmprsx ( nompro, ntrav1//'.Table' ) +c +c==== +c 7. prise en compte des mailles-points +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. traitement mailles-points ; codret', + > codret +#endif +c +c 7.1. ==> memorisation du nombre de mailles-points +c + if ( codret.eq.0 ) then +c + call gmecat ( nhmapo, 1, nbmpto, codret ) +c + endif +c +c 7.2. ==> allocation des tableaux +c + rsmpto = nbmpto + if ( nbmpto.ne.0 ) then + rsmpac = numael + else + rsmpac = 0 + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 2 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_mp', nompro +#endif + call utal02 ( iaux, jaux, + > nhmapo, nbmpto, kaux, + > phetmp, pnoemp, paux, paux, + > paux, paux, + > paux, paux, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + iaux = nbmpto * nctfmp + call gmaloj ( nccoex//'.Point', ' ', iaux , pcexmp, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_mp', nompro +#endif + iaux = 0 + kaux = 2310 + call utre01 ( iaux, kaux, norenu, rsmpac, rsmpto, + > admphn, admpcn, admpic, + > ulsort, langue, codret) +c + endif +c +c 7.3. ==> remplissage des tableaux +c e : ntrav1 : voisom, voisinage des sommets +c e : ntrav2 : povoso, pointeur sur ntrav1=voisom +c + if ( nbmpto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMMPO', nompro +#endif + call vcmmpo + > ( imem(pnoemp), imem(phetmp), imem(pcexmp), + > imem(adnocn), imem(admphn), imem(admpcn), + > imem(pfamee), imem(ptypel), + > imem(ppovos), imem(pvoiso), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. etablissement d'une table de connectivite par arete +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. connectivite par arete ; codret',codret +#endif +c +c 8.1. ==> allocation des tableaux +c la structure ntrav3 contiendra la table de connectivite par +c arete pour les elements 2d ou 3d. on la dimensionne au plus +c large en tenant compte du nombre maximum d'arete par element +c 2d ou 3d du maillage +c ici, seuls sont concernes les triangles, les quadrangles, +c les tetraedres, les pentaedres et les hexaedres +c c'est le tableau areele +c la structure ntrav4 contiendra le numero de la premiere arete +c partant d'un sommet donne ; c'est le tableau preare. +c pour dimensionner les tableaux lies aux aretes, on donne +c une estimation du nombre total par le maximum possible +c + if ( codret.eq.0 ) then +c + iaux = nbelem*nbmaae + call gmalot ( ntrav3, 'entier ', iaux , ptrav3, codre1 ) + call gmalot ( ntrav4, 'entier ', nbnoto, ptrav4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 8.2. ==> estimation du nombre d'aretes +c + if ( codret.eq.0 ) then +c + nbar00 = nbsegm + 3*nbtria + 4*nbquad + > + 6*nbtetr + 8*nbpyra + 12*nbhexa + 9*nbpent +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbar00 initial', nbar00 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMAR0', nompro +#endif + call vcmar0 ( imem(adnohn), imem(adnocn), + > imem(pnoeel), imem(ptypel), + > imem(ppovos), imem(pvoiso), + > nbardb, + > ulsort, langue, codret ) +c + nbar00 = nbar00 - nbardb/2 +c + if ( nbsegm.ne.0 ) then + rbar00 = nbar00 + rsarac = numael + else + rbar00 = 0 + rsarac = 0 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbar00, rbar00, rsarac', + > nbar00, rbar00, rsarac +#endif +c + cpt = 1 +c + endif +c +c 8.3. ==> allocations +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 30 + if ( degre.eq.2 ) then + jaux = jaux*13 + endif + if ( nbelig.ne.0 ) then + jaux = jaux*17 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_ar', nompro +#endif + call utal02 ( iaux, jaux, + > nharet, nbar00, kaux, + > phetar, psomar, pfilar, pmerar, + > paux, paux, + > paux, pnp2ar, adars2, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = nbar00 * nctfar + call gmaloj ( nccoex//'.Arete', ' ', iaux , pcexar, codre1 ) + call gmalot ( ntrav5, 'entier ', rbar00, ptrav5, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_ar', nompro +#endif + iaux = 1 + kaux = 2310 + call utre01 ( iaux, kaux, norenu, rsarac, rbar00, + > adarhn, adarcn, adaric, + > ulsort, langue, codret) +c + endif +c +c 8.4. ==> etablissement de la table et initialisation des tableaux +c lies aux aretes +c + 84 continue +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbar00, rbar00', nbar00, rbar00 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMARE', nompro +#endif + call vcmare + > ( imem(ptrav3), imem(psomar), imem(pnp2ar), + > imem(phetar), imem(pfilar), imem(pmerar), + > imem(pcexar), imem(pareno), imem(adars2), + > imem(adnohn), imem(adnocn), imem(adarhn), + > imem(adarcn), imem(pfamee), imem(pnoeel), + > imem(ptypel), imem(ppovos), imem(pvoiso), + > imem(ptrav4), + > arsmed, deamed, imem(ptrav5), + > imem(ptrav2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '--> nbarto', nbarto +#endif +c + endif +c +c 8.5. ==> si l'estimation est trop courte, on augmente +c + if ( codret.eq.0 ) then +c + if ( nbarto.lt.0 ) then +c + nbarne = int(1.3d0*dble(nbar00)) + rbarne = int(1.3d0*dble(rbar00)) + cpt = cpt + 1 +c + else +c + nbarne = nbarto + rbarne = rsarto + cpt = 0 +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarne, rbarne', nbarne, rbarne +#endif +c + endif +c +c 8.6. ==> connaissant le vrai nombre d'aretes, on ajuste les tableaux +c somare, nareho, nareca, hetare, filare, merare +c a leurs vraies tailles +c de plus, on desalloue les tableaux ne servant plus a rien +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8.6 apres vcmare ; codret', codret +#endif +c + if ( rsarto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_ar', nompro +#endif + iaux = 1 + jaux = 3 + call utre02 ( iaux, jaux, norenu, + > kaux, rbar00, kaux, rbarne, + > adarhn, adarcn, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 30 + if ( degre.eq.2 ) then + jaux = jaux*13 + endif + if ( nbelig.ne.0 ) then + jaux = jaux*17 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_ar', nompro +#endif + call utad06 ( iaux, jaux, kaux, nharet, + > nbar00, nbarne, 0, 0, + > phetar, psomar, pfilar, pmerar, + > paux, + > paux, pnp2ar, adars2, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( nccoex//'.Arete', + > pcexar, nbar00, nbarne, nctfar, nctfar, codre1 ) + call gmmod ( ntrav5, + > ptrav5, rbar00, rbarne, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 8.7. ==> si l'estimation est trop courte, on recommence +c + if ( codret.eq.0 ) then +c + if ( cpt.gt.0 ) then +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) cpt + nbar00 = nbarne + rbar00 = rbarne + goto 84 +c + endif +c + endif +c +c 8.8. ==> menage +c + if ( codret.eq.0 ) then +c + call gmsgoj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) + call gmlboj ( ntrav4 , codre3 ) + call gmlboj ( ntrav5 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 9. etablissement d'une table de connectivite par face +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. connectivite par face ; codret', codret +#endif +c +c 9.1. ==> determination des elements 2d ou 3d voisins des aretes +c +c 9.1.1. ==> comptage du nombre d'elements pour chaque arete +c + if ( codret.eq.0 ) then +c + iaux = nbarto + 1 + call gmalot ( ntrav2, 'entier ', iaux , ptrav2, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVAR1', nompro +#endif + call vcvar1 ( imem(ptrav3), imem(ptypel), imem(ptrav2) ) + imem(adnbrn+20) = nvoare +c + endif +c +c 9.1.2. ==> reperage des voisins +c allocation du tableau des voisins a une taille +c egale au nombre cumule de voisins des aretes +c en sortie : +c la structure ntrav1 contient la liste des elements 2d ou 3d +c voisins de chaque arete ; c'est le tableau vofaar +c la structure ntrav2 contient les pointeurs sur vofaar ; c'est +c le tableau povoar +c + if ( codret.eq.0 ) then + call gmalot ( ntrav1, 'entier ', nvoare, ptrav1, codret ) + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVAR2', nompro +#endif + call vcvar2 ( imem(ptrav3), imem(ptypel), imem(ptrav1), + > imem(ptrav2) ) +c + endif +c +c 9.2. ==> allocation des tableaux +c la structure ntrite contiendra la table de connectivite par +c face. on la dimmensionne au plus large en tenant compte du +c nombre maximum de face par element 3d du maillage ; c'est le +c tableau areele. +c la structure ntrav4 contiendra le numero de la premiere face +c partant d'une arete donnee ; c'est le tableau prefac. +c pour dimensionner les tableaux lies aux faces, on donne +c une estimation du nombre total par le maximum possible. +c +c 9.2.1. ==> on verifie qu'il y a assez de place avant de se lancer +c + if ( codret.eq.0 ) then +c + nbtr00 = nbtria + 4*nbtetr + 4*nbpyra + 2*nbpent + if ( nbtria.ne.0 ) then + rbtr00 = nbtr00 + rstrac = numael + else + rbtr00 = 0 + rstrac = 0 + endif +c + nbqu00 = nbquad + 6*nbhexa + nbpyra + 3*nbpent + if ( nbquad.ne.0 ) then + rbqu00 = nbqu00 + rsquac = numael + else + rbqu00 = 0 + rsquac = 0 + endif +c + rsteto = nbteto + if ( nbteto.ne.0 ) then + rsteac = numael + else + rsteac = 0 + endif +c + rsheto = nbheto + if ( nbheto.ne.0 ) then + rsheac = numael + else + rsheac = 0 + endif +c + rspyto = nbpyto + if ( nbpyto.ne.0 ) then + rspyac = numael + else + rspyac = 0 + endif +c + rspeto = nbpeto + if ( nbpeto.ne.0 ) then + rspeac = numael + else + rspeac = 0 + endif +c + endif +c +c 9.2.2. ==> allocation +c + if ( codret.eq.0 ) then +c +c 9.2.2.1. ==> pour les triangles, dans deux cas : +c . il y en a (quelle bonne idee) +c . il n'y en a pas, mais les quadrangles decoupes par +c conformite pourraient en produire ; on cree le tableau +c de sauvegarde des codes externes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.1. triangles ; codret', codret + write (ulsort,90002) 'nbtr00, nbqu00', nbtr00, nbqu00 +#endif +c + if ( nbtr00.ne.0 ) then +c + if ( mod(mailet,3).eq.0 ) then + if ( mod(mailet,2).ne.0 ) then + mailet = mailet * 2 + endif + endif +c + iaux = 2 + jaux = 330 + if ( mod(mailet,2).eq.0 ) then + jaux = jaux * 19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_tr', nompro +#endif + call utal02 ( iaux, jaux, + > nhtria, nbtr00, kaux, + > phettr, paretr, pfiltr, ppertr, + > paux , paux, + > pnivtr, paux, paux, + > adnmtr, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( nbtr00.ne.0 .or. nbqu00.ne.0 ) then +c + iaux = nbtr00 * nctftr + call gmaloj ( nccoex//'.Trian', ' ', iaux , pcextr, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.2. ==> pour les quadrangles, dans un cas : +c . il y en a (quelle bonne idee) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.2. quadrangles ; codret', codret + write (ulsort,90002) 'nbqu00', nbqu00 +#endif +c + if ( nbqu00.ne.0 ) then +c + iaux = 4 + jaux = 330 + if ( mod(mailet,3).eq.0 ) then + jaux = jaux * 19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro +#endif + call utal02 ( iaux, jaux, + > nhquad, nbqu00, kaux, + > phetqu, parequ, pfilqu, pperqu, + > paux , paux, + > pnivqu, paux, paux, + > adnmqu, paux, paux, + > ulsort, langue, codret ) +c + iaux = nbqu00 * nctfqu + call gmaloj ( nccoex//'.Quadr', ' ', iaux , pcexqu, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.3. ==> pour les tetraedres, dans un cas : +c . il y en a (quelle bonne idee) +c . il n'y en a pas, mais les hexaedres decoupes par +c conformite pourraient en produire ; on cree le tableau +c de sauvegarde des codes externes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.3. tetraedres ; codret', codret + write (ulsort,90002) 'nbteto', nbteto +#endif +c + if ( nbteto.ne.0 ) then +c + iaux = 3 + jaux = 390 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_te', nompro +#endif + call utal02 ( iaux, jaux, + > nhtetr, nbteto, kaux, + > phette, ptrite, pfilte, pperte, + > paux , paux, + > paux , pcotrt, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 .or. ( nbheto.ne.0 .and. tyconf.eq.-1 ) ) then +c + iaux = nbteto * nctfte + call gmaloj ( nccoex//'.Tetra', ' ', iaux , pcexte, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.4. ==> pour les hexaedres, dans un cas : +c . il y en a (quelle bonne idee) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.4. hexaedres ; codret', codret + write (ulsort,90002) 'nbheto', nbheto +#endif + if ( nbheto.ne.0 ) then +c + iaux = 6 + jaux = 390 + if ( mod(mailet,5).eq.0 ) then + jaux = jaux*19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_he', nompro +#endif + call utal02 ( iaux, jaux, + > nhhexa, nbheto, kaux, + > phethe, pquahe, pfilhe, pperhe, + > paux , paux, + > paux , pcoquh, paux, + > adnmhe, paux, paux, + > ulsort, langue, codret ) +c + iaux = nbheto * nctfhe + call gmaloj ( nccoex//'.Hexae', ' ', iaux , pcexhe, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.5. ==> pour les pyramides, dans un cas : +c . il y en a (quelle bonne idee) +c . il n'y en a pas, mais les hexaedres decoupes par +c conformite pourraient en produire ; on cree le tableau +c de sauvegarde des codes externes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.5. pyramides ; codret', codret + write (ulsort,90002) 'nbpyto', nbpyto + write (ulsort,90002) 'nbheto', nbheto + write (ulsort,90002) 'tyconf', tyconf +#endif + if ( nbpyto.ne.0 ) then +c + iaux = 5 + jaux = 390 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_py', nompro +#endif + call utal02 ( iaux, jaux, + > nhpyra, nbpyto, kaux, + > phetpy, pfacpy, pfilpy, pperpy, + > paux , paux, + > paux , pcofay, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 .or. ( nbheto.ne.0 .and. tyconf.eq.-1 ) ) then +c + iaux = nbpyto * nctfpy + call gmaloj ( nccoex//'.Pyram', ' ', iaux , pcexpy, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.6. ==> pour les pentaedres, 1 seul cas : il y en a +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.6. pentaedres ; codret', codret + write (ulsort,90002) 'nbpeto', nbpeto +#endif + if ( nbpeto.ne.0 ) then +c + iaux = 7 + jaux = 390 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_pe', nompro +#endif + call utal02 ( iaux, jaux, + > nhpent, nbpeto, kaux, + > phetpe, pfacpe, pfilpe, pperpe, + > paux , paux, + > paux , pcofap, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + iaux = nbpeto * nctfpe + call gmaloj ( nccoex//'.Penta', ' ', iaux , pcexpe, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 9.2.2.7. ==> la renumerotation des faces 2D +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.7. ren. faces 2D ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_tr', nompro +#endif + iaux = 2 + jaux = 2310 + call utre01 ( iaux, jaux, norenu, rstrac, rbtr00, + > adtrhn, adtrcn, adtric, + > ulsort, langue, codret) + + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_qu', nompro +#endif + iaux = 4 + if ( nbqu00.eq.0 ) then + jaux = 2310 + kaux = 0 + else + kaux = rsquac + endif + call utre01 ( iaux, jaux, norenu, kaux, rbqu00, + > adquhn, adqucn, adquic, + > ulsort, langue, codret) + + endif +c +c 9.2.2.8. ==> la renumerotation des tetraedres +c remarque : on alloue meme en l'absence de tetraedres +c car on utilise les attributs par la suite ! +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.8. ren. tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_te', nompro +#endif + iaux = 3 + jaux = 2310 + call utre01 ( iaux, jaux, norenu, rsteac, rsteto, + > adtehn, adtecn, adteic, + > ulsort, langue, codret) + + endif +c +c 9.2.2.9. ==> la renumerotation des pyramides +c remarque : on alloue meme en l'absence de pyramides +c car on utilise les attributs par la suite ! +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.9. ren. pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_py', nompro +#endif + iaux = 5 + jaux = 2310 + call utre01 ( iaux, jaux, norenu, rspyac, rspyto, + > adpyhn, adpycn, adpyic, + > ulsort, langue, codret) +c + endif +c +c 9.2.2.10. ==> la renumerotation des hexaedres +c remarque : on alloue meme en l'absence de hexaedres +c car on utilise les attributs par la suite ! +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.10. ren. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_he', nompro +#endif + iaux = 6 + jaux = 2310 + call utre01 ( iaux, jaux, norenu, rsheac, rsheto, + > adhehn, adhecn, adheic, + > ulsort, langue, codret) + + endif +c +c 9.2.2.11. ==> la renumerotation des pentaedres +c remarque : on alloue meme en l'absence de pentaedres +c car on utilise les attributs par la suite ! +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2.2.11. ren. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01_pe', nompro +#endif + iaux = 7 + jaux = 2310 + call utre01 ( iaux, jaux, norenu, rspeac, rspeto, + > adpehn, adpecn, adpeic, + > ulsort, langue, codret) +c + endif +c +c 9.2.2.12. ==> des tableaux de travail +c + iaux = 2*nbarto + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre1 ) + iaux = 2*max(rbtr00,rbqu00) + call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 9.3. ==> etablissement de la table et initialisation des faces +c +c rappel pour vcmfac : +c e : ntrav1 : vofaar, voisinage des aretes +c e : ntrav2 : povoar, pointeur sur ntrav1=vofaar +c e : ntrav3 : areele, table de connectivite par arete +c a : ntrav4 : prefac, premiere face s'appuyant sur une arete +c a : ntrav5 : dejavu, controle des doublons +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMFAC', nompro +#endif + call vcmfac + > ( imem(paretr), imem(phettr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(adnmtr), + > imem(pcextr), imem(adtrhn), imem(adtrcn), + > imem(parequ), imem(phetqu), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(adnmqu), + > imem(pcexqu), imem(adquhn), imem(adqucn), + > imem(ptrite), imem(phette), + > imem(pfilte), imem(pperte), + > imem(pcexte), imem(adtehn), imem(adtecn), + > imem(pquahe), imem(phethe), + > imem(pfilhe), imem(pperhe), imem(adnmhe), + > imem(pcexhe), imem(adhehn), imem(adhecn), + > imem(pfacpe), imem(phetpe), + > imem(pfilpe), imem(pperpe), + > imem(pcexpe), imem(adpehn), imem(adpecn), + > imem(pfacpy), imem(phetpy), + > imem(pfilpy), imem(pperpy), + > imem(pcexpy), imem(adpyhn), imem(adpycn), + > imem(ptrav3), imem(pnoeel), imem(ptypel), imem(pfamee), + > imem(ptrav1), imem(ptrav2), imem(ptrav4), imem(ptrav5), + > imem(psomar), imem(adnohn), imem(adnocn), + > ulsort, langue, codret ) +c + endif +c +c 9.4. ==> connaissant le vrai nombre de faces, on ajuste les tableaux +c a leurs vraies tailles +c de plus, on desalloue les tableaux ne servant plus a rien +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.4. apres vcmfac ; codret', codret +#endif +c +c 9.4.1. ==> triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.4.1. triangles ; codret', codret + write (ulsort,90002) 'nbtr00, nbtrto', nbtr00, nbtrto + write (ulsort,90002) 'rbtr00, rstrto', rbtr00, rstrto +#endif +c + if ( nbtr00.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 330 + if ( mod(mailet,2).eq.0 ) then + jaux = jaux*19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_tr', nompro +#endif + call utad06 ( iaux, jaux, kaux, nhtria, + > nbtr00, nbtrto, 0, 0, + > phettr, paretr, pfiltr, ppertr, + > paux, + > pnivtr, paux, paux, + > adnmtr, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( nccoex//'.Trian', + > pcextr, nbtr00, nbtrto, nctftr, nctftr, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c + if ( rbtr00.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_tr', nompro +#endif + iaux = 2 + jaux = 3 + call utre02 ( iaux, jaux, norenu, + > kaux, rbtr00, kaux, rstrto, + > adtrhn, adtrcn, + > ulsort, langue, codret) +c + endif +c + endif +c +c 9.4.2. ==> quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.4.2. quadrangles ; codret', codret + write (ulsort,90002) 'nbqu00, nbquto', nbqu00, nbquto + write (ulsort,90002) 'rbqu00, rsquto', rbqu00, rsquto +#endif +c + if ( nbqu00.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 330 + if ( mod(mailet,3).eq.0 ) then + jaux = jaux*19 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_qu', nompro +#endif + call utad06 ( iaux, jaux, kaux, nhquad, + > nbqu00, nbquto, 0, 0, + > phetqu, parequ, pfilqu, pperqu, + > paux, + > pnivqu, paux, paux, + > adnmqu, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( nccoex//'.Quadr', + > pcexqu, nbqu00, nbquto, nctfqu, nctfqu, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c + if ( rbqu00.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02_qu', nompro +#endif + iaux = 4 + jaux = 3 + call utre02 ( iaux, jaux, norenu, + > kaux, rbqu00, kaux, rsquto, + > adquhn, adqucn, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, norenu//'.QuCalcul') + call gmprsx (nompro, norenu//'.QuHOMARD') + call gmprsx (nompro, nhquad//'.ConnDesc' ) + call gmprsx (nompro, nhquad//'.HistEtat') + call gmprsx (nompro, nhquad//'.Fille' ) + call gmprsx (nompro, nhquad//'.Mere') + call gmprsx (nompro, nhquad//'.Niveau' ) + call gmprsx (nompro, nccoex//'.Quadr') +#endif +c +c==== +c 10. orientation des aretes et des faces du calcul et code des faces +c dans les volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. orientation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORIE', nompro +#endif + call vcorie + > ( eleinc, imem(pnoeel), imem(ptrav3), imem(ptypel), + > imem(psomar), imem(paretr), imem(parequ), + > imem(adnohn), imem(adarhn), imem(adtrhn), imem(adquhn), + > imem(pcexar), + > imem(ptrite), imem(pcotrt), imem(adtehn), + > imem(pquahe), imem(pcoquh), imem(adhehn), + > imem(pfacpe), imem(pcofap), imem(adpehn), + > imem(pfacpy), imem(pcofay), imem(adpyhn), + > ulsort, langue, codret ) +c + endif +c +c 10.2. ==> menage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10.2. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) + call gmlboj ( ntrav3 , codre3 ) + call gmlboj ( ntrav4 , codre4 ) + call gmlboj ( ntrav5 , codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 11. reperage des eventuelles non conformites +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. non conformites ; codret', codret + write (ulsort,90002) 'tyconf', tyconf +#endif +c + nbtrri = 0 + nbquri = 0 +c + if ( tyconf.gt.0 .or. tyconf.eq.-2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, nccoex//'.Arete' ) + call gmprsx (nompro, nharet//'.ConnDesc' ) + call gmprsx (nompro, nhtria//'.ConnDesc' ) + call gmprsx (nompro, nhquad//'.ConnDesc' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNCO', nompro +#endif +c + call vcmnco ( nohman, + > nhnoeu, nharet, nhtria, nhquad, nhvois, + > imem(pnoemp), + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(pcexno), imem(adnohn), imem(adnocn), + > imem(psomar), imem(phetar), imem(pnp2ar), + > imem(pmerar), imem(pfilar), imem(adars2), + > imem(pcexar), imem(adarhn), imem(adarcn), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), + > imem(pcexqu), imem(adquhn), imem(adqucn), + > imem(pquahe), imem(pcoquh), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, nccoex//'.Arete' ) +cgn call gmprsx (nompro, nhnoeu//'.AretSupp') +cgn call gmprsx (nompro, nharet//'.ConnDesc' ) +cgn call gmprsx (nompro, nharet//'.HistEtat' ) +cgn call gmprsx (nompro, nharet//'.Fille' ) +cgn call gmprsx (nompro, nharet//'.Mere' ) +cgn call gmprsx (nompro, nhtria//'.ConnDesc' ) +cgn call gmprsx (nompro, nhquad//'.ConnDesc' ) +#endif +c + endif +c + endif +c +c==== +c 12. determination des voisinages +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. voisinages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.ne.0 ) then + voarno = 2 + else + voarno = 0 + endif + vofaar = 2 + vovoar = 0 + vovofa = 2 +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx ('Volumes dans '//nompro,nohman//'.Volume') + if ( nbtrto.gt.0 ) then + call gmprsx ('nhtria dans '//nompro, nhtria) + call gmprot ('Triangle ConnDesc', nhtria//'.ConnDesc', + > 1, min(10,nbtrto) ) + call gmprsx ('InfoSupp', nhtria//'.InfoSupp') + endif + if ( nbquto.gt.0 ) then + call gmprsx ('nhquad dans '//nompro, nhquad) + call gmprot ('Quadrangle ConnDesc', nhquad//'.ConnDesc', + > 1, min(10,nbquto) ) + call gmprsx ('InfoSupp', nhquad//'.InfoSupp') + endif + if ( nbteto.gt.0 ) then + call gmprsx ('nhtetr dans '//nompro, nhtetr) + endif + if ( nbheto.gt.0 ) then + call gmprsx ('nhhexa dans '//nompro, nhhexa) + endif + if ( nbpeto.gt.0 ) then + call gmprsx ('nhpent dans '//nompro, nhpent) + endif + if ( nbpyto.gt.0 ) then + call gmprsx ('nhpyra dans '//nompro, nhpyra) + call gmprsx ('ConnDesc', nhpyra//'.ConnDesc') + call gmprsx ('InfoSupp', nhpyra//'.InfoSupp') + endif +cgn call gmprsx ('nhpyra dans '//nompro,nhpyra) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 13. mise a jour des numerotations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '13. numerotations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 13.1. ==> Decalage des numerotations (cf. eslmm2) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmapo', nbmapo + write(ulsort,90002) 'nbsegm', nbsegm + write(ulsort,90002) 'nbtria', nbtria + write(ulsort,90002) 'nbtetr', nbtetr + write(ulsort,90002) 'nbquad', nbquad + write(ulsort,90002) 'nbhexa', nbhexa + write(ulsort,90002) 'nbpent', nbpent + write(ulsort,90002) 'nbpyra', nbpyra +#endif + decanu(-1) = 0 + decanu(3) = 0 + decanu(2) = nbtetr + decanu(1) = nbtetr + nbtria + decanu(0) = nbtetr + nbtria + nbsegm + decanu(4) = nbtetr + nbtria + nbsegm + nbmapo + decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'decanu', decanu +#endif +#ifdef _DEBUG_HOMARD_ +cgn call gmprot (nompro, ncnoeu//'.NumeExte' , 1, 20 ) +cgn call gmprot (nompro, ncnoeu//'.NumeExte' , nbnoto-20, nbnoto ) +cgn call gmprot (nompro, nccono//'.NumeExte' , 1, 20 ) +cgn call gmprot (nompro, nccono//'.NumeExte' , nbelem-20, nbelem ) +cgn call gmprsx (nompro, nccono//'.NumeExte' ) +#endif +c +c 13.2. ==> Traitement +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMREN', nompro +#endif + call vcmren ( imem(adnohn), imem(adnocn), imem(adnoic), + > imem(admphn), imem(admpcn), imem(admpic), + > imem(adarhn), imem(adarcn), imem(adaric), + > imem(adtrhn), imem(adtrcn), imem(adtric), + > imem(adquhn), imem(adqucn), imem(adquic), + > imem(adtehn), imem(adtecn), imem(adteic), + > imem(adpyhn), imem(adpycn), imem(adpyic), + > imem(adhehn), imem(adhecn), imem(adheic), + > imem(adpehn), imem(adpecn), imem(adpeic), + > imem(pnunoe), imem(pnuele), decanu, + > ulsort, langue, codret ) +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.InfoSupE.Tab4') +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.TrHOMARD') +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.TrCalcul') +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.InfoSupE.Tab5') +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.QuHOMARD') +cgn call gmprsx (nompro//'-apres vcmren', norenu//'.QuCalcul') +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro, norenu//'.NoHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.NoHOMARD' , rsnoac-20, rsnoac ) + call gmprot (nompro, norenu//'.MPHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.MPHOMARD' , rsmpac-20, rsmpac ) + call gmprot (nompro, norenu//'.ArHOMARD' , 1 , 20 ) + call gmprot (nompro, norenu//'.ArHOMARD' , rsarac-20, rsarac ) + call gmprot (nompro, norenu//'.TrHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.TrHOMARD' , rstrac-20, rstrac ) + call gmprot (nompro, norenu//'.QuHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.QuHOMARD' , rsquac-20, rsquac ) + call gmprot (nompro, norenu//'.TeHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.TeHOMARD' , rsteac-20, rsteac ) + call gmprot (nompro, norenu//'.HeHOMARD' , 1, 20 ) + call gmprot (nompro, norenu//'.HeHOMARD' , rsheac-20, rsheac ) + call gmprot (nompro, nccono//'.NumeExte' , 1, 20 ) + call gmprot (nompro, nccono//'.NumeExte' , nbelem-20, nbelem ) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( rsteac.eq.0 .and. rsheac.eq.0 .and. rspyac.eq.0 ) then + rseutc = rstrac + rsquac + rsevca = nbtria + nbquad + rsevto = rstrto + rsquto + else + rseutc = rsteac + rsheac + rspyac + rsevca = nbtetr + nbhexa + nbpyra + rsevto = rsteto + rsheto + rspyto + endif +c + imem(adnbrn+6) = rseutc + imem(adnbrn+7) = rsevca + imem(adnbrn+8) = rsevto +c + endif +c +c==== +c 14. sauvegarde des informations generales, au sens +c du module de calcul associe +c attention : il faut faire des copies et non pas des attachements +c car la structure generale de l'objet "maillage de +c calcul" est detruite apres la phase de conversion. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '14. sauvegarde ; codret', codret + if ( codret.eq.0 ) then + write (ulsort,*) 'Avant copie de ncinfo' + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') + endif + call dmflsh (iaux) +#endif +c +c 14.1. ==> a-t-on defini des informations generales en externe ? +c 14.1.1. ==> branche principale +c + if ( codret.eq.0 ) then +c + call gmobal ( ncinfo, codret ) +c + if ( codret.eq.0 ) then + existe = .false. + elseif ( codret.eq.1 ) then + codret = 0 + existe = .true. + else + codret = 2 + endif +c + endif +c +c 14.1.2. ==> verification de l'existence des differentes branches +c + do 141 , iaux = 1 , 3 +c + if ( codret.eq.0 ) then +c + if ( existe ) then +c +c 123456789 + if ( iaux.eq.1 ) then + saux09 = '.Pointeur' + elseif ( iaux.eq.1 ) then + saux09 = '.Taille ' + else + saux09 = '.Table ' + endif + call gmobal ( ncinfo//saux09, codret ) + if ( codret.eq.0 ) then + existe = .false. + elseif ( codret.eq.2 ) then + codret = 0 + else + codret = 2 + endif +c + endif +c + endif +c + 141 continue +c +c 14.2. ==> copie des differentes branches et des attributs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '14.2. Copie ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( existe ) then +c + call gmliat ( ncinfo, 1, iaux , codre1 ) + call gmliat ( ncinfo, 2, jaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.eq.0 ) then +c + call gmecat ( nhsupe, 7, iaux, codre1 ) + call gmecat ( nhsupe, 8, iaux, codre2 ) + call gmecat ( nhsups, 3, jaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmcpoj ( ncinfo//'.Pointeur', nhsupe//'.Tab7', codre1 ) + call gmcpoj ( ncinfo//'.Taille', nhsupe//'.Tab8', codre2 ) + call gmcpoj ( ncinfo//'.Table', nhsups//'.Tab3', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncinfo//'.Table', pinftb, jaux, codre1 ) + call gmliat ( ncinfo, 1, iaux, codre2 ) + nbpqt = iaux - 1 +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 142 , iaux = 1, nbpqt +c + jaux = pinftb + 10*(iaux-1) +cgn write (ulsort,90064) jaux, '%'//smem(jaux)//'%' +c + if ( ( smem(jaux).ne.'NomCo ' ) .and. + > ( smem(jaux).ne.'UniteCo ' ) .and. + > ( smem(jaux).ne.'NOMAMD ' ) .and. + > ( smem(jaux).ne.'SATURNE ' ) ) then +c + kaux = min(80,len(titre)) +cgn write (ulsort,90002) 'longueur', kaux + call uts8ch ( smem(jaux), kaux, titre, + > ulsort, langue, codret ) +cgn write (ulsort,*) 'recuperation de titre =', titre +c + endif +c + 142 continue +c + endif +c + endif +c + endif +c +c==== +c 15. transfert des elements ignores +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '15. elements ignores ; codret', codret + write (ulsort,90002) 'nbelig', nbelig + call dmflsh(iaux) +#endif +c + if ( nbelig.ne.0 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( nhelig, 1, nbelig, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then + iaux = nbelig * 5 + else + iaux = nbelig * 13 + endif + call gmaloj ( nhelig//'.ConnNoeu', ' ', iaux , hnoeel, codre1 ) + call gmaloj ( nhelig//'.FamilMED', ' ', nbelig, hfmdel, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMAIG', nompro +#endif + call vcmaig + > ( imem(hfmdel), imem(hnoeel), + > imem(ptypel), imem(pfamee), imem(pnoeel), + > imem(adnohn), + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro, nhelig ) +cgn call gmprsx (nompro, nhelig//'.ConnNoeu' ) +cgn call gmprsx (nompro, nhelig//'.FamilMED' ) +c + endif +c +c==== +c 16. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '16. fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmafa.F b/src/tool/AV_Conversion/vcmafa.F new file mode 100644 index 00000000..b232d5b4 --- /dev/null +++ b/src/tool/AV_Conversion/vcmafa.F @@ -0,0 +1,2363 @@ + subroutine vcmafa ( modhom, pilraf, tyconf, suifro, + > nocman, nohman, + > ncafdg, ncafan, ncfgnf, ncfgng, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de MAillage - FAmilles +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nocman . s . char*8 . nom de l'objet maillage calcul iteration n . +c . nohman . e . char8 . nom de l'objet maillage homard iteration n . +c . ncafdg . e . char*8 . nom de l'objet des frontieres discretes/CAO. +c . . . . nom des groupes frontiere . +c . ncafan . e . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . description des frontieres . +c . ncfgnf . es . char*8 . lien frontiere/groupe : nom des frontieres . +c . ncfgng . e . char*8 . lien frontiere/groupe : nom des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMAFA' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "coftfq.h" +#include "coftfh.h" +#include "cofpfh.h" +#include "coftfp.h" +#include "cofpfp.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "nbutil.h" +#include "dicfen.h" +#include "envca1.h" +#include "nbfami.h" +#include "nbfamm.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer modhom, pilraf, tyconf, suifro +c + character*8 nocman, nohman + character*8 ncafdg, ncafan, ncfgnf, ncfgng +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer pfamno, pcfano, pcexno + integer pfammp, pcfamp, pcexmp + integer pfamar, pcfaar, pcexar + integer pfamtr, pcfatr, pcextr + integer pfamqu, pcfaqu, pcexqu + integer pfamte, pcfate, pcexte + integer pfamhe, pcfahe, pcexhe + integer pfampy, pcfapy, pcexpy + integer pfampe, pcfape, pcexpe + integer pnunoe, pnuele + integer pnoemp + integer psomar, pposif, pfacar, pnp2ar + integer paretr, parequ, pareno + integer pfamee, ptypel + integer pgrpo, pgrtai, pgrtab + integer nbfme0, ngrou0 +c + integer adhono, admpho, adhoar, adhotr, adhoqu + integer ppovos, pvoiso, adfrfa, pnumfa, pnomfa + integer adeqpo + integer adeqno, adeqar, adeqtr, adeqqu + integer adnomb +c + integer typenh, pfamen, pcfaen + integer nbento, nctfen, nbfenm, nbfaen +c + integer rvnoac, adnohn + integer rvmpac, admphn + integer rvarac, adarhn + integer rvtrac, adtrhn + integer rvquac, adquhn + integer rvteac, adtehn + integer rvheac, adhehn + integer rvpyac, adpyhn + integer rvpeac, adpehn + integer ptngrf +c + integer iaux, jaux, kaux, paux + integer iaux1, iaux2, iaux3, iaux4, iaux5, iaux6, iaux7, iaux8 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre0 + integer pttgrd, ptngrd, pointd + integer adcpoi, adctai, adctab + integer adfpoi, adftai, adftab + integer adgpoi, adgtai, adgtab + integer pointe + integer nbgrof, nbfrgr, nbfran + integer ptrav1 + integer adfrgr, adnogr + integer un + integer nbfmem, nbtype, nborie, nbrequ +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nhnofa, nhmpfa, nharfa + character*8 nhtrfa, nhqufa + character*8 nhtefa, nhhefa, nhpyfa, nhpefa + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*8 ntrav1 + character*8 nhenti, nhenfa +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Erreur dans le decodage de l''''objet '',a)' + texte(1,5) = '(''. Nombre de '',a,'' :'',i10)' + texte(1,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)' + texte(1,8) = + > '(''Aucune frontiere analytique n''''a ete definie.'')' +c + texte(2,4) = '(''Error while uncoding object '',a)' + texte(2,5) = '(''. Number of '',a,'' :'',i10)' + texte(2,7) = '(5x,''Conversion '',a18,'' ---> HOMARD'',/)' + texte(2,8) = '(''No analytical boundary was defined.'')' +c +#include "impr03.h" +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,-1), nbnoto + write (ulsort,texte(langue,5)) mess14(langue,3,0), nbmpto + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarto + write (ulsort,texte(langue,5)) mess14(langue,3,2), nbtrto + write (ulsort,texte(langue,5)) mess14(langue,3,3), nbteto + write (ulsort,texte(langue,5)) mess14(langue,3,4), nbquto + write (ulsort,texte(langue,5)) mess14(langue,3,6), nbheto +#endif +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocman, + > iaux1, iaux2, + > iaux3, iaux4, iaux5, iaux6, iaux7, + > iaux8, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nohman, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ +#include "mslve4.h" +#endif +c +c 2.2. ==> tableaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.==> tableaux ; codret', codret +#endif +c +c 2.2.1. ==> Numerotations externes du code de calcul +c + if ( codret.eq.0 ) then +c + if ( ( homolo.ge.1 ) .or. + > ( mod(suifro,2).eq.0 ) .or. + > ( mod(suifro,3).eq.0 ) .or. + > ( mod(suifro,5).eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + if ( suifro.eq.1 ) then + iaux = 85 + else + iaux = 6545 + endif + call utad11 ( iaux, ncnoeu, nccono, + > jaux, jaux, pnunoe, jaux, + > ptypel, pfamee, jaux, pnuele, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.2. ==> Groupes et codes externes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_no', nompro +#endif + iaux = 210 + jaux = -1 + call utad12 ( iaux, jaux, + > nccoex, pcexno, + > ulsort, langue, codret ) +c + if ( nbmpto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_mp', nompro +#endif + iaux = 210 + jaux = 0 + call utad12 ( iaux, jaux, + > nccoex, pcexmp, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_ar', nompro +#endif + iaux = 210 + jaux = 1 + call utad12 ( iaux, jaux, + > nccoex, pcexar, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_tr', nompro +#endif + iaux = 210 + jaux = 2 + call utad12 ( iaux, jaux, + > nccoex, pcextr, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_qu', nompro +#endif + iaux = 210 + jaux = 4 + call utad12 ( iaux, jaux, + > nccoex, pcexqu, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_te', nompro +#endif + iaux = 210 + jaux = 3 + call utad12 ( iaux, jaux, + > nccoex, pcexte, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_he', nompro +#endif + iaux = 210 + jaux = 6 + call utad12 ( iaux, jaux, + > nccoex, pcexhe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_py', nompro +#endif + iaux = 210 + jaux = 5 + call utad12 ( iaux, jaux, + > nccoex, pcexpy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD12_pe', nompro +#endif + iaux = 210 + jaux = 7 + call utad12 ( iaux, jaux, + > nccoex, pcexpe, + > ulsort, langue, codret ) +c + endif +c +c 2.2.3. ==> Connectivites des entites HOMARD +c + call gmadoj ( nhnoeu//'.AretSupp', pareno, iaux, codre1 ) + call gmadoj ( nhmapo//'.ConnDesc', pnoemp, iaux, codre2 ) + call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 ) + if ( degre.eq.2 ) then + call gmadoj ( nharet//'.InfoSupp', pnp2ar, iaux, codre4 ) + else + codre4 = 0 + endif + if ( nbtrto.ne.0 ) then + call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre5 ) + else + codre5 = 0 + endif + if ( nbquto.ne.0 ) then + call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre6 ) + else + codre6 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c +c 2.2.4. ==> Homologues +c + if ( homolo.ne.0 ) then +c + call gmadoj ( ncequi//'.Pointeur', adeqpo, iaux, codre1 ) + call gmadoj ( ncequi//'.Noeud' , adeqno, iaux, codre2 ) + call gmadoj ( ncequi//'.Arete' , adeqar, iaux, codre3 ) + call gmadoj ( ncequi//'.Trian' , adeqtr, iaux, codre4 ) + call gmadoj ( ncequi//'.Quadr' , adeqqu, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c 2.2.5. ==> Voisinages +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + if ( homolo.ne.0 ) then + iaux = iaux*2 + endif + call utad04 ( iaux, nhvois, + > ppovos, pvoiso, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) nocman + endif +c +c 2.3. ==> modification de la taille du tableau des codes par la prise +c en compte des groupes et des homologues +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. ==> modif taille ; codret', codret + write (ulsort,90002) 'homolo', homolo +#endif +c + if ( codret.eq.0 ) then +c + ncefno = 0 + ncefmp = 0 + ncefar = 0 + nceftr = 0 + ncefqu = 0 +c +c 2.3.1. ==> homologues +c + if ( homolo.ne.0 ) then +c +c pour chaque type d'entite, on repere si au moins une equivalence +c est concernee +c + do 23 , iaux = 1 , nbequi + jaux = adeqpo + 5*iaux - 5 + if ( imem(jaux).ne.0 ) then + ncefno = ncefno + 1 + endif + jaux = adeqpo + 5*iaux - 4 + if ( imem(jaux).ne.0 ) then + ncefmp = ncefmp + 1 + endif + jaux = adeqpo + 5*iaux - 3 + if ( imem(jaux).ne.0 ) then + ncefar = ncefar + 1 + endif + jaux = adeqpo + 5*iaux - 2 + if ( imem(jaux).ne.0 ) then + nceftr = nceftr + 1 + endif + jaux = adeqpo + 5*iaux - 1 + if ( imem(jaux).ne.0 ) then + ncefqu = ncefqu + 1 + nceftr = nceftr + 1 + endif + 23 continue +c +c pour chaque type d'entite, si au moins une equivalence est concernee, +c on dit que toutes les equivalences sont concernees. +c verrue car on n'a pas separe les equivalences par type comme cela +c est fait pour les groupes. +c on gaspille un peu de memoire, mais ce n'est pas tres grave. +c + if ( ncefno.ne.0 ) then + ncefno = nbequi + endif + if ( ncefmp.ne.0 ) then + ncefmp = nbequi + endif + if ( ncefar.ne.0 ) then + ncefar = nbequi + endif + if ( nceftr.ne.0 ) then + nceftr = nbequi + endif + if ( ncefqu.ne.0 ) then + ncefqu = nbequi + endif +c + endif +c +c 2.3.2. ==> Changement de tailles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.2. ==> modif taille ; codret', codret +#endif +c + iaux1 = nctfno + nctfno = nctfno + ncefno + call gmmod ( nccoex//'.Noeud', pcexno, + > nbnoto, nbnoto, iaux1, nctfno, codre1 ) +c + if ( nbmpto.ne.0 ) then + iaux1 = nctfmp + nctfmp = nctfmp + ncefmp + call gmmod ( nccoex//'.Point', pcexmp, + > nbmpto, nbmpto, iaux1, nctfmp, codre2 ) + endif +c + iaux1 = nctfar + nctfar = nctfar + ncefar + call gmmod ( nccoex//'.Arete', pcexar, + > nbarto, nbarto, iaux1, nctfar, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + if ( nbtria.ne.0 .or. nbquad.ne.0 ) then + iaux1 = nctftr + if ( nbtria.ne.0 ) then + nctftr = nctftr + nceftr + endif + if ( nbquad.ne.0 .and. modhom.eq.1 .and. pilraf.eq.1 ) then + nctftr = nctftr + endif + call gmmod ( nccoex//'.Trian', pcextr, + > nbtrto, nbtrto, iaux1, nctftr, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + if ( nbquto.ne.0 ) then + iaux1 = nctfqu + nctfqu = nctfqu + ncefqu + call gmmod ( nccoex//'.Quadr', pcexqu, + > nbquto, nbquto, iaux1, nctfqu, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + if ( nbteto.ne.0 ) then + iaux1 = nctfte + nctfte = nctfte + call gmmod ( nccoex//'.Tetra', pcexte, + > nbteto, nbteto, iaux1, nctfte, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + if ( nbheto.ne.0 ) then + iaux1 = nctfhe + nctfhe = nctfhe + call gmmod ( nccoex//'.Hexae', pcexhe, + > nbheto, nbheto, iaux1, nctfhe, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + if ( nbpyto.ne.0 ) then + iaux1 = nctfpy + nctfpy = nctfpy + call gmmod ( nccoex//'.Pyram', pcexpy, + > nbpyto, nbpyto, iaux1, nctfpy, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + if ( nbpeto.ne.0 ) then + iaux1 = nctfpe + nctfpe = nctfpe + call gmmod ( nccoex//'.Penta', pcexpe, + > nbpeto, nbpeto, iaux1, nctfpe, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + endif +c +c 2.4. ==> tableaux de renumerotation +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. ==> renumerotation ; codret', codret + call gmprsx (nompro,norenu) +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 10 + call utre03 ( iaux, jaux, norenu, + > rvnoac, kaux, adnohn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_mp', nompro +#endif + iaux = 0 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvmpac, kaux, admphn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + iaux = 1 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvarac, kaux, adarhn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvtrac, kaux, adtrhn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_te', nompro +#endif + iaux = 3 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvteac, kaux, adtehn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvquac, kaux, adquhn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_py', nompro +#endif + iaux = 5 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvpyac, kaux, adpyhn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_he', nompro +#endif + iaux = 6 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvheac, kaux, adhehn, kaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro +#endif + iaux = 7 + jaux = -10 + call utre03 ( iaux, jaux, norenu, + > rvpeac, kaux, adpehn, kaux, + > ulsort, langue, codret ) +c + endif +c +c 2.5. ==> borne maximale des dimensionnements en fonction +c de la configuration +c +c noeuds 1 : famille MED +c + l : appartenance a l'equivalence l +c +c mailles-points 1 : famille MED +c 2 : type de maille-point +c 3 : famille du sommet support +c + l : appartenance a l'equivalence l +c +c aretes 1 : famille MED +c 2 : type de segment +c 3 : orientation +c 4 : famille d'orientation inverse +c 5 : numero de ligne de frontiere +c > 0 si arete concernee par le suivi de frontiere +c <= 0 si non concernee +c 6 : famille de suivi de frontiere active/inactive +c 7 : numero de surface de frontiere +c + l : appartenance a l'equivalence l +c +c triangles 1 : famille MED +c 2 : type de triangle +c 3 : numero de surface de frontiere +c 4 : famille des aretes internes apres raf +c + l : appartenance a l'equivalence l +c +c quadrangles 1 : famille MED +c 2 : type de quadrangle +c 3 : numero de surface de frontiere +c 4 : famille des aretes internes apres raf +c 5 : famille des triangles de conformite +c 6 : famille de suivi de frontiere active/inactive +c + l : appartenance a l'equivalence l +c +c tetraedres 1 : famille MED +c 2 : type de tetraedres +c +c hexaedres 1 : famille MED +c 2 : type de hexaedres +c 3 : famille des tetraedres de conformite +c 4 : famille des pyramides de conformite +c +c pyramides 1 : famille MED +c 2 : type de pyramides +c +c pentaedres 1 : famille MED +c 2 : type de pentaedres +c 3 : famille des tetraedres de conformite +c 4 : famille des pyramides de conformite +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. ==> borne maximale ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) + > 'nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu', + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + write (ulsort,90002) 'nbfmen', nbfmen +#endif +c + if ( codret.eq.0 ) then +c +c 2.5.1. ==> Les noeuds +c + nbfnom = nbfmen + 2 +c prise en compte des equivalences possibles + if ( ncefno.ne.0 ) then + nbfnom = 2*nbfnom + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfnom', nbfnom +#endif +c +c 2.5.2. ==> Les mailles +c +c nombre de familles med + nbfmem = nbfmed - nbfmen +c + do 252 , typenh = 0 , 7 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) +#endif +c +c 2.5.2.1. ==> nombre de types possibles +c + if ( typenh.eq.0 ) then + nbtype = 1 + else + nbtype = 2 + endif +c +c 2.5.2.2. ==> nombre d'orientations possibles +c + if ( typenh.eq.1 ) then + nborie = 2 + else + nborie = 1 + endif +c +c 2.5.2.3. ==> equivalences possibles +c + if ( typenh.eq.0 ) then + nbrequ = ncefmp + elseif ( typenh.eq.1 ) then + nbrequ = ncefar + elseif ( typenh.eq.2 ) then + nbrequ = nceftr + elseif ( typenh.eq.4 ) then + nbrequ = ncefqu + else + nbrequ = 0 + endif + nbrequ = nbrequ + 1 +c +c 2.5.2.4. ==> evaluation du nombre maximum de familles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfmem', nbfmem + write (ulsort,90002) 'nbtype', nbtype + write (ulsort,90002) 'nborie', nborie + write (ulsort,90002) 'nbrequ', nbrequ +#endif + iaux = nbfmem*nbtype*nborie*nbrequ +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> iaux', iaux +#endif +c + if ( typenh.eq.0 ) then + nbfmpm = iaux*nbfnom + elseif ( typenh.eq.3 ) then + nbftem = iaux + elseif ( typenh.eq.5 ) then + nbfhem = iaux + elseif ( typenh.eq.6 ) then + nbfpym = iaux + elseif ( typenh.eq.7 ) then + nbfpem = iaux + endif +c + 252 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfmpm', nbfmpm + write (ulsort,90002) 'nbfarm', nbfarm + write (ulsort,90002) 'nbftrm', nbftrm + write (ulsort,90002) 'nbfqum', nbfqum + write (ulsort,90002) 'nbftem', nbftem + write (ulsort,90002) 'nbfhem', nbfhem + write (ulsort,90002) 'nbfpym', nbfpym + write (ulsort,90002) 'nbfpem', nbfpem +#endif +c + endif +c +c==== +c 3. allocation des nouveaux tableaux +c remarque : on alloue pour toutes les entites, meme s'il se +c peut qu'il n'y en ait pas. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. allocation nou tab ; codret', codret + call gmstat(1) +#endif +c + do 30 , typenh = -1 , 7 +c +c 3.1. ==> Caracteristiques des entites concernees +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nhenti = nhnoeu + nbento = nbnoto + nctfen = nctfno + nbfenm = nbfnom + elseif ( typenh.eq.0 ) then + nhenti = nhmapo + nbento = nbmpto + nctfen = nctfmp + nbfenm = nbfmpm + elseif ( typenh.eq.1 ) then + nhenti = nharet + nbento = nbarto + nctfen = nctfar + nbfenm = nbfarm + elseif ( typenh.eq.2 ) then + nhenti = nhtria + nbento = nbtrto + nctfen = nctftr + nbfenm = nbftrm + elseif ( typenh.eq.3 ) then + nhenti = nhtetr + nbento = nbteto + nctfen = nctfte + nbfenm = nbftem + elseif ( typenh.eq.4 ) then + nhenti = nhquad + nbento = nbquto + nctfen = nctfqu + nbfenm = nbfqum + elseif ( typenh.eq.5 ) then + nhenti = nhpyra + nbento = nbpyto + nctfen = nctfpy + nbfenm = nbfpym + elseif ( typenh.eq.6 ) then + nhenti = nhhexa + nbento = nbheto + nctfen = nctfhe + nbfenm = nbfhem + elseif ( typenh.eq.7 ) then + nhenti = nhpent + nbento = nbpeto + nctfen = nctfpe + nbfenm = nbfpem + endif +c + endif +c +c 3.2. ==> appel du programme generique +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,90002) 'nbento', nbento + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfenm', nbfenm +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFE', nompro +#endif + iaux = typenh + call utalfe ( iaux, nhenti, + > nbento, nctfen, nbfenm, + > nhenfa, pfamen, pcfaen, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Recuperation de l'adresse des codes +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nhnofa = nhenfa + pfamno = pfamen + pcfano = pcfaen + elseif ( typenh.eq.0 ) then + nhmpfa = nhenfa + pfammp = pfamen + pcfamp = pcfaen + elseif ( typenh.eq.1 ) then + nharfa = nhenfa + pfamar = pfamen + pcfaar = pcfaen + elseif ( typenh.eq.2 ) then + nhtrfa = nhenfa + pfamtr = pfamen + pcfatr = pcfaen + elseif ( typenh.eq.3 ) then + nhtefa = nhenfa + pfamte = pfamen + pcfate = pcfaen + elseif ( typenh.eq.4 ) then + nhqufa = nhenfa + pfamqu = pfamen + pcfaqu = pcfaen + elseif ( typenh.eq.5 ) then + nhpyfa = nhenfa + pfampy = pfamen + pcfapy = pcfaen + elseif ( typenh.eq.6 ) then + nhhefa = nhenfa + pfamhe = pfamen + pcfahe = pcfaen + elseif ( typenh.eq.7 ) then + nhpefa = nhenfa + pfampe = pfamen + pcfape = pcfaen + endif +c + endif +c + 30 continue +c +c==== +c 4. initialisations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. initialisations ; codret', codret + call gmstat(1) +#endif +c +c 4.1. ==> prise en compte de l'eventuel suivi de frontiere +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro', suifro +#endif +c + if ( ( mod(suifro,2).eq.0 ) .or. + > ( mod(suifro,3).eq.0 ) .or. + > ( mod(suifro,5).eq.0 ) ) then +c + nbgrof = 0 + nbfrgr = 0 +c + if ( codret.eq.0 ) then +c + if ( ( mod(suifro,2).eq.0 ) .or. + > ( mod(suifro,3).eq.0 ) ) then + call gmmod ( nocman//'.Frontier', + > adfrfa, 0, nbfmed, 1, 1, codre1 ) + else + codre1 = 0 + endif +c + call gmaloj ( nhsupe//'.Tab10', ' ', nbfmed, adfrgr, codre2 ) + call gmecat ( nhsupe, 10, nbfmed, codre3 ) + iaux = 10*nbfmed + call gmaloj ( nhsups//'.Tab10', ' ', iaux, adnogr, codre4 ) + call gmecat ( nhsups, 10, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +cgn call gmprsx (nompro,ncfami//'.Groupe.Table' ) +cgn call gmprsx (nompro,ncfami//'.Groupe.Pointeur' ) +c +c 4.1.1. ==> Groupes pour les frontieres discretes ou CAO +c + if ( ( mod(suifro,2).eq.0 ) .or. ( mod(suifro,5).eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1.1. F. discretes/CAO ; codret', codret +#endif +c +cgn call gmprsx (nompro,ncafdg ) +cgn call gmprsx (nompro,ncafdg//'.Pointeur' ) +cgn call gmprsx (nompro,ncafdg//'.Table' ) +cgn call gmprsx (nompro,ncafdg//'.Taille' ) +c + if ( codret.eq.0 ) then +c + call gmliat ( ncafdg, 1, nbgrof, codret ) +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbgrof', nbgrof +#endif +c + if ( nbgrof.gt.0 ) then +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafdg, iaux, + > jaux, kaux, + > pointd, pttgrd, ptngrd, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 4.1.2. ==> Frontieres analytiques +c + if ( mod(suifro,3).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1.2 Front analytiques ; codret', codret +#endif +c +c 4.1.2.1 ==> Combien de frontieres analytiques ? +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro,ncafan ) + call gmliat ( ncafan, 1, nbfran ,codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbfran.eq.0 ) then + write (ulsort,texte(langue,8)) + codret = 4121 + endif +c + endif +c +c 4.1.2.2 ==> Description des noms des frontieres dans les liens +c + if ( nbfran.gt.0 ) then +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro,ncfgnf//'.Pointeur' ) +cgn call gmprsx (nompro,ncfgnf//'.Table' ) +cgn call gmprsx (nompro,ncfgnf//'.Taille' ) + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncfgnf, iaux, + > nbfrgr, kaux, + > adfpoi, adftai, adftab, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.1.2.3 ==> Description des noms des groupes dans les liens +c + if ( nbfran.gt.0 ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx (nompro//' - ncfgng',ncfgng ) +cgn call gmprsx (nompro//' - ncfgng',ncfgng//'.Pointeur' ) +cgn call gmprsx (nompro//' - ncfgng',ncfgng//'.Table' ) +cgn call gmprsx (nompro//' - ncfgng',ncfgng//'.Taille' ) + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncfgng, iaux, + > jaux, kaux, + > adgpoi, adgtai, adgtab, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.1.2.3 ==> Description des frontieres +c + if ( nbfran.gt.0 ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx (nompro,ncafan//'.Pointeur' ) +cgn call gmprsx (nompro,ncafan//'.Table' ) +cgn call gmprsx (nompro,ncafan//'.Taille' ) +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafan, iaux, + > jaux, kaux, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 4.1.3. ==> Caracteristiques des familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1.3. Carac familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 30 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD13', nompro +#endif + call utad13 ( iaux, ncfami, + > pnumfa, pnomfa, + > pointe, jaux, ptngrf, + > ulsort, langue, codret ) +c + endif +c +c 4.1.4. ==> Initialisations ad-hoc +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1.4. Init ad hoc ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFIN', nompro +#endif + call vcsfin ( suifro, + > imem(pcexar), imem(pcextr), imem(pcexqu), + > nbgrof, nbfrgr, nbfran, nbfmed, nbelem, + > imem(pointd), imem(pttgrd), smem(ptngrd), + > imem(adcpoi), imem(adctai), smem(adctab), + > imem(adfpoi), imem(adftai), smem(adftab), + > imem(adgpoi), imem(adgtai), smem(adgtab), + > imem(pointe), smem(ptngrf), + > imem(adfrfa), imem(adfrgr), smem(adnogr), + > imem(pnuele), imem(adarhn), + > imem(pfamee), imem(ptypel), + > imem(pnumfa), smem(pnomfa), + > imem(paretr), imem(adtrhn), + > imem(parequ), imem(adquhn), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. homologues ; codret', codret +#endif +c + nbpnho = 0 + nbppho = 0 + nbpaho = 0 + nbptho = 0 +c +c 5.1. ==> allocation des tableaux etendus de description des +c homologues +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.1 ) then + call gmaloj ( nhnoeu//'.Homologu', ' ', nbnoto, adhono, codret ) + endif +c + if ( homolo.ge.1 .and. nbmpto.gt.0 ) then + typenh = 0 + iaux = 29 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_mp', nompro +#endif + call utal02 ( typenh, iaux, + > nhmapo, nbmpto, kaux, + > paux, paux, paux, paux, + > paux, paux, + > paux, paux, paux, + > paux, admpho, paux, + > ulsort, langue, codret ) + endif +c + if ( homolo.ge.2 ) then + typenh = 1 + iaux = 29 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_ar', nompro +#endif + call utal02 ( typenh, iaux, + > nharet, nbarto, kaux, + > paux, paux, paux, paux, + > paux, paux, + > paux, paux, paux, + > paux, adhoar, paux, + > ulsort, langue, codret ) + endif +c + if ( homolo.ge.3 .and. nbtrto.gt.0 ) then + typenh = 2 + iaux = 29 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_tr', nompro +#endif + call utal02 ( typenh, iaux, + > nhtria, nbtrto, kaux, + > paux, paux, paux, paux, + > paux, paux, + > paux, paux, paux, + > paux, adhotr, paux, + > ulsort, langue, codret ) + endif +c + if ( homolo.ge.3 .and. nbquto.gt.0 ) then + typenh = 4 + iaux = 29 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro +#endif + call utal02 ( typenh, iaux, + > nhquad, nbquto, kaux, + > paux, paux, paux, paux, + > paux, paux, + > paux, paux, paux, + > paux, adhoqu, paux, + > ulsort, langue, codret ) + endif +c + endif +c +c 5.2. ==> construction des tableaux etendus d'equivalence - phase 1 +c on ne fait ici que la traduction directe des donnees dans le +c but de pouvoir etablir les familles +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU1', nompro +#endif + call vcequ1 ( imem(pnunoe), imem(pnuele), + > imem(adhono), imem(adnohn), imem(adeqno), + > imem(adhoar), imem(adarhn), imem(adeqar), + > imem(adhotr), imem(adtrhn), imem(adeqtr), + > imem(adhoqu), imem(adquhn), imem(adeqqu), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.3. ==> prise en compte des equivalences dans les caracteristiques +c des entites +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQUI', nompro +#endif + call vcequi ( imem(pnunoe), imem(pnuele), + > imem(pcexno), imem(adnohn), imem(adeqno), + > imem(pcexar), imem(adarhn), imem(adeqar), + > imem(pcextr), imem(adtrhn), imem(adeqtr), + > imem(pcexqu), imem(adquhn), imem(adeqqu), + > imem(adeqpo), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. construction des familles de noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. familles de noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoto, nctfno, nbfnom', + > nbnoto, nctfno, nbfnom + write (ulsort,texte(langue,3)) 'VCCFAM_no', nompro +#endif +c + iaux = -1 + call vccfam + > ( iaux, + > nbnoto, nctfno, nbfnom, + > imem(pcexno), imem(pcfano), imem(iaux), imem(iaux), + > imem(pfamno), nbfnoe, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. construction des familles de mailles-points +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. familles de m-pt ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbmpto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbmpto, nctfmp, nbfmpm', + > nbmpto, nctfmp, nbfmpm + write (ulsort,texte(langue,3)) 'VCCFAM_mp', nompro +#endif +c + iaux = 0 + call vccfam + > ( iaux, + > nbmpto, nctfmp, nbfmpm, + > imem(pcexmp), imem(pcfamp), imem(pnoemp), imem(pfamno), + > imem(pfammp), nbfmpo, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. construction des familles d'aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. familles d aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto, nctfar, nbfarm', + > nbarto, nctfar, nbfarm + write (ulsort,texte(langue,3)) 'VCCFAM_ar', nompro +#endif +c + iaux = 1 + call vccfam + > ( iaux, + > nbarto, nctfar, nbfarm, + > imem(pcexar), imem(pcfaar), imem(iaux), imem(iaux), + > imem(pfamar), nbfare, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c +c==== +c 9. construction des familles de triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. familles de triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 .or. + > ( nbquto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtrto, nctftr, nbftrm', + > nbtrto, nctftr, nbftrm + write (ulsort,texte(langue,3)) 'VCCFAM_tr', nompro +#endif +c + iaux = 2 + call vccfam + > ( iaux, + > nbtrto, nctftr, nbftrm, + > imem(pcextr), imem(pcfatr), imem(iaux), imem(iaux), + > imem(pfamtr), nbftri, + > nctfar, nbfarm, imem(pcfaar), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. construction des familles de quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. familles de quad. ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbquto, nctfqu, nbfqum', + > nbquto, nctfqu, nbfqum + write (ulsort,texte(langue,3)) 'VCCFAM_qu', nompro +#endif +c + iaux = 4 + call vccfam + > ( iaux, + > nbquto, nctfqu, nbfqum, + > imem(pcexqu), imem(pcfaqu), imem(iaux), imem(iaux), + > imem(pfamqu), nbfqua, + > nctfar, nbfarm, imem(pcfaar), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 11. construction des familles de triangles pour la mise en conformite +c des quadrangles +c Remarque : seulement s'il y a du raffinement conforme +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. triangles conformite ; codret', codret + write (ulsort,90002) 'nbquto, modhom, pilraf', + > nbquto, modhom, pilraf +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfqua, nbftri', nbfqua, nbftri +#endif +c + if ( codret.eq.0 ) then + call gmalot ( ntrav1, 'entier ', nctftr, ptrav1, codret ) + endif +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCF_qu_tr', nompro +#endif + call vccfcf ( iaux, nctfqu, nbfqum, nbfqua, + > jaux, nctftr, nbftrm, nbftri, ncfftr, + > coftfq, + > imem(pcfaqu), imem(pcfatr), + > edqua4, edtri3, + > edqua8, edtri6, + > edqua9, edtri7, + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfqua, nbftri', nbfqua, nbftri +#endif +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav1, codret ) + endif +c + endif +c + endif +c +c==== +c 12. construction des familles de tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. familles de tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 .or. + > ( nbheto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFAM_te', nompro +#endif + iaux = 3 + call vccfam + > ( iaux, + > nbteto, nctfte, nbftem, + > imem(pcexte), imem(pcfate), imem(iaux), imem(iaux), + > imem(pfamte), nbftet, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 13. construction des familles d'hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '13. familles d''hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFAM_he', nompro +#endif + iaux = 6 + call vccfam + > ( iaux, + > nbheto, nctfhe, nbfhem, + > imem(pcexhe), imem(pcfahe), imem(iaux), imem(iaux), + > imem(pfamhe), nbfhex, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 14. construction des familles de pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '14. familles de pyramidess ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpyto.ne.0 .or. + > ( nbheto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFAM_py', nompro +#endif + iaux = 5 + call vccfam + > ( iaux, + > nbpyto, nctfpy, nbfpym, + > imem(pcexpy), imem(pcfapy), imem(iaux), imem(iaux), + > imem(pfampy), nbfpyr, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 15. construction des familles de tetraedres et pyramides pour la mise +c en conformite des hexaedres +c Remarque : seulement s'il y a du raffinement conforme +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '15. tetr/pyra conformite ; codret', codret + write (ulsort,90002) 'nbheto, modhom, pilraf', + > nbheto, modhom, pilraf +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfhex, nbftet, nbfpyr', + > nbfhex, nbftet, nbfpyr +#endif +c + if ( codret.eq.0 ) then + call gmalot ( ntrav1, 'entier ', nctftr, ptrav1, codret ) + endif +c + if ( codret.eq.0 ) then +c + iaux = 6 + jaux = 3 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCF_he_te', nompro +#endif + call vccfcf ( iaux, nctfhe, nbfhem, nbfhex, + > jaux, nctfte, nbftem, nbftet, ncffte, + > coftfh, + > imem(pcfahe), imem(pcfate), + > edhex8, edtet4, + > edhe20, edte10, + > edhe20, edte10, + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfhex, nbftet', nbfhex, nbftet +#endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 6 + jaux = 5 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCF_he_py', nompro +#endif + call vccfcf ( iaux, nctfhe, nbfhem, nbfhex, + > jaux, nctfpy, nbfpym, nbfpyr, ncffpy, + > cofpfh, + > imem(pcfahe), imem(pcfapy), + > edhex8, edpyr5, + > edhe20, edpy13, + > edhe20, edpy13, + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfhex, nbfpyr', nbfhex, nbfpyr +#endif +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav1, codret ) + endif +c + endif +c + endif +c +c==== +c 16. construction des familles de pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '16. familles de pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFAM_pe', nompro +#endif + iaux = 7 + call vccfam + > ( iaux, + > nbpeto, nctfpe, nbfpem, + > imem(pcexpe), imem(pcfape), imem(iaux), imem(iaux), + > imem(pfampe), nbfpen, + > jaux, jaux, imem(jaux), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 17. construction des familles de tetraedres et pyramides pour la mise +c en conformite des pentaedres +c Remarque : seulement s'il y a du raffinement conforme +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '17. tetr/pyra conformite ; codret', codret + write (ulsort,90002) 'nbpeto, modhom, pilraf', + > nbpeto, modhom, pilraf +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 .and. ( tyconf.eq.-1 .or. tyconf.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfpen, nbftet, nbfpyr', + > nbfpen, nbftet, nbfpyr +#endif +c + if ( codret.eq.0 ) then + call gmalot ( ntrav1, 'entier ', nctftr, ptrav1, codret ) + endif +c + if ( codret.eq.0 ) then +c + iaux = 7 + jaux = 3 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCF_pe_te', nompro +#endif + call vccfcf ( iaux, nctfpe, nbfpem, nbfpen, + > jaux, nctfte, nbftem, nbftet, ncffte, + > coftfp, + > imem(pcfape), imem(pcfate), + > edpen6, edtet4, + > edpe15, edte10, + > edpe15, edte10, + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfpen, nbftet', nbfpen, nbftet +#endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 7 + jaux = 5 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCF_pe_py', nompro +#endif + call vccfcf ( iaux, nctfpe, nbfpem, nbfpen, + > jaux, nctfpy, nbfpym, nbfpyr, ncffpy, + > cofpfp, + > imem(pcfape), imem(pcfapy), + > edpen6, edpyr5, + > edpe15, edpy13, + > edpe15, edpy13, + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfpen, nbfpyr', nbfpen, nbfpyr +#endif +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav1, codret ) + endif +c + endif +c + endif +c +c==== +c 18. complement des familles pour non conforme ou Carmel +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '18. complement familles ; codret', codret +#endif +c +c 18.1. ==> Adaptation non conforme +c + if ( tyconf.eq.-2 .or. + > tyconf.eq.1 .or. + > tyconf.eq.2 .or. + > tyconf.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '18.1. non-conforme ; codret', codret +cgn call gmprsx (nompro,ncfami) +cgn call gmprsx (nompro,ncfami//'.Numero') +cgn call gmprsx (nompro,ncfami//'.Nom') +#endif +c +c 18.1.1. ==> modifications des structures +c + if ( codret.eq.0 ) then +c + nbfme0 = nbfmed + nbfmed = nbfmed + 3 + ngrou0 = ngrouc + ngrouc = ngrouc + 3 + un = 1 +c + call gmecat ( ncfami, 1, nbfmed, codre1 ) + call gmecat ( ncfami, 2, ngrouc, codre2 ) + call gmecat ( ncfami//'.Groupe', 1, nbfmed, codre3 ) + iaux = 10*ngrouc + call gmecat ( ncfami//'.Groupe', 2, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmmod ( ncfami//'.Numero', + > pnumfa, nbfme0, nbfmed, un, un, codre1 ) + iaux1 = 10*nbfme0 + iaux2 = 10*nbfmed + call gmmod ( ncfami//'.Nom', + > pnomfa, iaux1, iaux2, un, un, codre2 ) + call gmmod ( ncfami//'.Groupe.Pointeur', + > pgrpo, nbfme0+1, nbfmed+1, un, un, codre3 ) + iaux1 = 10*ngrou0 + iaux2 = 10*ngrouc + call gmmod ( ncfami//'.Groupe.Taille', + > pgrtai, iaux1, iaux2, un, un, codre4 ) + call gmmod ( ncfami//'.Groupe.Table', + > pgrtab, iaux1, iaux2, un, un, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +c +c 18.1.2. ==> Modifications +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFNC', nompro +#endif + call vccfnc ( nbfare, imem(pcfaar), + > nbfqua, imem(pcfaqu), + > nbftri, imem(pcfatr), + > imem(adnomb+47), imem(adnomb+48), + > nbfme0, imem(pnumfa), smem(pnomfa), + > imem(pgrpo), + > imem(pgrtai), smem(pgrtab), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 18.2. ==> Carmel +c + if ( typcca.eq.66 .or. typcca.eq.76 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '18.2. Carmel ; codret', codret +cgn call gmprsx (nompro,ncfami) +cgn call gmprsx (nompro,ncfami//'.Numero') +cgn call gmprsx (nompro,ncfami//'.Nom') +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCCFCA', nompro +#endif + call vccfca ( nbfare, imem(pcfaar), + > nbfqua, imem(pcfaqu), + > nbftri, imem(pcfatr), + > imem(adnomb+47), imem(adnomb+48), + > nbfme0, imem(pnumfa), smem(pnomfa), + > imem(pgrpo), + > imem(pgrtai), smem(pgrtab), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 19. construction des tableaux etendus d'equivalence - phase 2 +c les familles etant construites, on enrichit les structures pour +c pouvoir passer l'algorithme de maillage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '19. equivalence ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCEQU2', nompro +#endif + call vcequ2 ( imem(adhono), imem(adhoar), + > imem(adhotr), imem(adhoqu), + > imem(psomar), imem(pnp2ar), + > imem(paretr), imem(parequ), + > imem(pposif), imem(pfacar), + > imem(ppovos), imem(pvoiso), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhnoeu//'.Homologu' ) + call gmprsx (nompro, nharet//'.Homologu' ) +cgn call gmprsx (nompro, nhtria//'.Homologu' ) +#endif +c + endif +c + endif +c +c==== +c 20. menage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '20. menage ; codret', codret +#endif +c +c 20.1. ==> mise a la bonne taille des tableaux lies aux familles HOMARD +c Attention : meme dans le cas ou un type d'entite est absent, +c (maille-point, tetraedre, etc.), il faut passer +c par chacune des mises a jour. En effet par la +c suite, certains traitements font des appels +c systematiques aux attributs et aux adresses des +c tableaux. Il est est donc indispensable d'avoir +c correctement rempli les structures. +c + do 201 , typenh = -1 , 7 +c +c 20.1.1. ==> Caracteristiques des entites concernees +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nhenfa = nhnofa + nctfen = nctfno + nbfenm = nbfnom + nbfaen = nbfnoe + elseif ( typenh.eq.0 ) then + nhenfa = nhmpfa + nctfen = nctfmp + nbfenm = nbfmpm + nbfaen = nbfmpo + elseif ( typenh.eq.1 ) then + nhenfa = nharfa + nctfen = nctfar + nbfenm = nbfarm + nbfaen = nbfare + elseif ( typenh.eq.2 ) then + nhenfa = nhtrfa + nctfen = nctftr + nbfenm = nbftrm + nbfaen = nbftri + elseif ( typenh.eq.3 ) then + nhenfa = nhtefa + nctfen = nctfte + nbfenm = nbftem + nbfaen = nbftet + elseif ( typenh.eq.4 ) then + nhenfa = nhqufa + nctfen = nctfqu + nbfenm = nbfqum + nbfaen = nbfqua + elseif ( typenh.eq.5 ) then + nhenfa = nhpyfa + nctfen = nctfpy + nbfenm = nbfpym + nbfaen = nbfpyr + elseif ( typenh.eq.6 ) then + nhenfa = nhhefa + nctfen = nctfhe + nbfenm = nbfhem + nbfaen = nbfhex + elseif ( typenh.eq.7 ) then + nhenfa = nhpefa + nctfen = nctfpe + nbfenm = nbfpem + nbfaen = nbfpen + endif +c + endif +c +c 20.1.2. ==> appel du programme generique +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfenm', nbfenm + write (ulsort,90002) 'nbfaen', nbfaen +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) + > 'UTFAM1 - '//mess14(langue,3,typenh), nompro +#endif + iaux = typenh + call utfam1 ( iaux, nhenfa, pcfaen, + > nctfen, nbfenm, nbfaen, + > ulsort, langue, codret ) +c + endif +c +c 20.1.3. ==> Recuperation de l'adresse des codes +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + pcfano = pcfaen + elseif ( typenh.eq.0 ) then + pcfamp = pcfaen + elseif ( typenh.eq.1 ) then + pcfaar = pcfaen + elseif ( typenh.eq.2 ) then + pcfatr = pcfaen + elseif ( typenh.eq.3 ) then + pcfate = pcfaen + elseif ( typenh.eq.4 ) then + pcfaqu = pcfaen + elseif ( typenh.eq.5 ) then + pcfapy = pcfaen + elseif ( typenh.eq.6 ) then + pcfahe = pcfaen + elseif ( typenh.eq.7 ) then + pcfape = pcfaen + endif +c + endif +c + 201 continue +c +c 20.2. ==> Liberation de structures inutiles +c + if ( codret.eq.0 ) then +c + call gmsgoj ( nhvois//'.0D/1D' , codret ) +c + endif +c +c==== +c 21. sauvegarde des informations sur les familles, au sens +c du module de calcul associe +c attention : il faut faire des copies et non pas des attachements +c car la structure generale de l'objet "maillage de +c calcul" est detruite apres la phase de conversion. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '21. sauvegarde ; codret', codret +#endif +c +cgn print *,nompro,' : nbfmed,ngrouc',nbfmed,ngrouc +c + if ( codret.eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( ngrouc.gt.0 ) then +c + call gmecat ( nhsupe, 5, nbfmed, codre1 ) + iaux = 10*ngrouc + call gmecat ( nhsupe, 6, iaux, codre2 ) + iaux = 10*ngrouc + call gmecat ( nhsups, 2, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + call gmecat ( nhsupe, 9, nbfmed, codre1 ) + call gmecat ( nhsups, 4, 10*nbfmed, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbfmed.ne.0 ) then +c + if ( ngrouc.gt.0 ) then +c + call gmcpoj ( ncfami//'.Groupe.Pointeur', + > nhsupe//'.Tab5', codre1 ) + call gmcpoj ( ncfami//'.Groupe.Taille', + > nhsupe//'.Tab6', codre2 ) + call gmcpoj ( ncfami//'.Groupe.Table', + > nhsups//'.Tab2', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + call gmcpoj ( ncfami//'.Numero', + > nhsupe//'.Tab9', codre1 ) + call gmcpoj ( ncfami//'.Nom', + > nhsups//'.Tab4', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsupe ) + call gmprsx (nompro, nhsupe//'.Tab3' ) + call gmprsx (nompro, nhsupe//'.Tab4' ) + call gmprsx (nompro, nhsupe//'.Tab5' ) + call gmprsx (nompro, nhsupe//'.Tab6' ) + call gmprsx (nompro, nhsupe//'.Tab9' ) + call gmprsx (nompro, nhsups ) + call gmprsx (nompro, nhsups//'.Tab2' ) + call gmprsx (nompro, nhsups//'.Tab3' ) + call gmprsx (nompro, nhsups//'.Tab4' ) + call gmprsx (nompro, nhsups//'.Tab9' ) +#endif +c + endif +c +c==== +c 22. sauvegarde des informations sur les equivalences, au sens +c du module de calcul associe +c attention : il faut faire des copies et non pas des attachements +c car la structure generale de l'objet "maillage de +c calcul" est detruite apres la phase de conversion. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '22. sauvegarde equivalences ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.ne.0 ) then +c + call gmecat ( nhsups, 5, 33*nbequi, codre1 ) + call gmcpoj ( ncequi//'.InfoGene', + > nhsups//'.Tab5', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsups ) + call gmprsx (nompro, nhsups//'.Tab5' ) +#endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c==== +c 23. impressions +c==== +cgn call gmprsx (nompro, nhnofa//'.EntiFamm') +cgn call gmprsx (nompro, nhmpfa//'.EntiFamm') +cgn call gmprsx (nompro, nharfa//'.EntiFamm') +cgn call gmprsx (nompro, nhtrfa//'.EntiFamm') +cgn call gmprsx (nompro, nhqufa//'.EntiFamm') +cgn call gmprsx (nompro, nhtefa//'.EntiFamm') +cgn call gmprsx (nompro, nhtrfa//'.Codes') +cgn call gmprsx (nompro, nhqufa//'.Codes') +cgn call gmprsx (nompro, nhtetr/1/'.Famille') +cgn call gmprsx (nompro, nhtetr//'.Famille.Codes') +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif + call utecfe ( iaux, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +c +#endif +c +c==== +c 24. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmaig.F b/src/tool/AV_Conversion/vcmaig.F new file mode 100644 index 00000000..244471db --- /dev/null +++ b/src/tool/AV_Conversion/vcmaig.F @@ -0,0 +1,174 @@ + subroutine vcmaig ( fmdeig, noeeig, + > typele, fameel, noeele, + > nnoeho, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de MAillage - elements IGnores +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noeeig . s .nbelig**. noeuds des elements . +c . fmdeig . s . nbelig . famille med des elements . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . fameel . e . nbelem . famille med des elements . +c . nnoeho . e . nbnoto . numero des noeuds dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMAIG' ) +c +#include "nblang.h" +#include "referx.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "meddc0.h" +#include "envca1.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer fmdeig(nbelig) + integer noeeig(nbelig,*) + integer typele(nbelem), fameel(nbelem) + integer noeele(nbelem,nbmane) + integer nnoeho(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer el, elig, noeud, typeig + integer nbnoel +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Fin du compteur sur les elements ignores :'',i10)' + texte(1,5) = + > '(''Or, on avait prevu'',i10,'' elements ignores.'')' +c + texte(2,4) = '(''End of count on ignored elements :'',i10)' + texte(2,5) = '(i10,'' elements were forecasted.'')' +c +#include "impr03.h" +c +c==== +c 2. on passe en revue chaque element ignore +c on memorise son nombre de noeuds et on transfere sa description +c dans la structure HOMARD +c==== +c + if ( degre.eq.1 ) then + typeig = edpyr5 + nbnoel = 5 + else + typeig = edpy13 + nbnoel = 13 + endif +cgn write (ulsort,90012) 'typeig, nbnoel', typeig, nbnoel +c + elig = 0 +c + do 21 , el = 1 , nbelem +c + if ( typele(el).eq.typeig ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90012) 'type de ', el, typele(el) +#endif +c + elig = elig + 1 + fmdeig(elig) = fameel(el) +c + do 211 , noeud = 1 , nbnoel +cgn write (ulsort,90002) 'noeud', noeud, noeele(el,noeud) + noeeig(elig,noeud) = nnoeho(noeele(el,noeud)) + 211 continue +c + endif +c + 21 continue +c + if ( elig.ne.nbelig ) then + write (ulsort,texte(langue,4)) elig + write (ulsort,texte(langue,5)) nbelig + codret = 1 + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmail.F b/src/tool/AV_Conversion/vcmail.F new file mode 100644 index 00000000..91297d55 --- /dev/null +++ b/src/tool/AV_Conversion/vcmail.F @@ -0,0 +1,272 @@ + subroutine vcmail ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de MAILlage +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMAIL' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux + integer typnom +c + character*6 saux + character*8 action + character*8 typobs, nocman, nohman +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONVERSION DU MAILLAGE'')' + texte(1,5) = '(29(''=''),/)' + texte(1,6) = '(''Le nom du maillage HOMARD est inconnu.'')' +c + texte(2,4) = '(/,a6,'' MESH CONVERSION'')' + texte(2,5) = '(22(''=''),/)' + texte(2,6) = '(''The name of the HOMARD mesh is unknown.'')' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + if ( taopti(4).ne.2 ) then + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) + endif +c +#include "impr03.h" +c +c==== +c 2. les structures de base +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> le maillage homard +c . en mode information et si l'entree n'est pas au format +c HOMARD et si on ne souhaite pas archiver le maillage, +c le nom du maillage HOMARD est cree automatiquement. +c . dans tous les autres modes, on doit l'avoir fourni. +c + if ( taopti(4).eq.2 .and. + > taopti(11).ne.1 .and. + > taopti(5).eq.1 ) then +c + typnom = 0 +c + else +c + typnom = 1 +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nohman, iaux, ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,6)) + endif +c + endif +c +c 2.2. ==> le maillage de calcul +c + nocman = taopts(1) +c + endif +c +c==== +c 3. conversion du maillage +c==== +c 3.1. ==> les connectivites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. connectivites ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMACO', nompro +#endif +c + call vcmaco ( taopti(4), taopti(11), taopti(49), + > taopti(30), taopti(39), + > nocman, nohman, typnom, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + taopts(3) = nohman +c + endif +c + endif +c +c 3.2. ==> les familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMAFA', nompro +#endif +c + call vcmafa ( taopti(4), taopti(31), taopti(30), taopti(29), + > nocman, nohman, + > taopts(17), taopts(25), taopts(23), taopts(24), + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> verifications sauf pour une information car c'est fait apres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. verifications ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + action = taopts(30) +c +#ifdef _DEBUG_HOMARD_ +c +#else + if ( action.ne.'info_av ' ) then +#endif +c + if ( action.eq.'homa ' ) then + action = 'avad' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMVER', nompro +#endif + call vcmver ( taopti(4), nohman, action, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +c +#else + endif +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/AV_Conversion/vcmar0.F b/src/tool/AV_Conversion/vcmar0.F new file mode 100644 index 00000000..ef8f054c --- /dev/null +++ b/src/tool/AV_Conversion/vcmar0.F @@ -0,0 +1,299 @@ + subroutine vcmar0 ( nnosho, nnosca, + > noeele, typele, + > povoso, voisom, + > nbardb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - ARetes - phase 0 +c - - - -- - +c ______________________________________________________________________ +c +c but : estime le nombre d'aretes en doubles dans le maillage +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . e . rsnoto . numero des noeuds dans le calcul . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . voisins des sommets en stockage morse . +c . nnardb . s . 1 . nombre d'aretes en double . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2313 : maille double . +c . . . . 232 : noeud bizarre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMAR0' ) +c +#include "coftex.h" +#include "referx.h" +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nbutil.h" +#include "nombno.h" +#include "refere.h" +#include "nombsr.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nnosho(rsnoac), nnosca(rsnoto) + integer noeele(nbelem,nbmane), typele(nbelem) + integer voisom(nvosom), povoso(0:nbnoto) + integer nbardb +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer poinde, poinfi, point + integer sommet, nbvois, nbaret + integer nbsomm, elem, elem00, typhom +#ifdef _DEBUG_HOMARD_ + integer glop +#endif + integer tbjaux(200,4) + integer tbkaux(200,2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = + >'('' Ses noeuds (numerotation du calcul) : '',/,10i10)' + texte(1,8) = + >'('' Ses noeuds (numerotation HOMARD) : '',/,10i10)' + texte(1,10) = + >'(''. Element voisin (numero du calcul)'',i10,'' ('',a,'')'')' +c + texte(2,7) = + > '('' Its nodes (with calculation #) : '',/,10i10)' + texte(2,8) = + > '('' Its nodes (with HOMARD #) : '',/,10i10)' + texte(2,10) = + >'(''. Neighbour element (calculation #)'',i10,'' ('',a,'')'')' +c +#include "impr03.h" +c +c==== +c 2. on passe en revue chaque maille +c pour chaque maille, on compte combien de ses voisins comptent +c au moins 2 de ses noeuds. Cela fait autant d'aretes doubles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. chaque maille ; codret', codret +#endif +c + nbardb = 0 +c + do 20 , elem = 1 , nbelem +c + typhom = medtrf(typele(elem)) + nbsomm = nbnref(typhom,1) +c +#ifdef _DEBUG_HOMARD_ + if ( elem.lt.1 ) then + glop = 1 + else + glop = 0 + endif + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + iaux = ( typhom + mod(typhom,2)) / 2 + write (ulsort,texte(langue,10)) elem, mess14(langue,1,iaux) + write (ulsort,texte(langue,7)) (noeele(elem,iaux),iaux=1,nbsomm) + write (ulsort,texte(langue,8)) + > (nnosho(noeele(elem,iaux)),iaux=1,nbsomm) + endif +#endif +c + nbvois = 0 +c +c 2.1. ==> Parcours des nbsomm sommets de la maille +c + do 21 , iaux = 1 , nbsomm +c + sommet = nnosho(noeele(elem,iaux)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '. sommet', sommet + endif +#endif +c + poinde = povoso(nnosca(sommet)-1) + 1 + poinfi = povoso(nnosca(sommet)) +c +cgn write(ulsort,90002) 'pointeur debut et fin', poinde, poinfi +c +c 2.1.1. ==> Examen des mailles contenant ce sommet +c + do 211 , point = poinde , poinfi +c + elem00 = voisom(point) +c +c 2.1.1.a. ==> Si la maille est de meme type que la maille courante +c mais sans l'etre : +c + if ( ( elem.ne.elem00 ) .and. + > ( typhom.eq.medtrf(typele(elem00)) ) ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '.... maille', elem00 + endif +#endif +c +c On cherche si cette maille est deja enregistre dans +c les voisins : +c . Si oui, on memorise le second sommet et on passe au +c sommet suivant (goto 211) +c . Si non, on enregistre cette maille avec +c ce premier sommet +c + do 212 , jaux = 1 , nbvois + if ( tbjaux(jaux,1).eq.elem00 ) then + tbjaux(jaux,2) = tbjaux(jaux,2) + 1 + tbjaux(jaux,4) = max(tbjaux(jaux,4),sommet) + goto 211 + endif + 212 continue +c + nbvois = nbvois + 1 +cgn write (ulsort,90002) '...... nbvois', nbvois + tbjaux(nbvois,1) = elem00 + tbjaux(nbvois,2) = 1 + tbjaux(nbvois,3) = sommet + tbjaux(nbvois,4) = 0 + if ( nbvois.eq.200 ) then + goto 2222 + endif +c + endif +c + 211 continue +c + 21 continue +c +c 2.2. ==> Bilan +c On parcourt les voisins enregistres. On compte a +c combien d'aretes identiques cela correspond. +c + 2222 continue +c + nbaret = 0 + do 22 , jaux = 1 , nbvois +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90015) '. maille', tbjaux(jaux,1), + > ' :', tbjaux(jaux,2), tbjaux(jaux,3), tbjaux(jaux,4) + endif +#endif +c + if ( tbjaux(jaux,2).ge.2 ) then +c + do 221 , kaux = 1 , nbaret + if ( ( tbkaux(kaux,1).eq.tbjaux(jaux,3) ) .and. + > ( tbkaux(kaux,2).eq.tbjaux(jaux,4) ) ) then + goto 22 + endif + 221 continue +c + nbaret = nbaret + 1 +cgn write (ulsort,90002) '...... nbaret', nbaret + tbkaux(nbaret,1) = tbjaux(jaux,3) + tbkaux(nbaret,2) = tbjaux(jaux,4) + nbardb = nbardb + 1 + endif +c + 22 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) 'nbardb', nbardb + endif +#endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbardb', nbardb +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmare.F b/src/tool/AV_Conversion/vcmare.F new file mode 100644 index 00000000..920d6ed7 --- /dev/null +++ b/src/tool/AV_Conversion/vcmare.F @@ -0,0 +1,624 @@ + subroutine vcmare ( areele, somare, np2are, + > hetare, filare, merare, + > coexar, arenoe, insoar, + > nnosho, nnosca, narsho, + > narsca, fameel, noeele, + > typele, povoso, voisom, + > preare, + > arsref, dearef, dejavu, + > trav2a, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - AREtes +c - - - --- +c ______________________________________________________________________ +c +c but : etablit la table de connectivite des mailles par arete +c initialisation des tableaux lies aux aretes +c Si l'estimation nbar00 est trop petite, on retourne une +c valeur negative pour nbarto. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . areele . s . nbelem . aretes des elements . +c . . .*nbmaae . . +c . somare . s .2*nbar00. numeros des extremites d'arete . +c . np2are . s . nbar00 . noeud milieux des aretes . +c . hetare . s . rbar00 . historique de l'etat des aretes . +c . filare . s . rbar00 . premiere fille des aretes . +c . merare . s . rbar00 . mere des aretes . +c . coexar . s . nbar00*. codes externes sur les aretes . +c . . . nctfar . 1 : famille MED . +c . . . . 2 : type de segment . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . insoar . s . nbar00 . information sur les sommets des aretes . +c . . . . 0 : ses deux sommets appartiennent . +c . . . . exclusivement a un element soumis a . +c . . . . l'adaptation . +c . . . . -1 : son 1er sommet appartient a un element. +c . . . . ignore . +c . . . . le 2nd sommet appartient exclusivement. +c . . . . a un element soumis a l'adaptation . +c . . . . -2 : son 2nd sommet appartient a un element. +c . . . . ignore . +c . . . . le 1er sommet appartient exclusivement. +c . . . . a un element soumis a l'adaptation +c . . . . 2 : ses deux sommets appartiennent a un . +c . . . . element ignore . +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . e . rsnoto . numero des noeuds dans le calcul . +c . narsho . s . rsarac . numero des aretes dans HOMARD . +c . narsca . s . rbar00 . numero des aretes du calcul . +c . fameel . e . nbelem . famille med des elements . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . voisins des sommets en stockage morse . +c . preare . a . nbnoto . premiere arete partant d'un sommet . +c . arsref . e .0:tehmax. numero local de l'arete reliee a un sommet . +c . . . *10*3 . 1er champ : type de l'element de reference . +c . . . . 2e champ : numero local du sommet concerne . +c . . . . 3e champ : rang de l'arete envisagee . +c . dearef . e .0:tehmax. description des aretes par les numeros . +c . . . *6*3 . locaux des noeuds sans se preoccuper . +c . . . . d'orientation . +c . . . .1er champ : type de l'element de reference . +c . . . .2e champ : numero local de l'arete envisagee. +c . . . .3e champ : 1 et 2 pour chaque extremite, . +c . . . . 3 pour le milieu . +c . dejavu . a . rbar00 . controle des doublons . +c . trav2a . e . nbnoto . tableau de travail numero 2 . +c . . . . 1, pour un noeud appartenant a au moins un . +c . . . . element ignore +c . . . . 0, sinon +c . . . . Il servira dans vcmare . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2313 : maille double . +c . . . . 232 : noeud bizarre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMARE' ) +c +#include "coftex.h" +#include "referx.h" +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "envca1.h" +#include "nbutil.h" +#include "nombno.h" +#include "refere.h" +#include "refert.h" +#include "nombar.h" +#include "nombsr.h" +#include "nomest.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer areele(nbelem,nbmaae) + integer somare(2,nbar00) + integer np2are(nbar00) + integer nnosho(rsnoac), nnosca(rsnoto) + integer narsho(rsarac), narsca(rbar00) + integer hetare(nbar00), filare(nbar00), insoar(nbar00) + integer merare(nbar00) + integer coexar(nbar00,nctfar) + integer arenoe(nbnoto) + integer fameel(nbelem), noeele(nbelem,nbmane), typele(nbelem) + integer arsref(0:tehmax,10,3), dearef(0:tehmax,12,3) + integer voisom(nvosom), povoso(0:nbnoto), preare(nbnoto) + integer dejavu(nbar00) + integer trav2a(rsnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer poinde, poinfi, point, nucode + integer mloc, n, nbas, nbnd, nloc, mglo, sommet, milieu + integer aloc, ar, larete, nuar, elem, typhom +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Les deux elements suivants sont doubles :'')' + texte(1,5) = '(''Numero dans le calcul : '',i10)' + texte(1,6) = '(''Famille MED : '',i4,'' ; type : '',i4)' + texte(1,7) = + >'('' Ses noeuds (numerotation du calcul) : '',/,10i10)' + texte(1,8) = + >'('' Ses noeuds (numerotation HOMARD) : '',/,10i10)' + texte(1,9) = '(''Le noeud'',i10,'' apparait plusieurs fois.'')' + texte(1,10) = + >'(''. Element voisin (numero du calcul)'',i10,'' ('',a,'')'')' + texte(1,11) = '(''Estimation du nombre d''''aretes :'',i10)' + texte(1,12) = '(''Ce nombre est trop petit.'')' +c + texte(2,4) = '(/,''The following two elements are double:'')' + texte(2,5) = '(''# in calculation : '',i10)' + texte(2,6) = '(''MED family : '',i4,'' ; type : '',i4)' + texte(2,7) = + > '('' Its nodes (with calculation #) : '',/,10i10)' + texte(2,8) = + > '('' Its nodes (with HOMARD #) : '',/,10i10)' + texte(2,9) = '(''Node'',i10,'' is present several times.'')' + texte(2,10) = + >'(''. Neighbour element (calculation #)'',i10,'' ('',a,'')'')' + texte(2,11) = '(''Estimation of the number of edges:'',i10)' + texte(2,12) = '(''This number is too low.'')' +c +#include "impr03.h" +c +c 1.2. ==> mise a zero +c + codret = 0 +c + do 11 , sommet = 1 , nbnoto + preare(sommet) = 0 + arenoe(sommet) = 0 + 11 continue +c + do 12 , larete = 1 , rsarac + narsho(larete) = 0 + 12 continue +c + do 13 , nucode = 1 , nctfar + do 131 , larete = 1 , nbar00 + coexar(larete,nucode) = 0 + 131 continue + 13 continue +c + do 14 , larete = 1 , rbar00 + dejavu(larete) = 0 + 14 continue +c + nbarto = 0 +c +c==== +c 2. on passe en revue chaque sommet +c remarque : l'exploration se fait dans la numerotation HOMARD +c ses elements voisins sont dans le tableau voisom, aux places +c comprises entre povoso(somm-1)+1 et povoso(somm), somm etant le +c numero dans le calcul correspondant au numero sommet dans +c homard +c remarque : si on ne tenait pas compte de certains elements, les +c quadrangles par exemple, cela est automatiquement traite avec +c les tableaux povoso/voisom. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. chaque sommet ; codret', codret +#endif +c + do 21 , sommet = 1 , nbnoto +c +#ifdef _DEBUG_HOMARD_ + if ( sommet.le.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,2,-1), sommet + endif +#endif +c + poinde = povoso(nnosca(sommet)-1) + 1 + poinfi = povoso(nnosca(sommet)) + +cgn write(ulsort,90002) 'pointeur debut et fin', poinde, poinfi +c + do 22 , point = poinde , poinfi +c +c 2.1. ==> caracterisation de l'element +c elem : son numero global +c typhom : son type dans HOMARD +c nbnd : son nombre de noeuds +c + elem = voisom(point) + typhom = medtrf(typele(elem)) + nbnd = nbnref(typhom,1) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + iaux = typhom + mod(typhom,2) + iaux = iaux / 2 + write (ulsort,texte(langue,10)) elem, mess14(langue,1,iaux) + write (ulsort,texte(langue,7)) (noeele(elem,n),n=1,nbnd) + write (ulsort,texte(langue,8)) (nnosho(noeele(elem,n)),n=1,nbnd) + endif +#endif +c +c 2.2. ==> recherche de nloc, numero local du sommet en cours d'examen +c vis-a-vis de la description de l'element de reference +c + do 221 , n = 1 , nbnd + if ( sommet.eq.nnosho(noeele(elem,n)) ) then + nloc = n + goto 2211 + endif + 221 continue + 2211 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(*,*) '. pour no =',sommet, ', nloc =',nloc + endif +#endif +c +c 2.3. ==> on explore toutes les aretes qui partent de ce sommet de +c numero local nloc +c nbas : le nombre d'aretes qui partent de chaque sommet +c aloc : numero local de la a-eme arete envisagee +c mloc : numero local de l'autre extremite +c mglo : numero global de l'autre extremite, dans la +c numerotation homard +c + nbas = nasref(typhom) +c ATTENTION : verrue pour le dernier noeud de la pyramide +c + if ( typhom.eq.tyhpy1 .or. typhom.eq.tyhpy2 ) then + if ( nloc.eq.5 ) then + nbas = nbas + 1 + endif + endif +c + do 223 , iaux = 1 , nbas +c + aloc = arsref(typhom,nloc,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(*,*) '.. iaux =',iaux,', aloc =',aloc + endif +#endif + if ( dearef(typhom,aloc,1).eq.nloc ) then + mloc = dearef(typhom,aloc,2) + else + mloc = dearef(typhom,aloc,1) + endif + mglo = nnosho(noeele(elem,mloc)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(*,*) '.. mglo =',mglo + endif +#endif +c +c 2.3.1. ==> . si la seconde extremite a un numero global plus grand que +c le sommet en cours d'examen, il faut chercher si l'arete +c de sommet vers somm2 a deja ete cree. +c la recherche de cette arete ne se fait pas parmi toutes les +c aretes deja creees, mais seulement parmi celles qui partent +c du sommet en cours. la premiere d'entre elles, si elle +c existe, est numerotee nuar=preare(sommet). Ce sont les +c dernieres aretes qui viennent d'etre creees, donc la +c recherche est rapide car elle ne porte que sur quelques +c aretes : au pire toutes celles partant du sommet en cours. +c . si la seconde extremite a un numero global egal a celui +c du sommet en cours d'examen, c'est qu'il y a un probleme +c dans le maillage de depart. +c . si la seconde extremite a un numero global plus petit que +c le sommet en cours d'examen, rien n'est a faire, car le +c traitement a deja ete fait lors de l'exploration de mglo. +c + if ( sommet.lt.mglo ) then +c +c 2.3.1.1. ==> recherche d'une eventuelle arete qui aurait deja ete +c creee entre sommet et mglo +c + larete = 0 + nuar = preare(sommet) + if ( nuar.ne.0 ) then + do 2231 , ar = nuar , nbarto + if ( somare(2,ar).eq.mglo ) then + larete = ar + goto 2232 + endif + 2231 continue + endif + 2232 continue +c +c 2.3.1.2. ==> Lorsque l'arete n'a pas ete trouvee, il faut la creer ; +c . elle est definie par ses deux extremites ; +c . on memorise le noeud milieu si on est en degre 2 ; +c . si l'arete n'est pas un element au sens du code de +c calcul, la caracteristique est nulle et il n'y a pas +c de probleme pour la renumerotation. +c Si aucune arete ne partait deja du sommet, on la +c memorise dans preare +c remarque : il ne faut pas oublier de tenir compte d'une +c eventuelle renumerotation des noeuds ; c'est fait +c auparavant pour les deux extremites, sommet et mglo, et +c il faut le faire pour le milieu eventuel. +c + if ( larete.eq.0 ) then + nbarto = nbarto + 1 + if ( nbarto.gt.nbar00 ) then + nbarto = - nbarto + goto 29 + endif + larete = nbarto + somare(1,larete) = sommet + somare(2,larete) = mglo +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(*,*) '... Creation de l''arete de ', sommet,' a ',mglo + write(*,*) '... Elle a pour numero',larete + endif +#endif + if ( degre.eq.2 ) then + milieu = nnosho(noeele(elem,dearef(typhom,aloc,3))) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(*,*) '... Noeud milieu',milieu + endif +#endif + np2are(larete) = milieu + arenoe(milieu) = larete + endif + if ( typhom.ne.tyhse1 .and. typhom.ne.tyhse2 ) then + coexar(larete,cofamd) = 0 + coexar(larete,cotyel) = 0 + if ( rbar00.ne.0 ) then + narsca(larete) = 0 + endif + endif + if ( preare(sommet).eq.0 ) then + preare(sommet) = larete + endif + endif +c +c 2.3.1.3. ==> si l'arete est un element au sens du calcul, il faut +c se souvenir de son type (linear beam, tapered beam, ...) +c et de sa famille MED. +c attention : il faut se poser la question a chaque fois, +c car l'arete a pu etre definie auparavant comme un cote +c de face et donc aura ete mise avec des caracteristiques +c nulles. +c en revanche, si on y est deja passe pour un autre +c element, il y a malaise : c'est un element double ! +c + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +c + if ( dejavu(larete).ne.0 .and. + > dejavu(larete).ne.elem ) then +c + write(ulsort,texte(langue,4)) + write(ulsort,texte(langue,5)) elem + write(ulsort,texte(langue,6)) fameel(elem), + > typele(elem) + write(ulsort,texte(langue,7)) + > (noeele(elem,n),n=1,nbnd) + write(ulsort,texte(langue,8)) + > (nnosho(noeele(elem,n)),n=1,nbnd) + write(ulsort,texte(langue,5)) dejavu(larete) + write(ulsort,texte(langue,6)) fameel(dejavu(larete)), + > typele(dejavu(larete)) + write(ulsort,texte(langue,8)) + > (noeele(dejavu(larete),n),n=1,nbnd) + write(ulsort,texte(langue,7)) + > (nnosho(noeele(dejavu(larete),n)),n=1,nbnd) + codret = 2313 +c + else +c + coexar(larete,cofamd) = fameel(elem) + coexar(larete,cotyel) = typele(elem) + narsho(elem) = larete + narsca(larete) = elem + dejavu(larete) = elem +c + endif +c + endif +c +c 2.3.1.4. ==> on stocke le numero de l'arete dans la connectivite +c descendante de l'element +c +ccc write(*,*) 'elem =',elem,', aloc =',aloc,', larete =',larete + areele(elem,aloc) = larete +c +c 2.3.2. ==> probleme car le noeud apparait plusieurs fois +c + elseif ( sommet.eq.mglo ) then +c + write (ulsort,90002) mess14(langue,2,13), elem + write(ulsort,texte(langue,9)) sommet + write(ulsort,texte(langue,7)) (noeele(elem,n),n=1,nbnd) + write(ulsort,texte(langue,7)) + > (nnosho(noeele(elem,n)),n=1,nbnd) + write(ulsort,*) ' ' + codret = 232 + goto 22 +c + endif +c + 223 continue +c + 22 continue +c + 21 continue +c + 29 continue +c +c==== +c 3. consequences +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. consequences ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto +#endif +c +c 3.1. ==> initialisations : +c +c . on suppose que l'on part d'un macro-maillage +c . la premiere caracteristique a ete initialisee, les autres sont +c initialisees a 0 +c . l'etat vaut 0 +c . il n'y a ni fille, ni mere +c + nbarac = nbarto + nbarma = nbarto + nbarpe = nbarto + nbarde = 0 + nbart2 = 0 + nbarq2 = 0 + nbarq3 = 0 + nbarq5 = 0 + nbarin = 0 +c + do 32 , larete = 1 , nbarto + hetare(larete) = 0 + filare(larete) = 0 + merare(larete) = 0 + 32 continue +c +c 3.2. ==> nombres propres a la renumerotation des aretes +c + if ( rbar00 .ne. 0 ) then + rsarto = nbarto + else + rsarto = 0 + endif +c + endif +c +c==== +c 4. Quand des elements sont ignores : +c informations supplementaires sur les aretes +c 2 : ses deux sommets appartiennent a un element ignore +c -1 : son 1er sommet appartient a un element ignore +c le 2nd appartient exclusivement a un element soumis +c a adaptation +c -2 : son 2nd sommet appartient a un element ignore +c le 1er appartient exclusivement a un element soumis +c a adaptation +c 0 : ses deux sommets appartiennent exclusivement a un +c element soumis a l'adaptation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. ignores ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbelig.ne.0 ) then +c + do 41 , larete = 1 , nbarto +c + if ( trav2a(nnosca(somare(1,larete))).eq.1 ) then + if ( trav2a(nnosca(somare(2,larete))).eq.1 ) then + insoar(larete) = 2 + else + insoar(larete) = -1 + endif + elseif ( trav2a(nnosca(somare(2,larete))).eq.1 ) then + insoar(larete) = -2 + else + insoar(larete) = 0 + endif +cgn print 1789,larete,nnosca(somare(1,larete)), +cgn > nnosca(somare(2,larete)),insoar(larete) +cgn 1789 format(4i5) +c + 41 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( nbarto.lt.0 ) then + write (ulsort,texte(langue,11)) nbar00 + write (ulsort,texte(langue,12)) + endif +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme21.F b/src/tool/AV_Conversion/vcme21.F new file mode 100644 index 00000000..b1975505 --- /dev/null +++ b/src/tool/AV_Conversion/vcme21.F @@ -0,0 +1,290 @@ + subroutine vcme21 ( typenh, cofxeo, + > nbinfx, nctfen, nbenti, + > notfen, nofaen, cofaen, + > nhenfa, fament, posent, inxent, + > nbfaen, pcfaen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 21 +c - - - - -- +c Determine les familles pour un type de mailles de la face avant +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . cofxeo . e . 1 . orientation de l'entite comme face/volume . +c . nbinfx . e . 1 . nombre d'informations pour inxent . +c . nctfen . e . 1 . nombre de caracteristique des f. entite . +c . nbenti . e . 1 . nombre d'entites . +c . notfen . e . 1 . nombre d'origine des carac. des f. entite . +c . nofaen . e . 1 . nombre d'origine de familles de l'entite . +c . cofaen . e . notfen*. codes d'origine des familles de l'entite . +c . . . nofaen . . +c . nhenfa . e . char8 . objet decrivant les familles de l'entite . +c . fament . es . nbenti . famille des entites . +c . posent . e . nbenti . position des entites . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : perpendiculaire . +c . inxent . e . nbinfx*. informations pour l'extrusion des entites . +c . . . nbenti . 1 : famille de l'entite extrudee . +c . . . . 2 : famille de l'entite perpendiculaire . +c . . . . Si arete : . +c . . . . 3 : code du quadrangle dans le volume . +c . . . . 4 : quadrangle perpendiculaire . +c . . . . Si triangle ou quadrangle : . +c . . . . 3 : code de la face dans le volume . +c . nbfaen . s . 1 . nombre de familles de l'entite . +c . pcfaen . s . 1 . codes des familles de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME21' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer cofxeo + integer nbinfx, nctfen, nbenti + integer notfen, nofaen, cofaen(notfen,nofaen) + integer nbfaen, pcfaen +c + integer fament(nbenti), posent(nbenti), inxent(nbinfx,nbenti) +c + character*8 nhenfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer nbfae0 + integer nument +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'nbenti', nbenti + write (ulsort,90002) 'cofxeo', cofxeo + write (ulsort,90002) 'nbinfx', nbinfx + write (ulsort,90002) 'nctfen', nctfen +#endif +c +#ifdef _DEBUG_HOMARD_ + do 4991 , nument = 1 , nbenti + if ( posent(nument).eq.0 .or. typenh.eq.4 ) then + write(ulsort,90012) mess14(langue,3,typenh),nument, + > fament(nument),(inxent(iaux,nument),iaux=1,nbinfx) + endif + 4991 continue +#endif +c + codret = 0 +c +c==== +c 2. Menage initial +c==== +c + call gmlboj ( nhenfa//'.Codes' , codre0 ) + codret = max ( abs(codre0), codret ) +c +c==== +c 3. Parcours des entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 3.1. ==> Taille initiale du tableau +c + nbfae0 = 0 + nbfaen = 0 + nument = 0 +c +c 3.2. ==> Creation/Allongement du tableau des familles +c Au moins 6 pour passer la phase initiale +c + 32 continue +c + if ( codret.eq.0 ) then +c + nbfae0 = nbfae0 + 21 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfaen', nbfaen + write (ulsort,90002) 'nbfae0', nbfae0 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( typenh, nhenfa, nctfen, nbfae0, + > pcfaen, + > ulsort, langue, codret) +#ifdef _DEBUG_HOMARD_ + if ( typenh.eq.1 ) then + call gmprsx ( mess14(langue,3,typenh), nhenfa//'.Codes') + endif +#endif +c + endif +c +c 3.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME22', nompro +#endif + call vcme22 ( typenh, nument, cofxeo, + > nbinfx, nctfen, nbenti, + > notfen, nofaen, cofaen, + > nbfae0, nbfaen, imem(pcfaen), + > fament, posent, inxent, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbfaen.lt.0 ) then +c + nbfaen = -nbfaen + goto 32 +c + endif +c + endif +c +c==== +c 4. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Redimensionnement ; codret', codret + write (ulsort,90002) 'nbfaen', nbfaen + write (ulsort,90002) 'nbfae0', nbfae0 +#endif +#ifdef _DEBUG_HOMARD_ + if ( typenh.eq.1 ) then + call gmprsx ( mess14(langue,3,typenh), nhenfa//'.Codes') + endif +#endif +c + if ( nbfaen.ne.nbfae0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( typenh, nhenfa, nctfen, nbfaen, + > pcfaen, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( typenh.eq.1 ) then + call gmprsx ( mess14(langue,3,typenh), nhenfa//'.Codes') + endif +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme22.F b/src/tool/AV_Conversion/vcme22.F new file mode 100644 index 00000000..6b1c4165 --- /dev/null +++ b/src/tool/AV_Conversion/vcme22.F @@ -0,0 +1,429 @@ + subroutine vcme22 ( typenh, nument, cofxeo, + > nbinfx, nctfen, nbenti, + > notfen, nofaen, cofaen, + > nbfae0, nbfaen, cfaent, + > fament, posent, inxent, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 22 +c - - - - -- +c Determine les familles pour un type de mailles de la face avant +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nument . es . 1 . numero de la derniere entite traitee . +c . cofxeo . e . 1 . orientation de l'entite comme face/volume . +c . nbinfx . e . 1 . nombre d'informations pour inxent . +c . nctfen . e . 1 . nombre de caracteristique des f. entite . +c . nbenti . e . 1 . nombre d'entites . +c . notfen . e . 1 . nombre d'origine des carac. des f. entite . +c . nofaen . e . 1 . nombre d'origine de familles de l'entite . +c . cofaen . e . notfen*. codes d'origine des familles de l'entite . +c . . . nofaen . . +c . fament . e . nbenti . famille des entites . +c . posent . e . nbenti . position des entites . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : perpendiculaire . +c . inxent . e . nbinfx*. informations pour l'extrusion des entites . +c . . . nbenti . 1 : famille de l'entite extrudee . +c . . . . 2 : famille de l'entite perpendiculaire . +c . . . . Si triangle ou quadrangle : . +c . . . . 3 : code de la face dans le volume . +c . nbfae0 . e . 1 . nombre de familles pour le dimensionnement . +c . nbfaen . es . 1 . nombre de familles enregistrees . +c . cfaent . es . nctfen*. codes des familles d'entites . +c . . . nbfaen . 1 : famille MED . +c . . . . si maille-point : . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . si arete : . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si triangle : . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . . . . si quadrangle : . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si extrusion et noeud/arete/tria/quad : . +c . . . . n+1 : famille de l'entite extrudee . +c . . . . n+2 : famille de l'entite perpendiculaire . +c . . . . si extrusion et triangle ou quadrangle : . +c . . . . n+3 : code de la face dans le volume . +c . . . . si extrusion : . +c . . . . n+3/4 : position de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME22' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofexq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, nument + integer cofxeo + integer nbinfx, nctfen, nbenti + integer notfen, nofaen, cofaen(notfen,nofaen) + integer nbfae0, nbfaen, cfaent(nctfen,nbfae0) +c + integer fament(nbenti), posent(nbenti), inxent(nbinfx,nbenti) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lentit, entdeb + integer caract(100) + integer nufaex + integer posmax +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'nument', nument + write (ulsort,90002) 'nbinfx', nbinfx + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbenti', nbenti + write (ulsort,90002) 'notfen', notfen + write (ulsort,90002) 'nofaen', nofaen + write (ulsort,90002) 'nbfae0', nbfae0 + write (ulsort,90002) 'nbfaen', nbfaen +#endif +c +#ifdef _DEBUG_HOMARD_ +49900 format(33x,a) + write (ulsort,*) + > 'Informations d''extrusion des ', mess14(langue,3,typenh) + if ( typenh.eq.-1 ) then + write(ulsort,49900) ' famille fa noe ex fa arete' + elseif ( typenh.eq.1 ) then + write(ulsort,49900) + > ' famille fa are ex fa quad code q/vo face perp' + elseif ( typenh.eq.2 ) then + write(ulsort,49900) 'famille fa tri ex fa pent code t/pe' + else + write(ulsort,49900) + > 'famille position fa qua ex fa hexa code q/vo' + endif + do 4991 , lentit = 1 , nbenti + if ( posent(lentit).eq.0 ) then + write(ulsort,90012) + > mess14(langue,2,typenh),lentit,fament(lentit), + > (inxent(jaux,lentit),jaux=1,nbinfx) + endif + 4991 continue + write (ulsort,*) 'Codes des familles d''origine des ', + > mess14(langue,3,typenh) + do 5991 , iaux = 1 , nofaen + write(ulsort,90012) 'Famille origine', iaux, + > (cofaen(jaux,iaux),jaux=1,notfen) + 5991 continue +#endif +c + codret = 0 +c +c==== +c 2. Creation des premieres familles, libres +c Dans l'ordre : famille a l'avant, a l'arriere, perpendiculaire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. famille libre ; codret', codret +#endif +c + if ( nbfaen.eq.0 ) then +c + if ( typenh.eq.-1 .or. typenh.eq.2 ) then + kaux = 2 + else + kaux = 3 + endif +c + do 21 , iaux = 1 , kaux +c +c 2.1. ==> La famille libre de base +c + nbfaen = nbfaen + 1 + do 211 , jaux = 1 , notfen + cfaent(jaux,nbfaen) = cofaen(jaux,1) + 211 continue +c + if ( iaux.eq.1 ) then + do 2121 , jaux = notfen+1 , nctfen-1 + cfaent(jaux,nbfaen) = 1 + 2121 continue + else + do 2122 , jaux = notfen+1 , nctfen-1 + cfaent(jaux,nbfaen) = 0 + 2122 continue + endif +c +c Pour les faces, on met un code 1 pour la relation +c avec les volumes + if ( typenh.ge.2 ) then + cfaent(cofxeo,nbfaen) = 1 + endif +c +c Pour les quadrangles, on met un code 1 pour la 1ere +c composante de la normale + if ( typenh.ge.4 ) then + cfaent(cofxqt,nbfaen) = 1 + endif +c +c Position + cfaent(nctfen,nbfaen) = iaux-1 +cgn write (ulsort,90002) '.. Creation de la famille libre', nbfaen +cgn write (ulsort,90005) '.. avec', +cgn > (cfaent(jaux,nbfaen),jaux=1,nctfen) +c + 21 continue +c + endif +c +c==== +c 3. Parcours des entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c + if ( typenh.le.1 ) then + posmax = 0 + elseif ( typenh.eq.2 ) then + posmax = 1 + else + posmax = 2 + endif +cgn write (ulsort,90002) 'posmax', posmax +c + entdeb = nument + 1 + do 30 , lentit = entdeb, nbenti +c + if ( posent(lentit).le.posmax ) then +cgn write (ulsort,90012) '. Famille du '//mess14(langue,1,typenh), +cgn > lentit, fament(lentit) +cgn write (ulsort,90002) '.. position', posent(lentit) +c +c 3.1. ==> Les caracteristiques de l'entite courante +c 3.1.1. ==> On commence par les caracteristiques d'origine +c de la famille de l'entite courante +c + do 311 , iaux = 1 , notfen + caract(iaux) = cofaen(iaux,fament(lentit)) + 311 continue +c +c 3.1.2. ==> On complete par les proprietes de l'extrusion +c Remarque : dans le cas des aretes, la derniere information, +c code de la face perpendiculaire dans le volume, +c est ecrasee par la position. Elle sera utilisee +c plus tard +c + do 312 , iaux = 1 , nbinfx + caract(notfen+iaux) = inxent(iaux,lentit) + 312 continue +c +c 3.1.3. ==> Position de l'entite +c + caract(nctfen) = posent(lentit) +cgn write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctfen) +c +c 3.2. ==> Recherche d'une situation analogue +c + do 32 , iaux = 1 , nbfaen +c + do 321 , jaux = 1 , nctfen + if ( cfaent(jaux,iaux).ne.caract(jaux) ) then + goto 32 + endif + 321 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 34 +c + 32 continue +c +c 3.3. ==> Creation d'une nouvelle famille +c 3.3.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfaen.ge.nbfae0-1 ) then +c + nument = lentit - 1 + nbfaen = -nbfaen + goto 3999 +c +c 3.3.2. ==> Creation +c + else +c +c 3.3.2.1. ==> La famille avec les memes caracteristiques +c + nbfaen = nbfaen + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfaen +cgn write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfen) + do 3321 , iaux = 1 , nctfen + cfaent(iaux,nbfaen) = caract(iaux) + 3321 continue + nufaex = nbfaen +c +c 3.3.2.2. ==> Pour les aretes, la famille avec l'orientation inverse +c + if ( typenh.eq.1 ) then +c + if ( cfaent(coorfa,nbfaen).ne.0 ) then +c + nbfaen = nbfaen + 1 +cgn write (ulsort,90015) '.. Creation de la famille', nbfaen, +cgn > ' d''orientation opposee' + do 3322 , iaux = 1 , nctfen + cfaent(iaux,nbfaen) = caract(iaux) + 3322 continue + cfaent(coorfa,nbfaen) = -cfaent(coorfa,nbfaen-1) + cfaent(cofifa,nbfaen ) = nbfaen-1 + cfaent(cofifa,nbfaen-1) = nbfaen +c + else +c + cfaent(cofifa,nbfaen) = nbfaen +c + endif +c + endif +c + endif +c +c 3.4. ==> Enregistrement de la nouvelle famille pour l'entite +c + 34 continue +c + fament(lentit) = nufaex +c + endif +c + 30 continue +c + 3999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfaen', nbfaen + if ( typenh.eq.4 ) then + write (ulsort,*) '... Codes des familles des ', + > mess14(langue,3,typenh) + do 5992 , iaux = 1 , abs(nbfaen) + write(ulsort,90022) 'Famille', iaux, + > (cfaent(jaux,iaux),jaux=1,nctfen) + 5992 continue + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme23.F b/src/tool/AV_Conversion/vcme23.F new file mode 100644 index 00000000..d495af3a --- /dev/null +++ b/src/tool/AV_Conversion/vcme23.F @@ -0,0 +1,209 @@ + subroutine vcme23 ( nhpefa, + > pcfaqu, + > pcfahe, + > pcfape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 23 +c - - - - -- +c Determine les familles pour la relation hexaedres/pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhpefa . e . char8 . objet decrivant les familles de pentaedres . +c . pcfaqu . es . 1 . codes des familles des quadrangles . +c . pcfahe . es . 1 . codes des familles des hexaedres . +c . pcfape . s . 1 . codes des familles de pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME23' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer pcfaqu + integer pcfahe + integer pcfape +c + character*8 nhpefa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbfpe0 + integer numfam +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c. Parcours des familles initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 2.1. ==> Taille initiale du tableau +c + nbfpe0 = nbfpen + numfam = 0 +c +c 2.2. ==> Allongement de la taille du tableau des familles +c des pentaedres +c + 22 continue +c + if ( codret.eq.0 ) then +c + nbfpe0 = nbfpe0 + 23 +c + iaux = 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nhpefa, nctfpe, nbfpe0, + > pcfape, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME24', nompro +#endif + call vcme24 ( numfam, + > nbfpe0, + > imem(pcfaqu), + > imem(pcfahe), + > imem(pcfape), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbfpen.lt.0 ) then +c + nbfpen = -nbfpen + goto 22 +c + endif +c + endif +c +c==== +c 3. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Redimensionnement ; codret', codret + write (ulsort,90002) 'nbfpen', nbfpen + write (ulsort,90002) 'nbfpe0', nbfpe0 +#endif +c + if ( nbfpen.ne.nbfpe0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nhpefa, nctfpe, nbfpen, + > pcfape, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme24.F b/src/tool/AV_Conversion/vcme24.F new file mode 100644 index 00000000..0e7845d8 --- /dev/null +++ b/src/tool/AV_Conversion/vcme24.F @@ -0,0 +1,273 @@ + subroutine vcme24 ( numfam, + > nbfpe0, + > cfaqua, + > cfahex, + > cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 24 +c - - - - -- +c Determine les familles pour la relation hexaedres/pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfam . es . 1 . numero de la derniere famille traitee . +c . nbfpe0 . e . 1 . nombre de familles pour le dimensionnement . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . cfahex . es . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . si extrusion : . +c . . . . 3 : famille des pentaedres de conformite . +c . cfapen . es . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME24' ) +c +#include "nblang.h" +#include "consts.h" +#include "cofaar.h" +#include "coftex.h" +#include "cofexq.h" +#include "cofexh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "meddc0.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer numfam + integer nbfpe0 + integer cfaqua(nctfqu,nbfqua) + integer cfahex(nctfhe,nbfhex) + integer cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lafami, famdeb + integer fahohe, fammed + integer nufaex +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numfam', numfam + write (ulsort,90002) 'nbfpe0', nbfpe0 + write (ulsort,90002) 'nbfqua', nbfqua + write (ulsort,90002) 'nctfqu', nctfqu +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Codes des familles des quadrangles' + do 5991 , iaux = 1 , nbfqua + write(ulsort,90012) 'Famille', iaux, + > (cfaqua(jaux,iaux),jaux=1,nctfqu) + 5991 continue + write (ulsort,*) 'Codes des familles des hexaedres' + do 5992 , iaux = 1 , nbfhex + write(ulsort,90012) 'Famille', iaux, + > (cfahex(jaux,iaux),jaux=1,nctfhe) + 5992 continue + write (ulsort,*) 'Codes des familles des pentaedres' + do 5993 , iaux = 1 , nbfpen + write(ulsort,90012) 'Famille', iaux, + > (cfapen(jaux,iaux),jaux=1,nctfpe) +#endif + 5993 continue +c + codret = 0 +c +c==== +c 2. Parcours des familles de la face avant des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours ; codret', codret +#endif +c + famdeb = numfam + 1 + do 20 , lafami = famdeb, nbfqua +c + if ( cfaqua(cofxqp,lafami).eq.0 ) then +cgn write (ulsort,90002) '. Famille de quadrangle', lafami +c +c 2.1. ==> La famille du volume d'extrusion +c + fahohe = cfaqua(cofxqx,lafami) + fammed = cfahex(cofamd,fahohe) +cgn write (ulsort,90002) '.. Familles HOMARD/MED hexa',fahohe,fammed +c +c 2.1.2. ==> On veut une famille de pentaedre avec la meme famille MED +c + do 212 , iaux = 1 , nbfpen +c + do 2121 , jaux = 1 , nctfpe + if ( cfapen(cofamd,iaux).ne.fammed ) then + goto 212 + endif + 2121 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 23 +c + 212 continue +c +c 2.2. ==> Creation d'une nouvelle famille +c 2.2.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfpen.ge.nbfpe0 ) then +c + numfam = lafami - 1 + nbfpen = -nbfpen + goto 2999 +c +c 2.2.2. ==> Creation +c + else +c +c 2.2.2.1. ==> La famille avec les memes caracteristiques +c + nbfpen = nbfpen + 1 + do 222 , iaux = 1 , nctfpe + cfapen(iaux,nbfpen) = 0 + 222 continue +cgn write (ulsort,90002) '.. Creation de la famille', nbfpen + cfapen(cofamd,nbfpen) = fammed + if ( cfahex(cotyel,fahohe).eq.edhex8 ) then + cfapen(cotyel,nbfpen) = edpen6 + else + cfapen(cotyel,nbfpen) = edpe15 + endif + nufaex = nbfpen +c + endif +c +c 2.3. ==> Enregistrement de la famille de pentaedres associee a +c la famille des hexaedres +c + 23 continue +c + cfahex(cofexh,fahohe) = nufaex +c + endif +c + 20 continue +c + 2999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfhex', nbfhex + write (ulsort,*) 'Codes des familles des hexaedres' + do 6991 , iaux = 1 , abs(nbfhex) + write(ulsort,90012) 'Famille', iaux, + > (cfahex(jaux,iaux),jaux=1,nctfhe) + 6991 continue + write (ulsort,90002) 'A la sortie de '//nompro//', nbfpen', nbfpen + write (ulsort,*) 'Codes des familles des pentaedres' + do 6992 , iaux = 1 , abs(nbfpen) + write(ulsort,90012) 'Famille', iaux, + > (cfapen(jaux,iaux),jaux=1,nctfpe) + 6992 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme25.F b/src/tool/AV_Conversion/vcme25.F new file mode 100644 index 00000000..0148a2ac --- /dev/null +++ b/src/tool/AV_Conversion/vcme25.F @@ -0,0 +1,236 @@ + subroutine vcme25 ( typenh, + > nctfen, ncffen, cofxet, cofxep, + > notfen, nofaen, cofaen, + > nhenfa, + > nbfaen, pcfaen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 25 +c - - - - -- +c Determine les familles pour le lien face avant / face arriere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nctfen . e . 1 . nombre de caracteristique des f. entite . +c . ncffen . e . 1 . nombre de caracteristique figees entite . +c . cofxet . e . 1 . code de la famille de l'entite translatee . +c . cofxep . e . 1 . code de la position de l'entite . +c . nbenti . e . 1 . nombre d'entites . +c . notfen . e . 1 . nombre d'origine des carac. des f. entite . +c . nofaen . e . 1 . nombre d'origine de familles de l'entite . +c . cofaen . e . notfen*. codes d'origine des familles de l'entite . +c . . . nofaen . . +c . nhenfa . e . char8 . objet decrivant les familles de l'entite . +c . nbfaen . s . 1 . nombre de familles de l'entite . +c . pcfaen . s . 1 . codes des familles de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME25' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nctfen, ncffen, cofxet, cofxep + integer notfen, nofaen, cofaen(notfen,nofaen) + integer nbfaen, pcfaen +c + character*8 nhenfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbfae0 + integer numfam +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'nctfen', nctfen +#endif +c + codret = 0 +c +c==== +c. Parcours des familles initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 2.1. ==> Taille initiale du tableau +c + nbfae0 = nbfaen + numfam = 0 +c +c 2.2. ==> Allongement de la taille du tableau des familles +c + 22 continue +c + if ( codret.eq.0 ) then +c + nbfae0 = nbfae0 + 25 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( typenh, nhenfa, nctfen, nbfae0, + > pcfaen, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME26', nompro +#endif + call vcme26 ( typenh, numfam, + > nctfen, ncffen, cofxet, cofxep, + > notfen, nofaen, cofaen, + > nbfae0, nbfaen, imem(pcfaen), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbfaen.lt.0 ) then +c + nbfaen = -nbfaen + goto 22 +c + endif +c + endif +c +c==== +c 3. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Redimensionnement ; codret', codret + write (ulsort,90002) 'nbfaen', nbfaen + write (ulsort,90002) 'nbfae0', nbfae0 +#endif +c + if ( nbfaen.ne.nbfae0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( typenh, nhenfa, nctfen, nbfaen, + > pcfaen, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( mess14(langue,3,typenh), nhenfa//'.Codes') +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme26.F b/src/tool/AV_Conversion/vcme26.F new file mode 100644 index 00000000..73a97e19 --- /dev/null +++ b/src/tool/AV_Conversion/vcme26.F @@ -0,0 +1,354 @@ + subroutine vcme26 ( typenh, numfam, + > nctfen, ncffen, cofxet, cofxep, + > notfen, nofaen, cofaen, + > nbfae0, nbfaen, cfaent, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 26 +c - - - - -- +c Determine les familles pour le lien face avant / face arriere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . numfam . es . 1 . numero de la derniere famille traitee . +c . nctfen . e . 1 . nombre de caracteristique des f. entite . +c . ncffen . e . 1 . nombre de caracteristique figees entite . +c . cofxet . e . 1 . code de la famille de l'entite translatee . +c . cofxep . e . 1 . code de la position de l'entite . +c . notfen . e . 1 . nombre d'origine des carac. des f. entite . +c . nofaen . e . 1 . nombre d'origine de familles de l'entite . +c . cofaen . e . notfen*. codes d'origine des familles de l'entite . +c . . . nofaen . . +c . nbfae0 . e . 1 . nombre de familles pour le dimensionnement . +c . nbfaen . es . 1 . nombre de familles enregistrees . +c . cfaent . es . nctfen*. codes des familles d'entites . +c . . . nbfaen . 1 : famille MED . +c . . . . si maille-point : . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . si arete : . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si triangle : . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . . . . si quadrangle : . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si extrusion et noeud/arete/tria/quad : . +c . . . . n+1 : famille du noeud extrude . +c . . . . n+2 : famille de l'entite perpendiculaire . +c . . . . si extrusion et triangle ou quadrangle : . +c . . . . n+3 : code de la face dans le volume . +c . . . . si extrusion : . +c . . . . n+3/4 : position de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME26' ) +c +#include "nblang.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, numfam + integer nctfen, ncffen, cofxet, cofxep + integer notfen, nofaen, cofaen(notfen,nofaen) + integer nbfae0, nbfaen, cfaent(nctfen,nbfae0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lafami, famdeb + integer caract(100) + integer nufaex +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'numfam', numfam + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'ncffen', ncffen + write (ulsort,90002) 'cofxet', cofxet + write (ulsort,90002) 'cofxep', cofxep + write (ulsort,90002) 'notfen', notfen + write (ulsort,90002) 'nofaen', nofaen + write (ulsort,90002) 'nbfae0', nbfae0 + write (ulsort,90002) 'nbfaen', nbfaen +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A l''entree de '//nompro//', nbfaen', nbfaen + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,typenh) + do 5991 , iaux = 1 , nofaen + write(ulsort,90022) 'Famille originale 3D', iaux, + > (cofaen(jaux,iaux),jaux=1,notfen) + 5991 continue + do 5992 , iaux = 1 , nbfaen + write(ulsort,90022) 'Famille', iaux, + > (cfaent(jaux,iaux),jaux=1,nctfen) + 5992 continue +#endif +c + codret = 0 +c +c==== +c 2. Parcours des familles de la face avant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours ; codret', codret +#endif +c + famdeb = numfam + 1 + do 20 , lafami = famdeb, nbfaen +c + if ( cfaent(cofxep,lafami).eq.0 ) then +cgn write (ulsort,90012) '. Famille de '//mess14(langue,1,typenh), +cgn > lafami +c +c 2.1. ==> On veut une famille : +c . qui a les caracteristiques de celle du maillage 3D +c . les valeurs pour l'extrusion sont nulles +c . la position doit etre arriere +c +c 2.1.1. ==> Rien a priori +c + do 211 , iaux = 1 , nctfen + caract(iaux) = 0 + 211 continue +c +c 2.1.2. ==> Les caracteristiques d'origine de la famille +c + jaux = cfaent(cofxet,lafami) + do 212 , iaux = 1 , notfen + caract(iaux) = cofaen(iaux,jaux) + 212 continue +c +c 2.1.3. ==> L'entite est a l'arriere +c + caract(cofxep) = 1 +cgn write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctfen) +c +c 2.2. ==> Recherche d'une situation analogue dans les familles +c Remarque : on ne tient pas compte des codes lies a +c l'extrusion car ils ne serviront jamais pour des +c entites placees sur la face arriere +c 2.2.1. ==> Pour une arete, sans tenir compte de l'orientation +c + if ( typenh.eq.1 ) then +c + do 221 , iaux = 1 , nbfaen +c + do 2211 , jaux = 1 , ncffen + if ( jaux.ne.cofifa ) then + if ( cfaent(jaux,iaux).ne.caract(jaux) ) then + goto 221 + endif + endif + 2211 continue +c + nufaex = iaux + goto 24 +c + 221 continue +c +c 2.2.2. ==> Autre entite +c + else +c + do 222 , iaux = 1 , nbfaen +c + do 2221 , jaux = 1 , ncffen + if ( cfaent(jaux,iaux).ne.caract(jaux) ) then + goto 222 + endif + 2221 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 24 +c + 222 continue +c + endif +c +c 2.3. ==> Creation d'une nouvelle famille +c 2.3.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfaen.ge.nbfae0-1 ) then +c + numfam = lafami - 1 + nbfaen = -nbfaen + goto 2999 +c +c 2.3.2. ==> Creation +c + else +c +c 2.3.2.1. ==> La famille avec les memes caracteristiques +c + nbfaen = nbfaen + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfaen +cgn write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfen) + do 2321 , iaux = 1 , nctfen + cfaent(iaux,nbfaen) = caract(iaux) + 2321 continue + nufaex = nbfaen +c +c 2.3.2.2. ==> Pour les aretes, la famille avec l'orientation inverse +c + if ( typenh.eq.1 ) then +c + if ( cfaent(coorfa,nbfaen).ne.0 ) then +c + nbfaen = nbfaen + 1 +cgn write (ulsort,90015) '.. Creation de la famille', nbfaen, +cgn > ' d''orientation opposee' + do 2322 , iaux = 1 , nctfen + cfaent(iaux,nbfaen) = caract(iaux) + 2322 continue + cfaent(coorfa,nbfaen) = -cfaent(coorfa,nbfaen-1) + cfaent(cofifa,nbfaen ) = nbfaen-1 + cfaent(cofifa,nbfaen-1) = nbfaen +c + else +c + cfaent(cofifa,nbfaen) = nbfaen +c + endif +c + endif +c + endif +c +c 2.4. ==> Enregistrement de la nouvelle famille pour la famille +c + 24 continue +c + cfaent(cofxet,lafami) = nufaex +c + endif +c + 20 continue +c + 2999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfaen', nbfaen + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,typenh) + do 6992 , iaux = 1 , abs(nbfaen) + write(ulsort,90022) 'Famille', iaux, + > (cfaent(jaux,iaux),jaux=1,nctfen) + 6992 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme27.F b/src/tool/AV_Conversion/vcme27.F new file mode 100644 index 00000000..bec59d82 --- /dev/null +++ b/src/tool/AV_Conversion/vcme27.F @@ -0,0 +1,215 @@ + subroutine vcme27 ( notftr, nofatr, cofatr, + > nhtrfa, + > pcfatr, + > pcfaqu, + > pcfahe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 27 +c - - - - -- +c Determine les familles pour la relation quadrangles/triangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . notftr . e . 1 . nombre d'origine des carac. des triangles . +c . nofatr . e . 1 . nombre d'origine de familles de triangles . +c . cofatr . e . notftr*. codes d'origine des familles des triangles . +c . . . nofatr . . +c . nhtrfa . e . char8 . objet decrivant les familles de triangles . +c . pcfatr . es . 1 . codes des familles des triangles . +c . pcfaqu . es . 1 . codes des familles des quadrangles . +c . pcfahe . e . 1 . codes des familles des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME27' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer notftr, nofatr, cofatr(notftr,nofatr) + integer pcfatr + integer pcfaqu + integer pcfahe +c + character*8 nhtrfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbftr0 + integer numfam +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c. Parcours des familles initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 2.1. ==> Taille initiale du tableau +c + nbftr0 = nbftri + numfam = 0 +c +c 2.2. ==> Allongement de la taille du tableau des familles de triangles +c + 22 continue +c + if ( codret.eq.0 ) then +c + nbftr0 = nbftr0 + 27 +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nhtrfa, nctftr, nbftr0, + > pcfatr, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME28', nompro +#endif + call vcme28 ( numfam, + > nbftr0, + > notftr, nofatr, cofatr, + > imem(pcfatr), + > imem(pcfaqu), + > imem(pcfahe), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbftri.lt.0 ) then +c + nbftri = -nbftri + goto 22 +c + endif +c + endif +c +c==== +c 3. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Redimensionnement ; codret', codret + write (ulsort,90002) 'nbftri', nbftri + write (ulsort,90002) 'nbftr0', nbftr0 +#endif +c + if ( nbftri.ne.nbftr0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nhtrfa, nctftr, nbftri, + > pcfatr, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme28.F b/src/tool/AV_Conversion/vcme28.F new file mode 100644 index 00000000..1ca39252 --- /dev/null +++ b/src/tool/AV_Conversion/vcme28.F @@ -0,0 +1,363 @@ + subroutine vcme28 ( numfam, + > nbftr0, + > notftr, nofatr, cofatr, + > cfatri, + > cfaqua, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 28 +c - - - - -- +c Determine les familles pour le decoupage des quadrangles en triangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfam . es . 1 . numero de la derniere famille traitee . +c . nbftr0 . e . 1 . nombre de familles pour le dimensionnement . +c . notftr . e . 1 . nombre d'origine des carac. des triangles . +c . nofatr . e . 1 . nombre d'origine de familles de triangles . +c . cofatr . e . notftr*. codes d'origine des familles des triangles . +c . . . nofatr . . +c . cfatri . es . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . si extrusion : . +c . . . . 5 : famille du triangle extrude . +c . . . . 6 : famille du pent. perpendiculaire . +c . . . . 7 : code du triangle dans le pentaedre . +c . . . . 8 : position du triangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . cfaqua . es . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . cfahex . e . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . si extrusion : . +c . . . . 3 : famille des pentaedres de conformite . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME28' ) +c +#include "nblang.h" +#include "consts.h" +#include "cofaar.h" +#include "coftex.h" +#include "cofext.h" +#include "cofexq.h" +#include "cofexh.h" +#include "coftfq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "meddc0.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer numfam + integer nbftr0 + integer notftr, nofatr, cofatr(notftr,nofatr) + integer cfatri(nctftr,nbftri) + integer cfaqua(nctfqu,nbfqua) + integer cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lafami, famdeb + integer fahohe + integer caract(100) + integer nufaex +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numfam', numfam + write (ulsort,90002) 'notftr', notftr + write (ulsort,90002) 'nofatr', nofatr + write (ulsort,90002) 'nbftr0', nbftr0 + write (ulsort,90002) 'nbfqua', nbfqua + write (ulsort,90002) 'nctfqu', nctfqu +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Codes des familles des quadrangles' + do 5991 , iaux = 1 , nbfqua + write(ulsort,90012) 'Famille', iaux, + > (cfaqua(jaux,iaux),jaux=1,nctfqu) + 5991 continue + write (ulsort,*) 'Codes des familles des triangles' + do 5992 , iaux = 1 , nofatr + write(ulsort,90012) 'Famille originale 3D', iaux, + > (cofatr(jaux,iaux),jaux=1,notftr) + 5992 continue + do 5993 , iaux = 1 , nbftri + write(ulsort,90012) 'Famille', iaux, + > (cfatri(jaux,iaux),jaux=1,nctftr) + 5993 continue +#endif +c + codret = 0 +c +c==== +c 2. Parcours des familles des faces avant et arriere des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours ; codret', codret +#endif +c + famdeb = numfam + 1 + do 20 , lafami = famdeb, nbfqua +c + if ( cfaqua(cofxqp,lafami).le.1 ) then +cgn write (ulsort,90002) '. Famille de quadrangle', lafami +c +c 2.1. ==> La famille d'origine du triangle de conformite +c + fahohe = cfaqua(coftfq,lafami) +cgn write (ulsort,90002) '.. Famille origine HOMARD tria', fahohe +c +c 2.1. ==> On veut une famille similaire +c +c 2.1.1. ==> Rien a priori +c + do 211 , iaux = 1 , nctftr + caract(iaux) = 0 + 211 continue +c +c 2.1.2. ==> Les caracteristiques d'origine de la famille +c + do 212 , iaux = 1 , notftr + caract(iaux) = cofatr(iaux,fahohe) + 212 continue +c +c 2.1.3. ==> L'orientation doit rester la meme +c + if ( cfaqua(cofxqo,lafami).le.4 ) then + if ( caract(cofxto).gt.3 ) then + caract(cofxto) = 1 + endif + else + if ( caract(cofxto).le.3 ) then + caract(cofxto) = 4 + endif + endif +c +c 2.1.4. ==> Pour une face avant, le pentaedre construit est deduit +c de l'hexaedre construit sur le quadrangle +c Sinon, on s'en moque. +c + if ( cfaqua(cofxqp,lafami).eq.0 ) then + caract(cofxtx) = cfahex(cofexh,cfaqua(cofxqx,lafami)) + endif +c +c 2.1.5. ==> Le triangle est a la meme position que le quadrangle +c + caract(nctftr) = cfaqua(cofxqp,lafami) +cgn write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctftr) +c +c 2.2. ==> Recherche d'une situation analogue dans les familles +c + do 221 , iaux = 1 , nbftri +c + do 2211 , jaux = 1 , ncfftr + if ( cfatri(jaux,iaux).ne.caract(jaux) ) then + goto 221 + endif + 2211 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 24 +c + 221 continue +c +c 2.3. ==> Creation d'une nouvelle famille +c 2.3.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbftri.ge.nbftr0 ) then +c + numfam = lafami - 1 + nbftri = -nbftri + goto 2999 +c +c 2.3.2. ==> Creation +c + else +c +c 2.3.2.1. ==> La famille avec les memes caracteristiques +c + nbftri = nbftri + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfatr +cgn write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctftr) + do 2321 , iaux = 1 , nctftr + cfatri(iaux,nbftri) = caract(iaux) + 2321 continue + nufaex = nbftri +c + endif +c +c 2.4. ==> Enregistrement de la famille de triangles associe a +c la famille des quadrangles +c + 24 continue +c + cfaqua(coftfq,lafami) = nufaex +c + endif +c + 20 continue +c + 2999 continue +c +c==== +c 3. Quand toutes les familles ont ete crees, on gere les extrusions +c des triangles +c==== +c + if ( nbftri.gt.0 ) then +c + if ( codret.eq.0 ) then +c + do 30 , lafami = 1, nbfqua +c + if ( cfaqua(cofxqp,lafami).eq.0 ) then +c +c 3.1. ==> La famille du triangle de conformite +c + fahohe = cfaqua(coftfq,lafami) +cgn write (ulsort,90002) '.. Famille tria', fahohe +c +c 3.2. ==> La famille du quadrangle translate +c + iaux = cfaqua(cofxqt,lafami) +cgn write (ulsort,90002) '.. Famille quad translate', iaux +c +c 3.3. ==> La famille du triangle de conformite pour +c le quadrangle translate +c + jaux = cfaqua(coftfq,iaux) +cgn write (ulsort,90002) '.. Famille tria translate', jaux +c +c 3.4. ==> Mise en place de la correspondance +c + cfatri(cofxtt,fahohe) = jaux +c + endif +c + 30 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfqua', nbfqua + write (ulsort,*) 'Codes des familles des quadrangles' + do 6991 , iaux = 1 , abs(nbfqua) + write(ulsort,90012) 'Famille', iaux, + > (cfaqua(jaux,iaux),jaux=1,nctfqu) + 6991 continue + write (ulsort,90002) 'A la sortie de '//nompro//', nbftri', nbftri + write (ulsort,*) 'Codes des familles des triangles' + do 6992 , iaux = 1 , abs(nbftri) + write(ulsort,90012) 'Famille', iaux, + > (cfatri(jaux,iaux),jaux=1,nctftr) + 6992 continue +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme29.F b/src/tool/AV_Conversion/vcme29.F new file mode 100644 index 00000000..0ffc4aad --- /dev/null +++ b/src/tool/AV_Conversion/vcme29.F @@ -0,0 +1,235 @@ + subroutine vcme29 ( nofaar, cofaar, + > cfanoe, + > nharfa, + > pcfaar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 29 +c - - - - -- +c Determine les familles pour le lien face avant / face perpendiculaire +c au cours de l'extrusion des noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nofaar . e . 1 . nombre d'origine de familles d'aretes . +c . cofaar . e . ncffar*. codes d'origine des familles d'aretes . +c . . . nofaar . . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbfnoe . 1 : famille MED . +c . . . . si extrusion : . +c . . . . 2 : famille du noeud extrude . +c . . . . 3 : famille de l'arete perpendiculaire . +c . . . . 4 : position du noeud . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . nharfa . e . char8 . objet decrivant les familles d'aretes . +c . pcfaar . s . 1 . codes des familles d'aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME29' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "nbfami.h" +#include "dicfen.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nofaar, cofaar(ncffar,nofaar) + integer cfanoe(nctfno,nbfnoe) + integer pcfaar +c + character*8 nharfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbfar0 + integer numfam +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' + texte(1,5) = '(''Influence des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' + texte(2,5) = '(''Influence of the '',a)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,-1) + write (ulsort,texte(langue,5)) mess14(langue,3,1) + write (ulsort,90002) 'nctfno', nctfno + write (ulsort,90002) 'ncffar', ncffar +#endif +c +c==== +c. Parcours des familles initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 2.1. ==> Taille initiale du tableau +c + nbfar0 = nbfare + numfam = 0 +c +c 2.2. ==> Allongement de la taille du tableau des familles +c + 22 continue +c + if ( codret.eq.0 ) then +c + nbfar0 = nbfar0 + 29 +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nharfa, nctfar, nbfar0, + > pcfaar, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME30', nompro +#endif + call vcme30 ( numfam, + > nbfar0, + > nofaar, cofaar, + > nbfnoe, cfanoe, + > nbfare, imem(pcfaar), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbfare.lt.0 ) then +c + nbfare = -nbfare + goto 22 +c + endif +c + endif +c +c==== +c 3. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Redimensionnement ; codret', codret + write (ulsort,90002) 'nbfare', nbfare + write (ulsort,90002) 'nbfar0', nbfar0 +#endif +c + if ( nbfare.ne.nbfar0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2', nompro +#endif + call utfam2 ( iaux, nharfa, nctfar, nbfare, + > pcfaar, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( mess14(langue,3,1), nharfa//'.Codes') +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme30.F b/src/tool/AV_Conversion/vcme30.F new file mode 100644 index 00000000..8d26f357 --- /dev/null +++ b/src/tool/AV_Conversion/vcme30.F @@ -0,0 +1,312 @@ + subroutine vcme30 ( numfam, + > nbfar0, + > nofaar, cofaar, + > nbfnoe, cfanoe, + > nbfare, cfaare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 30 +c - - - - -- +c Determine les familles pour le lien face avant / face perpendiculaire +c au cours de l'extrusion des noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfam . es . 1 . numero de la derniere famille traitee . +c . nbfar0 . e . 1 . nombre de familles pour le dimensionnement . +c . nofaar . e . 1 . nombre d'origine de familles d'aretes . +c . cofaar . e . ncffar*. codes d'origine des familles d'aretes . +c . . . nofaar . . +c . nbfnoe . e . 1 . nombre de familles de noeuds enregistrees . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbfnoe . 1 : famille MED . +c . . . . si extrusion : . +c . . . . 2 : famille du noeud extrude . +c . . . . 3 : famille de l'arete perpendiculaire . +c . . . . 4 : position du noeud . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . nbfare . es . 1 . nombre de familles d'aretes enregistrees . +c . cfaare . es . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . si extrusion : . +c . . . . 8 : famille de l'arete extrudee . +c . . . . 9 : famille du quadrangle perpendiculaire. +c . . . . 10 : position de l'arete . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME30' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofexn.h" +#include "cofexa.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "dicfen.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer numfam + integer nbfar0 + integer nofaar, cofaar(ncffar,nofaar) + integer nbfnoe, cfanoe(nctfno,nbfnoe) + integer nbfare, cfaare(nctfar,nbfar0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lafami, famdeb, famarx + integer caract(100) + integer nufaex +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) + write (ulsort,90002) 'numfam', numfam + write (ulsort,90002) 'nctfno', nctfno + write (ulsort,90002) 'cofxnx', cofxnx + write (ulsort,90002) 'nctfar', nctfar + write (ulsort,90002) 'ncffar', ncffar + write (ulsort,90002) 'ncffar', ncffar + write (ulsort,90002) 'nofaar', nofaar + write (ulsort,90002) 'nbfar0', nbfar0 + write (ulsort,90002) 'nbfnoe', nbfnoe +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1) + do 5991 , iaux = 1 , nofaar + write(ulsort,90012) 'Famille originale 3D', iaux, + > (cofaar(jaux,iaux),jaux=1,ncffar) + 5991 continue + do 5992 , iaux = 1 , nbfare + write(ulsort,90022) 'Famille', iaux, + > (cfaare(jaux,iaux),jaux=1,nctfar) + 5992 continue + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,-1) + do 5993 , iaux = 1 , nbfnoe + write(ulsort,90022) 'Famille', iaux, + > (cfanoe(jaux,iaux),jaux=1,nctfno) + 5993 continue +#endif +c + codret = 0 +c +c==== +c 2. Parcours des familles de la face avant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours ; codret', codret +#endif +c + famdeb = numfam + 1 + do 20 , lafami = famdeb, nbfnoe +c + famarx = cfanoe(cofxnx,lafami) + if ( famarx.ne.0 ) then +cgn write (ulsort,90012) +cgn > '. Famille de '//mess14(langue,1,-1), lafami +cgn write (ulsort,90012) +cgn > '. Famille de '//mess14(langue,1,1), famarx +c +c 2.1. ==> On veut une famille d'aretes : +c . qui a les caracteristiques de celle du maillage 3D pour : +c . les valeurs pour l'extrusion sont nulles +c . la position doit etre perpendiculaire +c +c 2.1.1. ==> Les caracteristiques d'origine de la famille +c + do 211 , iaux = 1 , ncffar + caract(iaux) = cofaar(iaux,famarx) + 211 continue +c +c 2.1.2. ==> On complete par les proprietes de l'extrusion bidon +c + do 212 , iaux = ncffar+1 , nctfar + caract(iaux) = 0 + 212 continue +c +c 2.1.3. ==> L'entite est perpendiculaire +c + caract(cofxap) = 2 +cgn write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctfar) +c +c 2.2. ==> Recherche d'une situation analogue dans les familles, +c + do 221 , iaux = 1 , nbfare +c + do 2211 , jaux = 1 , ncffar + if ( cfaare(jaux,iaux).ne.caract(jaux) ) then + goto 221 + endif + 2211 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 24 +c + 221 continue +c +c 2.3. ==> Creation d'une nouvelle famille +c 2.3.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfare.ge.nbfar0-1 ) then +c + numfam = lafami - 1 + nbfare = -nbfare + goto 2999 +c +c 2.3.2. ==> Creation +c + else +c +c 2.3.2.1. ==> La famille avec les memes caracteristiques +c + nbfare = nbfare + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfare +cgn write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfar) + do 2321 , iaux = 1 , nctfar + cfaare(iaux,nbfare) = caract(iaux) + 2321 continue + nufaex = nbfare +c +c 2.3.2.2. ==> La famille avec l'orientation inverse +c + if ( cfaare(coorfa,nbfare).ne.0 ) then +c + nbfare = nbfare + 1 +cgn write (ulsort,90015) '.. Creation de la famille', nbfare, +cgn > ' d''orientation opposee' +c + do 2322 , iaux = 1 , nctfar + cfaare(iaux,nbfare) = caract(iaux) + 2322 continue + cfaare(coorfa,nbfare) = -cfaare(coorfa,nbfare-1) + cfaare(cofifa,nbfare ) = nbfare-1 + cfaare(cofifa,nbfare-1) = nbfare +c + else +c + cfaare(cofifa,nbfare) = nbfare +c + endif +c + endif +c +c 2.4. ==> Enregistrement de la nouvelle famille pour la famille +c + 24 continue +c + cfanoe(cofxnx,lafami) = nufaex +c + endif +c + 20 continue +c + 2999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfare', nbfare + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1) + do 6992 , iaux = 1 , abs(nbfare) + write(ulsort,90022) 'Famille', iaux, + > (cfaare(jaux,iaux),jaux=1,nctfar) + 6992 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme31.F b/src/tool/AV_Conversion/vcme31.F new file mode 100644 index 00000000..85920a7d --- /dev/null +++ b/src/tool/AV_Conversion/vcme31.F @@ -0,0 +1,315 @@ + subroutine vcme31 ( nofaqu, cofaqu, + > nharfa, pcfaar, famare, posare, inxare, + > nhqufa, pcfaqu, inxqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 31 +c - - - - -- +c Determine les familles pour le lien face avant / face perpendiculaire +c au cours de l'extrusion des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nofaqu . e . 1 . nombre d'origine de familles quadrangles . +c . cofaqu . e . ncffqu*. codes d'origine des familles des quads. . +c . . . nofaqu . . +c . nharfa . e . char8 . objet decrivant les familles des aretes . +c . pcfaar . e . 1 . codes des familles des aretes . +c . famare . es . nbarto . famille des aretes . +c . posare . e . nbarto . position des aretes . +c . . . . 0 : arete avant . +c . . . . 1 : arete arriere . +c . . . . 2 : arete perpendiculaire . +c . inxare . e .4*nbarto. informations pour l'extrusion des aretes . +c . . . . 1 : famille de l'arete extrudee . +c . . . . 2 : famille du quadrangle perpendiculaire . +c . . . . 3 : code du quadrangle dans le volume . +c . . . . 4 : quadrangle perpendiculaire . +c . nhqufa . e . char8 . objet decrivant les familles de quadrangles. +c . pcfaqu . s . 1 . codes des familles de quadrangles . +c . inxqua . es .3*nbquto. informations pour l'extrusion des quads . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 1 : famille du quadrangle extrude . +c . . . . 2 : famille de l'hexaedre . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle a l'arriere : . +c . . . . 1 : inutile . +c . . . . 2 : inutile . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 1 : sens de la 1ere compos. de la normale . +c . . . . 2 : sens de la 2eme compos. de la normale . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME31' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "nombar.h" +#include "nombqu.h" +#include "nbfami.h" +#include "dicfen.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nofaqu, cofaqu(ncffqu,nofaqu) + integer famare(nbarto), posare(nbarto), inxare(4,nbarto) + integer inxqua(3,nbquto) + integer pcfaar + integer pcfaqu +c + character*8 nharfa + character*8 nhqufa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbfar0, nbfqu0 + integer numare +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' + texte(1,5) = '(''Influence des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' + texte(2,5) = '(''Influence of the '',a)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) + write (ulsort,texte(langue,5)) mess14(langue,3,4) + write (ulsort,90002) 'nctfar', nctfar + write (ulsort,90002) 'ncffqu', ncffqu +#endif +c +c==== +c. Parcours des familles initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c +c 2.1. ==> Taille initiale du tableau +c + nbfar0 = nbfare + nbfqu0 = nbfqua + numare = 0 +c +c 2.2. ==> Allongement de la taille des tableaux des familles +c + 22 continue +c +c 2.2.1. ==> Les familles d'aretes +c + if ( codret.eq.0 ) then +c + nbfar0 = nbfar0 + 31 + nbfare = abs(nbfare) +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfare', nbfar0 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2 - are', nompro +#endif + call utfam2 ( iaux, nharfa, nctfar, nbfar0, + > pcfaar, + > ulsort, langue, codret) +c + endif +c +c 2.2.2. ==> Les familles de quadrangles +c + if ( codret.eq.0 ) then +c + nbfqu0 = nbfqu0 + 31 + nbfqua = abs(nbfqua) +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfqua', nbfqu0 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2 - qua', nompro +#endif + call utfam2 ( iaux, nhqufa, nctfqu, nbfqu0, + > pcfaqu, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Programme utilitaire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME32', nompro +#endif + call vcme32 ( numare, + > nofaqu, cofaqu, + > famare, posare, inxare, + > inxqua, + > nbfar0, nbfare, imem(pcfaar), + > nbfqu0, nbfqua, imem(pcfaqu), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> A rallonger ? +c + if ( codret.eq.0 ) then +c + if ( nbfare.lt.0 ) then +c + goto 22 +c + endif +c + if ( nbfqua.lt.0 ) then +c + goto 22 +c + endif +c + endif +c +c==== +c 3. Redimensionnement final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Redimensionnement ; codret', codret +#endif +c 3.1. ==> Les familles d'aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfare', nbfare + write (ulsort,90002) 'nbfar0', nbfar0 +#endif +c + if ( nbfare.ne.nbfar0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2 - are', nompro +#endif + call utfam2 ( iaux, nharfa, nctfar, nbfare, + > pcfaar, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.2. ==> Les familles de quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfqua', nbfqua + write (ulsort,90002) 'nbfqu0', nbfqu0 +#endif +c + if ( nbfqua.ne.nbfqu0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM2 - qua', nompro +#endif + call utfam2 ( iaux, nhqufa, nctfqu, nbfqua, + > pcfaqu, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( mess14(langue,3,1), nharfa//'.Codes') + call gmprsx ( mess14(langue,3,4), nhqufa//'.Codes') +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcme32.F b/src/tool/AV_Conversion/vcme32.F new file mode 100644 index 00000000..191b32c9 --- /dev/null +++ b/src/tool/AV_Conversion/vcme32.F @@ -0,0 +1,451 @@ + subroutine vcme32 ( numare, + > nofaqu, cofaqu, + > famare, posare, inxare, + > inxqua, + > nbfar0, nbfare, cfaare, + > nbfqu0, nbfqua, cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage Extrude - phase 32 +c - - - - -- +c Determine les familles pour le lien face avant / face perpendiculaire +c au cours de l'extrusion des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numare . es . 1 . numero de la derniere arete traitee . +c . nofaqu . e . 1 . nombre d'origine de familles de quadrangles. +c . cofaqu . e . ncffqu*. codes d'origine des familles des quads. . +c . . . nofaqu . . +c . famare . es . nbarto . famille des aretes . +c . posare . e . nbarto . position des aretes . +c . . . . 0 : arete avant . +c . . . . 1 : arete arriere . +c . . . . 2 : arete perpendiculaire . +c . inxare . e .4*nbarto. informations pour l'extrusion des aretes . +c . . . . 1 : famille de l'arete extrudee . +c . . . . 2 : famille du quadrangle perpendiculaire . +c . . . . 3 : code du quadrangle dans le volume . +c . . . . 4 : quadrangle perpendiculaire . +c . inxqua . es .3*nbquto. informations pour l'extrusion des quads . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 1 : famille du quadrangle extrude . +c . . . . 2 : famille de l'hexaedre . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle a l'arriere : . +c . . . . 1 : inutile . +c . . . . 2 : inutile . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 1 : sens de la 1ere compos. de la normale . +c . . . . 2 : sens de la 2eme compos. de la normale . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . nbfar0 . e . 1 . nombre de familles d'aretes pour le dim. . +c . nbfare . e . 1 . nombre de familles d'aretes enregistrees . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . si extrusion : . +c . . . . 8 : famille de l'arete extrudee . +c . . . . 9 : famille du quadrangle perpendiculaire. +c . . . . 10 : position de l'arete . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . nbfqu0 . e . 1 . nombre de familles de quads pour le dim. . +c . nbfqua . es . 1 . nombre de familles de quadrangles . +c . cfaqua . es . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCME32' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofexa.h" +#include "cofexq.h" +#include "coftfq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "dicfen.h" +#include "nombar.h" +#include "nombqu.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer numare + integer nofaqu, cofaqu(ncffqu,nofaqu) + integer famare(nbarto), posare(nbarto), inxare(4,nbarto) + integer inxqua(3,nbquto) + integer nbfar0, nbfare, cfaare(nctfar,nbfare) + integer nbfqu0, nbfqua, cfaqua(nctfqu,nbfqu0) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer larete, aredeb + integer caract(100) + integer nufaar, nufaqu + integer nufaex +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + texte(1,4) = '(''Familles d''''extrusion des '',a)' +c + texte(2,4) = '(''Description of families of extruded '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) + write (ulsort,90002) 'numare', numare + write (ulsort,90002) 'nctfar', nctfar + write (ulsort,90002) 'cofxax', cofxax + write (ulsort,90002) 'cofxap', cofxap + write (ulsort,90002) 'nctfqu', nctfqu + write (ulsort,90002) 'ncffqu', ncffqu + write (ulsort,90002) 'ncffar', ncffar + write (ulsort,90002) 'nofaqu', nofaqu + write (ulsort,90002) 'nbfar0', nbfar0 + write (ulsort,90002) 'nbfare', nbfare + write (ulsort,90002) 'nbfqu0', nbfqu0 + write (ulsort,90002) 'nbfqua', nbfqua +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,4) + do 5991 , iaux = 1 , nofaqu + write(ulsort,90012) 'Famille originale 3D', iaux, + > (cofaqu(jaux,iaux),jaux=1,ncffqu) + 5991 continue + do 5992 , iaux = 1 , nbfqua + write(ulsort,90022) 'Famille', iaux, + > (cfaqua(jaux,iaux),jaux=1,nctfqu) + 5992 continue + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1) + do 5993 , iaux = 1 , nbfare + write(ulsort,90022) 'Famille', iaux, + > (cfaare(jaux,iaux),jaux=1,nctfar) + 5993 continue +49900 format(/,24x,a) + write(ulsort,49900) + > ' famille fa are ex fa quad code q/vo face perp' + do 4992 , iaux = 1 , nbarto + if ( posare(iaux).eq.0 ) then + write(ulsort,90012) 'arete',iaux,famare(iaux), + > inxare(1,iaux),inxare(2,iaux),inxare(3,iaux),inxare(4,iaux) + endif + 4992 continue +#endif +c + codret = 0 +c +c==== +c 2. Au premier passage, on met une valeur nulle a la famille du +c quadrangle perpendiculaire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours ; codret', codret +#endif +c + if ( numare.eq.0 ) then +c + do 20 , iaux = 1, nbfare + cfaare(cofxax,iaux) = 0 + 20 continue +c + endif +c +c==== +c 3. Parcours des aretes de la face avant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours ; codret', codret +#endif +c + aredeb = numare + 1 + do 30 , larete = aredeb, nbarto +c + if ( posare(larete).eq.0 ) then +cgn write (ulsort,90012) '. Famille de l''arete', +cgn > larete, famare(larete) +c +c 3.1. ==> On veut une famille de quadrangle : +c . qui a les caracteristiques de celle du maillage 3D +c . les valeurs pour l'extrusion sont nulles +c . la position doit etre perpendiculaire +c +c 3.1.1. ==> Les caracteristiques d'origine de la famille +c + jaux = inxare(2,larete) +cgn write (ulsort,90002) '.. Famille d''origine du quad', jaux + do 311 , iaux = 1 , ncffqu + caract(iaux) = cofaqu(iaux,jaux) + 311 continue + caract(coftfq) = 0 +c +c 3.1.2. ==> On complete par les proprietes de la normale du quadrangle +c + jaux = inxare(4,larete) + caract(cofxqt) = inxqua(1,jaux) + caract(cofxqx) = inxqua(2,jaux) +c +c 3.1.3. ==> Le code de la face dans le volume +c + caract(cofxqo) = inxare(3,larete) +c +c 3.1.4. ==> L'entite est perpendiculaire +c + caract(cofxqp) = 2 +cgn write (ulsort,90005) '.. Caract.',(caract(iaux),iaux=1,nctfqu) +c +c 3.2. ==> Recherche d'une situation analogue dans les familles +c Remarque : on ne tient pas compte des codes lies a la famille +c du triangle de conformite car il ne servira jamais +c pour des quadrangles places sur la face +c perpendiculaire +c + do 321 , iaux = 1 , nbfqua +c + do 3211 , jaux = 1 , nctfqu + if ( jaux.ne.coftfq ) then + if ( cfaqua(jaux,iaux).ne.caract(jaux) ) then + goto 321 + endif + endif + 3211 continue +c + nufaex = iaux +cgn write (ulsort,90002) '.. Correspond a la famille', nufaex + goto 34 +c + 321 continue +c +c 3.3. ==> Creation d'une nouvelle famille +c 3.3.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfqua.ge.nbfqu0 ) then +c + numare = larete - 1 + nbfqua = -nbfqua + goto 3999 +c +c 3.3.2. ==> Creation avec les memes caracteristiques +c + else +c + nbfqua = nbfqua + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfqua +cgn write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfqu) + do 3321 , iaux = 1 , nctfqu + cfaqua(iaux,nbfqua) = caract(iaux) + 3321 continue + nufaex = nbfqua +c + endif +c +c 3.4. ==> Enregistrement de la nouvelle famille de quadrangles +c . pour la famille d'aretes +c . pour la famille d'aretes d'orientation opposee +c + 34 continue +c +c 3.4.1. ==> La famille d'aretes a deja ete enregistree +c +cgn write (ulsort,90002) '. fam quad pour fam are', +cgn > famare(larete), cfaare(cofxax,famare(larete)),nufaex + if ( cfaare(cofxax,famare(larete)).eq.nufaex ) then +c +cgn write (ulsort,90002) +cgn > '.. deja vu pour',famare(larete),iaux, nufaex + goto 30 +c +c 3.4.2. ==> La famille d'aretes a deja ete vue : il faut la dupliquer +c + elseif ( ( cfaare(cofxax,famare(larete)).ne.nufaex ) .and. + > ( cfaare(cofxax,famare(larete)).ne.0 ) ) then +c +c 3.4.2.1. ==> S'il n'y a plus de places, on sort et on recommencera +c pour cette famille +c + if ( nbfare.ge.nbfar0-4 ) then +c + numare = larete - 1 + nbfare = -nbfare + goto 3999 +c +c 3.4.2.2. ==> Creation avec les memes caracteristiques +c + else +c + nbfare = nbfare + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfare +cgn write (ulsort,90005) +cgn > '.. avec',(cfaare(iaux,famare(larete)),iaux=1,nctfar) + do 3421 , iaux = 1 , nctfar + cfaare(iaux,nbfare) = cfaare(iaux,famare(larete)) + 3421 continue + cfaare(cofxax,nbfare) = 0 + famare(larete) = nbfare +c + nbfare = nbfare + 1 +cgn write (ulsort,90002) '.. Creation de la famille', nbfare + do 3422 , iaux = 1 , nctfar + cfaare(iaux,nbfare) = cfaare(iaux,famare(larete)) + 3422 continue + cfaare(cofxat,nbfare-1) = nbfare + cfaare(cofxat,nbfare) = 0 + cfaare(cofxap,nbfare) = 1 +c +c Les familles avec l'orientation inverse +c + if ( cfaare(coorfa,famare(larete)).ne.0 ) then +c + nbfare = nbfare + 2 +cgn write (ulsort,90002) '.. Creation des familles opposees' + do 3423 , iaux = 1 , nctfar + cfaare(iaux,nbfare-1) = cfaare(iaux,nbfare-3) + cfaare(iaux,nbfare) = cfaare(iaux,nbfare-2) + 3423 continue + cfaare(coorfa,nbfare-1) = -cfaare(coorfa,nbfare-3) + cfaare(coorfa,nbfare ) = -cfaare(coorfa,nbfare-2) + cfaare(cofifa,nbfare-3) = nbfare-1 + cfaare(cofifa,nbfare-1) = nbfare-3 + cfaare(cofifa,nbfare-2) = nbfare + cfaare(cofifa,nbfare ) = nbfare-2 +c + else +c + cfaare(cofifa,nbfare-1) = nbfare-1 + cfaare(cofifa,nbfare) = nbfare +c + endif +c + endif +c + endif +c +c 3.4.3. ==> Enregistrement +c + cfaare(cofxax,famare(larete)) = nufaex + iaux = cfaare(cofifa,famare(larete)) + cfaare(cofxax,iaux) = nufaex +cgn write (ulsort,90002) +cgn > '.. enregistrement pour',famare(larete),iaux, nufaex +c + endif +c + 30 continue +c + 3999 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'A la sortie de '//nompro//', nbfare', nbfare + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1) + do 6991 , iaux = 1 , abs(nbfare) + write(ulsort,90022) 'Famille', iaux, + > (cfaare(jaux,iaux),jaux=1,nctfar) + 6991 continue + write (ulsort,90002) 'A la sortie de '//nompro//', nbfqua', nbfqua + write (ulsort,*) 'Codes des familles des ',mess14(langue,3,4) + do 6992 , iaux = 1 , abs(nbfqua) + write(ulsort,90022) 'Famille', iaux, + > (cfaqua(jaux,iaux),jaux=1,nctfqu) + 6992 continue +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmex0.F b/src/tool/AV_Conversion/vcmex0.F new file mode 100644 index 00000000..3452249f --- /dev/null +++ b/src/tool/AV_Conversion/vcmex0.F @@ -0,0 +1,381 @@ + subroutine vcmex0 ( option, + > coocst, + > coonoe, posnoe, + > somare, posare, + > aretri, postri, + > arequa, posqua, inxqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase 0 +c - - - -- - +c Trie les noeuds, aretes, triangles et quadrangles selon leur +c position : avant, arriere et perpendiculaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option avec ou sans remplissage de inxqua . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . posnoe . s . nbnoto . position des noeuds . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . posare . s . nbarto . position des aretes . +c . . . . 0 : arete avant . +c . . . . 1 : arete arriere . +c . . . . 2 : arete perpendiculaire . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . postri . s . nbtrto . position des triangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . posqua . s . nbquto . position des quadrangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . inxqua . s .3*nbquto. informations pour l'extrusion des quads . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 1 : famille du quadrangle extrude . +c . . . . 2 : famille de l'hexaedre . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle a l'arriere : . +c . . . . 1 : inutile . +c . . . . 2 : inutile . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 1 : sens de la 1ere compos. de la normale . +c . . . . 2 : sens de la 2eme compos. de la normale . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEX0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer option + integer posnoe(nbnoto) + integer somare(2,nbarto), posare(nbarto) + integer aretri(nbtrto,3), postri(nbtrto) + integer arequa(nbquto,4), posqua(nbquto), inxqua(3,nbquto) +c + double precision coocst(11) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer iaux1, iaux2, iaux3, iaux4 + integer coor12(2) +c + double precision daux + double precision normal(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,5) = '(''Nombre de noeuds :'',i10)' + texte(1,6) = '(''==> epaisseur maximale = '',g13.5)' + texte(1,7) = '(''==> coordonnee '',a3,'' ='',g13.5)' +c + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,5) = '(''Number of nodes :'',i10)' + texte(2,6) = '(''==> maximal thickness:'',g13.5)' + texte(2,7) = '(''==> '',a3,'' coordinate:'',g13.5)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. caracterisation de l'extrusion +c==== +c + if ( maextr.eq.1 ) then + coor12(1) = 2 + coor12(2) = 3 + elseif ( maextr.eq.2 ) then + coor12(1) = 1 + coor12(2) = 3 + elseif ( maextr.eq.3 ) then + coor12(1) = 1 + coor12(2) = 2 + else + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) nbnoto + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + write (ulsort,texte(langue,4)) 'z', coocst(4), coocst(7) + write (ulsort,texte(langue,6)) coocst(11) + write (ulsort,texte(langue,7)) 'inf', coocst(maextr+1) + write (ulsort,texte(langue,7)) 'sup', coocst(maextr+4) + write (ulsort,90002) 'maextr', maextr + endif +#endif +c +c==== +c 3. classement des noeuds +c on retient tous ceux qui sont dans le plan cooinf +c on teste la proximite de cooinf au millionieme de l'epaisseur +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. classement noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoto', nbnoto +#endif +c + daux = coocst(10)*1.d-6 +c + do 31 , iaux = 1 , nbnoto +c + if ( abs(coonoe(iaux,maextr)-coocst(maextr+1)).le.daux ) then + posnoe(iaux) = 0 + else + posnoe(iaux) = 1 + endif +c + 31 continue +c + endif +c +c==== +c 4. classement des aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. classement aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto +#endif +c + do 41 , iaux = 1 , nbarto +c + iaux1 = posnoe(somare(1,iaux)) + iaux2 = posnoe(somare(2,iaux)) + if ( ( iaux1.eq.0 ) .and. ( iaux2.eq.0 ) ) then + posare(iaux) = 0 + elseif ( ( iaux1.eq.1 ) .and. ( iaux2.eq.1) ) then + posare(iaux) = 1 + else + posare(iaux) = 2 + endif +c + 41 continue +c + endif +c +c==== +c 5. classement des triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. classement triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtrto', nbtrto +#endif +c + do 51 , iaux = 1 , nbtrto +c + iaux1 = posare(aretri(iaux,1)) + iaux2 = posare(aretri(iaux,2)) + iaux3 = posare(aretri(iaux,3)) + if ( ( iaux1.eq.0 ) .and. + > ( iaux2.eq.0 ) .and. + > ( iaux3.eq.0 ) ) then + postri(iaux) = 0 + elseif ( ( iaux1.eq.1 ) .and. + > ( iaux2.eq.1 ) .and. + > ( iaux3.eq.1 ) ) then + postri(iaux) = 1 + else + postri(iaux) = 2 + endif +c + 51 continue +c + endif +c +c==== +c 6. classement des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. classement quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbquto', nbquto +#endif +c + do 61 , iaux = 1 , nbquto +c + iaux1 = posare(arequa(iaux,1)) + iaux2 = posare(arequa(iaux,2)) + iaux3 = posare(arequa(iaux,3)) + iaux4 = posare(arequa(iaux,4)) +c +c 6.1.1. ==> Face avant +c + if ( ( iaux1.eq.0 ) .and. + > ( iaux2.eq.0 ) .and. + > ( iaux3.eq.0 ) .and. + > ( iaux4.eq.0 ) ) then + posqua(iaux) = 0 +c +c 6.1.2. ==> Face arriere +c + elseif ( ( iaux1.eq.1 ) .and. + > ( iaux2.eq.1 ) .and. + > ( iaux3.eq.1 ) .and. + > ( iaux4.eq.1 ) ) then + posqua(iaux) = 1 +c +c 6.1.3. ==> Face perpendiculaire +c + else + posqua(iaux) = 2 +cgn write (ulsort,90002) 'Quadrangle', iaux +c + if ( option.ne.0 ) then +c +c 6.1.3.1. ==> Calcul du vecteur normal +c + call utnqua ( iaux, normal, + > nbnoto, nbquto, + > coonoe, somare, arequa ) +c +cgn write (ulsort,90004) '. Vecteur normal', normal +c +c 6.1.3.2. ==> Enregistrement de la caracterisation +c + do 6132 , jaux = 1 , 2 +c + iaux1 = coor12(jaux) + if ( normal(iaux1).gt.1.d-6 ) then + iaux2 = 1 + elseif ( normal(iaux1).lt.-1.d-6 ) then + iaux2 = -1 + else + iaux2 = 0 + endif +cgn write (ulsort,90002) '. iaux2', iaux2 +c + inxqua(jaux,iaux) = iaux2 +c + 6132 continue +c + endif +c + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmex1.F b/src/tool/AV_Conversion/vcmex1.F new file mode 100644 index 00000000..ca09bb2e --- /dev/null +++ b/src/tool/AV_Conversion/vcmex1.F @@ -0,0 +1,485 @@ + subroutine vcmex1 ( famnoe, posnoe, inxnoe, + > somare, famare, posare, inxare, + > famtri, + > postri, inxtri, pentri, + > arequa, famqua, posqua, inxqua, hexqua, + > quahex, coquhe, famhex, + > facpen, cofape, fampen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase 1 +c - - - -- - +c Memorise les informations pour l'extrusion +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . famnoe . e . nbnoto . famille des noeuds . +c . posnoe . e . nbnoto . position des noeuds . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . inxnoe . s .2*nbnoto. informations pour l'extrusion des noeuds . +c . . . . 1 : famille du noeud extrude . +c . . . . 2 : famille de l'arete perpendiculaire . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . famare . e . nbarto . famille des aretes . +c . posare . e . nbarto . position des aretes . +c . . . . 0 : arete avant . +c . . . . 1 : arete arriere . +c . . . . 2 : arete perpendiculaire . +c . inxare . s .4*nbarto. informations pour l'extrusion des aretes . +c . . . . 1 : famille de l'arete extrudee . +c . . . . 2 : famille du quadrangle perpendiculaire . +c . . . . 3 : code du quadrangle dans le volume . +c . . . . 4 : quadrangle perpendiculaire . +c . famtri . e . nbtrto . famille des triangles . +c . postri . e . nbtrto . position des triangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . inxtri . s .3*nbtrto. informations pour l'extrusion des triangles. +c . . . . 1 : famille du triangle extrude . +c . . . . 2 : famille du pentaedre . +c . . . . 3 : code du triangle dans le pentaedre . +c . pentri . s . nbtrto . pentaedre sur un triangle de la face avant . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . posqua . e . nbquto . position des quadrangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . inxqua . es .3*nbquto. informations pour l'extrusion des quads . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 1 : famille du quadrangle extrude . +c . . . . 2 : famille de l'hexaedre . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle a l'arriere : . +c . . . . 1 : inutile . +c . . . . 2 : inutile . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 1 : sens de la 1ere compos. de la normale . +c . . . . 2 : sens de la 2eme compos. de la normale . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . hexqua . s . nbquto . hexaedre sur un quadrangle de la face avant. +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nbheto . famille des hexaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . fampen . e . nbpeto . famille des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEX1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer famnoe(nbnoto) + integer posnoe(nbnoto), inxnoe(2,nbnoto) + integer somare(2,nbarto), famare(nbarto) + integer posare(nbarto), inxare(4,nbarto) + integer famtri(nbtrto) + integer postri(nbtrto), inxtri(3,nbtrto), pentri(nbtrto) + integer arequa(nbquto,4), famqua(nbquto) + integer posqua(nbquto), inxqua(3,nbquto), hexqua(nbquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), famhex(nbheto) + integer facpen(nbpecf,5), cofape(nbpecf,5), fampen(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer iaux1, iaux2, iaux3, iaux4 + integer lehexa, lepent + integer facear, cofaar + integer faceav, cofaav + integer facepp + integer aretar, aretav, aretpp + integer noeuar, noeuav +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Prealables : rien n'est vu +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Prealables ; codret', codret +#endif +c + do 21 , iaux = 1 , nbarto + inxare(1,iaux) = -1 + 21 continue +c + do 22 , iaux = 1 , nbtrto + pentri(iaux) = 0 + 22 continue +c + do 23 , iaux = 1 , nbquto + inxqua(3,iaux) = -1 + hexqua(iaux) = 0 + 23 continue +c +c==== +c 3. Examen des hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheto', nbheto +#endif +c + do 31 , lehexa = 1 , nbheto +c +c 3.1. ==> Bases quadrangulaires +c +cgn write (ulsort,90012) 'faces de l''hexa', lehexa, +cgn > ( quahex(lehexa,jaux) , jaux = 1 , 6) +cgn write (ulsort,90012) 'faces de l''hexa', lehexa, +cgn > ( inxqua(1,quahex(lehexa,jaux)) , jaux = 1 , 6) + do 311 , jaux = 1 , 6 + iaux1 = quahex(lehexa,jaux) + if ( posqua(iaux1).eq.0 ) then + faceav = iaux1 + cofaav = coquhe(lehexa,jaux) + elseif ( posqua(iaux1).eq.1 ) then + facear = iaux1 + cofaar = coquhe(lehexa,jaux) + endif + 311 continue +cgn write (ulsort,90002) '.. faces de base', faceav, facear +c +cgn write (ulsort,90002) '.. quad/hexa', faceav, lehexa + inxqua(1,faceav) = famqua(facear) + inxqua(2,faceav) = famhex(lehexa) + inxqua(3,faceav) = cofaav + inxqua(1,facear) = 0 + inxqua(2,facear) = 0 + inxqua(3,facear) = cofaar + hexqua(faceav) = lehexa +c +c 3.2. ==> Faces perpendiculaires a l'extrusion +c Remarque : une face n'est traitee qu'une fois, inxqua(3,.)<0 +c + do 312 , jaux = 1 , 6 +c + facepp = quahex(lehexa,jaux) + if ( inxqua(3,facepp).lt.0 ) then +c +cgn write (ulsort,90002) 'quad perp', facepp +c +c 3.2.1. ==> reperage des aretes avant et arriere +c + do 3211 , kaux = 1, 4 + if ( posare(arequa(facepp,kaux)).eq.0 ) then + iaux1 = kaux + endif + 3211 continue + aretav = arequa(facepp,iaux1) + aretar = arequa(facepp,per1a4(2,iaux1)) +cgn write (ulsort,90002) 'aretes av/ar', aretav, aretar +c +c 3.2.2. ==> informations pour les aretes avant et arriere +c + inxare(1,aretav) = famare(aretar) + inxare(2,aretav) = famqua(facepp) + inxare(3,aretav) = coquhe(lehexa,jaux) + inxare(4,aretav) = facepp +c +c 3.2.3. ==> les deux aretes perpendiculaires +c + do 3213 , kaux = 1 , 2 +c +c 3.2.3.1. ==> numero de l'arete perpendiculaire +c + if ( kaux.eq.1 ) then + iaux2 = per1a4(1,iaux1) + else + iaux2 = per1a4(3,iaux1) + endif + aretpp = arequa(facepp,iaux2) +c + if ( inxare(1,aretpp).lt.0 ) then +cgn write (ulsort,90002) '.... arete perp 1', aretpp +c +c 3.2.3.2. ==> les deux sommets avant et arriere +c + iaux3 = somare(1,aretpp) + iaux4 = somare(2,aretpp) + if ( posnoe(iaux3).eq.0 ) then + noeuav = iaux3 + noeuar = iaux4 + else + noeuav = iaux4 + noeuar = iaux3 + endif +cgn write (ulsort,90002) '.... noeuds av/ar', noeuav, noeuar + inxnoe(1,noeuav) = famnoe(noeuar) + inxnoe(2,noeuav) = famare(aretpp) + inxare(1,aretpp) = 0 + endif +c + 3213 continue +c +c 4.2.4. ==> Code de la face +c + inxqua(3,facepp) = coquhe(lehexa,jaux) +c + endif +c + 312 continue + +c + 31 continue +c + endif +c +c==== +c 4. Examen des pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpeto', nbpeto +#endif +c + do 41 , lepent = 1 , nbpeto +c +c 4.1. ==> Bases triangulaires +c +cgn write (ulsort,90012) 'faces du pentaedre', lepent, +cgn > ( facpen(lepent,jaux) , jaux = 1 , 5) +cgn write (ulsort,90012) 'faces du pentaedre', lepent, +cgn > ( inxtri(1,facpen(lepent,jaux)) , jaux = 1 , 2), +cgn > ( inxqua(1,facpen(lepent,jaux)) , jaux = 3 , 5) + iaux1 = facpen(lepent,1) + iaux2 = facpen(lepent,2) + if ( postri(iaux1) .eq.0 ) then + faceav = iaux1 + cofaav = cofape(lepent,1) + facear = iaux2 + cofaar = cofape(lepent,2) + else + faceav = iaux2 + cofaav = cofape(lepent,2) + facear = iaux1 + cofaar = cofape(lepent,1) + endif +cgn write (ulsort,90002) '.. faces de base', faceav, facear +c +cgn write (ulsort,90002) '.. tria/pent', faceav, lepent + inxtri(1,faceav) = famtri(facear) + inxtri(2,faceav) = fampen(lepent) + inxtri(3,faceav) = cofaav + inxtri(1,facear) = 0 + inxtri(2,facear) = 0 + inxtri(3,facear) = cofaar + pentri(faceav) = lepent +c +c 4.2. ==> Faces perpendiculaires a l'extrusion +c Remarque : on ne traite qu'une seule fois, inxqua(3,.)<0 +c + do 421 , jaux = 3 , 5 +c + facepp = facpen(lepent,jaux) + if ( inxqua(3,facepp).lt.0 ) then +c +cgn write (ulsort,90002) '.. quad perp', facepp +c +c 4.2.1. ==> reperage des aretes avant et arriere +c + do 4211 , kaux = 1, 4 + if ( posare(arequa(facepp,kaux)).eq.0 ) then + iaux1 = kaux + endif + 4211 continue + aretav = arequa(facepp,iaux1) + aretar = arequa(facepp,per1a4(2,iaux1)) +cgn write (ulsort,90002) '.... aretes av/ar', aretav, aretar +c +c 4.2.2. ==> informations pour les aretes avant et arriere +c + inxare(1,aretav) = famare(aretar) + inxare(2,aretav) = famqua(facepp) + inxare(3,aretav) = cofape(lepent,jaux) + inxare(4,aretav) = facepp +c +c 4.2.3. ==> les deux aretes perpendiculaires +c + do 4213 , kaux = 1 , 2 +c +c 4.2.3.1. ==> numero de l'arete perpendiculaire +c + if ( kaux.eq.1 ) then + iaux2 = per1a4(1,iaux1) + else + iaux2 = per1a4(3,iaux1) + endif + aretpp = arequa(facepp,iaux2) +c + if ( inxare(1,aretpp).lt.0 ) then +cgn write (ulsort,90002) '.... arete perp 1', aretpp +c +c 4.2.3.2. ==> les deux sommets avant et arriere +c + iaux3 = somare(1,aretpp) + iaux4 = somare(2,aretpp) + if ( posnoe(iaux3).eq.0 ) then + noeuav = iaux3 + noeuar = iaux4 + else + noeuav = iaux4 + noeuar = iaux3 + endif +cgn write (ulsort,90002) '.... noeuds av/ar', noeuav, noeuar + inxnoe(1,noeuav) = famnoe(noeuar) + inxnoe(2,noeuav) = famare(aretpp) + inxare(1,aretpp) = 0 + endif +c + 4213 continue +c +c 4.2.4. ==> Code de la face +c + inxqua(3,facepp) = cofape(lepent,jaux) +c + endif +c + 421 continue +c + 41 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +49900 format(/,24x,a) + write(ulsort,49900) ' famille fa noe ex fa arete' + do 4991 , iaux = 1 , nbnoto + if ( posnoe(iaux).eq.0 ) then + write(ulsort,90012) 'noeud',iaux,famnoe(iaux), + > inxnoe(1,iaux),inxnoe(2,iaux) + endif + 4991 continue +c + write(ulsort,49900) + > ' famille fa are ex fa quad code q/vo face perp' + do 4992 , iaux = 1 , nbarto + if ( posare(iaux).eq.0 ) then + write(ulsort,90012) 'arete',iaux,famare(iaux), + > inxare(1,iaux),inxare(2,iaux),inxare(3,iaux) + endif + 4992 continue +c + write(ulsort,49900) 'famille fa tri ex fa pent code t/pe' + do 4993 , iaux = 1 , nbtrto + if ( postri(iaux).eq.0 ) then + write(ulsort,90012) 'tria',iaux,famtri(iaux), + > inxtri(1,iaux),inxtri(2,iaux),inxtri(3,iaux) + endif + 4993 continue +c + write(ulsort,49900) + >'famille position fa qua ex fa hexa code q/vo' + do 4994 , iaux = 1 , nbquto + write(ulsort,90012) 'quad',iaux,famqua(iaux),posqua(iaux), + > inxqua(1,iaux),inxqua(2,iaux),inxqua(3,iaux) + 4994 continue +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmex2.F b/src/tool/AV_Conversion/vcmex2.F new file mode 100644 index 00000000..ae42fce9 --- /dev/null +++ b/src/tool/AV_Conversion/vcmex2.F @@ -0,0 +1,599 @@ + subroutine vcmex2 ( maconf, + > nhnofa, famnoe, notfno, nofano, cofano, + > posnoe, inxnoe, pcfano, + > nharfa, famare, notfar, nofaar, cofaar, + > posare, inxare, pcfaar, + > nhtrfa, famtri, notftr, nofatr, cofatr, + > postri, inxtri, pcfatr, + > nhqufa, famqua, notfqu, nofaqu, cofaqu, + > posqua, inxqua, pcfaqu, + > pcfahe, + > nhpefa, pcfape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase 2 +c - - - -- - +c Determine les nouvelles familles pour les mailles du maillage 2D +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . maconf . e . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . 10 : non-conforme sans autre connaissance . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . 10 : non-conforme sans autre connaissance . +c . nhnofa . e . char8 . objet decrivant les familles des noeuds . +c . famnoe . es . nbnoto . famille des noeuds . +c . notfno . e . 1 . nombre d'origine des carac. des f. noeuds . +c . nofano . e . 1 . nombre d'origine de familles de noeuds . +c . cofano . e . notfno*. codes d'origine des familles des noeuds . +c . . . nofano . 1 : famille MED . +c . posnoe . e . nbnoto . position des noeuds . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . inxnoe . e .2*nbnoto. informations pour l'extrusion des noeuds . +c . . . . 1 : famille du noeud extrude . +c . . . . 2 : famille de l'arete perpendiculaire . +c . pcfano . s . 1 . familles pour l'extrusion des noeuds . +c . nharfa . e . char8 . objet decrivant les familles des aretes . +c . famare . es . nbarto . famille des aretes . +c . notfar . e . 1 . nombre d'origine des carac. des f. aretes . +c . nofaar . e . 1 . nombre d'origine de familles d'aretes . +c . cofaar . e . notfar*. codes d'origine des familles des aretes . +c . . . nofaar . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . posare . e . nbarto . position des aretes . +c . . . . 0 : arete avant . +c . . . . 1 : arete arriere . +c . . . . 2 : arete perpendiculaire . +c . inxare . e .4*nbarto. informations pour l'extrusion des aretes . +c . . . . 1 : famille de l'arete extrudee . +c . . . . 2 : famille du quadrangle perpendiculaire . +c . . . . 3 : code du quadrangle dans le volume . +c . . . . 4 : quadrangle perpendiculaire . +c . pcfaar . s . 1 . familles pour l'extrusion des aretes . +c . nhtrfa . e . char8 . objet decrivant les familles des triangles . +c . famtri . es . nbtrto . famille des triangles . +c . notftr . e . 1 . nombre d'origine des carac. des f. tria. . +c . nofatr . e . 1 . nombre d'origine de familles de triangles . +c . cofatr . e . notftr*. codes d'origine des familles des triangles . +c . . . nofatr . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . postri . e . nbtrto . position des triangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . inxtri . e .3*nbtrto. informations pour l'extrusion des triangles. +c . . . . 1 : famille du triangle extrude . +c . . . . 2 : famille du pentaedre . +c . . . . 3 : code du triangle dans le pentaedre . +c . pcfatr . s . 1 . familles pour l'extrusion des triangles . +c . nhqufa . e . char8 . objet decrivant les familles des quad. . +c . famqua . es . nbquto . famille des quadrangles . +c . notfqu . e . 1 . nombre d'origine des carac. des f. quad. . +c . nofaqu . e . 1 . nombre d'origine de familles de quad. . +c . cofaqu . e . notfqu*. codes d'origine des familles des quad. . +c . . . nofaqu . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . posqua . e . nbquto . position des quadrangles . +c . . . . 0 : face avant . +c . . . . 1 : face arriere . +c . . . . 2 : face perpendiculaire . +c . inxqua . e .3*nbquto. informations pour l'extrusion des quads . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 1 : famille du quadrangle extrude . +c . . . . 2 : famille de l'hexaedre . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle a l'arriere : . +c . . . . 1 : inutile . +c . . . . 2 : inutile . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 1 : sens de la 1ere compos. de la normale . +c . . . . 2 : sens de la 2eme compos. de la normale . +c . . . . 3 : orientation du quadrangle dans le vol.. +c . pcfaqu . s . 1 . familles pour l'extrusion des quadrangles . +c . pcfahe . es . 1 . codes des familles des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEX2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nbfami.h" +#include "dicfen.h" +#include "cofexa.h" +#include "cofexn.h" +#include "cofext.h" +#include "cofexq.h" +c +c 0.3. ==> arguments +c + integer maconf +c + integer pcfano + integer pcfaar + integer pcfatr + integer pcfaqu + integer pcfape +c + integer famnoe(nbnoto), notfno, nofano, cofano(notfno,nofano) + integer posnoe(nbnoto), inxnoe(2,nbnoto) + integer famare(nbarto), notfar, nofaar, cofaar(notfar,nofaar) + integer posare(nbarto), inxare(4,nbarto) + integer famtri(nbtrto), notftr, nofatr, cofatr(notftr,nofatr) + integer postri(nbtrto), inxtri(3,nbtrto) + integer famqua(nbquto), notfqu, nofaqu, cofaqu(notfqu,nofaqu) + integer posqua(nbquto), inxqua(3,nbquto) + integer pcfahe +c + character*8 nhnofa, nharfa, nhtrfa, nhqufa + character*8 nhpefa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ +49900 format(/,24x,a) + write(ulsort,49900) ' famille fa noe ex fa arete' + do 4991 , iaux = 1 , nbnoto + if ( posnoe(iaux).eq.0 ) then + write(ulsort,90012) 'noeud',iaux,famnoe(iaux), + > inxnoe(1,iaux),inxnoe(2,iaux) + endif + 4991 continue +c + write(ulsort,49900) + > ' famille fa are ex fa quad code q/vo face perp' + do 4992 , iaux = 1 , nbarto + if ( posare(iaux).eq.0 ) then + write(ulsort,90012) 'arete',iaux,famare(iaux), + > inxare(1,iaux),inxare(2,iaux),inxare(3,iaux),inxare(4,iaux) + endif + 4992 continue +c + if ( nbtrto.ne.0 ) then + write(ulsort,49900) 'famille fa tri ex fa pent code t/pe' + do 4993 , iaux = 1 , nbtrto + if ( postri(iaux).eq.0 ) then + write(ulsort,90012) 'tria',iaux,famtri(iaux), + > inxtri(1,iaux),inxtri(2,iaux),inxtri(3,iaux) + endif + 4993 continue + endif +c + write(ulsort,49900) + >'famille position fa qua ex fa hexa code q/vo' + do 4994 , iaux = 1 , nbquto + write(ulsort,90012) 'quad',iaux,famqua(iaux),posqua(iaux), + > inxqua(1,iaux),inxqua(2,iaux),inxqua(3,iaux) + 4994 continue +#endif +c +c==== +c 2. Phase 1 : famille des entites sur la face avant +c==== +c 2.1. ==> Traitement des noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = -1 + jaux = -1 + kaux = 2 + nctfno = nctfno + ncxfno +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME21-noe', nompro +#endif + call vcme21 ( iaux, jaux, + > kaux, nctfno, nbnoto, + > notfno, nofano, cofano, + > nhnofa, famnoe, posnoe, inxnoe, + > nbfnoe, pcfano, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Traitement des aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = -1 + kaux = 4 + nctfar = nctfar + ncxfar +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME21-are', nompro +#endif + call vcme21 ( iaux, jaux, + > kaux, nctfar, nbarto, + > notfar, nofaar, cofaar, + > nharfa, famare, posare, inxare, + > nbfare, pcfaar, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> Traitement des triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = cofxto + kaux = 3 + nctftr = nctftr + ncxftr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME21-tri', nompro +#endif + call vcme21 ( iaux, jaux, + > kaux, nctftr, nbtrto, + > notftr, nofatr, cofatr, + > nhtrfa, famtri, postri, inxtri, + > nbftri, pcfatr, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.4. ==> Traitement des quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = cofxqo + kaux = 3 + nctfqu = nctfqu + ncxfqu +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME21-qua', nompro +#endif + call vcme21 ( iaux, jaux, + > kaux, nctfqu, nbquto, + > notfqu, nofaqu, cofaqu, + > nhqufa, famqua, posqua, inxqua, + > nbfqua, pcfaqu, + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx(nompro//' - apres Phase 1, noeuds', nhnofa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 1, aretes', nharfa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 1, trias', nhtrfa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 1, quads', nhqufa//'.Codes' ) +c +c==== +c 3. Phase 2 : Traitement des relations hexaedres/pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. hexa/pent ; codret', codret +#endif +c + if ( ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) .and. + > nbheto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME23', nompro +#endif + call vcme23 ( nhpefa, + > pcfaqu, + > pcfahe, + > pcfape, + > ulsort, langue, codret ) +c + endif +c + endif +c +cgn call gmprsx(nompro//' - apres Phase 2, quads', nhqufa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 2, aretes', nhpefa//'.Codes' ) +c +c==== +c 4. Phase 3 : relation face avant / face arriere +c==== +c 4.1. ==> Traitement des noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = -1 + jaux = cofxnt + kaux = cofxnp +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME25-noe', nompro +#endif + call vcme25 ( iaux, + > nctfno, ncffno, jaux, kaux, + > notfno, nofano, cofano, + > nhnofa, + > nbfnoe, pcfano, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> Traitement des aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = cofxat + kaux = cofxap +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME25-are', nompro +#endif + call vcme25 ( iaux, + > nctfar, ncffar, jaux, kaux, + > notfar, nofaar, cofaar, + > nharfa, + > nbfare, pcfaar, + > ulsort, langue, codret ) +c + endif +c +c 4.3. ==> Traitement des triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = cofxtt + kaux = cofxtp +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME25-tri', nompro +#endif + call vcme25 ( iaux, + > nctftr, ncfftr, jaux, kaux, + > notftr, nofatr, cofatr, + > nhtrfa, + > nbftri, pcfatr, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.4. ==> Traitement des quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. quadrangles ; codret', codret +#endif +c + if ( nbquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = cofxqt + kaux = cofxqp +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME25-qua', nompro +#endif + call vcme25 ( iaux, + > nctfqu, ncffqu, jaux, kaux, + > notfqu, nofaqu, cofaqu, + > nhqufa, + > nbfqua, pcfaqu, + > ulsort, langue, codret ) +c + endif +c + endif +c +cgn call gmprsx(nompro//' - apres Phase 3, noeuds', nhnofa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 3, aretes', nharfa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 3, trias', nhtrfa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 3, quads', nhqufa//'.Codes' ) +c +c==== +c 5. Phase 4 : Traitement des relations quadrangles/triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. quad/tria ; codret', codret +#endif +c + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME27', nompro +#endif + call vcme27 ( notftr, nofatr, cofatr, + > nhtrfa, + > pcfatr, + > pcfaqu, + > pcfahe, + > ulsort, langue, codret ) +c + endif +c + endif +c +cgn call gmprsx(nompro//' - apres Phase 4, trias', nhtrfa//'.Codes' ) +cgn call gmprsx(nompro//' - apres Phase 4, quads', nhqufa//'.Codes' ) +c +c==== +c 6. Phase 5 : relation face avant / face perpendiculaire +c==== +c 6.1. ==> Traitement de l'extrusion des noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME29', nompro +#endif + call vcme29 ( nofaar, cofaar, + > imem(pcfano), + > nharfa, + > pcfaar, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> Traitement de l'extrusion des aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCME31', nompro +#endif + call vcme31 ( nofaqu, cofaqu, + > nharfa, pcfaar, famare, posare, inxare, + > nhqufa, pcfaqu, inxqua, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmexa.F b/src/tool/AV_Conversion/vcmexa.F new file mode 100644 index 00000000..3c6bb2e5 --- /dev/null +++ b/src/tool/AV_Conversion/vcmexa.F @@ -0,0 +1,359 @@ + subroutine vcmexa ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase A +c - - - -- - +c Pour un maillage non initial +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEXA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envex1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux + integer tbiaux(1) + integer codre1, codre2, codre3, codre4 + integer codre0 + integer ptrav5, ptrav6, ptrav7, ptrav8 + integer pcoono, pareno, phetno, adcocs + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer paretr, phettr, pfiltr, ppertr, pnivtr, adnmtr, adpetr + integer parequ, phetqu, pfilqu, pperqu, pnivqu, adnmqu, adhequ + integer phethe, pquahe, pcoquh + integer phetpe, pfacpe, pcofap + integer pposif, pfacar +c + integer adnohn, adnocn + integer adtrhn, adtrcn + integer adquhn, adqucn +c + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamhe, pcfahe + integer pfampe, pcfape + integer nbqure + integer nbtrre + integer nbarre + integer nbnore + integer nbp2re, nbimre + integer adhono, adhoar, adhotr, adhoqu +c + character*6 saux + character*9 saux09 + character*8 nomail + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhhexa, nhpent + character*8 norenu + character*8 ntrav5, ntrav6, ntrav7, ntrav8 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( taopti(11).eq.26 ) then + saux09 = 'SATURNE ' + elseif ( taopti(11).eq.46 ) then + saux09 = 'NEPTUNE ' + else + if ( langue.eq.1 ) then + saux09 = 'EXTRUSION' + else + saux09 = 'EXTRUSION' + endif + endif +c + texte(1,4) = + > '(/,a6,1x,'''//saux09//' - PASSAGE DU MAILLAGE 3D EN 2D'')' + texte(1,5) = '(47(''=''),/)' +c + texte(2,4) = '(/,a6,1x,'''//saux09//' - FROM 3D MESH TO 2D'')' + texte(2,5) = '(37(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. les structures de base +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. structures de base ; codret', codret +#endif +c +c 2.1. ==> Le maillage 3D au format HOMARD +c + nomail = taopts(3) +c +c 2.2. ==> Les adresses +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. adresses ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = taopti(39) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXB', nompro +#endif + call vcmexb ( nomail, iaux, + > phetno, + > pcoono, pareno, adhono, adcocs, + > adnohn, adnocn, + > phetar, psomar, pfilar, pmerar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, + > pnivtr, adnmtr, adhotr, adpetr, + > adtrhn, adtrcn, + > phetqu, parequ, pfilqu, pperqu, + > pnivqu, adnmqu, adhoqu, adhequ, + > adquhn, adqucn, + > phethe, pquahe, pcoquh, + > phetpe, pfacpe, pcofap, + > pfamno, pcfano, + > pfammp, pcfamp, + > pfamar, pcfaar, + > pfamtr, pcfatr, + > pfamqu, pcfaqu, + > pfamhe, pcfahe, + > pfampe, pcfape, + > pposif, pfacar, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Tableaux de travail +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. Tableaux de travail ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav5, 'entier ', nbnoto, ptrav5, codre1 ) + call gmalot ( ntrav6, 'entier ', nbarto, ptrav6, codre2 ) + call gmalot ( ntrav7, 'entier ', nbtrto, ptrav7, codre3 ) + call gmalot ( ntrav8, 'entier ', nbquto, ptrav8, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. Reperage du positionnement des entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reperage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEX0', nompro +#endif + call vcmex0 ( iaux, + > rmem(adcocs), + > rmem(pcoono), imem(ptrav5), + > imem(psomar), imem(ptrav6), + > imem(paretr), imem(ptrav7), + > imem(parequ), imem(ptrav8), tbiaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ('Position des noeuds :', ntrav5) + call gmprsx ('Position des aretes :', ntrav6) + call gmprsx ('Position des triangles :', ntrav7) + call gmprsx ('Position des quadrangles :', ntrav8) +#endif +c + endif +c +c==== +c 4. Destruction des entites inutiles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. destruction ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXD', nompro +#endif + call vcmexd ( nomail, + > nhnoeu, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > imem(ptrav5), nbnore, nbp2re, nbimre, + > imem(phetno), rmem(pcoono), + > imem(pareno), imem(adhono), + > imem(adnocn), imem(adnohn), + > imem(ptrav6), nbarre, + > imem(phetar), imem(psomar), imem(pmerar), imem(pfilar), + > imem(pnp2ar), imem(adhoar), + > imem(pposif), imem(pfacar), + > imem(ptrav7), nbtrre, + > imem(phettr), imem(paretr), imem(ppertr), imem(pfiltr), + > imem(pnivtr), imem(adpetr), imem(adnmtr), imem(adhotr), + > imem(adtrcn), imem(adtrhn), + > imem(ptrav8), nbqure, + > imem(phetqu), imem(parequ), imem(pperqu), imem(pfilqu), + > imem(pnivqu), imem(adhequ), imem(adnmqu), + > imem(adqucn), imem(adquhn), + > rmem(adcocs), + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pcfahe), + > imem(pcfape), + > ulsort, langue, codret) +c + endif +c +c==== +c 5. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav5 , codre1 ) + call gmlboj ( ntrav6 , codre2 ) + call gmlboj ( ntrav7 , codre3 ) + call gmlboj ( ntrav8 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 11. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmexb.F b/src/tool/AV_Conversion/vcmexb.F new file mode 100644 index 00000000..0086c502 --- /dev/null +++ b/src/tool/AV_Conversion/vcmexb.F @@ -0,0 +1,506 @@ + subroutine vcmexb ( nomail, maext0, + > phetno, + > pcoono, pareno, adhono, adcocs, + > adnohn, adnocn, + > phetar, psomar, pfilar, pmerar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, + > pnivtr, adnmtr, adhotr, adpetr, + > adtrhn, adtrcn, + > phetqu, parequ, pfilqu, pperqu, + > pnivqu, adnmqu, adhoqu, adhequ, + > adquhn, adqucn, + > phethe, pquahe, pcoquh, + > phetpe, pfacpe, pcofap, + > pfamno, pcfano, + > pfammp, pcfamp, + > pfamar, pcfaar, + > pfamtr, pcfatr, + > pfamqu, pcfaqu, + > pfamhe, pcfahe, + > pfampe, pcfape, + > pposif, pfacar, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase B +c - - - -- - +c Recuperation des adresses +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEXB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envada.h" +#include "envex1.h" +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nbfami.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer maext0 + integer phetno, pcoono, pareno, adcocs + integer phetar, psomar, pfilar, pmerar, pnp2ar + integer phettr, paretr, pfiltr, ppertr, pnivtr, adnmtr, adpetr + integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu, adhequ + integer phethe, pquahe, pcoquh + integer phetpe, pfacpe, pcofap + integer pposif, pfacar +c + integer adnohn, adnocn + integer adtrhn, adtrcn + integer adquhn, adqucn +c + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamhe, pcfahe + integer pfampe, pcfape + integer adhono, adhoar, adhotr, adhoqu +c + character*8 nomail + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhhexa, nhpent + character*8 norenu + character*8 nhvois +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer tbiaux(1) +c + character*8 nhtetr, nhpyra + character*8 nhelig + character*8 nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Gestion de la memoire'')' +c + texte(2,4) = '(''Memory management'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. la structure generale +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. structures gale ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. Tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. ==> tableaux ; codret', codret + call dmflsh(iaux) +#endif +c +c 3.1. ==> Les noeuds +c + if ( codret.eq.0 ) then +c + iaux = 3990 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, adhono, adcocs, + > ulsort, langue, codret ) +c +c 3.2. ==> Les entites +c + if ( nbfmpo.ne.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + call utad02 ( iaux, nhmapo, + > jaux, jaux, jaux, jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + iaux = 7770 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( nbtrto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( nbiter.ge.1 ) then + iaux = iaux*13 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, adpetr, jaux, + > adnmtr, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c + iaux = 37 + if ( nbquto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( nbiter.ge.1 ) then + iaux = iaux*13 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, pcfaqu, jaux, + > pnivqu, adhequ, jaux, + > adnmqu, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfhex.ne.0 ) then +c + iaux = 37 + if ( nbheto.ne.0 ) then + iaux = iaux*182 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpen.ne.0 ) then +c + iaux = 37 + if ( nbpeto.ne.0 ) then + iaux = iaux*182 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.3. ==> Les voisinages +c + if ( codret.eq.0 ) then +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> Les liens triangle/pentaedre et quadrangle/hexaedre +c + if ( nbiter.eq.0 ) then +c + if ( nbftri.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 13 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_tr', nompro +#endif + call utal02 ( iaux, jaux, + > nhtria, nbtrto, 0, + > kaux, kaux, kaux, kaux, + > kaux, kaux, + > kaux, adpetr, kaux, + > kaux, kaux, kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbfqua.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 13 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro +#endif + call utal02 ( iaux, jaux, + > nhquad, nbquto, 0, + > kaux, kaux, kaux, kaux, + > kaux, kaux, + > kaux, adhequ, kaux, + > kaux, kaux, kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. Rableaux lies a la renumerotation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. renumerotation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > renoac, renoto, adnohn, adnocn, + > ulsort, langue, codret) +c + endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > retrac, retrto, adtrhn, adtrcn, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > requac, requto, adquhn, adqucn, + > ulsort, langue, codret) +c + endif +c +c==== +c 5. Impressions des familles d'origine +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Impressions familles ; codret', codret +#endif +c + nbftet = 0 + nbfpyr = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE - initial', nompro +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call utecfe ( maext0, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > tbiaux, tbiaux, + > imem(pfamhe), imem(pcfahe), + > tbiaux, tbiaux, + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmexd.F b/src/tool/AV_Conversion/vcmexd.F new file mode 100644 index 00000000..e7f93cd3 --- /dev/null +++ b/src/tool/AV_Conversion/vcmexd.F @@ -0,0 +1,744 @@ + subroutine vcmexd ( nomail, + > nhnoeu, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > disnoe, nbnore, nbp2re, nbimre, + > hetnoe, coonoe, + > arenoe, homnoe, + > nnoeca, nnoeho, + > disare, nbarre, + > hetare, somare, merare, filare, + > np2are, homare, + > posifa, facare, + > distri, nbtrre, + > hettri, aretri, pertri, filtri, + > nivtri, pentri, nintri, homtri, + > ntreca, ntreho, + > disqua, nbqure, + > hetqua, arequa, perqua, filqua, + > nivqua, hexqua, ninqua, + > nqueca, nqueho, + > coocst, + > famnoe, cfanoe, + > fammpo, cfampo, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > cfahex, + > cfapen, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXtrude - phase D +c - - - -- - +c Destruction des entites 3D +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disnoe . e . nbnoto . indicateurs de disparition des noeuds . +c . disare . e . nbarto . indicateurs de disparition des aretes . +c . distri . e . nbtrto . indicateurs de disparition des triangles . +c . disqua . e . nbquto . indicateurs de disparition des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEXD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nouvnb.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer disnoe(nbnoto), nbnore + integer nbp2re, nbimre + integer hetnoe(nbnoto) + integer arenoe(nouvno), homnoe(nouvno) + integer nnoeca(nouvno), nnoeho(*) + integer disare(nbarto), nbarre + integer hetare(nbarto), somare(2,nouvar) + integer merare(nouvar), filare(nouvar) + integer homare(nouvar) + integer np2are(nouvar) + integer posifa(0:nbarto), facare(nbfaar) + integer distri(nbtrto), nbtrre + integer hettri(nouvtr), aretri(nouvtr,3) + integer pertri(nouvtr), filtri(nouvtr) + integer nivtri(nouvtr), pentri(nbtrto), nintri(nouvtr) + integer homtri(nouvtr) + integer ntreca(nouvtr), ntreho(*) + integer disqua(nbquto), nbqure + integer hetqua(nouvqu), arequa(nouvqu,4) + integer perqua(nouvqu), filqua(nouvqu) + integer nivqua(nouvqu), hexqua(nbquto), ninqua(nouvqu) + integer nqueca(nouvqu), nqueho(*) +c + integer famnoe(nouvno), cfanoe(nctfno,nbfnoe) + integer fammpo(*), cfampo(nctfmp,nbfmpo) + integer famare(nouvar), cfaare(nctfar,nbfare) + integer famtri(nouvtr), cfatri(nctftr,nbftri) + integer famqua(nouvqu), cfaqua(nctfqu,nbfqua) + integer cfahex(nctfhe,nbfhex) + integer cfapen(nctfpe,nbfpen) +c + character*8 nomail, norenu + character*8 nhnoeu, nharet, nhtria, nhquad + character*8 nhhexa, nhpent +c + double precision coonoe(nouvno,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer tbiaux(1) + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer pcoono, pareno, phetno + integer adnoho, adnoca + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer paretr, phettr, pfiltr, ppertr, pnivtr, adpetr, adnmtr + integer adtrho, adtrca + integer parequ, phetqu, pfilqu, pperqu, pnivqu, adhequ, adnmqu + integer adquho, adquca + integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche + integer adnmhe + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe + integer pposif, pfacar + integer pfamno + integer pfamar + integer pfamtr + integer pfamqu + integer pfamte + integer pfamhe + integer pfampe + integer pfampy + integer pancqu + integer panctr + integer pancar + integer pancno + integer adhono, adhoar, adhotr, adhoqu +c + integer voarno, vofaar, vovoar, vovofa + integer ppovos, pvoiso +c + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno, nbtaan, nbtano + integer nbhean, nbheno, nbhaan, nbhano + integer nbpyan, nbpyno, nbyaan, nbyano + integer nbpean, nbpeno, nbpaan, nbpano +c + character*8 nhvois + character*8 nhenti +c + double precision dmin, dmax +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Destruction des entites inutiles'')' +c + texte(2,4) = '(''Removal of useless entities'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nomail ) + call gmprsx ( nompro, nomail//'.Volume' ) +#endif +c +c==== +c 2. Tableaux utilitaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Tableaux utilitaires ; codret', codret +#endif +c + nouvno = nbnoto + call gmaloj ( nhnoeu//'.Deraffin', ' ', nouvno, pancno, codre1 ) + nouvar = nbarto + call gmaloj ( nharet//'.Deraffin', ' ', nouvar, pancar, codre2 ) + nouvtr = nbtrto + call gmaloj ( nhtria//'.Deraffin', ' ', nouvtr, panctr, codre3 ) + nouvqu = nbquto + call gmaloj ( nhquad//'.Deraffin', ' ', nouvqu, pancqu, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +c==== +c 3. Suppression des entites inutiles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Suppression ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'utsuex', nompro +#endif + call utsuex ( disnoe, imem(pancno), nbnore, nbp2re, nbimre, + > hetnoe, + > famnoe, arenoe, homnoe, + > nnoeca, nnoeho, + > coonoe, + > disare, imem(pancar), nbarre, + > hetare, somare, merare, filare, + > famare, np2are, homare, + > posifa, facare, + > distri, imem(panctr), nbtrre, + > hettri, aretri, pertri, filtri, + > famtri, nivtri, pentri, nintri, homtri, + > ntreca, ntreho, + > disqua, imem(pancqu), nbqure, + > hetqua, arequa, perqua, filqua, + > famqua, nivqua, hexqua, ninqua, + > nqueca, nqueho, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. mise a jour avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. mise a jour ; codret', codret +#endif +c +c 4.1. ==> Nombres ancien/nouveau +c + if ( codret.eq.0 ) then +c + nbnoan = nbnoto + nbnono = nbnore +c + nbaran = nbarto + nbarno = nbarre +c + nbtran = nbtrto + nbtrno = nbtrre +c + nbquan = nbquto + nbquno = nbqure +c + nbtean = 0 + nbteno = 0 +c + nbhean = nbheto + nbheno = 0 +c + nbpean = nbpeto + nbpeno = 0 +c + nbpyan = 0 + nbpyno = 0 +c + endif +c +c 4.2. ==> noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. ==> noeuds, codret', codret + write (ulsort,90002) 'nbnoan', nbnoan + write (ulsort,90002) 'nbnono', nbnono +#endif +c + if ( codret.eq.0 ) then +c + iaux = 210 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + call utad05 ( iaux, jaux, nhnoeu, + > nbnoan, nbnono, sdim, + > phetno, + > pfamno, + > pcoono, pareno, adhono, jaux, + > ulsort, langue, codret ) +c + call gmecat ( nhnoeu, 1, nbnono, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 4.3. ==> Les entites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. ==> entites, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD98', nompro +#endif + call utad98 ( nomail, iaux, jaux, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, nbtaan, nbtano, + > nbhean, nbheno, nbhaan, nbhano, + > nbpyan, nbpyno, nbyaan, nbyano, + > nbpean, nbpeno, nbpaan, nbpano, + > phetar, psomar, pfilar, pmerar, pancar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, panctr, + > pnivtr, adpetr, adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pancqu, + > pnivqu, adhequ, adnmqu, adhoqu, + > phette, ptrite, pcotrt, parete, + > pfilte, pperte, pancte, + > phethe, pquahe, pcoquh, parehe, + > pfilhe, pperhe, panche, adnmhe, + > phetpy, pfacpy, pcofay, parepy, + > pfilpy, pperpy, pancpy, + > phetpe, pfacpe, pcofap, parepe, + > pfilpe, pperpe, pancpe, + > pfamar, pfamtr, pfamqu, + > pfamte, pfamhe, pfampy, pfampe, + > ulsort, langue, codret ) +c + endif +c +c 4.4. ==> Les renumerotations +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. ==> renumerotations, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = -1 + jaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02 - noe', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > renoac, nbnoan, renoac, nbnono, + > adnoho, adnoca, + > ulsort, langue, codret ) +c + endif +c + if ( retrac.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02 - tri', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > retrac, nbtran, retrac, nbtrno, + > adtrho, adtrca, + > ulsort, langue, codret ) +c + endif +c + endif +cgn call gmprsx(nompro, norenu//'.TrCalcul') +cgn call gmprsx(nompro, norenu//'.TrHOMARD') +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE02 - qua', nompro +#endif + call utre02 ( iaux, jaux, norenu, + > requac, nbquan, requac, nbquno, + > adquho, adquca, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx(nompro, norenu//'.QuCalcul') +cgn call gmprsx(nompro, norenu//'.QuHOMARD') +c +c 4.5. ==> Rearrangement des coordonnees +c Attention a fonctionner avec le pointeur car le +c tableau coonoe a ete raccourci par utsuex +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.5. coordonnees ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maextr', maextr + write (ulsort,90002) 'nbnore', nbnore +#endif +c +c 4.5.1. ==> Si l'extrusion a lieu selon X, on decale +c les coordonnees Y et Z +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ( nompro//' - noeuds', nhnoeu//'.CoorCons' ) +cgn call gmprsx ( nompro//' - noeuds', nhnoeu//'.Coor' ) +c + if ( maextr.eq.1 ) then +c + jaux = pcoono - 1 + kaux = pcoono - 1 + nbnore + laux = pcoono - 1 + 2*nbnore + do 451 , iaux = 1 , nbnore + rmem(jaux+iaux) = rmem(kaux+iaux) + rmem(kaux+iaux) = rmem(laux+iaux) + 451 continue +c + dmin = coocst(2) + dmax = coocst(5) + coocst(2) = coocst(3) + coocst(3) = coocst(4) + coocst(5) = coocst(6) + coocst(6) = coocst(7) + coocst(8) = coocst(9) + coocst(9) = coocst(10) + coocst(10) = -1.d0 +c +c 4.5.2. ==> Si l'extrusion a lieu selon Y, on decale la coordonnee Z +c + elseif ( maextr.eq.2 ) then +c + jaux = pcoono - 1 + nbnore + kaux = pcoono - 1 + 2*nbnore + do 452 , iaux = 1 , nbnore + rmem(jaux+iaux) = rmem(kaux+iaux) + 452 continue +c + dmin = coocst(3) + dmax = coocst(6) + coocst(3) = coocst(4) + coocst(6) = coocst(7) + coocst(9) = coocst(10) + coocst(10) = -1.d0 +c +c 4.5.3. ==> Si l'extrusion a lieu selon Z, on memorise la coordonnee Z +c + else +c + dmin = coocst(4) + dmax = coocst(7) +c + endif +c +c 4.5.4. ==> Memorisation de la coordonnee d'extrusion +c + coocst(4) = dmin + coocst(7) = dmax +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'dmin', dmin + write (ulsort,90004) 'dmax', dmax + call gmprsx ( nompro//' - noeuds', nhnoeu//'.CoorCons' ) +#endif +c +c 4.5.5. ==> Dimension du tableau des coordonnees +c + if ( codret.eq.0 ) then +c + call gmmod ( nhnoeu//'.Coor', + > pcoono, nbnore, nbnore, 3, 2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c==== +c 5. Suppression des familles des volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. familles des volumes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 51 , laux = 6, 7 +c + if ( codret.eq.0 ) then +c + if ( laux.eq.6 ) then + kaux = nbfhex + nhenti = nhhexa + elseif ( laux.eq.7 ) then + kaux = nbfpen + nhenti = nhpent + endif +c + if ( kaux.ne.0 ) then +c + iaux = 2 + jaux = laux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD08', nompro +#endif + call utad08 ( jaux, iaux, nhenti, + > ulsort, langue, codret ) +c + endif +c + endif +c + 51 continue +c + endif +c +c==== +c 6. Nombres (cf. cmmisa) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Nombres ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + nbnop1 = nbnore - nbp2re - nbimre - nbnomp - nbnoei - nbnois + nbnop2 = nbp2re + nbnoim = nbimre + nbnoma = nbnore + nbnoto = nbnore +c + nbarac = nbarre + nbarma = nbarre + nbarpe = nbarre + nbarto = nbarre +c + nbtrac = nbtrre + nbtrpe = nbtrre + nbtrto = nbtrre +c + nbquac = nbqure + nbqupe = nbqure + nbquto = nbqure +c + nbheto = 0 + nbheac = 0 + nbhema = 0 + nbhepe = 0 + nbhecf = 0 +c + nbpeto = 0 + nbpeac = 0 + nbpema = 0 + nbpepe = 0 + nbpecf = 0 +c + sdim = 2 + mdim = 2 +c + call gmecat ( nomail, 1, sdim, codre1 ) + call gmecat ( nomail, 2, mdim, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + call gmecat ( nharet, 1, nbarto, codre1 ) + call gmecat ( nhtria, 1, nbtrto, codre2 ) + call gmecat ( nhquad, 1, nbquto, codre3 ) + call gmecat ( nhhexa, 1, nbheto, codre4 ) + call gmecat ( nhpent, 1, nbpeto, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'nbheto', nbheto + write (ulsort,90002) 'nbpeto', nbpeto +cgn call gmprsx ( nompro//' - noeuds', nhnoeu ) +cgn call gmprsx ( nompro//' - noeuds', nhnoeu//'.Coor' ) +cgn call gmprsx ( nompro//' - aretes', nharet ) +cgn call gmprsx ( nompro//' - aretes', nharet//'.ConnDesc' ) +cgn call gmprsx ( nompro//' - triangles', nhtria ) +cgn call gmprsx ( nompro//' - triangles', nhtria//'.ConnDesc' ) +cgn call gmprsx ( nompro//' - quadrangles', nhquad ) +cgn call gmprsx ( nompro//' - quadrangles', nhquad//'.Famille' ) +cgn call gmprsx ( nompro//' - quadrangles', nhquad//'.ConnDesc' ) +cgn call gmprsx ( nompro//' - quadrangles', nhquad//'.HistEtat' ) +cgn call gmprsx ( nompro//' - quadrangles', nhquad//'.Fille' ) +#endif +c +c==== +c 7. mise a jour des voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. voisinages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( homolo.ne.0 ) then + voarno = 2 + else + voarno = 0 + endif + voarno = -1 + vofaar = 2 + vovoar = -1 + vovofa = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 8. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( nhnoeu//'.Deraffin', codre1 ) + call gmlboj ( nharet//'.Deraffin', codre2 ) + call gmlboj ( nhtria//'.Deraffin', codre3 ) + if ( nbquto.ne.0 ) then + call gmlboj ( nhquad//'.Deraffin', codre4 ) + else + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE - final', nompro +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call utecfe ( maextr, + > famnoe, cfanoe, + > fammpo, cfampo, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > tbiaux, tbiaux, + > tbiaux, cfahex, + > tbiaux, tbiaux, + > tbiaux, cfapen, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmext.F b/src/tool/AV_Conversion/vcmext.F new file mode 100644 index 00000000..100dea3a --- /dev/null +++ b/src/tool/AV_Conversion/vcmext.F @@ -0,0 +1,572 @@ + subroutine vcmext ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage EXTrude +c - - - --- +c Pour un maillage initial +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMEXT' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envex1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nbfami.h" +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer ptrav1, ptrav2, ptrav3, ptrav4 + integer ptrav5, ptrav6, ptrav7, ptrav8 + integer pcoono, pareno, phetno, adcocs + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer paretr, phettr, pfiltr, ppertr, pnivtr, adnmtr, adpetr + integer parequ, phetqu, pfilqu, pperqu, pnivqu, adnmqu, adhequ + integer phethe, pquahe, pcoquh + integer phetpe, pfacpe, pcofap + integer pposif, pfacar +c + integer adnohn, adnocn + integer adtrhn, adtrcn + integer adquhn, adqucn +c + integer pfamno, pcfano, pcofno + integer pfammp, pcfamp + integer pfamar, pcfaar, pcofar + integer pfamtr, pcfatr, pcoftr + integer pfamqu, pcfaqu, pcofqu + integer pfamhe, pcfahe + integer pfampe, pcfape + integer nbqure + integer nbtrre + integer nbarre + integer nbnore + integer nbp2re, nbimre + integer nbfent + integer adhono, adhoar, adhotr, adhoqu + integer notfno, notfar, notftr, notfqu + integer nofano, nofaar, nofatr, nofaqu +c + character*6 saux + character*9 saux09 + character*8 nomail + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhhexa, nhpent + character*8 norenu + character*8 nhnofa, nharfa, nhtrfa, nhqufa + character*8 nhpefa + character*8 nhenti, nhenfa + character*8 ntrav1, ntrav2, ntrav3, ntrav4 + character*8 ntrav5, ntrav6, ntrav7, ntrav8 + character*8 nforfa(-1:4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( taopti(11).eq.26 ) then + saux09 = 'SATURNE ' + elseif ( taopti(11).eq.46 ) then + saux09 = 'NEPTUNE ' + else + if ( langue.eq.1 ) then + saux09 = 'EXTRUSION' + else + saux09 = 'EXTRUSION' + endif + endif +c + texte(1,4) = + > '(/,a6,1x,'''//saux09//' - PASSAGE DU MAILLAGE 3D EN 2D'')' + texte(1,5) = '(47(''=''),/)' +c + texte(2,4) = '(/,a6,1x,'''//saux09//' - FROM 3D MESH TO 2D'')' + texte(2,5) = '(37(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. les structures de base +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. structures de base ; codret', codret +#endif +c +c 2.1. ==> Le maillage 3D au format HOMARD +c + nomail = taopts(3) +c +c 2.2. ==> Les adresses +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. adresses ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXB', nompro +#endif + call vcmexb ( nomail, iaux, + > phetno, + > pcoono, pareno, adhono, adcocs, + > adnohn, adnocn, + > phetar, psomar, pfilar, pmerar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, + > pnivtr, adnmtr, adhotr, adpetr, + > adtrhn, adtrcn, + > phetqu, parequ, pfilqu, pperqu, + > pnivqu, adnmqu, adhoqu, adhequ, + > adquhn, adqucn, + > phethe, pquahe, pcoquh, + > phetpe, pfacpe, pcofap, + > pfamno, pcfano, + > pfammp, pcfamp, + > pfamar, pcfaar, + > pfamtr, pcfatr, + > pfamqu, pcfaqu, + > pfamhe, pcfahe, + > pfampe, pcfape, + > pposif, pfacar, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Sauvegarde des familles d'origine +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. Sauvegarde familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 23 , iaux = -1, 4 +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.-1 ) then + nhenti = nhnoeu + nbfent = nbfnoe + elseif ( iaux.eq.1 ) then + nhenti = nharet + nbfent = nbfare + elseif ( iaux.eq.2 ) then + nhenti = nhtria + nbfent = nbftri + elseif ( iaux.eq.4 ) then + nhenti = nhquad + nbfent = nbfqua + else + nforfa(iaux) = blan08 + goto 23 + endif +c + call gmnomc ( nhenti//'.Famille', nhenfa, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.-1 ) then + nhnofa = nhenfa + elseif ( iaux.eq.1 ) then + nharfa = nhenfa + elseif ( iaux.eq.2 ) then + nhtrfa = nhenfa + elseif ( iaux.eq.4 ) then + nhqufa = nhenfa + endif +c + jaux = 0 + call gmcpal ( nhenfa//'.Codes', + > nforfa(iaux), jaux, kaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90012) '.. codre0123 apres phase', + > iaux, codre0, codre1, codre2, codre3 +cgn call gmprsx ( nompro, nforfa(iaux) ) +#endif +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.-1 ) then + pcofno = kaux + elseif ( iaux.eq.1 ) then + pcofar = kaux + elseif ( iaux.eq.2 ) then + pcoftr = kaux + elseif ( iaux.eq.4 ) then + pcofqu = kaux + endif +c + endif +c + 23 continue +c + endif +c +c 2.4. ==> Tableaux de travail +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. Tableaux de travail ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2*nbnoto + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + iaux = 4*nbarto + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) + iaux = 3*nbtrto + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre3 ) + iaux = 3*nbquto + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmalot ( ntrav5, 'entier ', nbnoto, ptrav5, codre1 ) + call gmalot ( ntrav6, 'entier ', nbarto, ptrav6, codre2 ) + call gmalot ( ntrav7, 'entier ', nbtrto, ptrav7, codre3 ) + call gmalot ( ntrav8, 'entier ', nbquto, ptrav8, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. Reperage du positionnement des entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reperage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEX0', nompro +#endif + call vcmex0 ( iaux, + > rmem(adcocs), + > rmem(pcoono), imem(ptrav5), + > imem(psomar), imem(ptrav6), + > imem(paretr), imem(ptrav7), + > imem(parequ), imem(ptrav8), imem(ptrav4), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ('Position des noeuds :', ntrav5) + call gmprsx ('Position des aretes :', ntrav6) + call gmprsx ('Position des triangles :', ntrav7) + call gmprsx ('Position des quadrangles :', ntrav8) +#endif +c + endif +c +c==== +c 4. Memorisation des informations pour l'extrusion +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Memorisation extrusion ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEX1', nompro +#endif + call vcmex1 ( imem(pfamno), + > imem(ptrav5), imem(ptrav1), + > imem(psomar), imem(pfamar), + > imem(ptrav6), imem(ptrav2), + > imem(pfamtr), + > imem(ptrav7), imem(ptrav3), imem(adpetr), + > imem(parequ), imem(pfamqu), + > imem(ptrav8), imem(ptrav4), imem(adhequ), + > imem(pquahe), imem(pcoquh), imem(pfamhe), + > imem(pfacpe), imem(pcofap), imem(pfampe), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ('inxnoe - noeuds :', ntrav1) + call gmprsx ('inxare - aretes :', ntrav2) + call gmprsx ('inxtri - triangles :', ntrav3) + call gmprsx ('inxqua - quadrangles :', ntrav4) +#endif +c + endif +c +c==== +c 5. Creation des tableaux de memorisation des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. creation tableaux ; codret', codret +#endif +c 5.1. ==> Les familles des pentaedres +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhpent//'.Famille', nhpefa, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +c 5.2. ==> La creation +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. creation ; codret', codret +#endif + if ( codret.eq.0 ) then +c + notfno = nctfno + notfar = nctfar + notftr = nctftr + notfqu = nctfqu +c + nofano = nbfnoe + nofaar = nbfare + nofatr = nbftri + nofaqu = nbfqua +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEX2', nompro +#endif + call vcmex2 ( + > taopti(30), + > nhnofa, imem(pfamno), notfno, nofano, imem(pcofno), + > imem(ptrav5), imem(ptrav1), pcfano, + > nharfa, imem(pfamar), notfar, nofaar, imem(pcofar), + > imem(ptrav6), imem(ptrav2), pcfaar, + > nhtrfa, imem(pfamtr), notftr, nofatr, imem(pcoftr), + > imem(ptrav7), imem(ptrav3), pcfatr, + > nhqufa, imem(pfamqu), notfqu, nofaqu, imem(pcofqu), + > imem(ptrav8), imem(ptrav4), pcfaqu, + > pcfahe, + > nhpefa, pcfape, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Destruction des entites inutiles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. destruction ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXD', nompro +#endif + call vcmexd ( nomail, + > nhnoeu, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > imem(ptrav5), nbnore, nbp2re, nbimre, + > imem(phetno), rmem(pcoono), + > imem(pareno), imem(adhono), + > imem(adnocn), imem(adnohn), + > imem(ptrav6), nbarre, + > imem(phetar), imem(psomar), imem(pmerar), imem(pfilar), + > imem(pnp2ar), imem(adhoar), + > imem(pposif), imem(pfacar), + > imem(ptrav7), nbtrre, + > imem(phettr), imem(paretr), imem(ppertr), imem(pfiltr), + > imem(pnivtr), imem(adpetr), imem(adnmtr), imem(adhotr), + > imem(adtrcn), imem(adtrhn), + > imem(ptrav8), nbqure, + > imem(phetqu), imem(parequ), imem(pperqu), imem(pfilqu), + > imem(pnivqu), imem(adhequ), imem(adnmqu), + > imem(adqucn), imem(adquhn), + > rmem(adcocs), + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pcfahe), + > imem(pcfape), + > ulsort, langue, codret) +c + endif +c +c==== +c 7. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) + call gmlboj ( ntrav3 , codre3 ) + call gmlboj ( ntrav4 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmlboj ( ntrav5 , codre1 ) + call gmlboj ( ntrav6 , codre2 ) + call gmlboj ( ntrav7 , codre3 ) + call gmlboj ( ntrav8 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + do 71 , iaux = -1, 4 +c + if ( nforfa(iaux).ne.blan08 ) then + call gmlboj ( nforfa(iaux) , codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + 71 continue +c + endif +c +cgn call gmprsx ( nompro, nhtria//'.InfoSupp' ) +cgn call gmprsx ( nompro, norenu//'.TrCalcul' ) +cgn call gmprsx ( nompro, norenu//'.TrHOMARD' ) +cgn call gmprsx ( nompro, norenu//'.PeCalcul' ) +cgn call gmprsx ( nompro, norenu//'.PeHOMARD' ) +cgn call gmprsx ( nompro, nhquad//'.InfoSupp' ) +cgn call gmprsx ( nompro, norenu//'.QuCalcul' ) +cgn call gmprsx ( nompro, norenu//'.QuHOMARD' ) +cgn call gmprsx ( nompro, norenu//'.HeCalcul' ) +cgn call gmprsx ( nompro, norenu//'.HeHOMARD' ) +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmfac.F b/src/tool/AV_Conversion/vcmfac.F new file mode 100644 index 00000000..a11b89a8 --- /dev/null +++ b/src/tool/AV_Conversion/vcmfac.F @@ -0,0 +1,1266 @@ + subroutine vcmfac ( aretri, hettri, + > filtri, pertri, nivtri, + > nintri, + > coextr, ntrsho, ntrsca, + > arequa, hetqua, + > filqua, perqua, nivqua, + > ninqua, + > coexqu, nqusho, nqusca, + > tritet, hettet, + > filtet, pertet, + > coexte, ntesho, ntesca, + > quahex, hethex, + > filhex, perhex, ninhex, + > coexhe, nhesho, nhesca, + > facpen, hetpen, + > filpen, perpen, + > coexpe, npesho, npesca, + > facpyr, hetpyr, + > filpyr, perpyr, + > coexpy, npysho, npysca, + > areele, noeele, typele, fameel, + > vofaar, povoar, prefac, dejavu, + > somare, nnosho, nnosca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - FACes +c - - - --- +c ______________________________________________________________________ +c +c but : etablit la table de connectivite des elements par face +c et initialise les tableaux lies aux faces +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretri . s .nbtr00*3. numeros des 3 aretes des triangles . +c . hettri . s . nbtr00 . historique de l'etat des triangles . +c . filtri . s . nbtr00 . premier fils des triangles . +c . pertri . s . nbtr00 . pere des triangles . +c . nivtri . s . nbtr00 . niveau des triangles . +c . nintri . s . nbtr00 . noeud interne au triangle . +c . coextr . s . nbtr00*. codes externes sur les triangles . +c . . . nctftr . 1 : famille MED . +c . . . . 2 : type de triangle . +c . ntrsho . s . rstrac . numero des triangles dans HOMARD . +c . ntrsca . s . rbtr00 . numero des triangles du calcul . +c . arequa . s .nbqu00*4. numeros des 4 aretes des quadrangles . +c . hetqua . s . nbqu00 . historique de l'etat des quadrangles . +c . filqua . s . nbqu00 . premier fils des quadrangles . +c . perqua . s . nbqu00 . pere des quadrangles . +c . nivqua . s . nbqu00 . niveau des quadrangles . +c . ninqua . s . nbqu00 . noeud interne au quadrangle . +c . coexqu . s . nbqu00*. codes externes sur les quadrangles . +c . . . nctfqu . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . nqusho . s . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . s . rbqu00 . numero des quadrangles du calcul . +c . tritet . s .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . s . nbteto . historique de l'etat des tetraedres . +c . filtet . s . nbteto . premier fils des tetraedres . +c . pertet . s . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . coexte . s . nbteto*. codes externes sur les tetraedres . +c . . . nctfte . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . ntesho . s . rsteac . numero des tetraedres dans HOMARD . +c . ntesca . s . rsteto . numero des tetraedres dans le calcul . +c . quahex . s .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . s . nbheto . historique de l'etat des hexaedres . +c . filhex . s . nbheto . premier fils des hexaedres . +c . perhex . s . nbheto . pere des hexaedres . +c . ninhex . s . nbheto . noeud interne a l'hexaedre . +c . coexhe . s . nbheto*. codes externes sur les hexaedres . +c . . . nctfhe . 1 : famille MED . +c . . . . 2 : type de hexaedres . +c . nhesho . s . rsheac . numero des hexaedres dans HOMARD . +c . nhesca . s . rsheto . numero des hexaedres dans le calcul . +c . facpen . s .nbpecf*5. numeros des 5 faces des pentaedres . +c . hetpen . s . nbpeto . historique de l'etat des pentaedres . +c . filpen . s . nbpeto . premier fils des pentaedres . +c . perpen . s . nbpeto . pere des pentaedres . +c . coexpe . s . nbpeto*. codes externes sur les pentaedres . +c . . . nctfpe . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . npesho . s . rspeac . numero des pentaedres dans HOMARD . +c . npesca . s . rspeto . numero des pentaedres dans le calcul . +c . facpyr . s .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpyr . s . nbpyto . historique de l'etat des pyramides . +c . coexpy . s . nbpyto*. codes externes sur les pyramides . +c . . . nctfpy . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . filpyr . s . nbpyto . premier fils des pyramides . +c . perpyr . s . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . npyrho . s . repyac . numero des pyramides dans HOMARD . +c . npyrca . s . * . numero des pyramides dans le calcul . +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . fameel . e . nbelem . famille med des elements . +c . vofaar . e . nvoare . voisins des aretes en stockage morse . +c . povoar . e .0:nbarto. pointeur des voisins par arete . +c . prefac . a .2*nbarto. premiere face partant d'une arete . +c . dejavu . a . 2* * . controle des doublons . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . e . rsnoto . numero des noeuds dans le calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMFAC' ) +c +#include "coftex.h" +#include "referx.h" +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "envca1.h" +#include "nbutil.h" +#include "refere.h" +#include "refert.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +#include "nomest.h" +#include "nancnb.h" +#include "envada.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer aretri(nbtr00,3), hettri(nbtr00) + integer filtri(nbtr00), pertri(nbtr00), nivtri(nbtr00) + integer nintri(nbtr00) + integer coextr(nbtr00,nctftr) + integer ntrsho(rstrac), ntrsca(rbtr00) +c + integer arequa(nbqu00,4), hetqua(nbqu00) + integer filqua(nbqu00), perqua(nbqu00), nivqua(nbqu00) + integer ninqua(nbqu00) + integer coexqu(nbqu00,nctfqu) + integer nqusho(rsquac), nqusca(rbqu00) +c + integer tritet(nbtecf,4), hettet(nbteto) + integer filtet(nbteto), pertet(nbteto) + integer coexte(nbteto,nctfte) + integer ntesho(rsteac), ntesca(rsteto) +c + integer quahex(nbhecf,6), hethex(nbheto) + integer filhex(nbheto), perhex(nbheto), ninhex(nbheto) + integer coexhe(nbheto,nctfhe) + integer nhesho(rsheac), nhesca(rsheto) +c + integer facpen(nbpecf,5), hetpen(nbpeto) + integer filpen(nbpeto), perpen(nbpeto) + integer coexpe(nbpeto,nctfpe) + integer npesho(rspeac), npesca(rspeto) +c + integer facpyr(nbpycf,5), hetpyr(nbpyto) + integer filpyr(nbpyto), perpyr(nbpyto) + integer coexpy(nbpyto,nctfpy) + integer npysho(rspyac), npysca(rspyto) +c + integer areele(nbelem,nbmaae) + integer noeele(nbelem,nbmane), typele(nbelem), fameel(nbelem) + integer vofaar(nvoare), povoar(0:nbarto), prefac(2,nbarto) + integer dejavu(2,*) + integer somare(2,nbarto) + integer nnosho(rsnoac), nnosca(rsnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux(4) + integer poinde, poinfi, point + integer nbfa, nbar, nbarfa + integer ar, aloc, bloc, cloc + integer aglmin, larete + integer f, fa, floc, nufa + integer letria, lequad, letetr, tetr, tetrae + integer hexa, lehexa, hexae + integer lepent, penta + integer lapyra, pyram + integer numloc(4), elem, typhom, nucode +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(//,''Examen de l''''arete :'',i10)' + texte(1,5) = + >'(/,''. Element voisin numero calcul'',i10,'', de type HOMARD'', + >i8)' + texte(1,6) = '(''.. Ses aretes : '',12i10)' + texte(1,7) = '(''... Examen de sa face de rang'',i2)' + texte(1,8) = '(''... Ses aretes '',a,'' : '',12i10)' + texte(1,9) = '(''... Creation du '',a,i10)' + texte(1,10) = '(''... Reperage du '',a,i10)' + texte(1,11) = '(''Les deux elements suivants sont doubles :'')' + texte(1,12) = '(''Numero dans le calcul :'',i10)' + texte(1,13) = '(''Famille MED : '',i4,'' ; type : '',i4)' + texte(1,14) = '(''Aretes (numero HOMARD) : '',6i10)' + texte(1,15) = '(''Noeuds (numero dans le calcul) : '',4i10)' +c + texte(2,4) = '(//,''Examination of edge # :'',i10)' + texte(2,5) = + > '(/,''. Neighbour element #'',i10,'', with HOMARD type'',i8)' + texte(2,6) = '(''.. Its edges : '',12i10)' + texte(2,7) = '(''... Examination of face #'',i2)' + texte(2,8) = '(''... Its edges '',a,'' : '',12i10)' + texte(2,9) = '(''... Creation of '',a,'' #'',i10)' + texte(2,10) = '(''... Tracking of '',a,'' #'',i10)' + texte(2,11) = '(/,''The following two elements are double:'')' + texte(2,12) = '(''# in calculation :'',i10)' + texte(2,13) = '(''MED family : '',i4,'' ; type : '',i4)' + texte(2,14) = '(''Edges (HOMARD #) : '',6i10)' + texte(2,15) = '(''Nodes (calculation #) : '',4i10)' +c +#include "impr03.h" +c +c 1.2. ==> mise a zero +c + codret = 0 +c + nbtrto = 0 + nbquto = 0 +c +c 1.2.1. ==> aretes +c + do 121 , larete = 1 , nbarto + prefac(1,larete) = 0 + prefac(2,larete) = 0 + 121 continue +c +c 1.2.2. ==> triangles +c + if ( nbtr00.ne.0 ) then +c + do 1221 , letria = 1 , rstrac + ntrsho(letria) = 0 + 1221 continue +c + do 1222 , nucode = 1 , nctftr + do 1223 , letria = 1 , nbtr00 + coextr(letria,nucode) = 0 + 1223 continue + 1222 continue +c + do 1224 , letria = 1 , rbtr00 + dejavu(1,letria) = 0 + 1224 continue +c + endif +c +c 1.2.3. ==> quadrangles +c + if ( nbqu00.ne.0 ) then +c + do 1231 , lequad = 1 , rsquac + nqusho(lequad) = 0 + 1231 continue +c + do 1232 , nucode = 1 , nctfqu + do 1233 , lequad = 1 , nbqu00 + coexqu(lequad,nucode) = 0 + 1233 continue + 1232 continue +c + do 1234 , lequad = 1 , rbqu00 + dejavu(2,lequad) = 0 + 1234 continue +c + endif +c +c 1.2.4. ==> tetraedres +c + if ( nbteto .ne. 0 ) then +c + do 1241 , tetr = 1 , rsteto + ntesca(tetr) = 0 + 1241 continue +c + do 1242 , tetr = 1 , rsteac + ntesho(tetr) = 0 + 1242 continue +c + do 1243 , nucode = 1 , nctfte + do 1244 , letetr = 1 , nbteto + coexte(letetr,nucode) = 0 + 1244 continue + 1243 continue +c + letetr = 0 +c + endif +c +c 1.2.5. ==> hexaedres +c + if ( nbheto .ne. 0 ) then +c + do 1251 , hexa = 1 , rsheto + nhesca(hexa) = 0 + 1251 continue +c + do 1252 , hexa = 1 , rsheac + nhesho(hexa) = 0 + 1252 continue +c + do 1253 , nucode = 1 , nctfhe + do 1254 , lehexa = 1 , nbheto + coexhe(lehexa,nucode) = 0 + 1254 continue + 1253 continue +c + lehexa = 0 +c + endif +c +c 1.2.6. ==> pentaedres +c + if ( nbpeto .ne. 0 ) then +c + do 1261 , lepent = 1 , rspeto + npesca(lepent) = 0 + 1261 continue +c + do 1262 , lepent = 1 , rspeac + npesho(lepent) = 0 + 1262 continue +c + do 1263 , nucode = 1 , nctfpe + do 1264 , lepent = 1 , nbpeto + coexpe(lepent,nucode) = 0 + 1264 continue + 1263 continue +c + lepent = 0 +c + endif +c +c 1.2.7. ==> pyramides +c + if ( nbpyto .ne. 0 ) then +c + do 1271 , lapyra = 1 , rspyto + npysca(lapyra) = 0 + 1271 continue +c + do 1272 , lapyra = 1 , rspyac + npysho(lapyra) = 0 + 1272 continue +c + do 1273 , nucode = 1 , nctfpy + do 1274 , lapyra = 1 , nbpyto + coexpy(lapyra,nucode) = 0 + 1274 continue + 1273 continue +c + lapyra = 0 +c + endif +c +c==== +c 2. on passe en revue chaque arete +c ses elements voisins sont dans le tableau vofaar, aux places +c comprises entre povoar(larete-1)+1 et povoar(larete) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto +#endif +cgn do 2222,elem=1,20 +cgn print *,elem,somare(1,elem),somare(2,elem) +cgn 2222 continue +cgn nbar = 12 +cgn elem = 1 +cgn write (ulsort,texte(langue,5)) elem, 11 +cgn write (ulsort,texte(langue,6)) (areele(elem,ar),ar=1,nbar) +cgn elem = 2 +cgn write (ulsort,texte(langue,5)) elem, 11 +cgn write (ulsort,texte(langue,6)) (areele(elem,ar),ar=1,nbar) +c + poinfi = 0 + do 21 , larete = 1 , nbarto +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( larete.gt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,4)) larete + endif +#endif +c + poinde = poinfi + 1 + poinfi = povoar(larete) +c + do 22 , point = poinde , poinfi +c + if ( codret.eq.0 ) then +c +c 2.1. ==> caracterisation de l'element +c elem : son numero global +c typhom : son type dans HOMARD +c nbar : son nombre d'aretes +c nbfa : le nombre de faces qui s'appuient sur l'arete en cours +c si c'est un element 1d, donc sans face, rien n'est a faire +c + elem = vofaar(point) + typhom = medtrf(typele(elem)) + nbar = nbaref(typhom) + nbfa = nfaref(typhom) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,5)) elem, typhom + write (ulsort,texte(langue,6)) (areele(elem,ar),ar=1,nbar) + endif +#endif +c + if ( nbfa.gt.0 ) then +c +c 2.2. ==> recherche de aloc, numero local de l'arete en cours d'examen +c vis-a-vis de la description de l'element de reference +c + do 221 , ar = 1 , nbar + if ( larete.eq.areele(elem,ar) ) then + aloc = ar + goto 2211 + endif + 221 continue +c + 2211 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. Numero local de l''arete ',larete,' : ', aloc + endif +#endif +c +c 2.3. ==> on explore toutes les faces qui s'appuient sur cette arete +c de numero local aloc +c + do 223 , f = 1 , nbfa +c +c========= debut de if ( codret.eq.0 ) debut 223 =========== + if ( codret.eq.0 ) then +c========= debut de if ( codret.eq.0 ) debut 223 =========== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,7)) f + endif +#endif +c +c 2.3.1. ==> on cherche les numeros locaux et globaux des autres aretes +c + floc = faaref(typhom,aloc,f) + nbarfa = nafref(typhom,floc) + numloc(1) = aloc +ccc write(*,*) 'dans vcmfac',typhom +c + aglmin = nbarto + do 231 , ar = 1 , nbarfa + bloc = defref(typhom,floc,ar) + if ( bloc.ne.aloc ) then + aglmin = min( aglmin, areele(elem,bloc) ) + endif + 231 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) 'aglmin = ', aglmin + endif +#endif +c +c 2.3.1.1. ==> face triangulaire +c +c========= debut de if ( nbarfa.eq.3 ) then =========== + if ( nbarfa.eq.3 ) then +c========= debut de if ( nbarfa.eq.3 ) then =========== +c + if ( defref(typhom,floc,1).eq.aloc ) then + bloc = defref(typhom,floc,2) + cloc = defref(typhom,floc,3) + else if ( defref(typhom,floc,2).eq.aloc ) then + bloc = defref(typhom,floc,3) + cloc = defref(typhom,floc,1) + else + bloc = defref(typhom,floc,1) + cloc = defref(typhom,floc,2) + endif +c + if ( areele(elem,bloc).lt.areele(elem,cloc) ) then + numloc(2) = bloc + numloc(3) = cloc + else + numloc(2) = cloc + numloc(3) = bloc + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) 'numloc', + > numloc(1), numloc(2), numloc(3) + endif +#endif +c +c 2.3.1.2. ==> face quadrangulaire +c + else +c +cccc if ( nbfa.eq.1 ) then +c + if ( defref(typhom,floc,1).eq.aloc ) then + numloc(2) = defref(typhom,floc,2) + numloc(3) = defref(typhom,floc,3) + numloc(4) = defref(typhom,floc,4) +cgn write(*,*) 1,numloc + else if ( defref(typhom,floc,2).eq.aloc ) then + numloc(2) = defref(typhom,floc,3) + numloc(3) = defref(typhom,floc,4) + numloc(4) = defref(typhom,floc,1) +cgn write(*,*) 2,numloc + else if ( defref(typhom,floc,3).eq.aloc ) then + numloc(2) = defref(typhom,floc,4) + numloc(3) = defref(typhom,floc,1) + numloc(4) = defref(typhom,floc,2) +cgn write(*,*) 3,numloc + else + numloc(2) = defref(typhom,floc,1) + numloc(3) = defref(typhom,floc,2) + numloc(4) = defref(typhom,floc,3) +cgn write(*,*) 4,numloc + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) 'numloc', + > numloc(1), numloc(2), numloc(3), numloc(4) + endif +#endif +c +cccc endif +c +c========= fin de if ( nbarfa.eq.3 ) then =========== + endif +c========= fin de if ( nbarfa.eq.3 ) then =========== +c +c 2.3.2. ==> si l'arete en cours d'examen a un numero global plus grand +c que l'une au moins des autres aretes, rien n'est a +c faire, car le traitement a deja ete fait lors de +c l'exploration de l'arete de plus petit numero global +c +c========= debut de if ( larete.lt.aglmin ) then =========== + if ( larete.lt.aglmin ) then +c========= debut de if ( larete.lt.aglmin ) then =========== +c +c 2.3.2.1. ==> si l'arete en cours d'examen a un numero global plus +c petit que les deux autres aretes, il faut d'abord +c chercher si la face contenant ces aretes n'a pas +c deja ete creee. la recherche de la face ne se fait pas +c parmi toutes les faces deja creees, mais seulement +c parmi celles qui s'appuient sur l'arete en cours. la +c premiere d'entre elles, si elle existe, est +c numerotee nufa=prefac(1/2,larete). Ce sont les +c dernieres faces qui viennent d'etre creees, donc la +c recherche est rapide car elle ne porte que sur quelques +c faces : au pire toutes celles contenant l'arete en cours. +c si on trouve cette face, on memorise son numero. +c +c attention : cela part du principe qu'a un triplet ou +c quadruplet d'aretes correspond une face et une seule. +c Donc, pas d'elements doubles. Si on libere cette +c contrainte, tout se passe bien : il y a creation d'une +c autre face au meme endroit. L'algorithme d'adaptation +c marche bien. La consequence est que sur le maillage +c raffine, les faces filles ne sont plus doubles : elles ne +c partagent que les aretes filles des aretes de bord des +c faces meres. Les aretes internes sont creees +c independamment les unes des autres. En effet, dans cmrdtr +c ou cmrdqu, on cree ces aretes en incrementant le compteur +c des aretes. Il faudrait verifier que les aretes +c n'existent pas deja. Or le tableau des voisinages est +c encore inconnu. Donc il est certainement complique. Il +c faudrait une recherche sur les aretes qui viennent d'etre +c creees mais la lourdeur du traitement meriterait qu'on le +c rende optionnel. +c +c 2.3.2.1.1. ==> face triangulaire +c + if ( nbarfa.eq.3 ) then +c + letria = 0 + nufa = prefac(1,larete) + if ( nufa.ne.0 ) then + do 2231 , fa = nufa , nbtrto + if ( aretri(fa,2).eq.areele(elem,numloc(2)) .and. + > aretri(fa,3).eq.areele(elem,numloc(3)) ) then + letria = fa + goto 2239 + endif + 2231 continue + endif +c +c 2.3.2.1.2. ==> face quadrangulaire +c + else +c + lequad = 0 + nufa = prefac(2,larete) + if ( nufa.ne.0 ) then + do 2232 , fa = nufa , nbquto + if ( arequa(fa,2).eq.areele(elem,numloc(2)) .and. + > arequa(fa,3).eq.areele(elem,numloc(3)) .and. + > arequa(fa,4).eq.areele(elem,numloc(4)) ) then + lequad = fa + goto 2239 + elseif ( arequa(fa,2).eq.areele(elem,numloc(4)) .and. + > arequa(fa,3).eq.areele(elem,numloc(3)) .and. + > arequa(fa,4).eq.areele(elem,numloc(2)) ) then + lequad = fa + goto 2239 + endif + 2232 continue + endif +c + endif +c + 2239 continue +c +c 2.3.2.2. ==> lorsque la face n'a pas ete trouvee, il faut la creer ; +c une seule caracteristique est introduite. +c si la face n'est pas un element au sens du code de +c calcul, la caracteristique est nulle et il n'y a pas de +c probleme pour la renumerotation. +c +c 2.3.2.2.1. ==> face triangulaire +c + if ( nbarfa.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( letria.eq.0 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,2), nbtrto+1 + else + write (ulsort,texte(langue,10)) mess14(langue,1,2), letria + endif + endif +#endif +c + if ( letria.eq.0 ) then + nbtrto = nbtrto + 1 + letria = nbtrto + aretri(letria,1) = larete + aretri(letria,2) = areele(elem,numloc(2)) + aretri(letria,3) = areele(elem,numloc(3)) + if ( mod(mailet,2).eq.0 ) then + nintri(letria) = 0 + endif + if ( prefac(1,larete).eq.0 ) then + prefac(1,larete) = letria + endif + if ( nbfa.ne.1 ) then + coextr(letria,cofamd) = 0 + coextr(letria,cotyel) = 0 + if ( rbtr00.ne.0 ) then + ntrsca(letria) = 0 + endif + endif + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) 'homard', aretri(letria,1), + >aretri(letria,2),aretri(letria,3) + endif +#endif +c +c 2.3.2.2.2. ==> face quadrangulaire +c + else +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( lequad.eq.0 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,4), nbquto+1 + else + write (ulsort,texte(langue,10)) mess14(langue,1,4), lequad + endif + endif +#endif +c + if ( lequad.eq.0 ) then + nbquto = nbquto + 1 + lequad = nbquto + arequa(lequad,1) = larete + arequa(lequad,2) = areele(elem,numloc(2)) + arequa(lequad,3) = areele(elem,numloc(3)) + arequa(lequad,4) = areele(elem,numloc(4)) + if ( mod(mailet,3).eq.0 ) then + ninqua(lequad) = 0 + endif + if ( prefac(2,larete).eq.0 ) then + prefac(2,larete) = lequad + endif + if ( nbfa.ne.1 ) then + coexqu(lequad,cofamd) = 0 + coexqu(lequad,cotyel) = 0 + if ( rbqu00.ne.0 ) then + nqusca(lequad) = 0 + endif + endif + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,8)) 'homard', arequa(lequad,1), + >arequa(lequad,2),arequa(lequad,3),arequa(lequad,4) + endif +#endif +c + endif +c +c 2.3.2.3. ==> si la face est un element au sens du code de calcul, il +c faut se souvenir de son type et de sa famille MED. +c attention : il faut se poser la question a chaque fois +c car la face a pu etre definie auparavant comme un bord +c d'element volumique et donc aura ete mise avec des +c caracteristiques nulles. +c en revanche, si on y est deja passe pour un autre +c element, il y a malaise : c'est un element double ! +c + if ( nbfa.eq.1 ) then +c +c 2.3.2.3.1. ==> face triangulaire +c + if ( nbarfa.eq.3 ) then +c + if ( dejavu(1,letria).ne.0 .and. + > dejavu(1,letria).ne.elem ) then +c + jaux(1) = nnosca(somare(1,areele(elem,1))) + jaux(2) = nnosca(somare(2,areele(elem,1))) + iaux = nnosca(somare(1,areele(elem,2))) + if ( iaux.ne.jaux(1) .and. iaux.ne.jaux(2) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(elem,2))) + endif + write(ulsort,texte(langue,11)) + write(ulsort,texte(langue,12)) elem + write(ulsort,texte(langue,13)) fameel(elem),typele(elem) + write(ulsort,texte(langue,14)) + > (areele(elem,iaux), iaux = 1 , nbar) + write(ulsort,texte(langue,15)) (jaux(iaux),iaux=1,3) +c + jaux(1) = nnosca(somare(1,areele(dejavu(1,letria),1))) + jaux(2) = nnosca(somare(2,areele(dejavu(1,letria),1))) + iaux = nnosca(somare(1,areele(dejavu(1,letria),2))) + if ( iaux.ne.jaux(1) .and. iaux.ne.jaux(2) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(dejavu(1,letria),2))) + endif + write(ulsort,texte(langue,12)) dejavu(1,letria) + write(ulsort,texte(langue,13)) fameel(dejavu(1,letria)), + > typele(dejavu(1,letria)) + write(ulsort,texte(langue,14)) + > (areele(dejavu(1,letria),iaux),iaux = 1,nbar) + write(ulsort,texte(langue,15)) (jaux(iaux),iaux=1,3) +c + codret = 3 +c + endif +c + if ( mod(mailet,2).eq.0 ) then + nintri(letria) = nnosho(noeele(elem,nbnref(typhom,3))) + endif + coextr(letria,cofamd) = fameel(elem) + coextr(letria,cotyel) = typele(elem) + ntrsho(elem) = letria + ntrsca(letria) = elem + dejavu(1,letria) = elem +c +c 2.3.2.3.2. ==> face quadrangulaire +c + else +c + if ( dejavu(2,lequad).ne.0 .and. + > dejavu(2,lequad).ne.elem ) then +c + jaux(1) = nnosca(somare(1,areele(elem,1))) + jaux(2) = nnosca(somare(2,areele(elem,1))) + iaux = nnosca(somare(1,areele(elem,2))) + if ( iaux.ne.jaux(1) .and. iaux.ne.jaux(2) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(elem,2))) + endif + iaux = nnosca(somare(1,areele(elem,3))) + if ( iaux.ne.jaux(3) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(elem,3))) + endif + write(ulsort,texte(langue,11)) + write(ulsort,texte(langue,12)) elem + write(ulsort,texte(langue,13)) fameel(elem),typele(elem) + write(ulsort,texte(langue,14)) + > (areele(elem,iaux), iaux = 1 , nbar) + write(ulsort,texte(langue,15)) (jaux(iaux),iaux=1,4) +c + jaux(1) = nnosca(somare(1,areele(dejavu(2,lequad),1))) + jaux(2) = nnosca(somare(2,areele(dejavu(2,lequad),1))) + iaux = nnosca(somare(1,areele(dejavu(2,lequad),2))) + if ( iaux.ne.jaux(1) .and. iaux.ne.jaux(2) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(dejavu(2,lequad),2))) + endif + iaux = nnosca(somare(1,areele(dejavu(2,lequad),3))) + if ( iaux.ne.jaux(3) ) then + jaux(3) = iaux + else + jaux(3) = nnosca(somare(2,areele(dejavu(2,lequad),3))) + endif + write(ulsort,texte(langue,12)) dejavu(2,lequad) + write(ulsort,texte(langue,13)) fameel(dejavu(2,lequad)), + > typele(dejavu(2,lequad)) + write(ulsort,texte(langue,14)) + > (areele(dejavu(2,lequad),iaux),iaux = 1,nbar) + write(ulsort,texte(langue,15)) (jaux(iaux),iaux=1,4) +c + codret = 3 +c + endif +c + if ( mod(mailet,3).eq.0 ) then + ninqua(lequad) = nnosho(noeele(elem,nbnref(typhom,3))) + endif + coexqu(lequad,cofamd) = fameel(elem) + coexqu(lequad,cotyel) = typele(elem) + nqusho(elem) = lequad + nqusca(lequad) = elem + dejavu(2,lequad) = elem +c + endif +c + endif +c +c 2.3.2.4. ==> la derniere etape consiste a completer la table de +c connectivite des elements 3d par face et le code de +c la face dans l'element. +c - si le tetraedre n'a pas encore ete vu, c'est-a-dire +c si l'element en cours n'a pas de numero dans HOMARD, +c il faut etablir un numero et memoriser la correspondance. +c - si le tetraedre a deja ete vu, on rappelle son numero +c dans HOMARD. +c ensuite, pour ce tetraedre de numero tetrae dans +c homard, on enrichit sa table de connectivite. +c numloc donne les trois numeros locaux dans l'element +c de reference des trois aretes qui definissent la +c face en cours +c (larete,areele(elem,numloc(2)),areele(elem,numloc(3))). +c lorsque le code vaut 1, la description de reference +c de la face est donnee par le triplet a1, a2, a3 dans +c cet ordre. ensuite, les changements de code sont +c transcrits via les fonctions i1, i2 et i3. +c +c 2.3.2.4.1. ==> pour un tetraedre +c + if ( typhom.eq.tyhte1 .or. typhom.eq.tyhte2 ) then +c + if ( ntesho(elem).eq.0 ) then +c + letetr = letetr + 1 + ntesca(letetr) = elem + ntesho(elem) = letetr + coexte(letetr,cofamd) = fameel(elem) + coexte(letetr,cotyel) = typele(elem) +c + tetrae = letetr +c + else +c + tetrae = ntesho(elem) +c + endif +c + tritet(tetrae,floc) = letria +c +c 2.3.2.4.2. ==> pour un hexaedre +c + elseif ( typhom.eq.tyhhe1 .or. typhom.eq.tyhhe2 ) then +c + if ( nhesho(elem).eq.0 ) then +c + lehexa = lehexa + 1 + if ( mod(mailet,5).eq.0 ) then + ninhex(lehexa) = nnosca(noeele(elem,nbnref(typhom,3))) + endif + nhesca(lehexa) = elem + nhesho(elem) = lehexa + coexhe(lehexa,cofamd) = fameel(elem) + coexhe(lehexa,cotyel) = typele(elem) +c + hexae = lehexa +c + else +c + hexae = nhesho(elem) +c + endif +c + quahex(hexae,floc) = lequad +c +c 2.3.2.4.3. ==> pour un pentaedre +c + elseif ( typhom.eq.tyhpe1 .or. typhom.eq.tyhpe2 ) then +c + if ( npesho(elem).eq.0 ) then +c + lepent = lepent + 1 + npesca(lepent) = elem + npesho(elem) = lepent + coexpe(lepent,cofamd) = fameel(elem) + coexpe(lepent,cotyel) = typele(elem) +c + penta = lepent +c + else +c + penta = npesho(elem) +c + endif +c + if ( nbarfa.eq.3 ) then +c + facpen(penta,floc) = letria +c + else +c + facpen(penta,floc) = lequad +c + endif +c +c 2.3.2.4.4. ==> pour une pyramide +c + elseif ( typhom.eq.tyhpy1 .or. typhom.eq.tyhpy2 ) then +c + if ( npysho(elem).eq.0 ) then +c + lapyra = lapyra + 1 + npysca(lapyra) = elem + npysho(elem) = lapyra + coexpy(lapyra,cofamd) = fameel(elem) + coexpy(lapyra,cotyel) = typele(elem) +c + pyram = lapyra +c + else +c + pyram = npysho(elem) +c + endif +c + if ( nbarfa.eq.3 ) then +c + facpyr(pyram,floc) = letria +c + else +c + facpyr(pyram,floc) = lequad +c + endif +c + endif +c +c========= fin de if ( larete.lt.aglmin ) then =========== + endif +c========= fin de if ( larete.lt.aglmin ) then =========== +c +c========= fin de if ( codret.eq.0 ) debut 223 =========== + endif +c========= fin de if ( codret.eq.0 ) debut 223 =========== +c + 223 continue +c + endif +c + endif +c + 22 continue +c + endif +c +cc if (larete.eq.1) stop + 21 continue +c +c==== +c 3. consequences +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. consequences ; codret = ', codret +#endif +c . on suppose que l'on part d'un macro-maillage +c . la premiere caracteristique des faces a deja ete initialisee +c on initialise les autres a 0 +c les autres prennent la valeur 0 +c . l'etat vaut 0 +c . il n'y a aucune parente +c . le niveau vaut 0 +c + nivinf = 0 + nivsup = 0 + niincf = 0 + nisucf = 0 + nancno = nbnoto + nancar = nbarto +c +c 3.1. ==> pour les triangles +c + nbtrac = nbtrto + nbtrma = nbtrto + nbtrpe = nbtrto + nbtrde = 0 + nbtrt2 = 0 + nbtrq3 = 0 + nbtrhc = 0 + nbtrpc = 0 + nbtrtc = 0 + nanctr = nbtrto +c + do 31 , letria = 1 , nbtrto + hettri(letria) = 0 + filtri(letria) = 0 + pertri(letria) = 0 + nivtri(letria) = 0 + 31 continue +c +c 3.2. ==> pour les quadrangles +c + nbquac = nbquto + nbquma = nbquto + nbqupe = nbquto + nbquq2 = 0 + nbquq5 = 0 + nbqude = 0 + nancqu = nbquto +c + do 32 , lequad = 1 , nbquto + hetqua(lequad) = 0 + filqua(lequad) = 0 + perqua(lequad) = 0 + nivqua(lequad) = 0 + 32 continue +c +c 3.3. ==> pour les tetraedres +c + nbteac = nbteto + nbtema = nbteto + nbtepe = nbteto + nbtecf = nbteto + nbteca = 0 + nbtea2 = 0 + nbtea4 = 0 + nbtede = 0 + nbtef4 = 0 + nbteh1 = 0 + nbteh2 = 0 + nbteh3 = 0 + nbteh4 = 0 + nbtep0 = 0 + nbtep1 = 0 + nbtep2 = 0 + nbtep3 = 0 + nbtep4 = 0 + nbtep5 = 0 + nbtedh = 0 + nbtedp = 0 + nancte = nbteto + nanctf = nbtecf + nancta = nbteca +c + do 33 , letetr = 1 , nbteto + hettet(letetr) = 0 + filtet(letetr) = 0 + pertet(letetr) = 0 + 33 continue +c +c 3.4. ==> pour les hexaedres +c + nbheac = nbheto + nbhema = nbheto + nbhepe = nbheto + nbhecf = nbheto + nbheca = 0 + nbhede = 0 + nbhedh = 0 + nanche = nbheto + nanchf = nbhecf + nancha = nbheca +c + do 34 , lehexa = 1 , nbheto + hethex(lehexa) = 0 + filhex(lehexa) = 0 + perhex(lehexa) = 0 + 34 continue +c +c 3.5. ==> pour les pentaedres +c + nbpeac = nbpeto + nbpema = nbpeto + nbpepe = nbpeto + nbpecf = nbpeto + nbpeca = 0 + nbpede = 0 + nbpedp = 0 + nancpe = nbpeto + nancpf = nbpecf + nancpa = nbpeca +c + do 35 , lepent = 1 , nbpeto + hetpen(lepent) = 0 + filpen(lepent) = 0 + perpen(lepent) = 0 + 35 continue +c +c 3.6. ==> pour les pyramides +c + nbpyac = nbpyto + nbpyma = nbpyto + nbpype = nbpyto + nbpycf = nbpyto + nbpyca = 0 + nbpyde = 0 + nbpyh1 = 0 + nbpyh2 = 0 + nbpyh3 = 0 + nbpyh4 = 0 + nbpyp0 = 0 + nbpyp1 = 0 + nbpyp2 = 0 + nbpyp3 = 0 + nbpyp4 = 0 + nbpyp5 = 0 + nbpydh = 0 + nbpydp = 0 + nancpy = nbpyto + nancyf = nbpycf + nancya = nbpyca +c + do 36 , lapyra = 1 , nbpyto + hetpyr(lapyra) = 0 + filpyr(lapyra) = 0 + perpyr(lapyra) = 0 + 36 continue +c +c 3.7. ==> nombres propres a la renumerotation +c + if ( rbtr00.ne.0 ) then + rstrto = nbtrto + else + rstrto = 0 + endif +c + if ( rbqu00.ne.0 ) then + rsquto = nbquto + else + rsquto = 0 + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmmen.F b/src/tool/AV_Conversion/vcmmen.F new file mode 100644 index 00000000..b0891e59 --- /dev/null +++ b/src/tool/AV_Conversion/vcmmen.F @@ -0,0 +1,295 @@ + subroutine vcmmen ( nbeled, nbelef, + > nbmaid, nbmaif, + > noeele, fameel, typele, nuelex, + > numfam, + > grfmpo, grfmtl, grfmtb, + > tbaux1, tbaux2, tbaux3, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - MENage +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbeled . e . 1 . nombre d'elements au debut . +c . nbelef . s . 1 . nombre d'elements a la fin . +c . nbmaid . e . 1 . nombre de mailles au debut . +c . nbmaif . s . 1 . nombre de mailles a la fin . +c . noeele . es . nbeled . noeuds des elements . +c . . .*nbmane . . +c . fameel . es . nbeled . famille med des elements . +c . typele . es . nbeled . type des elements pour le code de calcul . +c . nuelex . es . nbelem . numerotation des elements en exterieur . +c . tbaux1 . aux . nbeled . tableau de travail . +c . tbaux2 . aux . nbfmed . tableau de travail . +c . tbaux3 . aux . nbfmed . tableau de travail . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMMEN' ) +c +#include "consts.h" +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nbutil.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbeled, nbelef + integer nbmaid, nbmaif + integer noeele(nbeled,nbmane) + integer fameel(nbeled), typele(nbeled), nuelex(nbelem) + integer numfam(nbfmed), grfmpo(0:nbfmed), grfmtl(*) + integer tbaux1(nbeled), tbaux2(nbfmed), tbaux3(nbfmed) +c + character*8 grfmtb(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer nbfami, indice +c + character*80 nomgro +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Groupe : '',a)' + texte(1,5) = '(''Numero dans le calcul : '',i10)' + texte(1,6) = '(''Famille MED : '',i4,'' ; type : '',i4)' +c + texte(2,4) = '(''Group: '',a)' + texte(2,5) = '(''# in calculation : '',i10)' + texte(2,6) = '(''MED family : '',i4,'' ; type : '',i4)' +c +#include "impr03.h" +c + codret = 0 +c + nbfami = 0 +c +c==== +c 2. on passe en revue chaque groupe de mailles doubles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfmed', nbfmed +#endif +c +c 2.1. ==> Famille du groupe 'R_20_b' +c + nomgro = blan80 + nomgro(1:6) = 'R_20_b' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbaux3, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c +cgn write (ulsort,90002) '==> nombre de familles', jaux + do 21 , iaux = 1 , jaux + nbfami = nbfami + 1 + tbaux2(nbfami) = tbaux3(iaux) + 21 continue +c +c 2.2. ==> Familles des groupes 'CAV_xx_b' +c + do 22 , iaux = 1 , 20 +c + if ( codret.eq.0 ) then +c + nomgro = blan80 + nomgro(1:8) = 'CAV_00_b' + if ( iaux.le.9 ) then + write(nomgro(6:6),'(i1)') iaux + else + write(nomgro(5:6),'(i2)') iaux + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( nomgro, jaux, tbaux3, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +cgn write (ulsort,90002) '==> nombre de familles', jaux + do 221 , kaux = 1 , jaux + nbfami = nbfami + 1 + tbaux2(nbfami) = tbaux3(kaux) + 221 continue +c + endif +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,91020) (tbaux2(iaux),iaux=1,nbfami) +#endif +c +c==== +c 3. on passe en revue chaque maille +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) nompro//'-nbeled', nbeled + write(ulsort,90002) nompro//'-nbmaid', nbmaid +#endif +c + kaux = 0 +c + do 31 , iaux = 1 , nbeled +c + indice = 0 + do 311 , jaux = 1 , nbfami + if ( fameel(iaux).eq.tbaux2(jaux) ) then + indice = jaux + goto 312 + endif + 311 continue +c + 312 continue +c + if ( indice.eq.0 ) then +c + tbaux1(iaux) = iaux +c +cgn write (ulsort,texte(langue,6)) fameel(iaux), typele(iaux) + else +c + tbaux1(iaux) = 0 +cgn write (ulsort,texte(langue,5)) iaux + kaux = kaux + 1 +c + endif +c + 31 continue +c + nbelef = nbeled - kaux + nbmaif = nbmaid - kaux +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) nompro//'-nbelef', nbelef + write(ulsort,90002) nompro//'-nbmaif', nbmaif +#endif +c +c==== +c 4. consequences +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. consequences ; codret = ', codret +#endif +c + jaux = 1 + do 41 , iaux = 1 , nbelef +c +c recherche du 1er element a garder + laux = jaux + do 411 , kaux = laux , nbeled + if ( tbaux1(kaux).ne.0 ) then + jaux = kaux + goto 412 + endif + 411 continue +c + 412 continue +c +c transfert des valeurs des tableaux + do 413 , kaux = 1 , nbmane + noeele(iaux,kaux) = noeele(jaux,kaux) + 413 continue + fameel(iaux) = fameel(jaux) + typele(iaux) = typele(jaux) + nuelex(iaux) = nuelex(jaux) +c +c decalage + jaux = jaux + 1 +c + 41 continue +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmmpo.F b/src/tool/AV_Conversion/vcmmpo.F new file mode 100644 index 00000000..9aa21a61 --- /dev/null +++ b/src/tool/AV_Conversion/vcmmpo.F @@ -0,0 +1,210 @@ + subroutine vcmmpo ( noempo, hetmpo, coexmp, + > nnosca, nmpsho, nmpsca, + > fameel, typele, + > povoso, voisom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Mailles-POints +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noempo . s . nbmpto . numeros des noeuds associes aux mailles . +c . hetmpo . s . rbar00 . historique de l'etat des mailles-points . +c . coexmp . s . nbmpto*. codes externes sur les mailles-points . +c . . . nctfmp . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . nnosca . e . rsnoto . numero des noeuds dans le calcul . +c . nmpsho . s . rsmpac . numero des mailles-points dans HOMARD . +c . nmpsca . s . rsmpto . numero des mailles-points du calcul . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . voisins des sommets en stockage morse . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMMPO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbutil.h" +#include "nombno.h" +#include "refert.h" +#include "nombmp.h" +#include "nombsr.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer noempo(nbmpto), hetmpo(nbmpto) + integer nnosca(rsnoto) + integer nmpsho(rsmpac), nmpsca(rsmpto) + integer coexmp(nbmpto,nctfmp) + integer fameel(nbelem), typele(nbelem) + integer voisom(nvosom), povoso(0:nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer poinde, poinfi, point, nucode + integer sommet + integer lamapo, elem, typhom +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de mailles-points attendues : '',i10)' + texte(1,5) = '(''Nombre de mailles-points trouvees : '',i10)' +c + texte(2,4) = '(''Expected point-meshes : '',i10)' + texte(2,5) = '(''Found point-meshes : '',i10)' +c +c 1.2. ==> mise a zero +c + codret = 0 +c + do 11 , lamapo = 1 , rsmpac + nmpsho(lamapo) = 0 + 11 continue +c + do 12 , nucode = 1 , nctfmp + do 121 , lamapo = 1 , nbmpto + coexmp(lamapo,nucode) = 0 + 121 continue + 12 continue +c + lamapo = 0 +c +c==== +c 2. on passe en revue chaque sommet +c remarque : l'exploration se fait dans la numerotation HOMARD +c ses elements voisins sont dans le tableau voisom, aux places +c comprises entre povoso(somm-1)+1 et povoso(somm), somm etant le +c numero dans le calcul correspondant au numero sommet dans +c homard +c==== +c + do 21 , sommet = 1 , nbnoto +c + poinde = povoso(nnosca(sommet)-1) + 1 + poinfi = povoso(nnosca(sommet)) +c + do 22 , point = poinde , poinfi +c +c 2.1. ==> caracterisation de l'element +c elem : son numero global +c typhom : son type dans HOMARD +c + elem = voisom(point) + typhom = medtrf(typele(elem)) +c +c 2.2. ==> si l'element est une maille-point, il faut +c se souvenir de son type et de sa famille MED. +c + if ( typhom.eq.tyhmpo ) then +c + lamapo = lamapo + 1 + noempo(lamapo) = sommet + coexmp(lamapo,1) = fameel(elem) + coexmp(lamapo,2) = typele(elem) + nmpsho(elem) = lamapo + nmpsca(lamapo) = elem + endif +c + 22 continue +c + 21 continue +c + if ( lamapo.ne.nbmpto ) then + write(ulsort,texte(langue,4)) nbmpto + write(ulsort,texte(langue,5)) lamapo + codret = 3 + endif +c +c==== +c 3. consequences +c==== +c + do 32 , lamapo = 1 , nbmpto + hetmpo(lamapo) = 0 + 32 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnc1.F b/src/tool/AV_Conversion/vcmnc1.F new file mode 100644 index 00000000..04873086 --- /dev/null +++ b/src/tool/AV_Conversion/vcmnc1.F @@ -0,0 +1,335 @@ + subroutine vcmnc1 ( nbanci, nbgemx, + > arreca, arrecb, + > nohman, nhvois, + > arenoe, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > aretri, arequa, + > ppovos, pvoiso, + > pposif, pfacar, + > ngenar, nouare, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Non Conformite - 1 +c - - - - - - +c Traitement des aretes en vis-a-vis +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . nbgemx . e . 1 . nombre maximal de generations sous une . +c . . . . arete . +c . arreca . s .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . s .2*nbanci. liste des aretes recouvertes par une autre . +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . nhvois . e . char8 . nom de la branche Voisins . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . np2are . es . nbarto . noeud milieux des aretes . +c . merare . es . nbarto . mere des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . insoar . es . nbarto . information sur les sommets des aretes . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . narsho . es . rsarac . numero des aretes dans HOMARD . +c . narsca . es . rsarto . numero des aretes du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . ppovos . es . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . es . 1 . adresse des voisins des sommets . +c . pposif . es . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . es . 1 . adresse des voisins des aretes . +c . ngenar . e . nbarto . nombre de generations au-dessus des aretes . +c . nouare . s . nbarto . nouveau numero des aretes . +c . tabaux . a . * . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNC1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +#include "envex1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + character*8 nohman, nhvois +c + integer nbanci, nbgemx + integer arreca(2*nbanci), arrecb(2*nbanci) + integer arenoe(nbnoto) + integer somare(2,nbarto), hetare(nbarto), np2are(nbarto) + integer filare(nbarto), merare(nbarto), insoar(nbarto) + integer coexar(nbarto,nctfar) + integer narsho(rsarac), narsca(rsarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer ppovos, pvoiso + integer pposif, pfacar + integer ngenar(nbarto), nouare(0:nbarto) + integer tabaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer voarno, vofaar, vovoar, vovofa + integer numgen + integer numfin +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' + texte(1,5) = + > '(''Nombre maximal de generations de '',a,'' :'',i10))' + texte(1,6) = '(/,''Phase numero'',i2))' + texte(1,7) = '(''Decalage des '',a,'' de generation'',i3)' + texte(1,8) = '(''Regroupement des '',a,'' de generation'',i3)' + texte(1,10) = '(''Il devrait etre '',a,i10)' + texte(1,11) = '(a,''recouvert'',i10)' + texte(1,12) = '(a,''recouvrant'',i10)' +c + texte(2,4) = + > '(''Number of pairs of non-conformal '',a,'' :'',i10))' + texte(2,5) = + > '(''Maximal number of generations for '',a,'':'',i10))' + texte(2,6) = '(/,''Phase #'',i2)' + texte(2,7) = '(''Renumbering of '',a,'' in generation'',i3)' + texte(2,8) = '(''Gathering of '',a,'' in generation'',i3)' + texte(2,10) = '(''It should be '',a,i10)' + texte(2,11) = '(a,''covered #'',i10)' + texte(2,12) = '(a,''covering #'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbgemx +#endif +c +c==== +c 2. Stockage des aretes en vis-a-vis +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC02', nompro +#endif +c + call utnc02 ( nbanci, + > arreca, arrecb, + > merare, + > ulsort, langue, codret ) +c +c==== +c 3. Renumerotation des aretes +c On le fait en 2 passes : +c 1 : on classe par generations +c 2 : au sein d'une generation, on regroupe par fratries de soeurs. +c Remarque : les generations doivent etre parcourues de la plus jeune +c a la plus vieille, pour tasser vers la fin de la +c numerotation +c Remarque : il est inutile de faire un traitement special pour les +c aretes sans ascendance. Elles vont logiquement se +c trouver en tete de numerotation. +c==== +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , 2 +c + numfin = nbarto +c + do 310 , numgen = nbgemx , 1 , -1 +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,6)) iaux + if ( iaux.eq.1 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,1), numgen + else + write (ulsort,texte(langue,8)) mess14(langue,3,1), numgen + endif + endif +#endif +cgn write(ulsort,*) 'ante / erte' +cgn do jaux=1,2*nbanci +cgn write(ulsort,3333) jaux,arreca(jaux),arrecb(jaux) +cgn 3333 format (i10,' :',2i10) +cgn enddo +c +c 3.1. ==> Changement des renumerotations +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + jaux = -numgen + else + jaux = numgen + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC03', nompro +#endif +c + call utnc03 ( jaux, nbanci, numfin, + > arreca, arrecb, + > somare, filare, merare, + > ngenar, nouare, tabaux, + > ulsort, langue, codret ) +c +cgn write (ulsort,*)'nouare : ',nouare +c + endif +c +c 3.2. ==> Prise en compte des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC04', nompro +#endif +c + call utnc04 ( nbanci, arreca, arrecb, + > nouare, tabaux, + > arenoe, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > ngenar, + > aretri, arequa, + > ulsort, langue, codret ) +c + endif +c + 310 continue +cgn write (ulsort,*)'ngenar : ',ngenar +cgn write (ulsort,*)'merare : ',merare +c + 31 continue +c + endif +cgn do iaux=1,nbarto +cgn write(ulsort,*) iaux,somare(1,iaux),somare(2,iaux) +cgn enddo +c +cgn if ( codret.eq.0 ) then +c +cgn jaux = 2*nbanci +cgn do 321 , iaux = 1 , jaux +c +cgn if ( arreca(iaux).gt.nbanci ) then +cgn write(ulsort,*) 'arreca(', iaux, ') = ', arreca(iaux) +cgn codret = codret + 1 +cgn endif +c +cgn 321 continue +c +cgn endif +c +c==== +c 4. Mise a jour des faces voisines des aretes +c==== +c + if ( codret.eq.0 ) then +c + voarno = 0 + vofaar = 2 + vovoar = 0 + vovofa = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnc2.F b/src/tool/AV_Conversion/vcmnc2.F new file mode 100644 index 00000000..0bca8e39 --- /dev/null +++ b/src/tool/AV_Conversion/vcmnc2.F @@ -0,0 +1,369 @@ + subroutine vcmnc2 ( nbanci, nbgemx, + > arreca, arrecb, noerec, + > nohman, nhvois, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > noempo, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > aretri, arequa, + > ppovos, pvoiso, + > pposif, pfacar, + > ngenar, ngenno, nouent, tabaux, tbdaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Non Conformite - 2 +c - - - - - - +c Renumerotations des noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . nbgemx . e . 1 . nombre maximal de generations sous une . +c . . . . arete . +c . arreca . s .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . s .2*nbanci. liste des aretes recouvertes par une autre . +c . noerec . s . nbanci . liste initiale des noeuds de recollement . +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . nhvois . e . char8 . nom de la branche Voisins . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . coexno . es . nbnoto*. codes de conditions aux limites portants . +c . . . nctfno . sur les noeuds . +c . nnosho . es . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . es . rsnoto . numero des noeuds dans le calcul . +c . noempo . es . nbmpto . numeros des noeuds associes aux mailles . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . np2are . es . nbarto . noeud milieux des aretes . +c . merare . es . nbarto . mere des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . insoar . es . nbarto . information sur les sommets des aretes . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . narsho . es . rsarac . numero des aretes dans HOMARD . +c . narsca . es . rsarto . numero des aretes du calcul . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . ppovos . es . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . es . 1 . adresse des voisins des sommets . +c . pposif . es . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . es . 1 . adresse des voisins des aretes . +c . ngenar . e . nbarto . nombre de generations au-dessus des aretes . +c . ngenno . s . nbnoto . nombre de generations au-dessus des noeuds . +c . nouent . s . nbnoto . nouveau numero des noeuds . +c . tabaux . a . * . tableau auxiliaire . +c . tbdaux . a . * . tableau auxiliaire reel . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNC2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +#include "envex1.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + character*8 nohman, nhvois +c + integer nbanci, nbgemx + integer arreca(2*nbanci), arrecb(2*nbanci) + integer noerec(nbanci) + integer noempo(nbmpto) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer coexno(nbnoto,nctfno) + integer nnosho(rsnoac), nnosca(rsnoto) + integer somare(2,nbarto), hetare(nbarto), np2are(nbarto) + integer filare(nbarto), merare(nbarto), insoar(nbarto) + integer coexar(nbarto,nctfar) + integer narsho(rsarac), narsca(rsarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer ppovos, pvoiso + integer pposif, pfacar + integer ngenar(nbarto), ngenno(nbnoto), nouent(0:nbnoto) + integer tabaux(*) +c + double precision tbdaux(*) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer voarno, vofaar, vovoar, vovofa + integer numgen + integer numfin +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' + texte(1,8) = '(''Regroupement des '',a,'' de generation'',i3)' +c + texte(2,4) = + > '(''Number of pairs of non-conformal '',a,'' :'',i10))' + texte(2,8) = '(''Gathering of '',a,'' in generation'',i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci +#endif +c +c==== +c 2. Elaboration des generations des noeuds +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC05', nompro +#endif +c + jaux = -1 + call utnc05 ( jaux, nbanci,numfin, + > arreca, arrecb, + > somare, + > ngenar, ngenno, nouent, + > ulsort, langue, codret ) +c + endif +c +c==== +c 2. Renumerotation des noeuds +c Remarque : les generations doivent etre parcourues de la plus jeune +c a la plus vieille, pour tasser vers la fin de la +c numerotation +c==== +c + numfin = nbnoto +c + do 21 , numgen = nbgemx , 1 , -1 +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,-1), numgen + endif +#endif +c +c 2.1. ==> Recherche des renumerotations +c + if ( codret.eq.0 ) then +c + jaux = numgen +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC05', nompro +#endif +c + call utnc05 ( jaux, nbanci, numfin, + > arreca, arrecb, + > somare, + > ngenar, ngenno, nouent, + > ulsort, langue, codret ) +cgn write(ulsort,*) 'nouent' +cgn do jaux=1,nbnoto +cgn write(ulsort,3333) jaux,nouent(jaux) +cgn 3333 format (i10,' :',i10) +cgn enddo +c + endif +c +c 2.2. ==> Prise en compte des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC06', nompro +#endif +c + jaux = 0 + call utnc06 ( jaux, + > nouent, tabaux, tbdaux, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > ngenno, + > noempo, + > somare, + > ulsort, langue, codret ) +c + endif +c + 21 continue +cgn write(ulsort,*) 'ngenno(', 1,') = ',ngenno(1) +cgn do 2111,iaux=25300,25310 +cgn write(ulsort,*) 'ngenno(',iaux,') = ',ngenno(iaux) +cgn 2111 continue +cgn write(ulsort,*) 'ngenno(',36917,') = ',ngenno(36917) +cgn write(ulsort,*) 'ngenno(',36918,') = ',ngenno(36918) +cgn write(ulsort,*) 'ngenno(',nbnoto,') = ',ngenno(nbnoto) +c +c==== +c 3. Renumerotation des aretes soeurs : il faut que celle de plus petit +c numero soit celle qui demarre sur le noeud de + petit numero +c==== +c +c 3.1. ==> Changement des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC03', nompro +#endif +c + jaux = 0 + call utnc03 ( jaux, nbanci, iaux, + > arreca, arrecb, + > somare, filare, merare, + > ngenar, nouent, tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Prise en compte des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC04', nompro +#endif +c + call utnc04 ( nbanci, arreca, arrecb, + > nouent, tabaux, + > arenoe, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > ngenar, + > aretri, arequa, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Stockage du noeud commun aux aretes de recollement +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC07', nompro +#endif +c + call utnc07 ( nbanci, + > noerec, arreca, arrecb, + > somare, arenoe, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Mise a jour des aretes voisines des noeuds +c==== +c + if ( codret.eq.0 ) then +c + voarno = 2 + vofaar = 0 + vovoar = 0 + vovofa = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnc3.F b/src/tool/AV_Conversion/vcmnc3.F new file mode 100644 index 00000000..55cf817c --- /dev/null +++ b/src/tool/AV_Conversion/vcmnc3.F @@ -0,0 +1,425 @@ + subroutine vcmnc3 ( nbanci, + > nbnocq, qureca, qurecb, + > nbnoct, trreca, trrecb, + > nohman, nhvois, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > noempo, + > somare, filare, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, perqua, + > coexqu, nqusho, nqusca, + > quahex, coquhe, + > ppovos, pvoiso, + > pposif, pfacar, + > nouent, tabaux, tbdaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Non Conformite - 3 +c - - - - - - +c Faces en vis-a-vis +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre de non conformites . +c . nbqut1 . e . 1 . nombre de quad avec aretes 1&3 recouvrantes. +c . nbqut2 . e . 1 . nombre de quad avec aretes 2&4 recouvrantes. +c . nbqut4 . e . 1 . nombre de quad avec 4 aretes recouvrantes . +c . nbnocq . e . 1 . nombre de non conformites de quadrangles . +c . qureca . s .4*nbnocq. liste des quad. recouvrant un autre . +c . qurecb . s .4*nbnocq. liste des quad. recouverts par un autre . +c . nbnoct . e . 1 . nombre de non conformites de quadrangles . +c . trreca . s .4*nbnoct. liste des triangles recouvrant un autre . +c . trrecb . s .4*nbnoct. liste des triangles recouverts par un autre. +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . nhvois . e . char8 . nom de la branche Voisins . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . coexno . es . nbnoto*. codes de conditions aux limites portants . +c . . . nctfno . sur les noeuds . +c . nnosho . es . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . es . rsnoto . numero des noeuds dans le calcul . +c . noempo . es . nbmpto . numeros des noeuds associes aux mailles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . nqusho . es . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . es . rsquto . numero des quadrangles du calcul . +c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . ppovos . es . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . es . 1 . adresse des voisins des sommets . +c . pposif . es . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . es . 1 . adresse des voisins des aretes . +c . nouent . s . * . nouveau numero des entites (quad+noeuds) . +c . tabaux . a . * . tableau auxiliaire . +c . tbdaux . a . * . tableau auxiliaire reel . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNC3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "impr02.h" +c +#include "envex1.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "envca1.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + character*8 nohman, nhvois +c + integer nbanci + integer nbnocq, qureca(4*nbnocq), qurecb(4*nbnocq) + integer nbnoct, trreca(4*nbnoct), trrecb(4*nbnoct) + integer noempo(nbmpto) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer coexno(nbnoto,nctfno) + integer nnosho(rsnoac), nnosca(rsnoto) + integer somare(2,nbarto), filare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer coexqu(nbquto,nctfqu) + integer nqusho(rsquac), nqusca(rsquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer ppovos, pvoiso + integer pposif, pfacar + integer nouent(0:nbquto) + integer tabaux(*) +c + double precision tbdaux(*) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer voarno, vofaar, vovoar, vovofa + integer nbpass + integer advoqu + integer ngenno(1) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' + texte(1,5) = '(''Nombre de passages :'',i10))' + texte(1,8) = + > '(''Nombre de '',a,'' a aretes recouvrantes :'',i10))' +c + texte(2,4) = + > '(''Number of pairs of non-conformal '',a,'' :'',i10))' + texte(2,5) = '(''Number of turns :'',i10))' + texte(2,8) = + > '(''Number of '',a,'' with covering edges :'',i10))' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbnoct + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbnocq +#endif +c +c==== +c 3. Renumerotation des quadrangles +c On le fait en 3 passes +c==== +c + nbpass = 0 +c + do 31 , iaux = 1 , 3 +c + 310 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbpass +#endif +c + jaux = iaux +c +c 3.1. ==> Changement des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC13', nompro +#endif +c + call utnc13 ( jaux, + > nbnoct, trreca, trrecb, + > nbnocq, qureca, qurecb, + > arequa, filqua, perqua, + > filare, + > nouent, tabaux, + > ulsort, langue, codret ) +c + if ( codret.eq.3 ) then + nbpass = nbpass + 1 + codret = 0 + endif +c +cgn call gmprsx (nompro, ntrav3 ) + endif +c +c 3.2. ==> Prise en compte des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC14', nompro +#endif +cgn write(ulsort,*) nouent(794),nouent(10361) +c + call utnc14 ( nbnocq, qureca, qurecb, + > nouent, tabaux, + > arequa, hetqua, + > filqua, perqua, + > coexqu, nqusho, nqusca, + > quahex, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Si on n'a pas eu assez de trous a 2 ou 4 places, il faut +c recommencer la passe numero 3 +c A priori, on ne devrait pas faire ce traitement plus de +c nbanci fois +c + if ( codret.eq.0 ) then +c + if ( nbpass.eq.nbanci ) then + codret = 1 + elseif ( nbpass.gt.0 ) then + goto 310 + endif +c + endif +c + 31 continue +cgn do iaux=1,nbarto +cgn write(ulsort,*) iaux,somare(1,iaux),somare(2,iaux) +cgn enddo +c +c==== +c 4. Mise a jour des faces voisines des aretes et des volumes +c voisins des faces +c==== +c + if ( codret.eq.0 ) then +c + voarno = 0 + vofaar = 2 + vovoar = 0 + vovofa = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +cgn return +c + endif +c +c==== +c 3. Renumerotation des noeuds centraux des faces recouvrantes +c==== +c +c 3.1. ==> Reperage des noeuds centraux et creation de la nouvelle +c numerotation des noeuds +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC15', nompro +#endif +c + call utnc15 ( nbnocq, qureca, qurecb, + > somare, arequa, + > nouent, tabaux, + > ulsort, langue, codret ) +c +cgn write(ulsort,*) 'nbnoto = ',nbnoto +cgn write(ulsort,*) 'nounoe' +c + endif +c +c 3.2. ==> Prise en compte des renumerotations +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC06', nompro +#endif +c + iaux = 1 + call utnc06 ( iaux, + > nouent, tabaux, tbdaux, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > ngenno, + > noempo, + > somare, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Mise a jour des aretes voisines des noeuds +c + if ( codret.eq.0 ) then +c + voarno = 2 + vofaar = 0 + vovoar = 0 + vovofa = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Reorientation des faces recouvertes +c==== +c +c 4.1. ==> Les volumes voisins des faces +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 7 + call utad04 ( iaux, nhvois, + > jaux, jaux, jaux, jaux, + > jaux, advoqu, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> Reorientation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC16', nompro +#endif +c + call utnc16 ( hettri, aretri, filtri, + > hetqua, arequa, filqua, + > filare, + > quahex, coquhe, imem(advoqu), + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnc4.F b/src/tool/AV_Conversion/vcmnc4.F new file mode 100644 index 00000000..fb0c6a26 --- /dev/null +++ b/src/tool/AV_Conversion/vcmnc4.F @@ -0,0 +1,153 @@ + subroutine vcmnc4 ( typenh, nhenti, + > nhenrc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Non Conformite - 4 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenti . e . char*8 . nom de l'objet decrivant les entites . +c . nhenrc . s . char*8 . nom de l'objet des recollements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNC4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh +c + character*8 nhenti + character*8 nhenrc +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Structure du recollement pour les '',a)' +c + texte(2,4) = '(''... Structure for gluing for '',a)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c==== +c 2. Les structures +c==== +c + call gmaloj ( nhenti//'.Recollem', ' ', 0, iaux, codret ) +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhenti//'.Recollem' , nhenrc, codre1 ) + iaux = 0 + call gmecat ( nhenrc, 1, iaux, codre2 ) + call gmecat ( nhenrc, 2, iaux, codre3 ) + call gmecat ( nhenrc, 3, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnco.F b/src/tool/AV_Conversion/vcmnco.F new file mode 100644 index 00000000..d840536e --- /dev/null +++ b/src/tool/AV_Conversion/vcmnco.F @@ -0,0 +1,765 @@ + subroutine vcmnco ( nohman, + > nhnoeu, nharet, nhtria, nhquad, nhvois, + > noempo, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > hettri, aretri, filtri, pertri, + > hetqua, arequa, filqua, perqua, + > coexqu, nqusho, nqusca, + > quahex, coquhe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Non COnformite +c - - - - -- +c ATTENTION : cela suppose que le rapport de non conformite est 1/2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhvois . e . char8 . nom de la branche Voisins . +c . noempo . es . nbmpto . numeros des noeuds associes aux mailles . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . coexno . es . nbnoto*. codes de conditions aux limites portants . +c . . . nctfno . sur les noeuds . +c . nnosho . es . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . es . rsnoto . numero des noeuds dans le calcul . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . np2are . es . nbarto . noeud milieux des aretes . +c . merare . es . nbarto . mere des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . insoar . es . nbarto . information sur les sommets des aretes . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . narsho . es . rsarac . numero des aretes dans HOMARD . +c . narsca . es . rsarto . numero des aretes du calcul . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . nqusho . es . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . es . rsquto . numero des quadrangles du calcul . +c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "gmreel.h" +c +#include "impr02.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombte.h" +#include "envca1.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + character*8 nohman, nhvois + character*8 nhnoeu, nharet, nhtria, nhquad +c + integer noempo(nbmpto) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer coexno(nbnoto,nctfno) + integer nnosho(rsnoac), nnosca(rsnoto) + integer somare(2,nbarto), hetare(nbarto), np2are(nbarto) + integer filare(nbarto), merare(nbarto), insoar(nbarto) + integer coexar(nbarto,nctfar) + integer narsho(rsarac), narsca(rsarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer coexqu(nbquto,nctfqu) + integer nqusho(rsquac), nqusca(rsquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer un + parameter ( un = 1 ) + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer ppovos, pvoiso + integer pposif, pfacar + integer voarno, vofaar, vovoar, vovofa + integer nbanci, nbnoct, nbnocq + integer numead + integer nbgemx + integer conoct, conocq +c + integer adnoer, adarra, adarrb + integer adtrra, adtrrb + integer adqura, adqurb + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer ptrav6, ptrav7, ptrav8 +c + character*8 nharrc, nhtrrc, nhqurc + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*8 ntrav6, ntrav7, ntrav8 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' +c + texte(2,4) = + > '(''Number of pairs of non-conformal '',a,'' :'',i10))' +c + codret = 0 +c +c==== +c 2. Les structures +c==== +c 2.1. ==> Les structures des voisins +c + if ( codret.eq.0 ) then +c + voarno = 2 + vofaar = 2 + vovofa = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nohman, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Decompte et reperage des non-conformites +c==== +c 3.1. ==> Tableau de travail +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbarto, ptrav1, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +c 3.2. ==> Decompte et reperage des aretes en vis-a-vis +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC01', nompro +#endif +c + call utnc01 ( nbanci, nbgemx, + > coonoe, + > somare, merare, + > aretri, + > imem(ppovos), imem(pvoiso), + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro,ntrav1,1,nbarto) +#endif +c +c 3.3. ==> Enregistrement +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 ) then +c + maconf = 10 + call gmecat ( nohman, 4, maconf, codret ) +c + endif +c + endif +c +c==== +c 4. Gestion des tableaux +c==== +c +c 4.1. ==> Tableaux de travail +c + if ( nbanci.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre1 ) + iaux = max( nbarto+1,nbnoto+1) + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre2 ) + iaux = max(3*nbanci,nbnoto,2*nbarto,nbarto*nctfar) + call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre3 ) + iaux = nbnoto*sdim + call gmalot ( ntrav6, 'reel ', iaux, ptrav6, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 4.2. ==> Allocation de la memorisation des noeuds de non-conformite +c + if ( codret.eq.0 ) then +c + call gmecat ( nhnoeu, 4, nbanci, codre1 ) + call gmaloj ( nhnoeu//'.Recollem', ' ', nbanci, adnoer, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 4.3. ==> Memorisation des non-conformites en aretes +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC4_ar', nompro +#endif + call vcmnc4 ( iaux, nharet, + > nharrc, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nharrc, 1, nbanci, codre1 ) + iaux = 2 + call gmecat ( nharrc, 2, iaux, codre2 ) + iaux = 2*nbanci + call gmaloj ( nharrc//'.ListeA', ' ', iaux, adarra, codre3 ) + call gmaloj ( nharrc//'.ListeB', ' ', iaux, adarrb, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 4.4. ==> Memorisation des non-conformites en triangles +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC4_tr', nompro +#endif + call vcmnc4 ( iaux, nhtria, + > nhtrrc, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.5. ==> Memorisation des non-conformites en quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC4_qu', nompro +#endif + call vcmnc4 ( iaux, nhquad, + > nhqurc, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. Renumerotation des aretes +c==== +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC1', nompro +#endif + call vcmnc1 ( nbanci, nbgemx, + > imem(adarra), imem(adarrb), + > nohman, nhvois, + > arenoe, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > aretri, arequa, + > ppovos, pvoiso, + > pposif, pfacar, + > imem(ptrav1), imem(ptrav4), imem(ptrav5), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nharrc//'.ListeA' ) + call gmprsx (nompro, nharrc//'.ListeB' ) +cgn call gmprot (nompro,ntrav4,1,nbarto+1) +cgn call gmprot (nompro,ntrav5,1,3*nbanci) +#endif +c +cgn return + endif +c + endif +c +c==== +c 6. Renumerotation des noeuds +c==== +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC2', nompro +#endif + call vcmnc2 ( nbanci, nbgemx, + > imem(adarra), imem(adarrb), imem(adnoer), + > nohman, nhvois, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > noempo, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > aretri, arequa, + > ppovos, pvoiso, + > pposif, pfacar, + > imem(ptrav1), imem(ptrav2), + > imem(ptrav4), imem(ptrav5), + > rmem(ptrav6), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro,ntrav4,1,nbnoto+1) +#endif +c + endif +c + endif +c +c==== +c 7. On repere chaque face du macro maillage qui est bordee par une +c arete de non conformite initiale. On declare que cette face a une +c mere, dont le numero est un numero fictif, ne correspondant a +c aucune face possible. +c==== +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 ) then +c +cgn do iaux=1,nbquto +cgn write(ulsort,*) iaux,arequa(iaux,1),arequa(iaux,2), +cgn > arequa(iaux,3),arequa(iaux,4) +cgn enddo +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC09', nompro +#endif +c + iaux = 0 + call utnc09 ( nbanci, imem(adarrb), iaux, + > pertri, perqua, + > numead, + > imem(pposif), imem(pfacar), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.gt.0 ) then +c + call gmecat ( nhtrrc, 3, numead, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + if ( nbquto.gt.0 ) then +c + call gmecat ( nhqurc, 3, numead, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + endif +cgn return +c + endif +c + endif +c +c==== +c 8. Gestion des non-conformites sur les volumes +c==== +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 .and. + > ( nbheto.gt.0 .or. nbteto.gt.0 ) ) then +c +c 8.1. ==> Reperage des faces dont des aretes sont non-conformes : +c . les 4 aretes pour des quadrangles +c . les 3 aretes pour les triangles +c Les nombres nbnoct et nbnocq ne sont que des maxima : une +c face peut tres bien avoir ses aretes coupees sans etre +c decoupee elle-meme. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC11', nompro +#endif +c + call utnc11 ( nbanci, imem(adarra), + > aretri, filtri, + > arequa, filqua, + > filare, imem(pposif), imem(pfacar), + > nbnoct, nbnocq, + > ulsort, langue, codret ) +c + endif +c +c 8.2. ==> Les tableaux +c 8.2.1. ==> Allocation de la memorisation des faces en vis-a-vis +c On est dans un rapport de 4 pour 1 toujours. +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c + call gmecat ( nhqurc, 1, nbnocq, codre1 ) + iaux = 4 + call gmecat ( nhqurc, 2, iaux, codre2 ) + nbquri = 4*nbnocq + call gmaloj ( nhqurc//'.ListeA', ' ', nbquri, adqura, codre3 ) + call gmaloj ( nhqurc//'.ListeB', ' ', nbquri, adqurb, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( nbtrto.ne.0 ) then +c + call gmecat ( nhtrrc, 1, nbnoct, codre1 ) + iaux = 4 + call gmecat ( nhtrrc, 2, iaux, codre2 ) + nbtrri = 4*nbnoct + call gmaloj ( nhtrrc//'.ListeA', ' ', nbtrri, adtrra, codre3 ) + call gmaloj ( nhtrrc//'.ListeB', ' ', nbtrri, adtrrb, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + endif +c +c 8.2.2. ==> Tableaux de travail +c + if ( codret.eq.0 ) then +c + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre1 ) + iaux = max( nbtrto+1,nbquto+1) + call gmalot ( ntrav7, 'entier ', iaux, ptrav7, codre2 ) + iaux = + > max(5*nbnocq,5*nbnoct,4*nbquto,nbquto*nctfqu,rsquac,rsquto, + > 6*nbheto) + call gmalot ( ntrav8, 'entier ', iaux, ptrav8, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 8.3. ==> Repérage des faces en vis-a-vis +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC12', nompro +#endif +c + call utnc12 ( hettri, aretri, filtri, pertri, + > hetqua, arequa, filqua, perqua, + > filare, imem(pposif), imem(pfacar), + > nbnocq, imem(adqura), imem(adqurb), conocq, + > nbnoct, imem(adtrra), imem(adtrrb), conoct, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhqurc ) + call gmprot (nompro, nhqurc//'.ListeA', 1, 10 ) + call gmprot (nompro, nhqurc//'.ListeA', 4*conocq, nbquri ) + call gmprot (nompro, nhqurc//'.ListeB', 1, 10 ) + call gmprot (nompro, nhqurc//'.ListeB', 4*conocq, nbquri ) +#endif +c + endif +c +c 8.4 ==> Redimensionnement des tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'debut de 8.4 avec codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c + nbquri = 4*nbnocq + iaux = 4*conocq +c + call gmmod ( nhqurc//'.ListeA', + > adqura, nbquri, iaux, un, un, codre1 ) + call gmmod ( nhqurc//'.ListeB', + > adqurb, nbquri, iaux, un, un, codre2 ) + nbquri = iaux + nbnocq = conocq + call gmecat ( nhqurc, 1, nbnocq, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( nbtrto.ne.0 ) then +c + nbtrri = 4*nbnoct + iaux = 4*conoct + call gmmod ( nhtrrc//'.ListeA', + > adtrra, nbtrri, iaux, un, un, codre1 ) + call gmmod ( nhtrrc//'.ListeB', + > adtrrb, nbtrri, iaux, un, un, codre2 ) + nbtrri = iaux + nbnoct = conoct + call gmecat ( nhtrrc, 1, nbnoct, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhqurc ) + call gmprsx (nompro, nhqurc//'.ListeA' ) + call gmprsx (nompro, nhqurc//'.ListeB' ) +#endif +c + endif +c +c 8.5 ==> Renumérotation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMNC3', nompro +#endif + call vcmnc3 ( nbanci, + > nbnocq, imem(adqura), imem(adqurb), + > nbnoct, imem(adtrra), imem(adtrrb), + > nohman, nhvois, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > noempo, + > somare, filare, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, perqua, + > coexqu, nqusho, nqusca, + > quahex, coquhe, + > ppovos, pvoiso, + > pposif, pfacar, + > imem(ptrav7), imem(ptrav8), rmem(ptrav6), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 9. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'debut de 9 avec codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbanci.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav2, codre1 ) + call gmlboj ( ntrav4, codre2 ) + call gmlboj ( ntrav5, codre3 ) + call gmlboj ( ntrav6, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( nbheto.gt.0 .or. nbteto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav7 , codre1 ) + call gmlboj ( ntrav8 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c + endif +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmnoe.F b/src/tool/AV_Conversion/vcmnoe.F new file mode 100644 index 00000000..760c4150 --- /dev/null +++ b/src/tool/AV_Conversion/vcmnoe.F @@ -0,0 +1,586 @@ + subroutine vcmnoe ( eleinc, fameno, noeele, typele, + > dimcst, coonca, + > nnosho, nnosca, + > coonoe, hetnoe, coexno, + > trav1a, trav2a, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - NOEuds +c - - - --- +c ______________________________________________________________________ +c +c but : construction de la table des noeuds pour une connectivite de +c type med +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . eleinc . e . 1 . elements incompatibles . +c . . . . 0 : on bloque s'il y en a . +c . . . . 1 : on les ignore s'il y en a . +c . fameno . e . nbnoto . famille med des noeuds . +c . noeele . e . nbelem*. table de connectivite des elements . +c . . . nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . coonca . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . nnosho . s . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . s . rsnoto . numero des noeuds dans le calcul . +c . coonoe . s . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . s . nbnoto . historique de l'etat des noeuds . +c . . . . 0 pour les noeuds isoles . +c . . . . 1 pour les sommets . +c . . . . 2 pour les noeuds milieux . +c . . . . 3 pour les noeuds support de maille-point . +c . . . . 4 pour les noeuds internes aux mailles . +c . . . . 7 pour les noeuds n'appartenant qu'a des . +c . . . . elements ignores . +c . coexno . s . nbnoto*. codes externes sur les noeuds . +c . . . nctfno . 1 : famille MED . +c . . . nctfno . sur les noeuds . +c . trav1a . a . nbnoto . tableau de travail numero 1 . +c . . . . Il ne sert qu'ici . +c . trav2a . s . nbnoto . tableau de travail numero 2 . +c . . . . 1, pour un noeud appartenant a au moins un . +c . . . . element ignore +c . . . . 0, sinon +c . . . . Il servira dans vcmare . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMNOE' ) +c +#include "nblang.h" +#include "referx.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "refere.h" +#include "refert.h" +#include "dicfen.h" +#include "nbutil.h" +#include "nombno.h" +#include "nombsr.h" +#include "envca1.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer eleinc + integer dimcst + integer fameno(nbnoto), noeele(nbelem,nbmane), typele(nbelem) + integer nnosho(rsnoac), nnosca(rsnoto) + integer hetnoe(nbnoto) + integer coexno(nbnoto,nctfno) + integer trav1a(nbnoto), trav2a(nbnoto) +c + integer ulsort, langue, codret +c + double precision coonoe(nbnoto,sdim), coonca(nbnoto,sdimca) +c +c 0.4. ==> variables locales +c + integer el, noeud, typhom, numero, nunoca + integer iaux, jaux + integer nbsoma, nbnsma, nbndma +c + integer nbmess + parameter ( nbmess = 17 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds incorrect :'')' + texte(1,5) = '(''. On denombre :'',i10,'' noeuds,'')' + texte(1,6) = '('' au lieu de '',i10,'' prevus ...'')' + texte(1,7) = '(''Coordonnee constante incorrecte :'',i7)' + texte(1,5) = '(''Nombre de noeuds incorrect :'')' + texte(1,11) = + > '(''Nombre total de noeuds :'',i10)' + texte(1,12) = + > '(''. dont sommets d''''aretes (noeud P1) :'',i10)' + texte(1,13) = + > '(''. dont milieux d''''aretes (noeud P2) :'',i10)' + texte(1,14) = + > '(''. dont noeuds internes aux mailles :'',i10)' + texte(1,15) = + > '(''. dont noeuds isoles :'',i10)' + texte(1,16) = + > '(''. dont noeuds elements ignores uniquement :'',i10)' + texte(1,17) = + > '(''. dont noeuds mailles-points uniquement :'',i10)' +c + texte(2,4) = '(''Number of nodes is wrong:'')' + texte(2,5) = '(i0,'' nodes are counted,'')' + texte(2,6) = '(''instead of '',i10)' + texte(2,7) = '(''Constant coordinate is wrong:'',i7)' + texte(2,11) = + > '(''Total number of nodes :'',i10)' + texte(2,12) = + > '(''. included vertices of edges (P1 node):'',i10)' + texte(2,13) = + > '(''. included centers of edges (P2 node) :'',i10)' + texte(2,14) = + > '(''. included mesh internal nodes :'',i10)' + texte(2,15) = + > '(''. included isolated nodes :'',i10)' + texte(2,16) = + > '(''. included only ignored element nodes :'',i10)' + texte(2,17) = + > '(''. included only mesh-point nodes :'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) nbnoto + write (ulsort,90002) 'nbelem', nbelem + write (ulsort,90002) 'nbmane', nbmane + write (ulsort,90002) 'eleinc', eleinc +#endif +c +c==== +c 2. trav1a vaudra : +c 0, pour un noeud isole +c -1, pour un noeud p2, c'est-a-dire au milieu d'une arete +c -2, pour un noeud qui est uniquement support d'une maille-point +c -3, pour un noeud n'appartenant qu'a un element ignore +c -4, pour un noeud interne a la face d'une maille +c -5, pour un noeud interne a une maille +c n, pour un noeud p1, c'est-a-dire un sommet d'arete, qui +c appartient a n elements +c +c trav2a vaudra : +c 1, pour un noeud appartenant a au moins un element ignore +c 0, sinon +c +c elem : le numero global de l'element +c typhom : le type dans homard de l'element +c==== +c +c 2.1. ==> initialisation : a priori tous les noeuds sont isoles +c + do 21 , noeud = 1 , nbnoto + trav1a(noeud) = 0 + trav2a(noeud) = 0 + 21 continue +c +c 2.2. ==> pour chaque element soumis au traitement : +c . on incremente de 1 le nombre de voisins de ses sommets +c . on marque a -1 chacun des noeuds milieux d'aretes +c . on marque a -4 son noeud interne +c +c nbsoma = nombre de sommets de la maille +c nbnsma = nombre de noeuds sommets et milieux d'aretes de la maille +c nbndma = nombre total de noeuds de la maille +c + do 22 , el = 1 , nbelem +c +#ifdef _DEBUG_HOMARD_ + if ( el.lt.1 ) then + write (ulsort,90015) 'typele(',el,') = ',typele(el) + do 22221 , iaux = 1 , nbmane + write (ulsort,90007) 'noeele',el,iaux,noeele(el,iaux) +22221 continue + endif +#endif + typhom = medtrf(typele(el)) + nbsoma = nbnref(typhom,1) + nbnsma = nbnref(typhom,2) + nbndma = nbnref(typhom,3) +#ifdef _DEBUG_HOMARD_ + if ( el.lt.1 ) then + write (ulsort,90002) 'typhom',typhom + write (ulsort,90002) 'nbsoma, nbnsma, nbndma',nbsoma,nbnsma,nbndma + endif +#endif + if ( eleinc.ne.0 ) then + if ( tyeref(typhom).ne.0 ) then + nbsoma = 0 + nbnsma = 0 + nbndma = 0 + endif + endif +c + do 221 , iaux = 1 , nbsoma +cgn if ( el.eq.644 .or. el.ge.988 ) then +cgn write (ulsort,90007) 'noeele',el,iaux,noeele(el,iaux) +cgn endif + trav1a(noeele(el,iaux)) = trav1a(noeele(el,iaux)) + 1 + 221 continue +c + do 222 , iaux = nbsoma+1 , nbnsma +cgn write (ulsort,90007) 'noeele',el,iaux,noeele(el,iaux) + trav1a(noeele(el,iaux)) = -1 + 222 continue +c + do 223 , iaux = nbnsma+1 , nbndma +cgn write (ulsort,90007) 'noeele',el,iaux,noeele(el,iaux) + trav1a(noeele(el,iaux)) = -4 + 223 continue +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. fin de 2.2.' + write (ulsort,91040) (trav1a(noeud), noeud = 1 , nbnoto) + write (ulsort,91040) (trav2a(noeud), noeud = 1 , nbnoto) +#endif +c +c 2.3. ==> On parcourt les autres elements, non soumis au traitement +c . On regarde toutes les mailles-points. Si son noeud n'a +c toujours pas ete repere (trav1a=0) ou s'il a ete vu comme +c sommet d'un element ignore (trav1a=-3), c'est qu'il ne fait +c partie d'aucun element soumis a l'adaptation. On le +c considere donc comme un noeud support de maille-point. +c . On regarde tous les elements ignores. Pour chacun de leurs +c noeuds, s'il n'a toujours pas ete repere (trav1a=0), on le +c repere par -3. +c +c nbnsma = nombre de noeuds sommets et milieux d'aretes de la maille +c + do 23 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) +c + if ( typhom.eq.tyhmpo ) then +c + if ( trav1a(noeele(el,1)).eq.0 .or. + > trav1a(noeele(el,1)).eq.-3 ) then + trav1a(noeele(el,1)) = -2 + endif +c + else +c + if ( eleinc.eq.0 ) then + nbnsma = 0 + else + if ( tyeref(typhom).eq.0 ) then + nbnsma = 0 + else + nbnsma = nbnref(typhom,2) + endif + endif +c + do 231 , iaux = 1 , nbnsma + if ( trav1a(noeele(el,iaux)).eq.0 ) then + trav1a(noeele(el,iaux)) = -3 + endif + trav2a(noeele(el,iaux)) = 1 + 231 continue +c + endif +c + 23 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. fin de 2.3.' + write (ulsort,91040) (trav1a(noeud), noeud = 1 , nbnoto) + write (ulsort,91040) (trav2a(noeud), noeud = 1 , nbnoto) +#endif +c +c==== +c 3. reperage des numerotations des noeuds entre calcul et +c homard +c on les classe dans l'ordre suivant : les eventuels isoles, les +c supports de maille-points, les p1, et enfin les p2 +c cela va permettre de respecter la convention qui veut que le +c numero du noeud p2 soit superieur aux numeros des deux +c extremites de l'arete qui le porte. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reperage ; codret', codret +#endif +c +c 3.1. ==> initialisation +c + numero = 0 + do 31 , noeud = 1 , rsnoac + nnosho(noeud) = 0 + 31 continue +c +c 3.2. ==> les noeuds isoles +c + do 32 , noeud = 1 , nbnoto + if ( trav1a(noeud).eq.0 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud +cgn write (ulsort,90015) 'numero', numero, ' noeud', noeud + endif + 32 continue +c + nbnois = numero +c +c 3.3. ==> les noeuds d'elements ignores +c + do 33 , noeud = 1 , nbnoto + if ( trav1a(noeud).eq.-3 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud + endif + 33 continue +c + nbnoei = numero - nbnois +c +c 3.4. ==> les noeuds supports de maille-point +c + do 34 , noeud = 1 , nbnoto + if ( trav1a(noeud).eq.-2 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud + endif + 34 continue +c + nbnomp = numero - nbnoei - nbnois +c +c 3.5. ==> les noeuds p1 +c + do 35 , noeud = 1 , nbnoto + if ( trav1a(noeud).ge.1 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud + endif + 35 continue +c + nbnop1 = numero - nbnomp - nbnoei - nbnois +c +c 3.6. ==> les noeuds p2 milieu d'aretes, le cas echeant +c + if ( degre.eq.2 ) then +c + do 36 , noeud = 1 , nbnoto + if ( trav1a(noeud).eq.-1 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud + endif + 36 continue +c + nbnop2 = numero - nbnop1 - nbnomp - nbnoei - nbnois +c + else +c + nbnop2 = 0 +c + endif +c +c 3.7. ==> les noeuds internes, le cas echeant +c + if ( degre.eq.2 ) then +c + do 37 , noeud = 1 , nbnoto +cgn write (ulsort,90015) 'trav1a(',noeud,')', trav1a(noeud) + if ( trav1a(noeud).eq.-4 ) then + numero = numero + 1 + nnosho(noeud) = numero + nnosca(numero) = noeud + endif + 37 continue +c + nbnoim = numero - nbnop2 - nbnop1 - nbnomp - nbnoei - nbnois +c + else +c + nbnoim = 0 +c + endif +c +c 3.8. ==> pas de noeuds internes aux volumes coupes par conformite +c + nbnoin = 0 +c +c 3.9. ==> verification +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) nbnoto + write (ulsort,texte(langue,12)) nbnop1 + write (ulsort,texte(langue,13)) nbnop2 + write (ulsort,texte(langue,14)) nbnoim + write (ulsort,texte(langue,15)) nbnois + write (ulsort,texte(langue,16)) nbnoei + write (ulsort,texte(langue,17)) nbnomp +#endif +c + if ( numero.ne.nbnoto ) then +c + write(ulsort,texte(langue,4)) + write(ulsort,texte(langue,5)) numero + write(ulsort,texte(langue,6)) nbnoto + codret = 1 +c + endif +c +c 3.9. ==> numeros mini/maxi des noeuds p1 +c + numip1 = nbnois + nbnoei + nbnomp + 1 +c + numap1 = numip1 + nbnop1 - 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. fin de 3.' +#endif +c +c +c==== +c 4. caracterisations : +c . l'etat vaut : 0 pour les noeuds isoles, +c 1 pour les sommets, +c 2 pour les noeuds milieux. +c 3 pour les noeuds support de maille-point. +c 4 pour les noeuds internes aux mailles +c 7 pour les noeuds n'appartenant qu'a des +c elements ignores +c . les coordonnees sont les memes +c . la caracteristique est la famille MED du noeud +c . on suppose que l'on part d'un macro-maillage +c . les autres caracteristiques sont mises a 0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. caracterisations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 4.1. ==> caracteristiques +c + do 41 , noeud = 1 , nbnoto + nunoca = nnosca(noeud) + if ( trav1a(nunoca).eq.-4 ) then + hetnoe(noeud) = 4 + elseif ( trav1a(nunoca).eq.-3 ) then + hetnoe(noeud) = 7 + elseif ( trav1a(nunoca).eq.-2 ) then + hetnoe(noeud) = 3 + elseif ( trav1a(nunoca).eq.-1 ) then + hetnoe(noeud) = 2 + elseif ( trav1a(nunoca).eq.0 ) then + hetnoe(noeud) = 0 + else + hetnoe(noeud) = 1 + endif + coexno(noeud,cofamd) = fameno(nunoca) +cgn write (ulsort,90015) 'hetnoe(',noeud,')', hetnoe(noeud) +cgn write (ulsort,90015) 'nnosca(',noeud,')', nnosca(noeud) + 41 continue +c +c 4.2. ==> coordonnees +c + if ( sdim.eq.2 ) then +c + if ( dimcst.eq.0 .or. dimcst.eq.3 ) then + iaux = 1 + jaux = 2 + elseif ( dimcst.eq.1 ) then + iaux = 2 + jaux = 3 + elseif ( dimcst.eq.2 ) then + iaux = 1 + jaux = 3 + else + write (ulsort,texte(langue,7)) dimcst + codret = 1 + endif +c + if ( codret.eq.0 ) then +c + do 411 , noeud = 1 , nbnoto + nunoca = nnosca(noeud) + coonoe(noeud,1) = coonca(nunoca,iaux) + coonoe(noeud,2) = coonca(nunoca,jaux) + 411 continue +c + endif +c + else +c + do 412 , noeud = 1 , nbnoto + nunoca = nnosca(noeud) + coonoe(noeud,1) = coonca(nunoca,1) + coonoe(noeud,2) = coonca(nunoca,2) + coonoe(noeud,3) = coonca(nunoca,3) + 412 continue +c + endif +c + nbnoma = nbnoto +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. fin de 4.' +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmre0.F b/src/tool/AV_Conversion/vcmre0.F new file mode 100644 index 00000000..b3240583 --- /dev/null +++ b/src/tool/AV_Conversion/vcmre0.F @@ -0,0 +1,170 @@ + subroutine vcmre0 ( nbenti, rsenac, rsento, nbento, + > nensho, nensca, nensic, + > nuenex, decala, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - RENumerotation +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbenti . e . 1 . nombre d'entites dans le calcul . +c . rsenac . e . 1 . nombre d'entites utiles au calcul et . +c . . . . contenant des entites . +c . rsento . e . 1 . nombre d'entites total en sortie . +c . nbento . e . 1 . nombre d'entites total . +c . nensho . es . rsenac . numero des entites dans HOMARD . +c . nensca . es . rsento . numero des entites du calcul . +c . nensic . es . rsento . numero des entites du calcul (initial) . +c . nuenex . e . nbenti . numerotation des entites en exterieur . +c . decala . e . 1 . decalage des numerotations selon le type . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 3 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMRE0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbenti, rsenac, rsento, nbento +c + integer nensho(rsenac), nensca(rsento), nensic(rsento) + integer nuenex(nbenti), decala +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nuelca +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,90002) 'nbenti, rsenac, rsento, nbento', + > nbenti, rsenac, rsento, nbento + write (ulsort,90002) 'decala', decala +#endif +c + codret = 0 +c +c==== +c 2. renumerotation des entites le cas echeant +c==== +c + if ( rsenac.ne.0 ) then +cgn write (ulsort,*) 'nensca en entree' +cgn write (ulsort,91020) ( nensca(iaux), iaux = 1 , nbento) +cgn write (ulsort,*) 'nuenex' +cgn write (ulsort,91020) ( nuenex(iaux), iaux = 1 , rsenac) +c +c 2.1. ==> archivage de la renumerotation entre HOMARD et la +c numerotation compactee pour l'entite +c + do 21 , iaux = 1 , nbento + nensic(iaux) = nensca(iaux) - decala + 21 continue +cgn write (ulsort,*) 'nensic' +cgn write (ulsort,91020) ( nensic(iaux), iaux = 1 , nbento) +c +c 2.2. ==> initialisation des changements de numerotation +c + do 221 , iaux = 1 , rsenac + nensho(iaux) = 0 + 221 continue +c + do 222 , iaux = 1 , nbento + nensca(iaux) = 0 + 222 continue +c +c 2.3. ==> prise en compte des deux changements de numerotation +c + do 23 , iaux = 1 , nbento + if ( nensic(iaux).ne.-decala ) then + nuelca = nuenex(nensic(iaux)+decala) +cgn write (ulsort,90002) 'iaux,nensic(iaux),nuelca', +cgn >iaux,nensic(iaux),nuelca + nensca(iaux) = nuelca + nensho(nuelca) = iaux + endif + 23 continue +cgn write (ulsort,*) 'nensca en sortie' +cgn write (ulsort,91020) ( nensca(iaux), iaux = 1 , nbento) +cgn write (ulsort,*) 'nensho en sortie' +cgn write (ulsort,91020) ( nensho(iaux), iaux = 1 , rsenac) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmren.F b/src/tool/AV_Conversion/vcmren.F new file mode 100644 index 00000000..02d32384 --- /dev/null +++ b/src/tool/AV_Conversion/vcmren.F @@ -0,0 +1,345 @@ + subroutine vcmren ( nnosho, nnosca, nnosic, + > nmpsho, nmpsca, nmpsic, + > narsho, narsca, narsic, + > ntrsho, ntrsca, ntrsic, + > nqusho, nqusca, nqusic, + > ntesho, ntesca, ntesic, + > npysho, npysca, npysic, + > nhesho, nhesca, nhesic, + > npesho, npesca, npesic, + > nunoex, nuelex, decanu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - RENumerotation +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nnosho . es . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . es . rsnoto . numero des noeuds du code de calcul . +c . nnosic . es . rsnoto . numero des noeuds du code de calcul (init) . +c . nmpsho . es . rsmpac . numero des mailles-points dans HOMARD . +c . nmpsca . es . rsmpto . numero des mailles-points du calcul . +c . nmpsic . es . rsmpto . numero des mailles-points du calcul (init) . +c . narsho . es . rsarac . numero des aretes dans HOMARD . +c . narsca . es . rsarto . numero des aretes du calcul . +c . narsic . es . rsarto . numero des aretes du calcul (initial) . +c . ntrsho . es . rstrac . numero des triangles dans HOMARD . +c . ntrsca . es . rstrto . numero des triangles du calcul . +c . ntrsic . es . rstrto . numero des triangles du calcul (initial) . +c . nqusho . es . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . es . rsquto . numero des quadrangles du calcul . +c . nqusic . es . rsquto . numero des quadrangles du calcul (initial) . +c . ntesho . es . rsteac . numero des tetraedres dans HOMARD . +c . ntesca . es . rsteto . numero des tetraedres du calcul . +c . ntesca . es . rsteto . numero des tetraedres du calcul (initial) . +c . npysho . es . rspyac . numero des pyramides dans HOMARD . +c . npysca . es . rspyto . numero des pyramides du calcul . +c . npysic . es . rspyto . numero des pyramides du calcul (initial) . +c . nhesho . es . rsheac . numero des hexaedres dans HOMARD . +c . nhesca . es . rsheto . numero des hexaedres du calcul . +c . nhesic . es . rsheto . numero des hexaedres du calcul (initial) . +c . npesho . es . rspeac . numero des pentaedres dans HOMARD . +c . npesca . es . rspeto . numero des pentaedres du calcul . +c . npesic . es . rspeto . numero des pentaedres du calcul (initial) . +c . nunoex . e . nbnoto . numerotation des noeuds en exterieur . +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . decanu . e . -1:7 . decalage des numerotations selon le type . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 3 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMREN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombsr.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer nnosho(rsnoac), nnosca(rsnoto), nnosic(rsnoto) + integer nmpsho(rsmpac), nmpsca(rsmpto), nmpsic(rsmpto) + integer narsho(rsarac), narsca(rsarto), narsic(rsarto) + integer ntrsho(rstrac), ntrsca(rstrto), ntrsic(rstrto) + integer nqusho(rsquac), nqusca(rsquto), nqusic(rsquto) + integer ntesho(rsteac), ntesca(rsteto), ntesic(rsteto) + integer npysho(rspyac), npysca(rspyto), npysic(rspyto) + integer nhesho(rsheac), nhesca(rsheto), nhesic(rsheto) + integer npesho(rspeac), npesca(rspeto), npesic(rspeto) +c + integer nunoex(nbnoto), nuelex(nbelem) + integer decanu(-1:7) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. renumerotation des noeuds +c==== +c + iaux = decanu(-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_NO', nompro +#endif + call vcmre0 ( nbnoto, rsnoac, rsnoto, nbnoto, + > nnosho, nnosca, nnosic, + > nunoex, iaux, + > ulsort, langue, codret ) +c +c==== +c 3. renumerotation des mailles-points le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rsmpac.ne.0 ) then +c + iaux = decanu(0) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_MP', nompro +#endif + call vcmre0 ( nbelem, rsmpac, rsmpto, nbmpto, + > nmpsho, nmpsca, nmpsic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. renumerotation des aretes le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rsarac.ne.0 ) then +c + iaux = decanu(1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_AR', nompro +#endif + call vcmre0 ( nbelem, rsarac, rsarto, nbarto, + > narsho, narsca, narsic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. renumerotation des triangles le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rstrac.ne.0 ) then +c + iaux = decanu(2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_TR', nompro +#endif + call vcmre0 ( nbelem, rstrac, rstrto, nbtrto, + > ntrsho, ntrsca, ntrsic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. renumerotation des quadrangles le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rsquac.ne.0 ) then +c + iaux = decanu(4) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_QU', nompro +#endif + call vcmre0 ( nbelem, rsquac, rsquto, nbquto, + > nqusho, nqusca, nqusic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. renumerotation des tetraedres le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rsteac.ne.0 ) then +c + iaux = decanu(3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_TE', nompro +#endif + call vcmre0 ( nbelem, rsteac, rsteto, nbteto, + > ntesho, ntesca, ntesic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. renumerotation des pyramides le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rspyac.ne.0 ) then +c + iaux = decanu(5) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_PY', nompro +#endif + call vcmre0 ( nbelem, rspyac, rspyto, nbpyto, + > npysho, npysca, npysic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. renumerotation des hexaedres le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rsheac.ne.0 ) then +c + iaux = decanu(6) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_HE', nompro +#endif + call vcmre0 ( nbelem, rsheac, rsheto, nbheto, + > nhesho, nhesca, nhesic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. renumerotation des pentaedres le cas echeant +c==== +c + if ( codret.eq.0 ) then +c + if ( rspeac.ne.0 ) then +c + iaux = decanu(7) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMRE0_PE', nompro +#endif + call vcmre0 ( nbelem, rspeac, rspeto, nbpeto, + > npesho, npesca, npesic, + > nuelex, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 11. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcms20.F b/src/tool/AV_Conversion/vcms20.F new file mode 100644 index 00000000..674f3f7c --- /dev/null +++ b/src/tool/AV_Conversion/vcms20.F @@ -0,0 +1,741 @@ + subroutine vcms20 ( nocman, maext0, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - +c - - - +c Saturne 2D - phase 0 - Neptune 2D +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocman . e . char*8 . nom de l'objet maillage calcul iteration n . +c . maext0 . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMS20' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envca1.h" +c +#include "nbutil.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nocman +c + integer maext0 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbele2, nbman2, nbmaa2, nbmaf2 + integer nbse2d, nbtr2d, nbqu2d + integer nbno2d + integer nbno3d +c + integer pfamen, pfamee, pnoeel, ptypel, pcoonc, adcocs + integer pnuele, pnunoe + integer pinfpt, pinftl, pinftb + integer nbnomb, adnomb + integer lgpoin, lgtabl +c + integer ptrav1, ptrav2 + integer pfano2, pcono2 + integer pfame2, ptype2, pnoee2 + integer famaux(3) +c + integer iaux, jaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + character*8 saux08 + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*8 ntrav1, ntrav2 + character*8 nfano2, ncono2 + character*8 nfame2, ntype2, nnoee2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Maillage'',i2,''D'')' + texte(1,5) = '(''. Nombre de '',a,'' :'',i10)' + texte(1,6) = + >'(''Le nombre de noeuds,'',i10,'' devrait etre pair.'')' +c + texte(2,4) = '(i1,''D mesh'')' + texte(2,5) = '(''. Number of '',a,'' :'',i10)' + texte(2,6) = '(''The number of nodes,'',i10,'' should be pair.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maext0', maext0 +#endif +c + maextr = maext0 +c +c==== +c 2. recuperation des donnees du maillage a modifier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. recuperation donnees ; codret', codret +#endif +c +c 2.1. ==> les noms des structures +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocman, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> les principales constantes +c + if ( codret.eq.0 ) then +c + call gmliat ( ncnoeu, 1, nbno3d, codre1 ) + call gmliat ( nccono, 1, nbelem, codre2 ) + call gmadoj ( ncnomb, adnomb, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMC', nompro +#endif + call utnbmc ( imem(adnomb), + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 3 + write (ulsort,texte(langue,5)) mess14(langue,3,2), nbtria + write (ulsort,texte(langue,5)) mess14(langue,3,4), nbquad + write (ulsort,texte(langue,5)) mess14(langue,3,6), nbhexa + write (ulsort,texte(langue,5)) mess14(langue,3,7), nbpent +#endif +c + endif +c +c 2.3. ==> les adresses +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 114114 + call utad11 ( iaux, ncnoeu, nccono, + > pcoonc, pfamen, jaux, adcocs, + > ptypel, pfamee, pnoeel, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. traitement des noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. traitement des noeuds ; codret', codret +#endif +c +c 3.1. ==> nombre de noeuds du futur maillage +c + if ( codret.eq.0 ) then +c + if ( mod(nbno3d,2).eq.0 ) then +c + nbno2d = nbno3d/2 + 1 +c + else +c + write (ulsort,texte(langue,6)) nbno3d + codret = 1 +c + endif +c + endif +c +c 3.2. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbno2d, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbno3d, ptrav2, codre2 ) + call gmalot ( nfano2, 'entier ', nbno2d, pfano2, codre3 ) + iaux = nbno2d*2 + call gmalot ( ncono2, 'reel ', iaux , pcono2, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 3.3. ==> traitement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS21', nompro +cgn call gmprsx (nompro,ncnoeu//'.Coor') +#endif + call vcms21 ( nbno3d, imem(pfamen), rmem(pcoonc), rmem(adcocs), + > nbno2d, imem(ptrav1), imem(ptrav2), + > imem(pfano2), rmem(pcono2), famaux(3), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro//' - NUSTNO', ntrav1) + call gmprsx (nompro//' - NU2DNO', ntrav2) + call gmprsx (nompro//' - COON2D', ncono2) + call dmflsh (iaux) + endif +#endif +c +c==== +c 4. traitement des mailles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. traitement des mailles ; codret', codret +#endif +c +c 4.1. ==> preliminaires +c nombre de mailles du futur maillage : +c 1 hexaedre donne 1 quadrangle +c --> nbhexa quadrangles +c 1 pentaedre donne 1 triangle +c --> nbpent triangles +c 1 quadrangle sur la face superieure est ignore +c 1 quadrangle sur la face inferieure est ignore +c 1 quadrangle sur les faces laterales donne 1 segment +c --> nbquad - 2*nbhexa segments +c + if ( codret.eq.0 ) then +c + nbse2d = nbquad - 2*nbhexa + nbtr2d = nbpent + nbqu2d = nbhexa + nbele2 = nbtr2d + nbqu2d + nbse2d + if ( nbtr2d.eq.0 .and. nbqu2d.eq.0 ) then + nbman2 = 2 + nbmaa2 = 2 + elseif ( nbqu2d.eq.0 ) then + nbman2 = 3 + nbmaa2 = 3 + else + nbman2 = 4 + nbmaa2 = 4 + endif + nbmaf2 = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 2 + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbse2d + write (ulsort,texte(langue,5)) mess14(langue,3,2), nbtr2d + write (ulsort,texte(langue,5)) mess14(langue,3,4), nbqu2d +#endif +c + endif +c +c 4.2. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + call gmalot ( nfame2, 'entier ', nbele2, pfame2, codre1 ) + call gmalot ( ntype2, 'entier ', nbele2, ptype2, codre2 ) + iaux = nbele2*nbman2 + call gmalot ( nnoee2, 'entier ', iaux , pnoee2, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 4.3. ==> traitement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS22', nompro +ccc call gmprsx (nompro,nccono//'.FamilMED') +ccc call gmprsx (nompro,nccono//'.Type') +ccc call gmprsx (nompro,nccono//'.Noeuds') +#endif + call vcms22 ( maextr, + > nbno3d, nbelem, + > nbse2d, nbtr2d, nbqu2d, nbele2, + > imem(ptrav2), rmem(pcoonc), + > imem(pfamee), imem(ptypel), imem(pnoeel), + > imem(pfame2), imem(ptype2), imem(pnoee2), + > famaux(1), famaux(2), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro//' - Familles', nfame2) + call gmprsx (nompro//' - Types des mailles', ntype2) + call gmprsx (nompro//' - Connectivites', nnoee2) + call dmflsh(iaux) + endif +#endif +c +c==== +c 5. Les informations generales +c On ajoute 3 informations : familles des faces inf et sup, +c famille du noeud supplementaire +c La longueur du tableau "Pointeur" evolue : + 3 +c Les nom et unite sont en char*16 alors que les numeros des +c familles seront codes sur des char*8 : +c . la longueur du tableau "Taille" evolue : + 3 +c . la longueur du tableau "Table" evolue : + 3 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Informations generales ; codret', codret +#endif +c +c 5.1. ==> Caracteristiques de la structure et allongement du tableau +c des pointeurs et des tables +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') + call dmflsh(iaux) +#endif +c + call gmliat ( ncinfo, 1, lgpoin, codre1 ) + call gmliat ( ncinfo, 2, lgtabl, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgpoin', lgpoin + write (ulsort,90002) 'lgtabl', lgtabl +#endif +c + iaux = lgpoin + 1 + call gmecat ( ncinfo, 1, iaux, codre1 ) + call gmmod ( ncinfo//'.Pointeur', + > pinfpt, lgpoin, iaux, 1, 1, codre2 ) + iaux = lgtabl + 10 + call gmecat ( ncinfo, 2, iaux, codre3 ) + call gmmod ( ncinfo//'.Taille', + > pinftl, lgtabl, iaux, 1, 1, codre4 ) + call gmmod ( ncinfo//'.Table', + > pinftb, lgtabl, iaux, 1, 1, codre5 ) + lgpoin = lgpoin + 1 + lgtabl = lgtabl + 10 +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'lgpoin', lgpoin + write (ulsort,90002) 'lgtabl', lgtabl + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') + endif +#endif +c +c 5.2. ==> Mise a jour du contenu : ajout des numeros de familles des +c faces inf et sup et du noeud complementaire +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. Maj contenu ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(pinfpt+lgpoin-1) = imem(pinfpt+lgpoin-2) + 10 + imem(pinftl+lgtabl-10) = 8 + smem(pinftb+lgtabl-10) = 'SATURNE ' +c + do 521 , iaux = 1 , 3 +c + if ( codret.eq.0 ) then +c + call utench ( famaux(iaux), 'd', jaux, saux08, + > ulsort, langue, codret ) + imem(pinftl+lgtabl-10+iaux) = 8 + smem(pinftb+lgtabl-10+iaux) = saux08 +c + endif +c + 521 continue +c + do 522 , iaux = 4, 9 +c + imem(pinftl+lgtabl-10+iaux) = 0 +c + 522 continue +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncinfo) + call gmprsx (nompro,ncinfo//'.Pointeur') + call gmprsx (nompro,ncinfo//'.Taille') + call gmprsx (nompro,ncinfo//'.Table') +#endif +c + endif +c +c==== +c 6. Rangement dans la structure du maillage de calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Rangement structure ; codret', codret +ccc call gmprsx (nompro,nocman) +#endif +c +c 6.1. ==> Generalites +c + if ( codret.eq.0 ) then +c + sdim = 2 + call gmecat ( nocman, 1, sdim, codre1 ) + mdim = 2 + call gmecat ( nocman, 2, mdim, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.2. ==> Les noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. Les noeuds ; codret', codret +#endif +c +c 6.2.1. ==> Suppression des structures obsoletes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.2.1. ncnoeu avant :' + call gmprsx (nompro,ncnoeu) +#endif +c + call gmlboj ( ncnoeu//'.Coor', codre1 ) + call gmlboj ( ncnoeu//'.FamilMED', codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.2.2. ==> Mise a jour +c + if ( codret.eq.0 ) then +c + call gmecat ( ncnoeu, 1, nbno2d, codre1 ) + call gmatoj ( ncnoeu//'.Coor', ncono2, codre2 ) + call gmatoj ( ncnoeu//'.FamilMED' , nfano2, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.2.3. ==> Les numerotations externes +c + if ( codret.eq.0 ) then +c + call gmobal ( ncnoeu//'.NumeExte', codret ) + if ( codret.eq.2 ) then + call gmmod ( ncnoeu//'.NumeExte', + > pnunoe, nbno3d, nbno2d, 1, 1, codret ) + elseif ( codret.eq.0 ) then + call gmaloj ( ncnoeu//'.NumeExte', ' ', nbno2d, pnunoe, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + do 623 , iaux = 1 , nbno2d + imem(pnunoe-1+iaux) = iaux + 623 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.2.3. ncnoeu apres :' + call gmprsx (nompro,ncnoeu) +#endif +c + endif +c +c 6.3. ==> Les mailles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. Les mailles ; codret', codret +#endif +c +c 6.3.1. ==> Suppression des structures obsoletes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.3.1. nccono avant :' + call gmprsx (nompro,nccono) +#endif +c + call gmlboj ( nccono//'.FamilMED', codre1 ) + call gmlboj ( nccono//'.Type', codre2 ) + call gmlboj ( nccono//'.Noeuds', codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 6.3.2. ==> Mise a jour +c + if ( codret.eq.0 ) then +c + call gmatoj ( nccono//'.FamilMED', nfame2, codre1 ) + call gmatoj ( nccono//'.Type', ntype2, codre2 ) + call gmatoj ( nccono//'.Noeuds' , nnoee2, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nccono, 1, nbele2, codre1 ) + call gmecat ( nccono, 2, nbman2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.3.3. ==> Les numerotations externes +c + if ( codret.eq.0 ) then +c + call gmobal ( nccono//'.NumeExte', codret ) + if ( codret.eq.2 ) then + call gmmod ( nccono//'.NumeExte', + > pnuele, nbelem, nbele2, 1, 1, codret ) + elseif ( codret.eq.0 ) then + call gmaloj ( nccono//'.NumeExte', ' ', nbele2, pnuele, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + do 633 , iaux = 1 , nbele2 + imem(pnuele-1+iaux) = iaux + 633 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.2.3. nccono apres :' + call gmprsx (nompro,nccono) +#endif +c + endif +c +c 6.4. ==> Les generalites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.4. Les generalites ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.4. ncnomb avant :' + call gmprsx (nompro,ncnomb) +#endif +c + imem(adnomb) = nbmaa2 + imem(adnomb+1) = nbmaf2 + imem(adnomb+3) = nbno2d + imem(adnomb+4) = nbele2 + imem(adnomb+5) = nbtr2d + nbqu2d + imem(adnomb+6) = 0 + imem(adnomb+12) = nbse2d + imem(adnomb+13) = nbtr2d + imem(adnomb+15) = 0 + imem(adnomb+16) = nbqu2d + imem(adnomb+17) = 0 + imem(adnomb+18) = 0 + imem(adnomb+47) = famaux(1) + imem(adnomb+48) = famaux(2) + imem(adnomb+49) = famaux(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.4. ncnomb apres :' + call gmprsx (nompro,ncnomb) +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nocman) +#endif +c + endif +c +c==== +c 7. menage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. menage ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 8. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcms21.F b/src/tool/AV_Conversion/vcms21.F new file mode 100644 index 00000000..6be86df7 --- /dev/null +++ b/src/tool/AV_Conversion/vcms21.F @@ -0,0 +1,284 @@ + subroutine vcms21 ( nbno3d, famnoe, coonoe, coocst, + > nbno2d, nustno, nu2dno, + > famn2d, coon2d, famnzz, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - +c - - - +c Saturne 2D - phase 1 - Neptune 2D +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbno3d . e . 1 . nombre de noeuds du maillage 3d . +c . famnoe . e . nbno3d . famille des noeuds . +c . coonoe . e . nbno3d . coordonnees des noeuds . +c . . . * sdim . . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . nbno2d . e . 1 . nombre de noeuds du maillage 2d . +c . nustno . s . nbno2d . numero saturne/neptune des noeuds du calcul. +c . nu2dno . s . nbno3d . numero du calcul des noeuds saturne/neptune. +c . famn2d . s . nbno2d . famille des noeuds du maillage 2d . +c . coon2d . s .nbno2d*2. coordonnees des noeuds du maillage 2d . +c . famnzz . s . 1 . famille du noeud memorisant cooinf et zsup . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMS21' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer nbno3d, nbno2d + integer nustno(nbno2d), nu2dno(nbno3d) + integer famnoe(nbno3d), famn2d(nbno2d), famnzz +c + double precision coocst(11) + double precision coon2d(nbno2d,2) + double precision coonoe(nbno3d,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer iaux1, iaux2 +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,5) = + >'(''Nombre de noeuds pour le maillage 3D :'',i10)' + texte(1,6) = + >'(''Nombre de noeuds attendus pour le maillage 2D :'',i10)' + texte(1,7) = + >'(''Nombre de noeuds trouves pour le maillage 2D :'',i10)' + texte(1,8) = '(''==> epaisseur maximale = '',g13.5)' + texte(1,9) = '(''==> coordonnee '',a3,'' ='',g13.5)' +c + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,5) = + > '(''Number of nodes for the 3D mesh :'',i10)' + texte(2,6) = + > '(''Expected number of nodes for the 2D mesh:'',i10)' + texte(2,7) = + > '(''Found number of nodes for the 2D mesh :'',i10)' + texte(2,8) = '(''==> maximal thickness:'',g13.5)' + texte(2,9) = '(''==> '',a3,'' coordinate:'',g13.5)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maextr', maextr + write (ulsort,90002) 'nbno2d', nbno2d +#endif +c + if ( maextr.eq.1 ) then + iaux1 = 2 + iaux2 = 3 + elseif ( maextr.eq.2 ) then + iaux1 = 1 + iaux2 = 3 + elseif ( maextr.eq.3 ) then + iaux1 = 1 + iaux2 = 2 + else + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + write (ulsort,texte(langue,4)) 'z', coocst(4), coocst(7) + write (ulsort,texte(langue,8)) coocst(10) + write (ulsort,texte(langue,9)) 'inf', coocst(maextr+1) + write (ulsort,texte(langue,9)) 'sup', coocst(maextr+4) + endif +#endif +c +c==== +c 2. classement des noeuds +c on retient tous ceux qui sont dans le plan cooinf +c on teste la proximite de cooinf au millionieme de l'epaisseur +c on ne remplit le tableau que si on n'a pas depasse le maximum +c de l'allocation pour eviter les plantages parasites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. classement des noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbno3d + write (ulsort,texte(langue,6)) nbno2d-1 +#endif +c + do 21 , iaux = 1 , nbno3d + nu2dno(iaux) = 0 + 21 continue +c + daux = coocst(10)*1.d-6 +c + jaux = 0 +c + do 22 , iaux = 1 , nbno3d +c + if ( abs(coonoe(iaux,maextr)-coocst(maextr+1)).le.daux ) then +c + jaux = jaux + 1 + if ( jaux.le.(nbno2d-1) ) then + coon2d(jaux,1) = coonoe(iaux,iaux1) + coon2d(jaux,2) = coonoe(iaux,iaux2) + famn2d(jaux) = famnoe(iaux) + nustno(jaux) = iaux + nu2dno(iaux) = jaux + endif +c + endif +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) jaux +#endif + if ( jaux.ne.(nbno2d-1) ) then + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + write (ulsort,texte(langue,4)) 'z', coocst(4), coocst(7) + write (ulsort,texte(langue,6)) nbno2d-1 + write (ulsort,texte(langue,7)) jaux + codret = 2 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbno2d-1 +#endif +c +c==== +c 3. creation d'un noeud supplementaire pour conserver les cotes des +c faces inferieures et superieures : ( x = cooinf , y = zsup ) +c on utilise une famille qui n'existe pas dans le maillage fourni. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Noeud supplementaire ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + jaux = nbno2d - 1 + famnzz = 0 +c + 30 continue +c + famnzz = famnzz + 1 +c + do 31 , iaux = 1 , jaux +c + if ( famn2d(iaux).eq.famnzz ) then + goto 30 + endif +c + 31 continue +c + coon2d(nbno2d,1) = coocst(maextr+1) + coon2d(nbno2d,2) = coocst(maextr+4) + famn2d(nbno2d) = famnzz + nustno(nbno2d) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90024) 'Noeud supplementaire', nbno2d, + > coocst(maextr+1), coocst(maextr+4) +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcms22.F b/src/tool/AV_Conversion/vcms22.F new file mode 100644 index 00000000..bbd04727 --- /dev/null +++ b/src/tool/AV_Conversion/vcms22.F @@ -0,0 +1,595 @@ + subroutine vcms22 ( maextr, + > nbnoto, nbelem, + > nbse2d, nbtr2d, nbqu2d, nbele2, + > nu2dno, coonoe, + > fameel, typele, noeele, + > fame2d, type2d, noee2d, + > faminf, famsup, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - +c - - - +c Saturne 2D - phase 2 - Neptune 2D +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non (defaut) . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . nbnoto . e . 1 . nombre de noeuds du maillage externe . +c . nbse2d . e . 1 . nombre de segments du maillage 2d . +c . nbtr2d . e . 1 . nombre de triangles du maillage 2d . +c . nbqu2d . e . 1 . nombre de quadrangles du maillage 2d . +c . nbelem . e . 1 . nombre d'elements du maillage externe . +c . nu2dno . e . nbnoto . numero du calcul des noeuds saturne/neptune. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . fame2d . s . nbele2 . famille med des elements du maillage 2d . +c . type2d . s . nbele2 . type des elements du maillage 2d . +c . noee2d . s . nbele2 . noeuds des elements du maillage 2d . +c . . .*nbman2 . . +c . faminf . s . 1 . famille med des quad de la face inferieure . +c . famsup . s . 1 . famille med des quad de la face superieure . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMS22' ) +c +#include "nblang.h" +#include "consta.h" +#include "consts.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "infini.h" +#include "meddc0.h" +#include "impr02.h" +#include "op0123.h" +c +c 0.3. ==> arguments +c + integer maextr + integer nbnoto + integer nbse2d, nbtr2d, nbqu2d, nbele2 + integer nbelem + integer faminf, famsup + integer nu2dno(nbnoto) + integer fameel(nbelem), typele(nbelem), noeele(nbelem,*) + integer fame2d(nbele2), type2d(nbele2), noee2d(nbele2,*) +c + double precision coonoe(nbnoto,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer iaux1, iaux2 + integer tbiaux(4) + integer el, nuel2d + integer numloc(4) +c + character*1 saux01 +c + double precision xymil(2) + double precision v1(2), vn(2) + double precision daux1, daux2 + double precision epsilo + double precision daux(0:4) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Maille numero :'',i10,'', de noeuds '',8i10)' + texte(1,5) = '(i1,'' noeud(s) sont dans le plan cooinf.'')' + texte(1,6) = '(''Pour un '',a,'', il en faudrait '',a)' + texte(1,7) = '(''Famille de la face '',a,'' : '',i6)' + texte(1,8) = '(''Famille du '',a,i10,'' : '',i6)' + texte(1,9) = + >'(''Nombre de '',a,'' attendus pour le maillage 2D :'',i10)' + texte(1,10) = + >'(''Nombre de '',a,'' trouves pour le maillage 2D :'',i10)' + texte(1,11) = '(''Element '',i10,'' ('',a,''), numloc = '',4i10)' +c + texte(2,4) = '(''Mesh # :'',i10,'', with nodes '',8i10)' + texte(2,5) = '(i1,'' node(s) are in cooinf plane.'')' + texte(2,6) = '(''For '',a,'', '',a,'' were expected.'')' + texte(2,7) = '(''Family for '',a,'' face : '',i6)' + texte(2,8) = '(''Family for '',a,'' #'',i10,'' : '',i6)' + texte(2,9) = + > '(''Expected number of '',a,'' for the 2D mesh :'',i10)' + texte(2,10) = + > '(''Found number of '',a,'' for the 2D mesh :'',i10)' + texte(2,11) = '(''Element '',i10,'' ('',a,''), numloc = '',4i10)' +c +#include "impr03.h" +c + codret = 0 +c + if ( maextr.eq.1 ) then + saux01 = 'X' + iaux1 = 2 + iaux2 = 3 + elseif ( maextr.eq.2 ) then + saux01 = 'Y' + iaux1 = 1 + iaux2 = 3 + elseif ( maextr.eq.3 ) then + saux01 = 'Z' + iaux1 = 1 + iaux2 = 2 + else + codret = 1 + endif +c + nuel2d = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maextr', maextr + write (ulsort,90002) 'nbelem', nbelem + write (ulsort,90002) 'nbele2', nbele2 + write (ulsort,90002) 'nbse2d', nbse2d + write (ulsort,90002) 'nbqu2d', nbqu2d + write (ulsort,90002) 'nbtr2d', nbtr2d +#endif +c + epsilo = 1.d-10 * pi +c +c==== +c 2. transformations des quadrangles en segments +c Attention a les mettre avant les quadrangles pour respecter +c les conventions ... +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. quad -> segm ; codret', codret +#endif +c + faminf = 1 + famsup = 1 +c + do 21 , el = 1 , nbelem +c + if ( codret.eq.0 ) then +c + if ( typele(el).eq.edqua4 ) then +c +c 2.1. ==> recherche des noeuds dans le plan cooinf +c + jaux = 0 + do 211 , iaux = 1 , 4 + if ( nu2dno(noeele(el,iaux)).ne.0 ) then + jaux = jaux + 1 + numloc(jaux) = noeele(el,iaux) + if ( jaux.eq.1 ) then + kaux = iaux + else + laux = iaux + endif + endif + 211 continue +c +#ifdef _DEBUG_HOMARD_ + if ( jaux.gt.0 .and. el.lt.1 ) then + write (ulsort,texte(langue,11)) el, 'quad', + > (numloc(iaux),iaux=1,jaux) + endif +#endif +c +c 2.2. ==> si exactement 2 noeuds sont dans le plan, on cree le segment +c Le segment est cree avec les noeuds dans l'ordre +c d'apparition dans la connectivite du quadrangle. Cela +c permettra a la reconstitution du quadrangle apres adaptation +c de retrouver la meme orientation de la face. +c attention au retournemnt eventuel ... +c + if ( jaux.eq.2 ) then +c + nuel2d = nuel2d + 1 + if ( kaux.eq.1 .and. laux.eq.4 ) then + iaux = numloc(2) + numloc(2) = numloc(1) + numloc(1) = iaux + endif + noee2d(nuel2d,1) = nu2dno(numloc(1)) + noee2d(nuel2d,2) = nu2dno(numloc(2)) + fame2d(nuel2d) = fameel(el) + type2d(nuel2d) = edseg2 +c +c 2.3. ==> si exactement 4 noeuds sont dans ce plan, c'est la face +c inferieure. On memorise le numero de famille +c + elseif ( jaux.eq.4 ) then +c + if ( faminf.eq.1 ) then + faminf = fameel(el) + else + if ( fameel(el).ne.faminf ) then + write (ulsort,texte(langue,7)) 'inf', faminf + write (ulsort,texte(langue,8)) + > mess14(langue,1,4), el, fameel(el) + codret = 23 + endif + endif +c +c 2.4. ==> si exactement 4 noeuds sont dans l'autre plan, c'est la face +c superieure. On memorise le numero de famille +c + elseif ( jaux.eq.0 ) then +c + if ( famsup.eq.1 ) then + famsup = fameel(el) + else + if ( fameel(el).ne.famsup ) then + write (ulsort,texte(langue,7)) 'sup', famsup + write (ulsort,texte(langue,8)) + > mess14(langue,1,4), el, fameel(el) + codret = 24 + endif + endif +c +c 2.5. ==> sinon, c'est louche ... +c + else +c + write (ulsort,texte(langue,4)) el,(noeele(el,iaux),iaux=1,4) + write (ulsort,texte(langue,5)) jaux + write (ulsort,texte(langue,6)) mess14(langue,1,4), + > '0, 2 ou 4' +c + endif +c + endif +c + endif +c + 21 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'nuel2d', nuel2d +cgn write (ulsort,90002) 'nbse2d', nbse2d + if ( nuel2d.ne.nbse2d ) then + write (ulsort,texte(langue,9)) mess14(langue,3,1), nbse2d + write (ulsort,texte(langue,10)) + > mess14(langue,3,1), nuel2d-nbse2d + codret = 222 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'inf', faminf + write (ulsort,texte(langue,7)) 'sup', famsup +#endif +c +c==== +c 3. transformations des hexaedres en quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. hexa -> quad ; codret', codret +#endif +c + if ( nbqu2d.ne.0 ) then +c + do 31 , el = 1 , nbelem +c + if ( codret.eq.0 ) then +c + if ( typele(el).eq.edhex8 ) then +c +c 3.1. ==> recherche des noeuds dans le plan cooinf +c +cgn write (ulsort,90012) 'noeele',el,(noeele(el,iaux),iaux=1,8) + jaux = 0 + do 311 , iaux = 1 , 8 + if ( nu2dno(noeele(el,iaux)).ne.0 ) then + jaux = jaux + 1 + numloc(jaux) = noeele(el,iaux) + endif + 311 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'jaux', jaux + if ( nuel2d.eq.nbse2d.or. nuel2d.eq.988.or.nuel2d.eq.987 ) then + write (ulsort,texte(langue,11)) el, 'hexa', + > (numloc(iaux),iaux=1,jaux) + write (ulsort,90004) 'X',(coonoe(numloc(iaux),1),iaux = 1,jaux) + write (ulsort,90004) 'Y',(coonoe(numloc(iaux),2),iaux = 1,jaux) + write (ulsort,90004) 'Z',(coonoe(numloc(iaux),3),iaux = 1,jaux) + endif +#endif +c +c 3.2. ==> si exactement 4 noeuds sont dans ce plan, creation du +c quadrangle asssocie +c attention a bien ranger les noeuds pour ne pas croiser ! +c pour cela, on les positionne en fonction de leur milieu : +c +c Y +c . +c . +c 4...............3 +c . . . +c . . . +c . . . +c ........M...........> X +c . . . +c . . . +c . . . +c 1...............2 +c +c + if ( jaux.eq.4 ) then +c +c Le milieu du quadrangle +c + xymil(1) = 0.d0 + xymil(2) = 0.d0 + do 313 , iaux = 1 , 4 + xymil(1) = xymil(1) + coonoe(numloc(iaux),iaux1) + xymil(2) = xymil(2) + coonoe(numloc(iaux),iaux2) + 313 continue + xymil(1) = unsqu * xymil(1) + xymil(2) = unsqu * xymil(2) +cgn write (ulsort,90004) 'xymil', xymil +c +c Le vecteur entre le milieu et le premier noeud +c + v1(1) = coonoe(numloc(1),iaux1) - xymil(1) + v1(2) = coonoe(numloc(1),iaux2) - xymil(2) + daux1 = sqrt(v1(1)**2+v1(2)**2) + v1(1) = v1(1)/daux1 + v1(2) = v1(2)/daux1 +cgn write (ulsort,90004) 'v1', v1 +c +c Les angles entre le segment (milieu,noeud 1) et +c (milieu,noeud suivant) +c + do 314 , iaux = 2 , 4 + vn(1) = coonoe(numloc(iaux),iaux1) - xymil(1) + vn(2) = coonoe(numloc(iaux),iaux2) - xymil(2) + daux1 = sqrt(vn(1)**2+vn(2)**2) + vn(1) = vn(1)/daux1 + vn(2) = vn(2)/daux1 +cgn write (ulsort,*) ' ' +cgn write (ulsort,90114) 'vn', iaux,vn + daux1 = v1(1)*vn(1) + v1(2)*vn(2) + daux2 = v1(1)*vn(2) - v1(2)*vn(1) +cgn write (ulsort,90114) 'p scal', iaux, daux1 +cgn write (ulsort,90114) 'p vect', iaux, daux2 +c + if ( (daux1+1.d0).le.zeroma ) then + daux(iaux) = pi + else + daux(iaux) = acos(daux1) + endif + if ( daux2.le.0.d0 ) then + daux(iaux) = deuxpi - daux(iaux) + endif + 314 continue +#ifdef _DEBUG_HOMARD_ + if ( nuel2d.lt.1 ) then + write (ulsort,90004) 'angles', daux(2), daux(3), daux(4) + endif +#endif +c +c Classement des angles +c + daux1 = min(daux(2), daux(3), daux(4)) + daux2 = max(daux(2), daux(3), daux(4)) +cgn write (ulsort,90004) 'angles min', daux1 +cgn write (ulsort,90004) 'angles max', daux2 + tbiaux(1) = 1 + do 315 , iaux = 2 , 4 + if ( abs(daux(iaux)-daux1).le.epsilo ) then + tbiaux(2) = iaux + endif + if ( abs(daux(iaux)-daux2).le.epsilo ) then + tbiaux(4) = iaux + endif + 315 continue +c + tbiaux(3) = fp0123(tbiaux(2)-1, tbiaux(4)-1) + 1 +cgn write (ulsort,90002) 'tbiaux final ', tbiaux +c +c Transfert de la connectivite +c + nuel2d = nuel2d + 1 + do 316 , iaux = 1 , 4 + noee2d(nuel2d,iaux) = nu2dno(numloc(tbiaux(iaux))) + 316 continue + fame2d(nuel2d) = fameel(el) + type2d(nuel2d) = edqua4 +#ifdef _DEBUG_HOMARD_ + if ( nuel2d.lt.1 ) then + write (ulsort,90015) 'typele(',nuel2d,') = ',type2d(nuel2d) + do 32221 , iaux = 1 , 4 + write (ulsort,90007) + > ' noeele',nuel2d,iaux,noee2d(nuel2d,iaux) +32221 continue + endif +#endif +c + else + write (ulsort,texte(langue,4)) el,(noeele(el,iaux),iaux=1,8) + write (ulsort,texte(langue,5)) jaux + write (ulsort,texte(langue,6)) mess14(langue,1,9), '4' +c a changer un jour + codret = 31 + endif +c + endif +c + endif +c + 31 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'nuel2d', nuel2d +cgn write (ulsort,90002) 'nbqu2d', nbqu2d +cgn write (ulsort,90002) 'nuel2d-nbse2d', nuel2d-nbse2d + if ( (nuel2d-nbse2d).ne.nbqu2d ) then + write (ulsort,texte(langue,9)) mess14(langue,3,4), nbqu2d + write (ulsort,texte(langue,10)) mess14(langue,3,4), + > nuel2d-nbse2d + codret = 333 + endif +c + endif +c + endif +c +c==== +c 4. transformations des pentaedres en triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. pent -> tria ; codret', codret +#endif +c + if ( nbtr2d.ne.0 ) then +c + if ( codret.eq.0 ) then +c + do 41 , el = 1 , nbelem +c + if ( typele(el).eq.edpen6 ) then +c +c 4.1. ==> recherche des noeuds dans le plan cooinf +c + jaux = 0 + do 411 , iaux = 1 , 6 + if ( nu2dno(noeele(el,iaux)).ne.0 ) then + jaux = jaux + 1 + numloc(jaux) = noeele(el,iaux) + endif + 411 continue +c +#ifdef _DEBUG_HOMARD_ + if ( jaux.gt.0 ) then + write (ulsort,texte(langue,11)) el, 'pent', + > (numloc(iaux),iaux=1,jaux) + endif +#endif +c +c 4.2. ==> si exactement 3 noeuds sont dans ce plan, creation du +c triangle asssocie +c + if ( jaux.eq.3 ) then +c + nuel2d = nuel2d + 1 + noee2d(nuel2d,1) = nu2dno(numloc(3)) + noee2d(nuel2d,2) = nu2dno(numloc(2)) + noee2d(nuel2d,3) = nu2dno(numloc(1)) + fame2d(nuel2d) = fameel(el) + type2d(nuel2d) = edtri3 +c + else + write (ulsort,texte(langue,4)) el,(noeele(el,iaux),iaux=1,8) + write (ulsort,texte(langue,5)) jaux + write (ulsort,texte(langue,6)) mess14(langue,1,9), '4' +c a changer un jour + codret = 42 + endif +c + endif +c + 41 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'nuel2d', nuel2d +cgn write (ulsort,90002) 'nbtr2d', nbtr2d +cgn write (ulsort,90002) 'nuel2d-nbse2d-nbqu2d', nuel2d-nbse2d-nbqu2d + if ( (nuel2d-nbse2d-nbqu2d).ne.nbtr2d ) then + write (ulsort,texte(langue,9)) mess14(langue,3,2), nbtr2d + write (ulsort,texte(langue,10)) mess14(langue,3,2), + > nuel2d-nbse2d-nbqu2d + codret = 444 + endif +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcms2d.F b/src/tool/AV_Conversion/vcms2d.F new file mode 100644 index 00000000..91894ef4 --- /dev/null +++ b/src/tool/AV_Conversion/vcms2d.F @@ -0,0 +1,168 @@ + subroutine vcms2d ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - Saturne 2D - Neptune 2D +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMS2D' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux +c + character*6 saux + character*7 saux07 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( taopti(11).eq.26 .or. + > taopti(11).eq.36 ) then + saux07 = 'SATURNE' + elseif ( taopti(11).eq.46 .or. + > taopti(11).eq.56 ) then + saux07 = 'NEPTUNE' + else + if ( langue.eq.1 ) then + saux07 = 'PRISMES' + else + saux07 = 'PRISMS ' + endif + endif +c + texte(1,4) = + > '(/,a6,1x,'''//saux07//' - PASSAGE DU MAILLAGE 3D EN 2D'')' + texte(1,5) = '(45(''=''),/)' +c + texte(2,4) = '(/,a6,1x,'''//saux07//' - FROM 3D MESH TO 2D'')' + texte(2,5) = '(35(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. conversion du maillage +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS20', nompro +#endif + call vcms20 ( taopts(1), taopti(39), + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcmver.F b/src/tool/AV_Conversion/vcmver.F new file mode 100644 index 00000000..87eedbf8 --- /dev/null +++ b/src/tool/AV_Conversion/vcmver.F @@ -0,0 +1,429 @@ + subroutine vcmver ( modhom, nomail, action, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion de Maillage - VERification +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . nomail . es . char*8 . nom de l'objet maillage homard iteration n . +c . action . e . char8 . action en cours . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCMVER' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +#ifdef _DEBUG_HOMARD_ +#include "dicfen.h" +#include "nbfami.h" +#endif +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer modhom +c + character*8 nomail + character*8 action +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer phetar, psomar + integer ppovos, pvoiso + integer pposif, pfacar + integer phettr, paretr + integer phetqu, parequ + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu +c + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer ptra15, ptra16 +c + integer iaux, jaux, kaux, laux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer nbquad, nbblqu +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*8 ntra15, ntra16 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = '(''Erreur pour ce maillage au format '',a)' + texte(1,8) = '(i6,'' blocs de '',a,/)' + texte(1,9) = + > '(''Le maillage initial ne doit comporter que la boite 0.'',/)' + texte(1,10) = '(5x,''Verifications complementaires'',/)' +c + texte(2,7) = '(''Error with this mesh from '',a)' + texte(2,8) = '(i6,'' blocks of '',a,/)' + texte(2,9) = '(''Initial mesh must contain only box # 0.'',/)' + texte(2,10) = '(5x,''Additional controls'',/)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) +#endif +c +c==== +c 2. Controle preliminaire du maillage d'entree +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVERI', nompro +#endif +c + iaux = 0 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. recuperation des donnees ; codret = ', codret +#endif +c +c 3.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 3.2. ==> adresses des tableaux +c + if ( typcca.eq.16 ) then +c +c 3.2.1. ==> les aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 14 + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.2. ==> les voisinages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + iaux = 1 + jaux = 0 + kaux = 0 + laux = 0 + call utvois ( nomail, nhvois, + > iaux, jaux, kaux, laux, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.3. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + call gmobal ( nhquad, codret ) + if ( codret.eq.1 ) then + call gmliat( nhquad, 1, nbquad, codret ) + elseif ( codret.ne.0 ) then + codret = 2 + endif +c + endif +c + if ( nbquad.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 14 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2.4. ==> divers +c + phettr = 1 + paretr = 1 + pfamtr = 1 + pcfatr = 1 +c + endif +c +c==== +c 4. recherche des blocs dans le cas d'Athena +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. recherche blocs Athena ; codret = ', codret +#endif +c + if ( typcca.eq.16 ) then +c +c 4.1. ==> allocation de structures temporaires +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbquto, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', nbarto, ptrav3, codre3 ) + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre4 ) + iaux = nbquto + 1 + call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmalot ( ntra15, 'entier ', nbarto, ptra15, codre1 ) + call gmalot ( ntra16, 'entier ', nbarto, ptra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 4.2. ==> les blocs +c + if ( codret.eq.0 ) then +c +c on examine toutes les faces +c + jaux = nbquto + nbtrto + do 42 , iaux = 0, jaux + imem(ptrav4+iaux) = 1 + 42 continue + imem(ptrav4+nbquto) = 0 + iaux = 0 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11C', nompro +#endif + call utb11c ( nbblqu, iaux, imem(ptrav4), + > imem(phetar), imem(psomar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > imem(ptra15), imem(ptra16), + > imem(ptrav5), + > jaux, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +10000 format(3x,20i4) +10001 format(4x,80('-')) + write(ulsort,*) 'Fin etape 3 avec codret = ', codret + write(ulsort,texte(langue,8)) nbblqu, mess14(langue,3,4) + write(ulsort,10000) (iaux,iaux=1,min(20,nbquto)) + write(ulsort,10001) + write(ulsort,10000) (imem(ptrav1+iaux),iaux=0,min(20,nbquto-1)) + write(ulsort,10000) (imem(pcfaqu+iaux),iaux=0,nctfqu*nbfqua-1) + write(ulsort,10000) (imem(pfamqu+iaux),iaux=0,min(20,nbquto-1)) +#endif +c + endif +c +c 4.3. ==> diagnostic +c + if ( codret.eq.0 ) then +c + if ( nbblqu.ne.1 ) then +c +#include "mslve4.h" + write(ulsort,texte(langue,8)) nbblqu, mess14(langue,3,4) + write(ulsort,texte(langue,9)) + codret = 12 +c + endif +c + endif +c +c 4.4. ==> menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) + call gmlboj ( ntrav4, codre4 ) + call gmlboj ( ntrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmlboj ( ntra15, codre1 ) + call gmlboj ( ntra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. fin ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcori1.F b/src/tool/AV_Conversion/vcori1.F new file mode 100644 index 00000000..db316cba --- /dev/null +++ b/src/tool/AV_Conversion/vcori1.F @@ -0,0 +1,173 @@ + subroutine vcori1 ( elemen, typhom, numfac, letria, + > areele, aretri, + > code, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - ORIentation - phase 1 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c ______________________________________________________________________ +c . elemen . e . 1 . numero de l'element en cours d'examen . +c . typhom . e . 1 . type homard de l'element en cours d'examen . +c . numfac . e . 1 . numero de la face en cours d'examen . +c . letria . e . 1 . numero homard du triangle . +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . code . s . 1 . code de la numfac-eme face dans elemen . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCORI1' ) +c +#include "nblang.h" +#include "referx.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "refere.h" +#include "nbutil.h" +#include "nombtr.h" +#include "i1i2i3.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer elemen, typhom, numfac + integer letria + integer areele(nbelem,nbmaae) + integer aretri(nbtrto,3) + integer code +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer a1, a2, a3 +#ifdef _DEBUG_HOMARD_ + integer glop + integer jaux +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Element'',i10,'', de type HOMARD'',i4)' + texte(1,5) = + > '(4x,''==> '',a,i10,'', face de numero local'',i2,'' :'')' + texte(1,7) = '(''Impossible de trouver le code'')' +c + texte(2,4) = '(''Element'',i10,'', with HOMARD type'',i4)' + texte(2,5) = '(4x,''==> '',a,i10,'', local face position'',i2)' + texte(2,7) = '(''Code cannot be found'')' +c +#include "impr03.h" +c +c==== +c 2. exploration des possibilites +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,2), letria + write (ulsort,90002) mess14(langue,3,1), + > (aretri(letria,jaux),jaux=1,3) + endif +#endif +c + a1 = areele(elemen,defref(typhom,numfac,1)) + a2 = areele(elemen,defref(typhom,numfac,2)) + a3 = areele(elemen,defref(typhom,numfac,3)) + do 21 , iaux = 1 , 6 + if ( aretri(letria,i1(iaux)).eq.a1 .and. + > aretri(letria,i2(iaux)).eq.a2 .and. + > aretri(letria,i3(iaux)).eq.a3 ) then + code = iaux + goto 22 + endif + 21 continue +c + codret = codret + 1 +c + write (ulsort,texte(langue,4)) elemen, typhom + write (ulsort,texte(langue,5)) mess14(langue,2,2), + > letria, iaux + write (ulsort,texte(langue,7)) +c + 22 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcori2.F b/src/tool/AV_Conversion/vcori2.F new file mode 100644 index 00000000..54860d96 --- /dev/null +++ b/src/tool/AV_Conversion/vcori2.F @@ -0,0 +1,175 @@ + subroutine vcori2 ( elemen, typhom, numfac, lequad, + > areele, arequa, + > code, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - ORIentation - phase 2 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c ______________________________________________________________________ +c . elemen . e . 1 . numero de l'element en cours d'examen . +c . typhom . e . 1 . type homard de l'element en cours d'examen . +c . numfac . e . 1 . numero de la face en cours d'examen . +c . lequad . e . 1 . numero homard du quadrangle . +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . code . s . 1 . code de la numfac-eme face dans elemen . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCORI2' ) +c +#include "nblang.h" +#include "referx.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "refere.h" +#include "nbutil.h" +#include "nombqu.h" +#include "j1234j.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer elemen, typhom, numfac + integer lequad + integer areele(nbelem,nbmaae) + integer arequa(nbquto,4) + integer code +#ifdef _DEBUG_HOMARD_ + integer glop + integer jaux +#endif +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer a1, a2, a3, a4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Element'',i10,'', de type HOMARD'',i4)' + texte(1,5) = + > '(4x,''==> '',a,i10,'', face de numero local'',i2,'' :'')' + texte(1,7) = '(''Impossible de trouver le code'')' +c + texte(2,4) = '(''Element'',i10,'', with HOMARD type'',i4)' + texte(2,5) = '(4x,''==> '',a,i10,'', local face position'',i2)' + texte(2,7) = '(''Code cannot be found'')' +c +#include "impr03.h" +c +c==== +c 2. exploration des possibilites +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,4), lequad + write (ulsort,90002) mess14(langue,3,1), + > (arequa(lequad,jaux),jaux=1,3) + endif +#endif +c + a1 = areele(elemen,defref(typhom,numfac,1)) + a2 = areele(elemen,defref(typhom,numfac,2)) + a3 = areele(elemen,defref(typhom,numfac,3)) + a4 = areele(elemen,defref(typhom,numfac,4)) + do 21 , iaux = 1 , 8 + if ( arequa(lequad,j1(iaux)).eq.a1 .and. + > arequa(lequad,j2(iaux)).eq.a2 .and. + > arequa(lequad,j3(iaux)).eq.a3 .and. + > arequa(lequad,j4(iaux)).eq.a4 ) then + code = iaux + goto 22 + endif + 21 continue +c + codret = codret + 1 +c + write (ulsort,texte(langue,4)) elemen, typhom + write (ulsort,texte(langue,5)) mess14(langue,2,2), + > lequad, iaux + write (ulsort,texte(langue,7)) +c + 22 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcorie.F b/src/tool/AV_Conversion/vcorie.F new file mode 100644 index 00000000..5198a450 --- /dev/null +++ b/src/tool/AV_Conversion/vcorie.F @@ -0,0 +1,736 @@ + subroutine vcorie ( eleinc, noeele, areele, typele, + > somare, aretri, arequa, + > nnosho, narsho, ntrsho, nqusho, + > coexar, + > tritet, cotrte, ntesho, + > quahex, coquhe, nhesho, + > facpen, cofape, npesho, + > facpyr, cofapy, npysho, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - ORIEntation +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c ______________________________________________________________________ +c . eleinc . e . 1 . elements incompatibles . +c . . . . 0 : on bloque s'il y en a . +c . . . . 1 : on les ignore s'il y en a . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . nnosho . e . rsnoac . numero des noeuds dans HOMARD . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . s .nbtecf*4. code des 4 triangles des tetraedres . +c . ntesho . e . rsteac . numero des tetraedres dans HOMARD . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . s .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . nhesho . e . rsheac . numero des hexaedres dans HOMARD . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . s .nbpecf*5. codes des 5 faces des pentaedres . +c . npesho . e . rspeac . numero des pentaedres dans HOMARD . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . s .nbpycf*5. codes des faces des pyramides . +c . npyrho . e . repyac . numero des pyramides dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCORIE' ) +c +#include "nblang.h" +#include "referx.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "dicfen.h" +#include "refert.h" +#include "refere.h" +#include "nbutil.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombsr.h" +#include "envca1.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer eleinc + integer noeele(nbelem,nbmane) + integer areele(nbelem,nbmaae) + integer typele(nbelem) + integer somare(2,nbarto), aretri(nbtrto,3) + integer arequa(nbquto,4) + integer nnosho(rsnoac), narsho(rsarac) + integer ntrsho(rstrac), nqusho(rsquac) + integer coexar(nbarto,nctfar) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer ntesho(rsteac) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer nhesho(rsheac) + integer facpen(nbpecf,5), cofape(nbpecf,5) + integer npesho(rspeac) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) + integer npysho(rspyac) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer elemen, typhom + integer numfac + integer letria, lequad + integer letetr, lehexa, lepent, lapyra + integer s1, s2 + integer sa1a2, sa1a3, sa1a4, sa2a3, sa3a4 + integer a1, a2, a3, a4 + integer orient + integer code +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Element'',i10,'', de type HOMARD'',i4)' + texte(1,5) = + > '(4x,''==> '',a,i10,'', face de numero local'',i2,'' :'')' + texte(1,7) = '(''Impossible de trouver le code'')' +c + texte(2,4) = '(''Element'',i10,'', with HOMARD type'',i4)' + texte(2,5) = '(4x,''==> '',a,i10,'', local face position'',i2)' + texte(2,7) = '(''Code cannot be found'')' +c +#include "impr03.h" +c +c==== +c 2. determination de l'orientation des aretes, des triangles et +c des quadrangles +c==== +c + do 20 , elemen = 1 , nbelem +c + typhom = medtrf(typele(elemen)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.eq.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,4)) elemen, typhom + endif +#endif +c +c 2.1. ==> on saute si c'est un element incompatible avec le mode +c d'utilisation de HOMARD +c + if ( eleinc.ne.0 ) then + if ( tyeref(typhom).ne.0 ) then + goto 20 + endif + endif +c +c 2.2. ==> les aretes +c +c code de calcul : x--------x HOMARD : x---------x +c s1 s2 iaux n2 +c + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,1), narsho(elemen) + endif +#endif +c +c s1 = numero dans HOMARD du 1er noeud de l'element dans MED +c + s1 = nnosho(noeele(elemen,1)) +c +c iaux = numero dans HOMARD du 1er noeud de l'arete +c narsho(elemen) correspondant a l'element elemen dans MED +c + iaux = somare(1,narsho(elemen)) +c + if ( iaux.eq.s1 ) then + orient = 1 + else + orient = -1 + endif +c + coexar(narsho(elemen),coorfa) = orient +c +c 2.3. ==> les triangles +c en fonction du positionnement relatif des noeuds, on a une valeur +c d'orientation. +c il y a 6 possibilites : +c . la valeur absolue est le numero local MED du sommet en face +c de l'arete a1 +c . on note positif quand la description par +c aretes (HOMARD) tourne dans le meme sens que la description +c par noeuds (MED), negatif pour le sens inverse : +c +c s3 s3 s3 +c /\ /\ /\ +c / \ / \ / \ +c a2/ 1 \a1 a1/ 2 \a3 a3/ 3 \a2 +c / \ / \ / \ +c /________\ /________\ /________\ +c s1 a3 s2 s1 a2 s2 s1 a1 s2 +c +c s3 s3 s3 +c /\ /\ /\ +c / \ / \ / \ +c a3/ -1 \a1 a1/ -2 \a2 a2/ -3 \a3 +c / \ / \ / \ +c /________\ /________\ /________\ +c s1 a2 s2 s1 a3 s2 s1 a1 s2 +c +c on va modifier la description du triangle pour faire coincider +c les numero si et les sommets des aretes ai, saiaj : +c +c s3 sa2a3 +c /\ /\ +c MED : / \ HOMARD : a3/ \a2 +c / \ / \ +c /______\ /______\ +c s1 s2 sa1a3 a1 sa1a2 +c + elseif ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,2), ntrsho(elemen) + endif +#endif +c +c numeros dans HOMARD du 1er et 2eme noeud +c de l'element elemen dans MED +c + s1 = nnosho(noeele(elemen,1)) + s2 = nnosho(noeele(elemen,2)) +c +c ak = numero dans HOMARD de la k-eme arete +c du triangle ntrsho(elemen) correspondant a l'element elemen +c dans MED +c sajak = numero dans HOMARD du noeud +c commun aux aretes aj et ak +c + a1 = aretri(ntrsho(elemen),1) + a2 = aretri(ntrsho(elemen),2) + a3 = aretri(ntrsho(elemen),3) +c + if ( somare(1,a1) .eq. somare(1,a3) .or. + > somare(1,a1) .eq. somare(2,a3) ) then +c le 1er noeud de l'arete 1 est un des sommets de a3 ; +c donc le 2nd noeud de l'arete 1 est un des sommets de a2 + sa1a3 = somare(1,a1) + sa1a2 = somare(2,a1) + else +c le 1er noeud de l'arete 1 n'est pas un des sommets de a3 ; +c donc c'est qu'il est un des sommets de a2 +c donc le 2nd noeud de l'arete 1 est un des sommets de a3 + sa1a3 = somare(2,a1) + sa1a2 = somare(1,a1) + endif +c +c comparaison des deux numerotations +c + if ( s1 .eq. sa1a3 ) then + if ( s2 .eq. sa1a2 ) then +cgn orient = 3 + aretri(ntrsho(elemen),1) = a2 + aretri(ntrsho(elemen),2) = a3 + aretri(ntrsho(elemen),3) = a1 + else +cgn orient = -2 + aretri(ntrsho(elemen),1) = a2 + aretri(ntrsho(elemen),2) = a1 + aretri(ntrsho(elemen),3) = a3 + endif + elseif ( s1 .eq. sa1a2 ) then + if ( s2 .eq. sa1a3 ) then +cgn orient = -3 + aretri(ntrsho(elemen),1) = a3 + aretri(ntrsho(elemen),3) = a1 + else +cgn orient = 2 + aretri(ntrsho(elemen),1) = a3 + aretri(ntrsho(elemen),2) = a1 + aretri(ntrsho(elemen),3) = a2 + endif + else +c on a alors s1 .eq. sa2a3 + if ( s2 .ne. sa1a3 ) then +cgn orient = -1 + aretri(ntrsho(elemen),2) = a3 + aretri(ntrsho(elemen),3) = a2 +cgn else +cgn orient = 1 + endif + endif +c +c 2.4. ==> les quadrangles +c en fonction du positionnement relatif des noeuds, on a une valeur +c d'orientation. +c il y a 8 possibilites : +c . on note positif quand la description par +c aretes (HOMARD) tourne dans le meme sens que la description +c par noeuds (MED), negatif pour le sens inverse +c . la valeur absolue est le numero local MED du sommet commun +c aux aretes a1 et a4 si >0, a1 et a2 si <0 +c +c remarque : entre deux orientations de signes opposes, +c les aretes 1 et 3 sont a la meme place et +c les aretes 2 et 4 sont permutees. +c +c +c s1 a4 s4 s1 a3 s4 s1 a2 s4 s1 a1 s4 +c .________. .________. .________. .________. +c . . . . . . . . +c . . . . . . . . +c a1. 1 .a3 a4. 2 .a2 a3. 3 .a1 a2. 4 .a4 +c . . . . . . . . +c .________. .________. .________. .________. +c s2 a2 s3 s2 a1 s3 s2 a4 s3 s2 a3 s3 +c +c +c +c s1 a2 s4 s1 a3 s4 s1 a4 s4 s1 a1 s4 +c .________. .________. .________. .________. +c . . . . . . . . +c . . . . . . . . +c a1. -1 .a3 a2. -2 .a4 a3. -3 .a1 a4. -4 .a2 +c . . . . . . . . +c .________. .________. .________. .________. +c s2 a4 s3 s2 a1 s3 s2 a2 s3 s2 a3 s3 +c +c on va modifier la description du quadrangle pour faire coincider +c les numero si et les sommets des aretes ai, saiaj : +c +c +c s1 s4 sa4a1 a4 sa3a4 +c .________. .________. +c . . . . +c . . . . +c MED : . . HOMARD : a1. .a3 +c . . . . +c .________. .________. +c s2 s3 sa1a2 a2 sa2a3 +c +c + elseif ( typhom.eq.tyhqu1 .or. typhom.eq.tyhqu2 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,4), nqusho(elemen) + endif +#endif +c +c numeros dans HOMARD du 1er et 2eme noeud +c de l'element elemen dans MED +c + s1 = nnosho(noeele(elemen,1)) + s2 = nnosho(noeele(elemen,2)) +c +c ak = numero dans HOMARD de la k-eme arete +c du quadrangle nqusho(elemen) correspondant a l'element elemen +c dans MED +c sajak = numero dans HOMARD du noeud +c commun aux aretes aj et ak +c +c on commence par regarder si le sommet s1 est une extremite de +c l'arete a1 +c + a1 = arequa(nqusho(elemen),1) + a2 = arequa(nqusho(elemen),2) + a3 = arequa(nqusho(elemen),3) + a4 = arequa(nqusho(elemen),4) +c + if ( somare(1,a1) .eq. somare(1,a2) .or. + > somare(1,a1) .eq. somare(2,a2) ) then +c le 1er noeud de l'arete 1 est un des sommets de a2 ; +c donc le 2nd noeud de l'arete 1 est un des sommets de a4 + sa1a2 = somare(1,a1) + sa1a4 = somare(2,a1) + else +c le 1er noeud de l'arete 1 n'est pas un des sommets de a2 ; +c donc c'est qu'il est un des sommets de a4 +c donc le 2nd noeud de l'arete 1 est un des sommets de a2 + sa1a2 = somare(2,a1) + sa1a4 = somare(1,a1) + endif +c + if ( s1 .eq. sa1a4 ) then + if ( s2 .ne. sa1a2 ) then +cgn orient = -4 + arequa(nqusho(elemen),1) = a4 + arequa(nqusho(elemen),2) = a3 + arequa(nqusho(elemen),3) = a2 + arequa(nqusho(elemen),4) = a1 +cgn else +cgn orient = 1 + endif + elseif ( s1 .eq. sa1a2 ) then + if ( s2 .eq. sa1a4 ) then +cgn orient = -1 + arequa(nqusho(elemen),2) = a4 + arequa(nqusho(elemen),4) = a2 + else +cgn orient = 4 + arequa(nqusho(elemen),1) = a2 + arequa(nqusho(elemen),2) = a3 + arequa(nqusho(elemen),3) = a4 + arequa(nqusho(elemen),4) = a1 + endif +c + else +c +c le sommet s1 n'est pas une extremite de l'arete a1 +c il est donc un sommet de a3. on precise comment +c + if ( somare(1,a3) .eq. somare(1,a2) .or. + > somare(1,a3) .eq. somare(2,a2) ) then +c le 1er noeud de l'arete 3 est un des sommets de a2 ; +c donc le 2nd noeud de l'arete 3 est un des sommets de a4 + sa2a3 = somare(1,a3) + sa3a4 = somare(2,a3) + else +c le 1er noeud de l'arete 3 n'est pas un des sommets de a2 ; +c donc c'est qu'il est un des sommets de a4 +c donc le 2nd noeud de l'arete 3 est un des sommets de a2 + sa2a3 = somare(2,a3) + sa3a4 = somare(1,a3) + endif +c + if ( s1 .eq. sa3a4 ) then + if ( s2 .eq. sa2a3 ) then +cgn orient = -3 + arequa(nqusho(elemen),1) = a3 + arequa(nqusho(elemen),3) = a1 + else +cgn orient = 2 + arequa(nqusho(elemen),1) = a4 + arequa(nqusho(elemen),2) = a1 + arequa(nqusho(elemen),3) = a2 + arequa(nqusho(elemen),4) = a3 + endif + else + if ( s2 .eq. sa3a4 ) then +cgn orient = 3 + arequa(nqusho(elemen),1) = a3 + arequa(nqusho(elemen),2) = a4 + arequa(nqusho(elemen),3) = a1 + arequa(nqusho(elemen),4) = a2 + else +cgn orient = -2 + arequa(nqusho(elemen),1) = a2 + arequa(nqusho(elemen),2) = a1 + arequa(nqusho(elemen),3) = a4 + arequa(nqusho(elemen),4) = a3 + endif + endif +c + endif +cgn print *,elemen,nnosho(noeele(elemen,1)), +cgn > nnosho(noeele(elemen,2)), +cgn > nnosho(noeele(elemen,3)), +cgn > nnosho(noeele(elemen,4)) +cgn print *,nqusho(elemen),arequa(nqusho(elemen),1), +cgn > arequa(nqusho(elemen),2), +cgn > arequa(nqusho(elemen),3), +cgn > arequa(nqusho(elemen),4) +cgn print *,orient +c + endif +c + 20 continue +c +c==== +c 3. determination des codes des faces dans les volumes +c==== +c + do 30 , elemen = 1 , nbelem +c + typhom = medtrf(typele(elemen)) +c +#ifdef _DEBUG_HOMARD_ + if ( elemen.ge.-12 ) then + glop = 1 + else + glop = 0 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,4)) elemen, typhom + endif +#endif +c +c 3.1. ==> on saute si c'est un element incompatible avec le mode +c d'utilisation de HOMARD +c + if ( eleinc.ne.0 ) then + if ( tyeref(typhom).ne.0 ) then + goto 30 + endif + endif +c +c 3.2. ==> les tetraedres +c + if ( typhom.eq.tyhte1 .or. typhom.eq.tyhte2 ) then +c + letetr = ntesho(elemen) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,2,3), letetr + write (ulsort,90002) mess14(langue,3,1), + > (areele(elemen,iaux),iaux=1,6) + endif +#endif +c + do 321 , iaux = 1 , 4 +c + numfac = iaux + letria = tritet(letetr,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI1', nompro +#endif + call vcori1 ( elemen, typhom, numfac, letria, + > areele, aretri, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + cotrte(letetr,numfac) = code + endif +c + 321 continue +c +c 3.3. ==> les hexaedres +c + elseif ( typhom.eq.tyhhe1 .or. typhom.eq.tyhhe2 ) then +c + lehexa = nhesho(elemen) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,2,6), lehexa + write (ulsort,90002) mess14(langue,3,1), + > (areele(elemen,iaux),iaux=1,6) + write (ulsort,90002) mess14(langue,3,1), + > (areele(elemen,iaux),iaux=7,12) + endif +#endif +c + do 331 , iaux = 1 , 6 +c + numfac = iaux + lequad = quahex(lehexa,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI2', nompro +#endif + call vcori2 ( elemen, typhom, numfac, lequad, + > areele, arequa, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + coquhe(lehexa,numfac) = code + endif +c + 331 continue +c +c 3.4. ==> les pentaedres +c + elseif ( typhom.eq.tyhpe1 .or. typhom.eq.tyhpe2 ) then +c + lepent = npesho(elemen) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,2,7), lepent + write (ulsort,90002) mess14(langue,3,1), + > (areele(elemen,iaux),iaux=1,9) + endif +#endif +c + do 341 , iaux = 1 , 2 +c + numfac = iaux + letria = facpen(lepent,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI1', nompro +#endif + call vcori1 ( elemen, typhom, numfac, letria, + > areele, aretri, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + cofape(lepent,iaux) = code + endif +c + 341 continue +c + do 344 , iaux = 3 , 5 +c + numfac = iaux + lequad = facpen(lepent,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI2', nompro +#endif + call vcori2 ( elemen, typhom, numfac, lequad, + > areele, arequa, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + cofape(lepent,numfac) = code + endif +c + 344 continue +c +c 3.5. ==> les pyramides +c + elseif ( typhom.eq.tyhpy1 .or. typhom.eq.tyhpy2 ) then +c + lapyra = npysho(elemen) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,2,5), lapyra + write (ulsort,90002) mess14(langue,3,1), + > (areele(elemen,iaux),iaux=1,8) + endif +#endif +c + do 351 , iaux = 1 , 4 +c + numfac = iaux + letria = facpyr(lapyra,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI1', nompro +#endif + call vcori1 ( elemen, typhom, numfac, letria, + > areele, aretri, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + cofapy(lapyra,numfac) = code + endif +c + 351 continue +c + numfac = 5 + lequad = facpyr(lapyra,numfac) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCORI2', nompro +#endif + call vcori2 ( elemen, typhom, numfac, lequad, + > areele, arequa, + > code, + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + cofapy(lapyra,numfac) = code + endif +c + endif +c + 30 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfal.F b/src/tool/AV_Conversion/vcsfal.F new file mode 100644 index 00000000..561c4f12 --- /dev/null +++ b/src/tool/AV_Conversion/vcsfal.F @@ -0,0 +1,226 @@ + subroutine vcsfal ( nbelem, nbf, + > pointl, taigrl, nomgrl, + > coexar, + > frofam, typefr, nogrfr, + > nuelex, narsho, + > fameel, typele, numfam, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion +c - - +c - Suivi de Frontiere - lien Arete Ligne +c - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbelem . e . 1 . nombre d'elements dans le maillage . +c . nbf . e . 1 . nombre de familles du maillage de calcul . +c . pointl . e .0:nbfron. pointeur sur le tableau nomgrl . +c . taigrl . e . * . taille des noms des groupes des frontieres . +c . nomgrl . e . * . noms des groupes des frontieres . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . frofam . e . nbfami . donne l'eventuel numero de ligne . +c . . . . associee a chaque famille MED . +c . typefr . es . nbf . type de frontiere (1:ligne/-1:surface) . +c . nogrfr . es . 10*nbf . nom des groupes frontieres CAO . +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . numfam . e . 1 . numero MED des familles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFAL' ) +c +#include "nblang.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nombar.h" +#include "refert.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer nbelem, nbf + integer pointl(0:*) + integer taigrl(*) + integer coexar(nbarto,nctfar) + integer frofam(nbf), typefr(nbf) + integer nuelex(nbelem) + integer narsho(*), fameel(nbelem), typele(nbelem) + integer numfam(*) +c + integer ulsort, langue, codret +c + character*8 nomgrl(*) + character*8 nogrfr(10*nbf) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer el, nufro + integer typhom + integer lgngro +c + character*80 nomgro +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. prise en compte du suivi de frontiere +c prise en compte de la correspondance entre les aretes de bord +c et des lignes du format c pour le suivi de frontiere. +c==== +c +c si une arete est attachee a une frontiere alors le premier code +c contient le numero de la frontiere ; sinon 0 +c le numero de la frontiere est positif si le suivi de frontiere +c est actif pour cette arete, negatif sinon +c le deuxieme code contient le numero de la famille dont le +c numero de frontiere est l'oppose +c + do 21 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) +c + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +c + nufro = 0 + if ( fameel(el).ne.0 ) then + do 211 , iaux = 1 , nbf + if ( numfam(iaux).eq.fameel(el) ) then + nufro = frofam(iaux) + endif + 211 continue + endif +c + coexar(narsho(nuelex(el)),cosfli) = nufro +c +c Si on a trouve une frontiere, on doit supprimer +c l'eventuelle surface +c + if ( nufro.ne.0 ) then +c + coexar(narsho(nuelex(el)),cosfsa) = 0 +c +c memorisation pour le suivi +c + if ( typefr(nufro).eq.0 ) then +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe associe a la frontiere nufro + iaux = pointl(nufro-1) + 1 +c +c longueur utile du nom du groupe + lgngro = 0 + do 31 , jaux = iaux , pointl(nufro) + lgngro = lgngro + taigrl(jaux) + 31 continue +c + endif +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere nufro + call uts8ch ( nomgrl(iaux), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + typefr(nufro) = 1 + call utchs8 ( nomgro, lgngro, nogrfr(10*(nufro-1)+1), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. bilan +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfas.F b/src/tool/AV_Conversion/vcsfas.F new file mode 100644 index 00000000..95007846 --- /dev/null +++ b/src/tool/AV_Conversion/vcsfas.F @@ -0,0 +1,267 @@ + subroutine vcsfas ( nbelem, nbf, + > pointl, taigrl, nomgrl, + > coexar, coextr, coexqu, + > frofam, decala, typefr, nogrfr, + > nuelex, + > fameel, typele, numfam, + > aretri, ntrsho, + > arequa, nqusho, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion +c - - +c - Suivi de Frontiere - lien Arete Surface +c - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbelem . e . 1 . nombre d'elements dans le maillage . +c . nbf . e . 1 . nombre de familles du maillage de calcul . +c . pointl . e .0:nbfron. pointeur sur le tableau nomgrl . +c . taigrl . e . * . taille des noms des groupes des frontieres . +c . nomgrl . e . * . noms des groupes des frontieres . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . coextr . es . nbtrto*. codes de conditions aux limites portants . +c . . . nctftr . sur les triangles . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . frofam . e . nbfami . donne l'eventuel numero de surface . +c . . . . associee a chaque famille MED . +c . decala . e . 1 . decalage dans le stockage des numeros de fr. +c . typefr . es . nbf . type de frontiere (1:ligne/-1:surface) . +c . nogrfr . es . 10*nbf . nom des groupes frontieres CAO . +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . numfam . e . 1 . numero MED des familles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFAS' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "refert.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer nbelem, nbf + integer pointl(0:*) + integer taigrl(*) + integer coexar(nbarto,nctfar) + integer coextr(nbtrto,nctftr) + integer coexqu(nbquto,nctfqu) + integer frofam(nbf), decala + integer typefr(nbf) + integer nuelex(nbelem) + integer fameel(nbelem), typele(nbelem) + integer numfam(*) + integer aretri(nbtrto,3), ntrsho(*) + integer arequa(nbquto,4), nqusho(*) +c + integer ulsort, langue, codret +c + character*8 nomgrl(*) + character*8 nogrfr(10*nbf) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer el, nufro + integer typhom + integer larete + integer lgngro +c + character*80 nomgro +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. prise en compte de la correspondance entre les aretes +c et les surfaces pour le suivi de frontiere. +c==== +c si une arete est attachee a une surface alors le premier code +c contiendra le numero de la surface ; sinon 0 +c le numero de la surface est positif si le suivi de frontiere +c est actif pour cette arete, negatif sinon +c le deuxieme code contient le numero de la famille dont le +c numero de surface est l'oppose +c + do 21 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) +c + if ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 .or. + > typhom.eq.tyhqu1 .or. typhom.eq.tyhqu2 ) then +c + if ( fameel(el).ne.0 ) then +c + nufro = 0 + do 211 , iaux = 1 , nbf + if ( numfam(iaux).eq.fameel(el) ) then + nufro = frofam(iaux) + endif + 211 continue +c + if ( nufro.ne.0 ) then +c +c complement dans le descriptif de la face +c + if ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 ) then + kaux = 3 + else + kaux = 4 + endif +c + do 212 , iaux = 1 , kaux + if ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 ) then + larete = aretri(ntrsho(nuelex(el)),iaux) + else + larete = arequa(nqusho(nuelex(el)),iaux) + endif + if ( coexar(larete,cosfsa).eq.nufro .or. + > coexar(larete,cosfsa).eq. 0 ) then + coexar(larete,cosfsa) = nufro + else + coexar(larete,cosfsa) = -1968 + endif + 212 continue +c +c memorisation pour le suivi +c + if ( typefr(nufro).eq.0 ) then +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe associe a la frontiere nufro + iaux = pointl(nufro-1 - decala) + 1 +c +c longueur utile du nom du groupe + lgngro = 0 + do 31 , jaux = iaux , pointl(nufro - decala) + lgngro = lgngro + taigrl(jaux) + 31 continue +c + endif +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere nufro + call uts8ch ( nomgrl(iaux), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + typefr(nufro) = -1 + call utchs8 ( nomgro, lgngro, nogrfr(10*(nufro-1)+1), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + if ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 ) then + coextr(ntrsho(nuelex(el)),cosfsu) = nufro + else + coexqu(nqusho(nuelex(el)),cosfsu) = nufro + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. bilan +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfin.F b/src/tool/AV_Conversion/vcsfin.F new file mode 100644 index 00000000..bc46ae0c --- /dev/null +++ b/src/tool/AV_Conversion/vcsfin.F @@ -0,0 +1,339 @@ + subroutine vcsfin ( suifro, + > coexar, coextr, coexqu, + > nbgrof, nbfrgr, nbfran, nbf, nbelem, + > pointl, taigrl, nomgrl, + > cacfpo, cacfta, cacfnm, + > calfpo, calfta, calfnm, + > calgpo, calgta, calgnm, + > pointe, nomgrf, + > frofam, typefr, nogrfr, + > nuelex, narsho, + > fameel, typele, + > numfam, nomfam, + > aretri, ntrsho, + > arequa, nqusho, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion +c - - +c - Suivi de Frontiere - INitialisation +c - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . coextr . es . nbtrto*. codes de conditions aux limites portants . +c . . . nctfar . sur les triangles . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . nbgrof . e . 1 . nombre de groupes pour la frontiere . +c . nbfrgr . e . 1 . nombre de liens frontiere/groupe . +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . nbf . e . 1 . nombre de familles du maillage de calcul . +c . nbelem . e . 1 . nombre d'elements dans le maillage . +c . pointl . e .0:nbgrof. pointeur sur le tableau nomgrl . +c . taigrl . e . * . taille des noms des groupes des lignes . +c . nomgrl . e . * . noms des groupes des lignes . +c . cacfpo . e .0:nbfran. pointeurs sur le tableau du nom frontieres . +c . cacfta . e .10nbfran. taille du nom des frontieres . +c . cacfnm . e .10nbfran. nom des frontieres . +c . calfpo . e .0:nbfrgr. pointeurs sur le tableau du nom frontieres . +c . calfta . e .10nbfrgr. taille du nom des frontieres . +c . calfnm . e .10nbfrgr. nom des frontieres . +c . calgpo . e .0:nbfrgr. pointeurs sur le tableau du nom groupes . +c . calgta . e .10nbfrgr. taille du nom des groupes . +c . calgnm . e .10nbfrgr. nom des groupes . +c . pointe . e . 0:nbf . pointeur sur le tableau nomgrf . +c . nomgrf . e . * . noms des groupes des familles . +c . frofam . s . nbf . donne l'eventuel numero de frontiere . +c . . . . associee a chaque famille MED . +c . typefr . s . nbf . type de frontiere (1:ligne/-1:surface) . +c . nogrfr . s . 10*nbf . nom des groupes frontieres CAO . +c . nuelex . e . nbelem . numerotation des elements en exterieur . +c . narsho . e . rsarac . numero des aretes dans HOMARD . +c . fameel . e . nbelem . famille med des elements . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . numfam . e . 1 . numero MED des familles . +c . nomfam . e . 10*nbf . nom des familles MED . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ntrsho . e . rstrac . numero des triangles dans HOMARD . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nqusho . e . rsquac . numero des quadrangles dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFIN' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer suifro + integer nbgrof, nbfrgr, nbfran, nbf, nbelem + integer coexar(nbarto,nctfar) + integer coextr(nbtrto,nctftr) + integer coexqu(nbquto,nctfqu) + integer frofam(nbf), typefr(nbf) + integer pointl(0:nbgrof), taigrl(*) + integer cacfpo(0:nbfran), cacfta(10*nbfran) + integer calfpo(0:nbfrgr), calfta(10*nbfrgr) + integer calgpo(0:nbfrgr), calgta(10*nbfrgr) + integer pointe(0:nbf) + integer nuelex(nbelem) + integer narsho(*) + integer fameel(nbelem), typele(nbelem) + integer numfam(*) + integer aretri(nbtrto,3), ntrsho(*) + integer arequa(nbquto,4), nqusho(*) +c + character*8 cacfnm(10*nbfran) + character*8 calfnm(10*nbfrgr) + character*8 calgnm(10*nbfrgr) + character*8 nomgrl(*) + character*8 nomgrf(*) + character*8 nogrfr(10*nbf) + character*8 nomfam(10,nbf) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de groupes pour la frontiere :'',i10)' + texte(1,5) = '(''Nombre de frontieres discretes :'',i10)' + texte(1,6) = + > '(''Nombre de liens frontiere analytique / groupe :'',i10)' +c + texte(2,4) = '(''Number of groupes for the boundary:'',i10)' + texte(2,5) = '(''Number of discrete boundaries :'',i10)' + texte(2,6) = + > '(''Number of links analytical boundary / group:'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro', suifro + write (ulsort,90002) 'nbf', nbf +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( mod(suifro,5).eq.0 ) then + write (ulsort,texte(langue,4)) nbgrof + else + write (ulsort,texte(langue,5)) nbgrof + write (ulsort,texte(langue,6)) nbfrgr + endif +#endif +c + do 11 , iaux = 1, nbf + typefr(iaux) = 0 + 11 continue + do 12 , iaux = 1, 10*nbf + nogrfr(iaux) = blan08 + 12 continue +c +c==== +c 2. correspondance entre les familles du maillage de calcul +c et les frontieres analytiques +c==== +c + if ( nbfrgr.gt.0 ) then +c +c 2.1. ==> Description par des groupes +c + if ( codret.eq.0 ) then +c + iaux = nbgrof +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFLL', nompro +#endif + call vcsfll ( nbfrgr, nbfran, nbf, + > cacfpo, cacfta, cacfnm, + > calfpo, calfta, calfnm, + > calgpo, calgta, calgnm, + > pointe, nomgrf, numfam, nomfam, + > frofam, iaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Impact dans les caracteristiques des faces +c + if ( codret.eq.0 ) then +c + iaux = nbgrof +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFAS', nompro +#endif + call vcsfas ( nbelem, nbf, + > calgpo, calgta, calgnm, + > coexar, coextr, coexqu, + > frofam, iaux, typefr, nogrfr, + > nuelex, + > fameel, typele, numfam, + > aretri, ntrsho, + > arequa, nqusho, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 3. correspondance entre les familles du maillage de calcul +c et les frontieres discretes ou CAO +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Front. discretes/CAO ; codret', codret +#endif +c + if ( nbgrof.gt.0 ) then +c +c 3.1. ==> Description par des groupes +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFLG', nompro +#endif + call vcsflg ( nbgrof, nbf, + > pointl, taigrl, nomgrl, + > pointe, nomgrf, numfam, nomfam, + > frofam, iaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Impact dans les caracteristiques des faces +c dans le cas de la frontiere CAO +c + if ( mod(suifro,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFAS', nompro +#endif + call vcsfas ( nbelem, nbf, + > pointl, taigrl, nomgrl, + > coexar, coextr, coexqu, + > frofam, iaux, typefr, nogrfr, + > nuelex, + > fameel, typele, numfam, + > aretri, ntrsho, + > arequa, nqusho, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.3. ==> Impact dans les caracteristiques des segments +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFAL', nompro +#endif + call vcsfal ( nbelem, nbf, + > pointl, taigrl, nomgrl, + > coexar, + > frofam, typefr, nogrfr, + > nuelex, narsho, + > fameel, typele, numfam, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfl0.F b/src/tool/AV_Conversion/vcsfl0.F new file mode 100644 index 00000000..2414feca --- /dev/null +++ b/src/tool/AV_Conversion/vcsfl0.F @@ -0,0 +1,359 @@ + subroutine vcsfl0 (sdimca, nbelem, nvosom, nbnoto, nbf, + > coonca, + > typele, fameel, + > povoso, voisom, + > numfam, nomfam, ligfam, + > laligd, nbli00, + > lalign, noelig, arelig, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion +c - - +c - Suivi de Frontiere - creation des Lignes +c - - - +c - phase 0 +c - +c remarque : vcsfl0 et vcsfli sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sdimca . e . * . dimension du maillage de calcul . +c . coonca . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . fameel . e . nbelem . famille med des elements . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . numfam . e . nbf . donne le vrai numero de famille med . +c . . . . associee a chaque famille classee selon . +c . . . . l'ordre d'arrivee . +c . nomfam . e . 10*nbf . nom des familles MED . +c . ligfam . e . nbf . numero de la ligne de la famille MED . +c . nbli00 . e . 1 . nombre estime de lignes . +c . lalign . s . 1 . 0, si aucune ligne n'est fermee . +c . . . . !=0 : numero d'une ligne fermee . +c . noelig . s . 1 . un noeud de la ligne fermee . +c . arelig . s . 1 . une arete liee au noeud noelig . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFL0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "refert.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer sdimca + integer nbelem, nvosom, nbnoto, nbf + integer typele(nbelem), fameel(nbelem) + integer voisom(nvosom), povoso(0:nbnoto) + integer numfam(nbf), ligfam(nbf) + integer laligd, nbli00 + integer lalign, noelig, arelig +c + character*8 nomfam(10,nbf) +c + double precision coonca(nbnoto,sdimca) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer el, elx, typhom + integer nbnoex + integer lig, jaux, kaux, compte +c + integer nbnomx + parameter ( nbnomx = 100 ) + integer tbiaux(nbnomx) +c + character*3 saux03(3) + character*64 saux64 +c + logical exista +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Ligne numero '',i5,/,18(''=''))' + texte(1,5) = + > '(''.'',i5,''-eme famille, de numero MED '',i5,'', de nom '',a)' + texte(1,6) = '(''Estimation du nombre total de lignes :'',i10)' + texte(1,7) = '(''Premiere ligne a examiner :'',i10)' + texte(1,8) = '(''Cette ligne a'',i10,'' extremites ?'')' + texte(1,9) = '(''La ligne numero '',i5,'' est fermee.'')' + texte(1,10) = + > '(''.. Extremite'',i3,'' : noeud '',i10,3(a3,'' ='',g15.8))' +c + texte(2,4) = '(/,''Line # '',i5,/,12(''=''))' + texte(2,5) = '(''.'',i5,''-th family, MED # '',i5,'', name '',a)' + texte(2,6) = '(''Estimation of total number of lines:'',i10)' + texte(2,7) = '(''First line to be examined:'',i10)' + texte(2,8) = '(''This line has got'',i10,'' ends?'')' + texte(2,9) = '(''The line # '',i5,'' is closed.'')' + texte(2,10) = + > '(''.. End #'',i3,'' : noeud '',i10,3(a3,'' ='',g15.8))' +c +#include "impr03.h" +c + codret = 0 +c + saux03(1) = ', X' + saux03(2) = ', Y' + saux03(3) = ', Z' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbli00 + write (ulsort,texte(langue,7)) laligd +#endif +c +c==== +c 2. analyse +c==== +c + lalign = 0 +c + do 20 , lig = laligd , nbli00 +c +c 2.1 ==> recherche d'une extremite de la ligne +c remarque : il est plus economique de boucler d'abord sur +c les familles qui decrivent la ligne courante, puis +c sur les noeuds. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lig +#endif +c + exista = .false. + nbnoex = 0 + noelig = 0 +c +c ..... on parcourt les familles MED, pour ne retenir que celles qui +c ..... correspondent a la ligne courante +c + do 21 , kaux = 1 , nbf +c + if ( codret.eq.0 ) then +c + if ( ligfam(kaux).eq.lig ) then +c +#ifdef _DEBUG_HOMARD_ + saux64( 1: 8) = nomfam(1,kaux) + saux64( 9:16) = nomfam(2,kaux) + saux64(17:24) = nomfam(3,kaux) + saux64(25:32) = nomfam(4,kaux) + saux64(33:40) = nomfam(5,kaux) + saux64(41:48) = nomfam(6,kaux) + saux64(49:56) = nomfam(7,kaux) + saux64(57:64) = nomfam(8,kaux) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,5)) + > kaux, numfam(kaux), saux64(1:jaux) +#endif +c +c ......... on parcourt tous les noeuds du maillage +c + do 211 , iaux = 1 , nbnoto +c + if ( codret.eq.0 ) then +c + compte = 0 +cgn if ( lig.ge.0) then +cgn write(ulsort,90002) 'noeud ',iaux +cgn write(ulsort,90015) '. pointeur des voisins de', +cgn > povoso(iaux-1) + 1, ' a', povoso(iaux) +cgn endif +c +c ........... on parcourt les aretes voisines du noeud +c ........... on compte combien appartiennent a la famille retenue +c + do 2111, jaux = povoso(iaux-1) + 1, povoso(iaux) +c + el = voisom(jaux) +cgn if ( lig.ge.0) then +cgn write(ulsort,90015) '.. voisin # ',jaux, +cgn > ' ; numero et type med',el, medtrf(typele(el)) +cgn endif + if ( numfam(kaux).eq.fameel(el) ) then +c + typhom = medtrf(typele(el)) + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +cgn if ( lig.ge.0) then +cgn write(ulsort,90002)'.. La frontiere contient l''arete', el +cgn endif + elx = el + compte = compte + 1 + exista = .true. + endif +c + endif +c + 2111 continue +c +c .......... si le noeud n'a qu'une seule arete qui appartient +c .......... a la ligne, c'est une extremite +c + if ( compte.eq.1 ) then + nbnoex = nbnoex + 1 + if ( nbnoex.le.nbnomx ) then + tbiaux(nbnoex) = iaux + else + write (ulsort,texte(langue,4)) lig + write (ulsort,texte(langue,8)) nbnoex + codret = codret + 1 + endif +c + elseif ( compte.eq.2 .and. noelig.eq.0 ) then +c +c .......... si le noeud a 2 aretes qui appartient a la ligne, on +c .......... l'enregistre si c'est le premier +c + noelig = iaux + arelig = elx +c + endif +c + endif +c + 211 continue +c + endif +c + endif +c + 21 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoex', nbnoex + write (ulsort,90002) 'noelig, arelig', noelig, arelig +#endif +c +c 2.2. ==> controle : +c . si une ligne est fermee, on sort pour l'ouvrir +c . si une ligne a plus de deux extremites, c'est une erreur +c + if ( codret.eq.0 ) then +c + if ( exista ) then +c + if ( nbnoex.eq.0 ) then +c + lalign = lig + write (ulsort,texte(langue,9)) lig + goto 2999 +c + elseif ( nbnoex.ne.2 ) then +c + write (ulsort,texte(langue,4)) lig + write (ulsort,texte(langue,8)) nbnoex +c + do 221 , kaux = 1 , nbf + if ( ligfam(kaux).eq.lig ) then + saux64( 1: 8) = nomfam(1,kaux) + saux64( 9:16) = nomfam(2,kaux) + saux64(17:24) = nomfam(3,kaux) + saux64(25:32) = nomfam(4,kaux) + saux64(33:40) = nomfam(5,kaux) + saux64(41:48) = nomfam(6,kaux) + saux64(49:56) = nomfam(7,kaux) + saux64(57:64) = nomfam(8,kaux) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,5)) + > kaux, numfam(kaux), saux64(1:jaux) + endif + 221 continue + do 222 , kaux = 1 , nbnoex + jaux = tbiaux(kaux) + write (ulsort,texte(langue,10)) kaux, jaux, + > (saux03(iaux), coonca(jaux,iaux),iaux=1,sdimca) + 222 continue +c + codret = 2 +c + endif +c + endif +c + endif +c + 20 continue +c + 2999 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsflg.F b/src/tool/AV_Conversion/vcsflg.F new file mode 100644 index 00000000..f1149283 --- /dev/null +++ b/src/tool/AV_Conversion/vcsflg.F @@ -0,0 +1,331 @@ + subroutine vcsflg ( nbfron, nbf, + > pointl, taigrl, nomgrl, + > pointe, nomgrf, numfam, nomfam, + > frofam, decala, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - Suivi de Frontiere +c - - - - +c - Lien famille/ligne.surface - par les Groupes +c - - +c ______________________________________________________________________ +c +c Chaque element de frontiere (ligne ou surface) dont on demande le +c suivi est designe par son nom. +c On passe en revue toutes les familles du maillage MED. Quand +c le nom du groupe lie a une frontiere apparait dans la description +c des groupes definissant la famille, on indique que la famille est +c liee a la frontiere courante. La sortie est donc un tableau donnant +c pour chaque famille MED l'eventuel numero de frontiere qui lui +c correspond. +c remarque : vcsflg et vcsfll sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfron . e . 1 . nombre de frontieres decrites . +c . nbf . e . 1 . nombre de familles du maillage de calcul . +c . pointl . e .0:nbfron. pointeur sur le tableau nomgrl . +c . taigrl . e . * . taille des noms des groupes des frontieres . +c . nomgrl . e . * . noms des groupes des frontieres . +c . pointf . e . 0:nbf . pointeur sur le tableau nomgrf . +c . nomgrf . e . * . noms des groupes des familles . +c . numfam . e . 1 . numero MED des familles . +c . nomfam . e . 10*nbf . nom des familles MED . +c . frofam . s . nbf . donne l'eventuel numero de frontiere . +c . . . . associee a chaque famille MED . +c . decala . e . 1 . decalage dans le stockage des numeros de fr. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFLG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfron, nbf + integer numfam(nbf) + integer frofam(nbf), decala + integer pointl(0:nbfron), pointe(0:nbf) + integer taigrl(*) +c + character*8 nomgrl(*) + character*8 nomgrf(*) + character*8 nomfam(10,nbf) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, nufro, fam + integer nbgr, gr + integer lgngro, lgngrm +c + character*64 saux64 + character*80 nomgro, groupm +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Frontiere numero '',i5,/,16(''=''))' + texte(1,5) = '(''. Elle est definie sur le groupe : '',a)' + texte(1,6) = '(7x,''. Comparaison avec le groupe : '',a)' + texte(1,7) = + > '(''.'',i5,''-eme famille, de numero MED '',i5,'', de nom '',a)' + texte(1,8) = + > '(''Cette famille est deja liee a la frontiere '',i5)' + texte(1,9) = '(''On veut ajouter le groupe : '',a)' + texte(1,10) = + > '(i5,'' probleme(s) dans la definition des frontieres.'')' + texte(1,11) = '(7x,''. Cette famille correspond'')' +c + texte(2,4) = '(/,''Boundary #'',i5,/,12(''=''))' + texte(2,5) = '(''. It is defined on group: '',a)' + texte(2,6) = '(7x,''. Comparizon with group: '',a)' + texte(2,7) = '(''.'',i5,''-th family, MED # '',i5,'', name '',a)' + texte(2,8) = + > '(''This family is already connected to boundary'',i5)' + texte(2,9) = '(''Group : '',a,'' is to be added.'')' + texte(2,10) = '(i5,'' problem(s) in boundary definition'')' + texte(2,11) = '(7x,''. This family matches.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. a priori, aucune famille n'est liee a une frontiere +c==== +c + do 21 , iaux = 1, nbf + frofam(iaux) = 0 + 21 continue +c +c On parcourt tous les liens frontiere/groupe +c Remarque : le decodage est analogue a celui de vcfia2 +c + do 10 , nufro = 1, nbfron +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) nufro + endif +#endif +c +c==== +c 3. Nom du groupe associe a ce lien +c==== +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe associe a la frontiere nufro + iaux = pointl(nufro-1) + 1 +c +c longueur utile du nom du groupe + lgngro = 0 + do 31 , jaux = iaux , pointl(nufro) + lgngro = lgngro + taigrl(jaux) + 31 continue +c + endif +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere nufro + call uts8ch ( nomgrl(iaux), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nomgro(1:lgngro) +#endif +c +c==== +c 4. On parcourt toutes les familles de mailles +c==== +c + if ( codret.eq.0 ) then +c + do 40 , fam = 1, nbf +c + if ( numfam(fam).lt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + saux64( 1: 8) = nomfam(1,fam) + saux64( 9:16) = nomfam(2,fam) + saux64(17:24) = nomfam(3,fam) + saux64(25:32) = nomfam(4,fam) + saux64(33:40) = nomfam(5,fam) + saux64(41:48) = nomfam(6,fam) + saux64(49:56) = nomfam(7,fam) + saux64(57:64) = nomfam(8,fam) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,7)) + > fam, numfam(fam), saux64(1:jaux) +#endif +c + nbgr = (pointe(fam)-pointe(fam-1))/10 +c +c 4.1. ==> on parcourt tous les groupes entrant dans la +c definition de la famille +c + do 41 , gr = 1, nbgr +c +c 4.1.1. ==> nom du groupe +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe numero gr de la famille fam + iaux = pointe(fam-1)+1+10*(gr-1) +c +c recuperation du nom du groupe numero gr dans la famille +c numero fam + call uts8ch ( nomgrf(iaux), 80, groupm, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrm, groupm, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) groupm(1:lgngrm) +#endif +c + endif +c +c 4.1.2. ==> si le groupe de la frontiere et le groupe courant +c coincident, on declare que la famille est concernee par +c cette frontiere +c attention, on n'autorise qu'une seule frontiere par famille +c + if ( codret.eq.0 ) then +c + if ( lgngro.eq.lgngrm ) then +c + if ( nomgro(1:lgngro).eq.groupm(1:lgngrm) ) then +c + if ( frofam(fam).eq.0 ) then +c + frofam(fam) = nufro + decala +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) +#endif + else + saux64( 1: 8) = nomfam(1,fam) + saux64( 9:16) = nomfam(2,fam) + saux64(17:24) = nomfam(3,fam) + saux64(25:32) = nomfam(4,fam) + saux64(33:40) = nomfam(5,fam) + saux64(41:48) = nomfam(6,fam) + saux64(49:56) = nomfam(7,fam) + saux64(57:64) = nomfam(8,fam) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,7)) + > fam, numfam(fam), saux64(1:jaux) + write (ulsort,texte(langue,8)) frofam(fam) + write (ulsort,texte(langue,9)) groupm(1:lgngrm) + codret = codret + 1 + endif +c + endif +c + endif +c + endif +c + 41 continue +c + endif +c + 40 continue +c + endif +c + 10 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + do 3000 , iaux = 1, nbf + write (ulsort,90112) 'frofam', iaux, frofam(iaux) + 3000 continue + write (ulsort,*) ' ' +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfli.F b/src/tool/AV_Conversion/vcsfli.F new file mode 100644 index 00000000..357d89ce --- /dev/null +++ b/src/tool/AV_Conversion/vcsfli.F @@ -0,0 +1,412 @@ + subroutine vcsfli ( sdimca, nbelem, nbmane, nvosom, nbnoto, nbf, + > coonca, + > noeele, typele, fameel, + > povoso, voisom, + > numfam, nomfam, ligfam, + > nbli00, nblign, nsomli, + > numlig, seglig, somseg, + > abscur, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion +c - - +c - Suivi de Frontiere - creation des LIgnes +c - - -- +c remarque : vcsfl0 et vcsfli sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sdimca . e . * . dimension du maillage de calcul . +c . coonca . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . fameel . e . nbelem . famille med des elements . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . numfam . e . nbf . donne le vrai numero de famille med . +c . . . . associee a chaque famille classee selon . +c . . . . l'ordre d'arrivee . +c . nomfam . e . 10*nbf . nom des familles MED . +c . ligfam . e . nbf . numero de la ligne de la famille MED . +c . nbli00 . e . 1 . nombre estime de lignes . +c . nblign . s . 1 . nombre reel de lignes . +c . nsomli . s . 1 . nombre de sommets pour decrire les lignes . +c . seglig . s .0:nblign. pointeur dans les tableaux somseg et abscur. +c . . . . les segments de la ligne i sont aux places . +c . . . . de seglig(i-1)+1 a seglig(i)-1 inclus . +c . somseg . s . nsomli . liste des sommets des lignes separees par . +c des 0 . +c . abscur . s . nsomli . longueur des segments des lignes . +c . tabaux . a . nbarto . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFLI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "refert.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer sdimca + integer nbelem, nbmane, nvosom, nbnoto, nbf + integer noeele(nbelem,nbmane), typele(nbelem), fameel(nbelem) + integer voisom(nvosom), povoso(0:nbnoto) + integer numfam(nbf), ligfam(nbf) + integer nbli00, nblign, nsomli + integer numlig(nbli00), seglig(0:nbli00), somseg(*) + integer tabaux(nbelem) +c + double precision coonca(nbnoto,sdimca) + double precision abscur(*) +c + character*8 nomfam(10,nbf) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer el, elx, areext, arete, nrsom, nrsom1, typhom + integer noeext + integer lig, jaux, kaux, compte +c + double precision daux +c +#ifdef _DEBUG_HOMARD_ + character*64 saux64 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Ligne numero '',i5,/,18(''=''))' + texte(1,5) = + > '(''.'',i5,''-eme famille, de numero MED '',i5,'', de nom '',a)' + texte(1,6) = + > '(''.. Extremite '',i1,'' : noeud '',i10,'', arete '',i10)' + texte(1,7) = '(''.. Nombre d''''aretes :'',i10)' + texte(1,8) = '(''Estimation du nombre total de lignes :'',i10)' + texte(1,9) = '(/,''Nombre total de lignes :'',i10)' + texte(1,10) = + > '(''Nombre de sommets pour decrire les lignes :'',i10)' +c + texte(2,4) = '(/,''Line # '',i5,/,12(''=''))' + texte(2,5) = '(''.'',i5,''-th family, MED # '',i5,'', name '',a)' + texte(2,6) = '(''.. End # '',i1,'' : node '',i10,'', edge '',i10)' + texte(2,7) = '(''.. Number of edges :'',i10)' + texte(2,8) = '(''Estimation of total number of lines :'',i10)' + texte(2,9) = '(/,''Total number of lines :'',i10)' + texte(2,10) = '(''Number of vertices to describe lines :'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbli00 +#endif +c +c==== +c 2. Conversion +c==== +c 2.0. ==> aucune maille ne fait partie d'une ligne +c + do 200 , iaux = 1 , nbelem + tabaux(iaux) = 0 + 200 continue +c + nblign = 0 + seglig(0) = 0 + nsomli = 0 +c + do 20 , lig = 1 , nbli00 +c +c 2.1 ==> recherche d'une extremite de la ligne +c remarque : il est plus economique de boucler d'abord sur +c les familles qui decrivent la ligne courante, puis +c sur les noeuds. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lig +#endif +c +c ..... on parcourt les familles MED, pour ne retenir que celles qui +c ..... correspondent a la ligne courante +c + do 21 , kaux = 1 , nbf +c + if ( codret.eq.0 ) then +c + if ( ligfam(kaux).eq.lig ) then +c +#ifdef _DEBUG_HOMARD_ + saux64( 1: 8) = nomfam(1,kaux) + saux64( 9:16) = nomfam(2,kaux) + saux64(17:24) = nomfam(3,kaux) + saux64(25:32) = nomfam(4,kaux) + saux64(33:40) = nomfam(5,kaux) + saux64(41:48) = nomfam(6,kaux) + saux64(49:56) = nomfam(7,kaux) + saux64(57:64) = nomfam(8,kaux) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,5)) + > kaux, numfam(kaux), saux64(1:jaux) +#endif +c +c ......... on parcourt tous les noeuds du maillage +c + do 211 , iaux = 1 , nbnoto +c + if ( codret.eq.0 ) then +c + compte = 0 +cgn if ( lig.ge.0) then +cgn write(ulsort,90002) 'noeud ',iaux +cgn write(ulsort,90015) '. pointeur des voisins de', +cgn > povoso(iaux-1) + 1, ' a', povoso(iaux) +cgn endif +c +c ........... on parcourt les aretes voisines du noeud +c ........... on compte combien appartiennent a la famille retenue +c + do 2111, jaux = povoso(iaux-1) + 1, povoso(iaux) +c + el = voisom(jaux) +cgn if ( lig.ge.0) then +cgn write(ulsort,90015) '.. voisin # ',jaux, +cgn > ' ; numero et type med',el, medtrf(typele(el)) +cgn endif + if ( numfam(kaux).eq.fameel(el) ) then +c + typhom = medtrf(typele(el)) + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +cgn if ( lig.ge.0) then +cgn write(ulsort,90002)'.. La frontiere contient l''arete', el +cgn endif + elx = el + compte = compte + 1 + endif +c + endif +c + 2111 continue +c +c .......... si le noeud n'a qu'une seule arete qui appartient +c .......... a la ligne, c'est une extremite +c + if ( compte.eq.1 ) then + areext = elx + noeext = iaux + goto 2199 + + endif +c + endif +c + 211 continue +c + endif +c + endif +c + 21 continue +c + 2199 continue +c + endif +c +c 2.2. ==> Liste ordonnee des sommets constituant la ligne +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 1, noeext, areext +#endif +c + if ( codret.eq.0 ) then +c +c 2.2.1. ==> on enregistre le point de depart : la derniere extremite +c trouvee precedemment +c + nblign = nblign + 1 +c + numlig(nblign) = lig +c + nsomli = nsomli + 1 + somseg(nsomli) = noeext + abscur(nsomli) = 0.d0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90024) 'Debut noeud', noeext, abscur(nsomli) +#endif + nrsom1 = noeext +c + arete = areext + nrsom = noeext + tabaux(arete) = lig +c +c 2.2.2. ==> on va parcourir les aretes de proche en proche +c + 22 continue +c +c ..... recherche de l'autre extremite de l'arete courante +#ifdef _DEBUG_HOMARD_ + write (ulsort,90012) 'noeuds de l''arete', arete, + > noeele(arete,1), noeele(arete,2) +#endif + if ( noeele(arete,1).ne.nrsom ) then + nrsom = noeele(arete,1) + else + nrsom = noeele(arete,2) + endif +c +c ..... incrementation du nombre de sommets +c . stockage du nouveau sommet +c . memorisation de la longueur du brin +c + nsomli = nsomli + 1 + somseg(nsomli) = nrsom + daux = 0.d0 + do 220 , jaux = 1 , sdimca + daux = daux + (coonca(nrsom1,jaux)-coonca(nrsom,jaux))**2 + 220 continue + abscur(nsomli) = abscur(nsomli-1) + sqrt(daux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90024) 'Suite noeud', nrsom, abscur(nsomli) +#endif + nrsom1 = nrsom +c +c ..... boucle sur les aretes voisines de ce noeud + do 221 , jaux = povoso(nrsom-1) + 1, povoso(nrsom) +c + el = voisom(jaux) + typhom = medtrf(typele(el)) +cgn write (ulsort,90015) 'Maille voisine' , el,' typhom :',typhom +c + if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then +c + areext = el +c +c ......... si c'est une nouvelle arete + if ( areext.ne.arete ) then +c +c ........... et si cette arete appartient a la ligne, c'est-a-dire si +c ........... sa famille MED fait partie de la description de la ligne + do 2211 , kaux = 1 , nbf + if ( numfam(kaux).eq.fameel(areext) ) then + if ( ligfam(kaux).eq.lig ) then +cgn write (ulsort,90002) 'on poursuit le trajet avec l''arete', el +c ............... alors on poursuit le trajet + arete = areext + tabaux(arete) = lig + goto 22 + endif + endif + 2211 continue +c + endif +c + endif +c + 221 continue +c +c 2.2.3. ==> la ligne est finie +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90024) ' Fin noeud', nrsom, abscur(nsomli) + write (ulsort,texte(langue,6)) 2, nrsom, arete + write (ulsort,texte(langue,7)) nsomli - seglig(nblign-1) - 1 +#endif +c + nsomli = nsomli + 1 +c + somseg(nsomli) = 0 +c + seglig(nblign) = nsomli +c + endif +c + 20 continue +cgn write (ulsort,*) somseg(nsomli-1) +cgn write (ulsort,*) (seglig(iaux),iaux=0,nblign) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,9)) nblign + write (ulsort,texte(langue,10)) nsomli + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcsfll.F b/src/tool/AV_Conversion/vcsfll.F new file mode 100644 index 00000000..997da252 --- /dev/null +++ b/src/tool/AV_Conversion/vcsfll.F @@ -0,0 +1,412 @@ + subroutine vcsfll ( nbfrgr, nbfran, nbf, + > cacfpo, cacfta, cacfnm, + > calfpo, calfta, calfnm, + > calgpo, calgta, calgnm, + > pointe, nomgrf, numfam, nomfam, + > frofam, decala, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - Suivi de Frontiere +c - - - - +c - Lien famille/ligne.surface - par les Liens +c - - +c ______________________________________________________________________ +c +c Chaque element de frontiere (ligne ou surface) dont on demande le +c suivi est designe par son nom. +c On passe en revue toutes les familles du maillage MED. Quand +c le nom du groupe lie a une frontiere apparait dans la description +c des groupes definissant la famille, on indique que la famille est +c liee a la frontiere courante. La sortie est donc un tableau donnant +c pour chaque famille l'eventuel numero de frontiere qui lui +c correspond. +c remarque : vcsflg et vcsfll sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfrgr . e . 1 . nombre de liens frontiere/groupe . +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . nbf . e . 1 . nombre de familles du maillage de calcul . +c . cacfpo . e .0:nbfran. pointeurs sur le tableau du nom frontieres . +c . cacfta . e .10nbfran. taille du nom des frontieres . +c . cacfnm . e .10nbfran. nom des frontieres . +c . calfpo . e .0:nbfrgr. pointeurs sur le tableau du nom frontieres . +c . calfta . e .10nbfrgr. taille du nom des frontieres . +c . calfnm . e .10nbfrgr. nom des frontieres . +c . calgpo . e .0:nbfrgr. pointeurs sur le tableau du nom groupes . +c . calgta . e .10nbfrgr. taille du nom des groupes . +c . calgnm . e .10nbfrgr. nom des groupes . +c . pointf . e . 0:nbf . pointeur sur le tableau nomgrf . +c . nomgrf . e . * . noms des groupes des familles . +c . numfam . e . 1 . numero MED des familles . +c . nomfam . e . 10*nbf . nom des familles MED . +c . frofam . s . nbf . donne l'eventuel numero de frontiere . +c . . . . associee a chaque famille . +c . decala . e . 1 . decalage dans le stockage des numeros de fr. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'VCSFLL' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfrgr, nbfran, nbf + integer numfam(nbf) + integer frofam(nbf), decala + integer cacfpo(0:nbfran), cacfta(10*nbfran) + integer calfpo(0:nbfrgr), calfta(10*nbfrgr) + integer calgpo(0:nbfrgr), calgta(10*nbfrgr) + integer pointe(0:nbf) +c + character*8 cacfnm(10*nbfran) + character*8 calfnm(10*nbfrgr) + character*8 calgnm(10*nbfrgr) + character*8 nomgrf(*) + character*8 nomfam(10,nbf) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nufrgr, fam, nufr + integer nbgr, gr + integer lgngro, lgngrm, lgnfro, lgnfra +c + character*64 saux64 + character*80 nomgro, groupm, nomfro, nomfra +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,''Lien frontiere/groupe numero '',i5,/,21(''=''))' + texte(1,5) = '(''. Nom du groupe : '',a)' + texte(1,6) = '(''.. Comparaison avec le groupe : '',a)' + texte(1,7) = + > '(''.'',i5,''-eme famille, de numero MED '',i5,'', de nom '',a)' + texte(1,8) = + > '(''Cette famille est deja liee a la frontiere '',i5)' + texte(1,9) = '(''On veut ajouter le groupe : '',a)' + texte(1,10) = + > '(i5,'' probleme(s) dans la definition des frontieres.'')' + texte(1,11) = '(''. Nom de la frontiere : '',a)' + texte(1,12) = '(''.. Nom de la frontiere numero '',i5,'' : '',a)' + texte(1,13) = + > '(/,''Impossible de trouver la definition de la frontiere.'')' +c + texte(2,4) = '(/,''Link boundary/group #'',i5,/,12(''=''))' + texte(2,5) = '(''. Name of the group: '',a)' + texte(2,6) = '(''.. Comparizon with the group: '',a)' + texte(2,7) = '(''.'',i5,''-th family, MED # '',i5,'', name '',a)' + texte(2,8) = + > '(''This family is already connected to boundary'',i5)' + texte(2,9) = '(''Group : '',a,'' is to be added.'')' + texte(2,10) = '(i5,'' problem(s) in boundary definition'')' + texte(2,11) = '(''. Name of the boundary: '',a)' + texte(2,12) = '(''. Name of the boundary # '',i5,'': '',a)' + texte(2,13) = + > '(/,''The definition of this boundary cannot be found.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. a priori, aucune famille n'est liee a une frontiere +c==== +c + do 21 , iaux = 1, nbf + frofam(iaux) = 0 + 21 continue +c +c On parcourt tous les liens frontiere/groupe +c Remarque : le decodage est analogue a celui de vcfia2 +c + do 30 , nufrgr = 1, nbfrgr +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) nufrgr + endif +#endif +c +c==== +c 3. Nom du groupe associe a ce lien +c==== +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe associe au lien nufrgr + iaux = calgpo(nufrgr-1) + 1 +c +c longueur utile du nom du groupe + lgngro = 0 + do 31 , jaux = iaux , calgpo(nufrgr) + lgngro = lgngro + calgta(jaux) + 31 continue +c + endif +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe au lien nufrgr + call uts8ch ( calgnm(iaux), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nomgro(1:lgngro) +#endif +c +c==== +c 4. On parcourt toutes les familles de mailles +c==== +c + if ( codret.eq.0 ) then +c + do 40 , fam = 1, nbf +c + if ( numfam(fam).lt.0 ) then +c + nbgr = (pointe(fam)-pointe(fam-1))/10 +c +c 4.1. ==> on parcourt tous les groupes entrant dans la +c definition de la famille +c + do 41 , gr = 1, nbgr +c +c 4.1.1. ==> nom du groupe +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe numero gr de la famille fam + iaux = pointe(fam-1)+1+10*(gr-1) +c +c recuperation du nom du groupe numero gr dans la famille +c numero fam + call uts8ch ( nomgrf(iaux), 80, groupm, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrm, groupm, ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) groupm(1:lgngrm) +#endif +c + endif +c +c 4.1.2. ==> si le groupe de la frontiere et le groupe courant +c coincident, on declare que la famille est concernee par +c cette frontiere +c On doit chercher le nom de la frontiere dans le lien, puis +c le rang de cette frontiere dans leurs descriptions +c attention, on n'autorise qu'une seule frontiere par famille +c + if ( codret.eq.0 ) then +c + if ( lgngro.eq.lgngrm ) then +c + if ( nomgro(1:lgngro).eq.groupm(1:lgngrm) ) then +c + if ( frofam(fam).eq.0 ) then +c +c 4.1.2.1. ==> nom de la frontiere associee a ce lien +c + if ( codret.eq.0 ) then +c +c adresse du debut de frontiere associee au lien nufrgr + iaux = calfpo(nufrgr-1) + 1 +c +c longueur utile du nom de la frontiere + lgnfro = 0 + do 4121 , jaux = iaux , calfpo(nufrgr) + lgnfro = lgnfro + calfta(jaux) + 4121 continue +c +c recuperation du nom de frontiere associee au lien nufrgr + call uts8ch ( calfnm(iaux), lgnfro, nomfro, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) nomfro(1:lgnfro) +#endif +c +c 4.1.2.2. ==> on parcourt toutes les frontieres decrites +c + do 4122 , nufr = 1, nbfran +c + if ( codret.eq.0 ) then +c + iaux = cacfpo(nufr-1) + 1 +c +c longueur utile du nom de la frontiere + lgnfra = 0 + do 41221 , jaux = iaux , cacfpo(nufr) + lgnfra = lgnfra + cacfta(jaux) +41221 continue +c +c recuperation du nom du groupe numero gr dans la famille + call uts8ch ( cacfnm(iaux), lgnfra, nomfra, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nufr, nomfra(1:lgnfra) +#endif +c + if ( lgnfro.eq.lgnfra ) then + if ( nomfro(1:lgnfro).eq.nomfra(1:lgnfra) ) then + goto 41222 + endif + endif + 4122 continue +c + write (ulsort,texte(langue,13)) + write (ulsort,texte(langue,5)) groupm(1:lgngrm) + write (ulsort,texte(langue,11)) nomfro(1:lgnfro) + codret = codret + 1 +c +41222 continue +c + if ( codret.eq.0 ) then + frofam(fam) = nufr + decala +#ifdef _DEBUG_HOMARD_ + saux64( 1: 8) = nomfam(1,fam) + saux64( 9:16) = nomfam(2,fam) + saux64(17:24) = nomfam(3,fam) + saux64(25:32) = nomfam(4,fam) + saux64(33:40) = nomfam(5,fam) + saux64(41:48) = nomfam(6,fam) + saux64(49:56) = nomfam(7,fam) + saux64(57:64) = nomfam(8,fam) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,7)) + > fam, numfam(fam), saux64(1:jaux) +#endif + endif + else + saux64( 1: 8) = nomfam(1,fam) + saux64( 9:16) = nomfam(2,fam) + saux64(17:24) = nomfam(3,fam) + saux64(25:32) = nomfam(4,fam) + saux64(33:40) = nomfam(5,fam) + saux64(41:48) = nomfam(6,fam) + saux64(49:56) = nomfam(7,fam) + saux64(57:64) = nomfam(8,fam) + call utlgut ( jaux, saux64, ulsort, langue, codret ) + write (ulsort,texte(langue,7)) + > fam, numfam(fam), saux64(1:jaux) + write (ulsort,texte(langue,8)) frofam(fam) + write (ulsort,texte(langue,9)) groupm(1:lgngrm) + codret = codret + 1 + endif + endif +c + endif +c + endif +c + 41 continue +c + endif +c + 40 continue +c + endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + do 3000 , iaux = 1, nbf + write (ulsort,90112) 'frofam', iaux, frofam(iaux) + 3000 continue + write (ulsort,*) ' ' +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/AV_Conversion/vcvar1.F b/src/tool/AV_Conversion/vcvar1.F new file mode 100644 index 00000000..ada58c86 --- /dev/null +++ b/src/tool/AV_Conversion/vcvar1.F @@ -0,0 +1,110 @@ + subroutine vcvar1 ( areele, typele, povoar ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - VOisins des Aretes - phase 1 +c - - -- - - +c ______________________________________________________________________ +c +c but : determine le nombre d'elements 2d ou 3d voisins de chaque arete +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoar . s .0:nbarto. pointeur des voisins par arete . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "referx.h" +c +c 0.2. ==> communs +c +#include "nbutil.h" +#include "nombar.h" +#include "refere.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer areele(nbelem,nbmaae), typele(nbelem) + integer povoar(0:nbarto) +c +c 0.4. ==> variables locales +c + integer el, arete, typhom + integer iaux + integer nbarel +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque element +c si c'est un element 2d ou 3d, on incremente de 1 le nombre +c d'elements 2d ou 3d voisins de ses aretes +c selon le type, il n'y a pas le meme nombre d'aretes +c==== +c + do 11 , arete = 1 , nbarto + povoar(arete) = 0 + 11 continue +c + do 12 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) + nbarel = nbaref(typhom) + if ( tyeref(typhom).ne.0 ) then + nbarel = 0 + endif +c + do 121 , iaux = 1 , nbarel + povoar(areele(el,iaux)) = povoar(areele(el,iaux)) + 1 + 121 continue +c + 12 continue +c +c==== +c 2. on initialise le pointeur dans le tableau des voisins +c povoar(i) = position du dernier voisin de l'arete i-1 +c = nombre cumule de voisins pour les (i-1) 1eres aretes +c==== +c + povoar(0) = 0 +c + do 21 , arete = 1 , nbarto + povoar(arete) = povoar(arete) + povoar(arete-1) + 21 continue +c + nvoare = povoar(nbarto) +c + do 22 , arete = nbarto , 1 , -1 + povoar(arete) = povoar(arete-1) + 22 continue +c + end diff --git a/src/tool/AV_Conversion/vcvar2.F b/src/tool/AV_Conversion/vcvar2.F new file mode 100644 index 00000000..4f8bac26 --- /dev/null +++ b/src/tool/AV_Conversion/vcvar2.F @@ -0,0 +1,100 @@ + subroutine vcvar2 ( areele, typele, vofaar, povoar ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - VOisins des Aretes - phase 2 +c - - -- - - +c ______________________________________________________________________ +c +c but : determine les elements 1d, 2d ou 3d voisins de chaque arete +c ce travail suppose que l'on ne garde du maillage de calcul +c que des triangles et des tetraedres. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . areele . e . nbelem . aretes des elements . +c . . .*nbmaae . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . vofaar . s . nvoare . voisins des aretes en stockage morse . +c . povoar . e/s .0:nbarto. pointeur des voisins par arete . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "referx.h" +c +c 0.2. ==> communs +c +#include "nbutil.h" +#include "nombar.h" +#include "refere.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer areele(nbelem,nbmaae), typele(nbelem) + integer vofaar(nvoare), povoar(0:nbarto) +c +c 0.4. ==> variables locales +c + integer el, arete, typhom + integer iaux + integer nbarel +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque element +c si c'est un element 2d ou 3d, on indique qu'il est +c le voisin de ses aretes +c selon le type, il n'y a pas le meme nombre d'aretes +c +c au depart : +c povoar(i) = position du dernier voisin de l'arete i-1 +c = nombre cumule de voisins pour les (i-1) 1eres aretes +c a l'arrivee : +c povoar(i) = position du dernier voisin de l'arete i +c = nombre cumule de voisins pour les i premieres aretes +c==== +c + do 11 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) + nbarel = nbaref(typhom) + if ( tyeref(typhom).ne.0 ) then + nbarel = 0 + endif +c + do 121 , iaux = 1 , nbarel + arete = areele(el,iaux) + povoar(arete) = povoar(arete) + 1 + vofaar(povoar(arete)) = el + 121 continue +c + 11 continue +c + end diff --git a/src/tool/AV_Conversion/vcvos1.F b/src/tool/AV_Conversion/vcvos1.F new file mode 100644 index 00000000..4bdb358c --- /dev/null +++ b/src/tool/AV_Conversion/vcvos1.F @@ -0,0 +1,147 @@ + subroutine vcvos1 ( noeele, typele, povoso, + > nvosom, nbelem, nbmane, nbnoto ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - VOisins des Sommets - phase 1 +c - - -- - - +c ______________________________________________________________________ +c +c but : determine le nombre d'elements 0d, 1d, 2d ou 3d voisins de +c chaque sommet pour un maillage a la table de connectivite +c du type med +c +c attention : tout est fait en numerotation du calcul pour les noeuds, +c c'est-a-dire avec la numerotation initiale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoso . s .0:nbnoto. pointeur des voisins par sommet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "referx.h" +c +c 0.2. ==> communs +c +#include "refere.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer nbelem, nbmane, nbnoto + integer noeele(nbelem,nbmane), typele(nbelem) + integer nvosom + integer povoso(0:nbnoto) +c +c 0.4. ==> variables locales +c + integer el, noeud, typhom + integer iaux + integer nbsoma +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'nbnoto', nbnoto + write (*,90002) 'nbelem', nbelem +#endif +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque maille et on incremente de 1 +c le nombre de voisins de ses sommets +c a la fin de cette partie, ni pour les noeuds au milieu des aretes +c ni pour les noeuds internes aux mailles, on ne definit de voisin +c==== +c + do 11 , noeud = 1 , nbnoto + povoso(noeud) = 0 + 11 continue +c + do 12 , el = 1 , nbelem +#ifdef _DEBUG_HOMARD_ + if ( el.le.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + typhom = medtrf(typele(el)) + nbsoma = nbnref(typhom,1) + if ( tyeref(typhom).ne.0 ) then + nbsoma = 0 + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (*,*) 'typele(',el,') = ',typele(el) + write (*,*) '==> typhom = ',typhom,', nbsoma = ',nbsoma + endif +#endif +c + do 121 , iaux = 1 , nbsoma +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (*,90007) 'noeele',el,iaux,noeele(el,iaux) + endif +#endif + povoso(noeele(el,iaux)) = povoso(noeele(el,iaux)) + 1 + 121 continue +c + 12 continue +c +c==== +c 2. on initialise le pointeur dans le tableau des voisins +c povoso(i) = position du dernier voisin du noeud i-1 +c = nombre cumule de voisins pour les (i-1) premiers noeuds +c a la fin de cette partie, pour les noeuds au milieu des aretes ou +c pour les noeuds internes aux mailles, le pointeur est le meme que +c celui affecte au noeud qui le suit. +c==== +c + povoso(0) = 0 +c + do 21 , noeud = 1 , nbnoto + povoso(noeud) = povoso(noeud) + povoso(noeud-1) + 21 continue +c + nvosom = povoso(nbnoto) +c + do 22 , noeud = nbnoto , 1 , -1 + povoso(noeud) = povoso(noeud-1) + 22 continue +c + end diff --git a/src/tool/AV_Conversion/vcvos2.F b/src/tool/AV_Conversion/vcvos2.F new file mode 100644 index 00000000..a3f14ce0 --- /dev/null +++ b/src/tool/AV_Conversion/vcvos2.F @@ -0,0 +1,103 @@ + subroutine vcvos2 ( noeele, typele, povoso, voisom, + > nvosom, nbelem, nbmane, nbnoto ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c aVant adaptation - Conversion - VOisins des Sommets - phase 2 +c - - -- - - +c ______________________________________________________________________ +c +c but : determine les elements 0d, 1d, 2d ou 3d voisins de +c chaque sommet pour un maillage a la table de connectivite +c du type med +c +c attention : tout est fait en numerotation du calcul pour les noeuds, +c c'est-a-dire avec la numerotation initiale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noeele . e . nbelem . noeuds des elements . +c . . .*nbmane . . +c . typele . e . nbelem . type des elements pour le code de calcul . +c . povoso . e/s .0:nbnoto. pointeur des voisins par sommet . +c . voisom . s . nvosom . voisins des sommets en stockage morse . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "referx.h" +c +c 0.2. ==> communs +c +#include "refere.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer nbelem, nbmane, nbnoto + integer noeele(nbelem,nbmane), typele(nbelem) + integer nvosom + integer voisom(nvosom), povoso(0:nbnoto) +c +c 0.4. ==> variables locales +c + integer el, sommet, typhom + integer iaux + integer nbsoma +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque maille et on indique qu'il est +c le voisin de ses sommets +c selon le type, les sommets ne sont pas ranges au meme endroit +c +c au depart : +c povoso(i) = position du dernier voisin du sommet i-1 +c = nombre cumule de voisins pour les (i-1) 1ers sommets +c a l'arrivee : +c povoso(i) = position du dernier voisin du sommet i +c = nombre cumule de voisins pour les i premiers sommets +c==== +c + do 11 , el = 1 , nbelem +c + typhom = medtrf(typele(el)) + nbsoma = nbnref(typhom,1) + if ( tyeref(typhom).ne.0 ) then + nbsoma = 0 + endif +c + do 111 , iaux = 1 , nbsoma + sommet = noeele(el,iaux) + povoso(sommet) = povoso(sommet) + 1 + voisom(povoso(sommet)) = el + 111 continue +c + 11 continue +c + end diff --git a/src/tool/CMakeLists.txt b/src/tool/CMakeLists.txt new file mode 100644 index 00000000..7062a57f --- /dev/null +++ b/src/tool/CMakeLists.txt @@ -0,0 +1,66 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +cmake_minimum_required (VERSION 2.8) +PROJECT (Homard C Fortran) + +SET(${PROJECT_NAME_UC}_VERSION_MAJOR 11) +SET(${PROJECT_NAME_UC}_VERSION_MINOR 99) +SET(${PROJECT_NAME_UC}_VERSION_PATCH 0) +SET(${PROJECT_NAME_UC}_VERSION ${${PROJECT_NAME_UC}_VERSION_MAJOR}.${${PROJECT_NAME_UC}_VERSION_MINOR}.${${PROJECT_NAME_UC}_VERSION_PATCH}) + +INCLUDE(FortranCInterface) +FortranCInterface_HEADER(${CMAKE_BINARY_DIR}/FC.h) + +# libraries to build +SET(DIRLIBS + HOMARD_00 + Suivi_Frontiere + Information + Modification + AV_Conversion + Decision + Creation_Maillage + AP_Conversion + ES_Xfig + ES_HOMARD + ES_MED + Utilitaire + Gestion_MTU + Dependance_Machine + ) + +FOREACH(dir Includes_Generaux ${DIRLIBS}) + ADD_SUBDIRECTORY(${dir}) +ENDFOREACH() + +# libraries to link with +SET(_link_LIBRARIES + ${MEDFILE_F_LIBRARIES} + ${HDF5_LIBRARIES} +) + +# Main binary +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_EXECUTABLE(homard.out homard.f) + +TARGET_LINK_LIBRARIES(homard.out ${DIRLIBS} ${_link_LIBRARIES}) + +INSTALL(TARGETS homard.out EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_BINS}) + diff --git a/src/tool/Creation_Maillage/CMakeLists.txt b/src/tool/Creation_Maillage/CMakeLists.txt new file mode 100644 index 00000000..80f823b1 --- /dev/null +++ b/src/tool/Creation_Maillage/CMakeLists.txt @@ -0,0 +1,291 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Creation_Maillage + +SET(Creation_Maillage_SOURCES + ./cmal01.F + ./cmalco.F + ./cmalde.F + ./cmalra.F + ./cmcact.F + ./cmcdhb.F + ./cmcdhe.F + ./cmcdpe.F + ./cmcdq2.F + ./cmcdq3.F + ./cmcdq5.F + ./cmcdqu.F + ./cmcdte.F + ./cmcdtr.F + ./cmch01.F + ./cmch02.F + ./cmch03.F + ./cmch04.F + ./cmch05.F + ./cmch06.F + ./cmch07.F + ./cmch08.F + ./cmch09.F + ./cmch10.F + ./cmch11.F + ./cmch12.F + ./cmch13.F + ./cmch14.F + ./cmch15.F + ./cmch16.F + ./cmch17.F + ./cmch18.F + ./cmch19.F + ./cmch20.F + ./cmch21.F + ./cmch22.F + ./cmch23.F + ./cmch24.F + ./cmch31.F + ./cmch32.F + ./cmch33.F + ./cmch34.F + ./cmch35.F + ./cmch36.F + ./cmch40.F + ./cmch41.F + ./cmch42.F + ./cmch43.F + ./cmch44.F + ./cmch45.F + ./cmch46.F + ./cmch61.F + ./cmch62.F + ./cmch63.F + ./cmch64.F + ./cmch65.F + ./cmch66.F + ./cmch67.F + ./cmch68.F + ./cmch69.F + ./cmch70.F + ./cmch71.F + ./cmch72.F + ./cmch81.F + ./cmch82.F + ./cmch83.F + ./cmch84.F + ./cmch85.F + ./cmch86.F + ./cmch87.F + ./cmch88.F + ./cmcha1.F + ./cmcha2.F + ./cmcha3.F + ./cmchaa.F + ./cmchac.F + ./cmchad.F + ./cmchae.F + ./cmchaf.F + ./cmchag.F + ./cmchah.F + ./cmchai.F + ./cmchak.F + ./cmchal.F + ./cmcham.F + ./cmchan.F + ./cmchap.F + ./cmchaq.F + ./cmchar.F + ./cmchas.F + ./cmchat.F + ./cmchau.F + ./cmchav.F + ./cmchaw.F + ./cmchea.F + ./cmchex.F + ./cmchf0.F + ./cmchfa.F + ./cmchfb.F + ./cmchfc.F + ./cmchfd.F + ./cmchfe.F + ./cmchpa.F + ./cmchpb.F + ./cmconf.F + ./cmcp01.F + ./cmcp02.F + ./cmcp03.F + ./cmcp04.F + ./cmcp05.F + ./cmcp06.F + ./cmcp0a.F + ./cmcp0b.F + ./cmcp0c.F + ./cmcp0d.F + ./cmcp17.F + ./cmcp18.F + ./cmcp19.F + ./cmcp1a.F + ./cmcp1b.F + ./cmcp1c.F + ./cmcp1e.F + ./cmcp21.F + ./cmcp22.F + ./cmcp23.F + ./cmcp24.F + ./cmcp25.F + ./cmcp26.F + ./cmcp2a.F + ./cmcp2b.F + ./cmcp2c.F + ./cmcp2e.F + ./cmcp31.F + ./cmcp32.F + ./cmcp33.F + ./cmcp34.F + ./cmcp35.F + ./cmcp36.F + ./cmcp3a.F + ./cmcp3b.F + ./cmcp3c.F + ./cmcp3e.F + ./cmcp3f.F + ./cmcp3g.F + ./cmcp3h.F + ./cmcp43.F + ./cmcp44.F + ./cmcp45.F + ./cmcp4a.F + ./cmcp4b.F + ./cmcp4c.F + ./cmcp4d.F + ./cmcp4e.F + ./cmcp51.F + ./cmcp52.F + ./cmcp5a.F + ./cmcp5b.F + ./cmcp5c.F + ./cmcp5e.F + ./cmcpen.F + ./cmcpy2.F + ./cmcpy3.F + ./cmcpy4.F + ./cmcpya.F + ./cmcpyr.F + ./cmcqua.F + ./cmcte3.F + ./cmctea.F + ./cmctet.F + ./cmctri.F + ./cmdera.F + ./cmdrar.F + ./cmdrhe.F + ./cmdrpe.F + ./cmdrqu.F + ./cmdrte.F + ./cmdrtr.F + ./cmh100.F + ./cmh200.F + ./cmh201.F + ./cmh202.F + ./cmh203.F + ./cmh204.F + ./cmh300.F + ./cmh301.F + ./cmh302.F + ./cmh303.F + ./cmh304.F + ./cmh305.F + ./cmh306.F + ./cmh307.F + ./cmh308.F + ./cmh309.F + ./cmh310.F + ./cmh311.F + ./cmh400.F + ./cmh401.F + ./cmh402.F + ./cmh403.F + ./cmh404.F + ./cmh405.F + ./cmh406.F + ./cmh407.F + ./cmh408.F + ./cmh409.F + ./cmh410.F + ./cmh411.F + ./cmh412.F + ./cmh413.F + ./cmh414.F + ./cmh415.F + ./cmh416.F + ./cmh417.F + ./cmh418.F + ./cmh500.F + ./cmh501.F + ./cmh502.F + ./cmh503.F + ./cmh504.F + ./cmh505.F + ./cmh506.F + ./cmh507.F + ./cmh508.F + ./cmh509.F + ./cmh510.F + ./cmh511.F + ./cmh512.F + ./cmh600.F + ./cmh601.F + ./cmh602.F + ./cmh603.F + ./cmh604.F + ./cmh605.F + ./cmh606.F + ./cmh607.F + ./cmh608.F + ./cmh700.F + ./cmh701.F + ./cmh800.F + ./cmh801.F + ./cmh900.F + ./cmhoma.F + ./cmhomo.F + ./cmhomq.F + ./cmhomt.F + ./cmin00.F + ./cminma.F + ./cmmisa.F + ./cmnbco.F + ./cmno22.F + ./cmnoim.F + ./cmnosu.F + ./cmraff.F + ./cmrda1.F + ./cmrda2.F + ./cmrdhe.F + ./cmrdpe.F + ./cmrdqu.F + ./cmrdte.F + ./cmrdtr.F + ./cmtrnp.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Creation_Maillage ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Creation_Maillage ${Creation_Maillage_SOURCES}) + +INSTALL(TARGETS Creation_Maillage EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Creation_Maillage/cmal01.F b/src/tool/Creation_Maillage/cmal01.F new file mode 100644 index 00000000..8ceb5a52 --- /dev/null +++ b/src/tool/Creation_Maillage/cmal01.F @@ -0,0 +1,645 @@ + subroutine cmal01 ( typall, extrus, + > nomail, ndecfa, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, nbtaan, nbtano, + > nbhean, nbheno, nbhaan, nbhano, + > nbpean, nbpeno, nbpaan, nbpano, + > nbpyan, nbpyno, nbyaan, nbyano, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - ALlocations - 01 +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typall . e . 1 . type d'allocation . +c . . . . 0 : raffinement . +c . . . . 1 : deraffinement . +c . . . . 2 : conformite . +c . extrus . e . 1 . prise en compte d'extrusion . +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . ndecfa . e . ch8 . nom de l'objet des decisions sur les faces . +c . nbnoan . e . 1 . nombre de noeuds - ancien . +c . nbnono . e . 1 . nombre de noeuds - nouveau . +c . nbaran . e . 1 . nombre d'aretes - ancien . +c . nbarno . e . 1 . nombre d'aretes - nouveau . +c . nbtran . e . 1 . nombre de triangles - ancien . +c . nbtrno . e . 1 . nombre de triangles - nouveau . +c . nbquan . e . 1 . nombre de quadrangles - ancien . +c . nbquno . e . 1 . nombre de quadrangles - nouveau . +c . nbtean . e . 1 . nombre de tetraedres - ancien . +c . nbteno . e . 1 . nombre de tetraedres - nouveau . +c . nbtaan . e . 1 . nombre de tetraedres - par aretes - ancien . +c . nbtano . e . 1 . nombre de tetraedres - par aretes - nouveau. +c . nbhean . e . 1 . nombre d'hexaedres - ancien . +c . nbheno . e . 1 . nombre d'hexaedres - nouveau . +c . nbhaan . e . 1 . nombre d'hexaedres - par aretes - ancien . +c . nbhano . e . 1 . nombre d'hexaedres - par aretes - nouveau . +c . nbpean . e . 1 . nombre de pentaedres - ancien . +c . nbpeno . e . 1 . nombre de pentaedres - nouveau . +c . nbpaan . e . 1 . nombre de pentaedres - par aretes - ancien . +c . nbpano . e . 1 . nombre de pentaedres - par aretes - nouveau. +c . nbpyan . e . 1 . nombre de pyramides - ancien . +c . nbpyno . e . 1 . nombre de pyramides - nouveau . +c . nbyaan . e . 1 . nombre de pyramides - par aretes - ancien . +c . nbyano . e . 1 . nombre de pyramides - par aretes - nouveau . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMAL01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer typall +c + character*8 nomail + character*8 ndecfa +c + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno, nbtaan, nbtano + integer nbhean, nbheno, nbhaan, nbhano + integer nbpyan, nbpyno, nbyaan, nbyano + integer nbpean, nbpeno, nbpaan, nbpano +c + logical extrus +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, paux +c + integer codre0 + integer codre1, codre2 + integer iaux1, iaux2 + integer un + integer pdecfa + integer pcoono, phetno, pareno, pancno + integer psomar, pposif, phetar, pfilar, pmerar + integer pancar, pnp2ar + integer paretr, phettr, pfiltr, ppertr, pnivtr + integer adpetr, panctr, adnmtr + integer parequ, phetqu, pfilqu, pperqu, pnivqu + integer adhequ, pancqu, adnmqu + integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche + integer adnmhe + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe + integer adhono, adhoar, adhotr, adhoqu + integer pfamno, pfamar, pfamtr, pfamqu + integer pfamte, pfamhe, pfampe, pfampy + integer typenh + integer option, optio2 +c + logical eancno, eancar, eanctr, eancqu + logical eancte, eanche, eancpe, eancpy +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data un / 1 / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typall', typall + write (ulsort,90002) 'no', nbnoan, nbnono + write (ulsort,90002) 'ar', nbaran, nbarno + write (ulsort,90002) 'tr', nbtran, nbtrno + write (ulsort,90002) 'qu', nbquan, nbquno + write (ulsort,90002) 'te', nbtean, nbteno, nbtaan, nbtano + write (ulsort,90002) 'he', nbhean, nbheno, nbhaan, nbhano + write (ulsort,90002) 'py', nbpyan, nbpyno, nbyaan, nbyano + write (ulsort,90002) 'pe', nbpean, nbpeno, nbpaan, nbpano +#endif +c +c 1.2. messages +c + eancno = .false. +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. reallocation des tableaux avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reallocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. ==> noeuds, codret', codret + write (ulsort,90002) 'nbnoan', nbnoan + write (ulsort,90002) 'nbnono', nbnono +#endif +c + if ( nbnoan.ne.nbnono ) then +c + if ( codret.eq.0 ) then +c + iaux = 210 + call gmobal ( nhnoeu//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancno = .true. + iaux = iaux*13 + endif + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + call utad05 ( iaux, jaux, nhnoeu, + > nbnoan, nbnono, sdim, + > phetno, + > pfamno, + > pcoono, pareno, adhono, pancno, + > ulsort, langue, codret ) +c + call gmecat ( nhnoeu, 1, nbnono, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 3.2. ==> Les entites +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. ==> entites, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + option = 1 + if ( extrus ) then + optio2 = 1 + else + optio2 = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD98', nompro +#endif + call utad98 ( nomail, option, optio2, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, nbtaan, nbtano, + > nbhean, nbheno, nbhaan, nbhano, + > nbpyan, nbpyno, nbyaan, nbyano, + > nbpean, nbpeno, nbpaan, nbpano, + > phetar, psomar, pfilar, pmerar, pancar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, panctr, + > pnivtr, adpetr, adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pancqu, + > pnivqu, adhequ, adnmqu, adhoqu, + > phette, ptrite, pcotrt, parete, + > pfilte, pperte, pancte, + > phethe, pquahe, pcoquh, parehe, + > pfilhe, pperhe, panche, adnmhe, + > phetpy, pfacpy, pcofay, parepy, + > pfilpy, pperpy, pancpy, + > phetpe, pfacpe, pcofap, parepe, + > pfilpe, pperpe, pancpe, + > pfamar, pfamtr, pfamqu, + > pfamte, pfamhe, pfampy, pfampe, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. triangles, codret', codret + write (ulsort,90002) 'nbtran', nbtran + write (ulsort,90002) 'nbtrno', nbtrno +#endif +c + if ( nbtran.ne.nbtrno ) then +c + if ( nbtran.eq.0 ) then +c + if ( codret.eq.0 ) then +c + typenh = 2 + iaux = 330 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_tr', nompro +#endif + call utal02 ( typenh, iaux, + > nhtria, nbtrno, kaux, + > phettr, paretr, pfiltr, ppertr, + > paux, paux, + > pnivtr, paux, paux, + > adnmtr, adhotr, paux, + > ulsort, langue, codret ) +c + call gmecat ( nhtria, 1, nbtrno, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c + endif +c +c 3.4. ==> tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. tetraedres, codret', codret + write (ulsort,90002) 'nbtean', nbtean + write (ulsort,90002) 'nbteno', nbteno + write (ulsort,90002) 'nbtano', nbtano +#endif +c + if ( nbtean.ne.nbteno ) then +c + if ( codret.eq.0 ) then +c + typenh = 3 + iaux = 1 + if ( nbtean.eq.0 ) then + iaux = iaux*390 + endif + if ( nbtano.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_te', nompro +#endif + call utal02 ( typenh, iaux, + > nhtetr, nbteno, nbtano, + > phette, ptrite, pfilte, pperte, + > paux, paux, + > paux, pcotrt, paux, + > paux, paux, parete, + > ulsort, langue, codret ) +c + call gmecat ( nhtetr, 1, nbteno, codre1 ) + call gmecat ( nhtetr, 2, nbtano, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c 3.5. ==> pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. pyramides, codret', codret + write (ulsort,90002) 'nbpyan', nbpyan + write (ulsort,90002) 'nbpyno', nbpyno + write (ulsort,90002) 'nbyano', nbyano +#endif +c + if ( nbpyan.ne.nbpyno ) then +c + if ( codret.eq.0 ) then +c + typenh = 5 + iaux = 1 + if ( nbpyan.eq.0 ) then + iaux = iaux*390 + endif + if ( nbyano.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_py', nompro +#endif + call utal02 ( typenh, iaux, + > nhpyra, nbpyno, nbyano, + > phetpy, pfacpy, pfilpy, pperpy, + > paux, paux, + > paux, pcofay, paux, + > paux, paux, parepy, + > ulsort, langue, codret ) +c + call gmecat ( nhpyra, 1, nbpyno, codre1 ) + call gmecat ( nhpyra, 2, nbyano, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c 3.6. ==> hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. hexaedres, codret', codret + write (ulsort,90002) 'nbhean', nbhean + write (ulsort,90002) 'nbheno', nbheno + write (ulsort,90002) 'nbhano', nbhano +#endif +c + if ( nbhean.ne.nbheno ) then +c + if ( codret.eq.0 ) then +c + typenh = 6 +c + if ( nbhean.eq.0 ) then + iaux = 390 + else + iaux = 1 + endif + if ( nbhano.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_he', nompro +#endif + call utal02 ( typenh, iaux, + > nhhexa, nbheno, nbhano, + > phethe, pquahe, pfilhe, pperhe, + > paux, paux, + > paux, pcoquh, paux, + > paux, paux, parehe, + > ulsort, langue, codret ) +c + call gmecat ( nhhexa, 1, nbheno, codre1 ) + call gmecat ( nhhexa, 2, nbhano, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 4. tableaux speciaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. tableaux speciaux ; codret', codret +#endif +c +c 4.1. ==> decisions +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. decisions, codret', codret +#endif +c + if ( typall.eq.0 .or. typall.eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GMMOD', nompro + write (ulsort,90002) 'nbtran', nbtran + write (ulsort,90002) 'nbtrno', nbtrno + write (ulsort,90002) 'nbquan', nbquan + write (ulsort,90002) 'nbquno', nbquno +#endif + call gmmod ( ndecfa, + > pdecfa, -nbquan, -nbquno, nbtran, nbtrno, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 4.2. ==> voisinages +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. voisinages, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux1 = nbaran + 1 + iaux2 = nbarno + 1 + call gmmod ( nhvois//'.1D/2D.Pointeur', + > pposif, iaux1, iaux2, un, un, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 4.3. ==> deraffinement +c + if ( codret.eq.0 ) then +c + call gmobal ( nharet//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancar = .true. + else + eancar = .false. + endif +c + call gmobal ( nhtria//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eanctr = .true. + else + eanctr = .false. + endif +c + call gmobal ( nhquad//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancqu = .true. + else + eancqu = .false. + endif +c + call gmobal ( nhtetr//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancte = .true. + else + eancte = .false. + endif +c + call gmobal ( nhhexa//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eanche = .true. + else + eanche = .false. + endif +c + call gmobal ( nhpyra//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancpy = .true. + else + eancpy = .false. + endif +c + call gmobal ( nhpent//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + eancpe = .true. + else + eancpe = .false. + endif +c + endif +c +c==== +c 5. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. initialisations ; codret', codret + write (ulsort,99002) 'eancno-ar-tr-qu-te-he-pe-py', + > eancno, eancar, eanctr, eancqu, eancte, eanche, eancpe, eancpy +#endif +c + if ( typall.eq.0 .or. typall.eq.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMIN00', nompro +#endif + call cmin00 ( typall, + > degre, homolo, + > eancno, nbnoan, nbnono, + > eancar, nbaran, nbarno, + > eanctr, nbtran, nbtrno, + > eancqu, nbquan, nbquno, + > eancte, nbtean, nbteno, + > eanche, nbhean, nbheno, + > eancpe, nbpean, nbpeno, + > eancpy, nbpyan, nbpyno, + > imem(pdecfa), + > imem(pancno), imem(adhono), + > imem(pancar), imem(adhoar), imem(pnp2ar), + > imem(panctr), imem(adhotr), + > imem(pancqu), imem(adhoqu), + > imem(pancte), imem(panche), + > imem(pancpe), imem(pancpy) ) +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmalco.F b/src/tool/Creation_Maillage/cmalco.F new file mode 100644 index 00000000..16f8f2ac --- /dev/null +++ b/src/tool/Creation_Maillage/cmalco.F @@ -0,0 +1,331 @@ + subroutine cmalco ( nomail, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - ALlocation pour la mise en COnformite +c - - -- -- +c ______________________________________________________________________ +c +c but : decompte les entites a creer lors du decoupage de mise en +c conformite des faces et des volumes. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMALCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +#include "envca1.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer codre0 + integer adtes2 + integer adhes2 + integer adpes2 + integer adpys2 +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ndecfa +c + logical extrus +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' ALLOCATION MEMOIRE POUR LA CONFORMITE'')' + texte(1,5) = '(44(''=''),/)' + texte(1,6) = '(''Modification de taille des tableaux des '',a)' + texte(1,7) = '(5x,''==> code de retour :'',i8)' +c + texte(2,4) = + > '(/,a6,'' MEMORY ALLOCATION FOR CONFORMITY'')' + texte(2,5) = '(39(''=''),/)' + texte(2,6) = '(''Size modification of arrays for '',a)' + texte(2,7) = '(5x,''==> error code :'',i8)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write ( ulsort,texte(langue,4)) saux + write ( ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. Reallocation des tableaux avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. reallocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2 + if ( typcca.eq.26 .or .typcca.eq.46 ) then + extrus = .false. + elseif ( maextr.ne.0 ) then + extrus = .true. + else + extrus = .false. + endif + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMAL01', nompro +#endif + call cmal01 ( iaux, extrus, + > nomail, ndecfa, + > permno, nouvno, + > permar, nouvar, + > permtr, nouvtr, + > permqu, nouvqu, + > permte, nouvte, jaux, provta, + > permhe, nouvhe, jaux, provha, + > permpe, nouvpe, jaux, provpa, + > permpy, nouvpy, jaux, provya, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx(nompro,nomail//'.Volume.HOM_Py05') +cgn call gmprsx(nompro,nomail//'.Volume.HOM_Py05.ConnDesc') +cgn call gmprsx(nompro,nomail//'.Volume.HOM_Py05.ConnAret') +cgn call gmprsx(nompro,nomail//'.Volume.HOM_Py05.InfoSupp') +c +c 3.2. ==> Les tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,3)//' - avant' + write (ulsort,texte(langue,7)) codret + write (ulsort,90002) 'permte', permte + write (ulsort,90002) 'nouvte', nouvte +#endif +c + if ( permte.ne.nouvte ) then +c + if ( nbpeco.ne.0 .or. nbheco.ne.0 ) then +c + iaux = nbheco + nbpeco + call gmaloj ( nhtetr//'.InfoSup2', ' ', + > iaux , adtes2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,3)//' - apres' + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c +c 3.3. ==> Les pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,5)//' - avant' + write (ulsort,texte(langue,7)) codret + write (ulsort,90002) 'permpy', permpy + write (ulsort,90002) 'nouvpy', nouvpy +#endif +c + if ( permpy.ne.nouvpy ) then +c + if ( nbpeco.ne.0 .or. nbheco.ne.0 ) then +c + iaux = nbheco + nbpeco + call gmaloj ( nhpyra//'.InfoSup2', ' ', + > iaux , adpys2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,5)//' - apres' + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c +c 3.4. ==> Les hexaedres : filiation en tetraedres/pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. hexaedres ; codret', codret +#endif +c + if ( nbheco.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbheco*2 + call gmaloj ( nhhexa//'.InfoSup2', ' ', iaux , adhes2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 3.5. ==> Les pentaedres : filiation en tetraedres/pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. pentaedres ; codret', codret +#endif +c + if ( nbpeco.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbpeco*2 + call gmaloj ( nhpent//'.InfoSup2', ' ', iaux , adpes2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmalde.F b/src/tool/Creation_Maillage/cmalde.F new file mode 100644 index 00000000..18b2232a --- /dev/null +++ b/src/tool/Creation_Maillage/cmalde.F @@ -0,0 +1,300 @@ + subroutine cmalde ( nomail, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - ALlocation pour le DEraffinement +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indnp2 . es . 1 . nombre de noeuds p2 en vigueur . +c . indnim . es . 1 . nombre de noeuds internes en vigueur . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMALDE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + character*6 saux + character*8 ndecfa +c + logical extrus +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' REALLOCATION MEMOIRE APRES LE DERAFFINEMENT'')' + texte(1,5) = '(50(''=''),/)' + texte(1,6) = '(''Modification de taille des tableaux des '',a)' +c + texte(2,4) = + > '(/,a6,'' MEMORY REALLOCATION AFTER UNREFINEMENT'')' + texte(2,5) = '(45(''=''),/)' + texte(2,6) = '(''Size modification of arrays for '',a)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. decompte du nombre d'entites restantes apres deraffinement +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '2. decompte ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + permno = indnoe + permar = indare + permtr = indtri + permqu = indqua + permte = indtet + permhe = indhex + permpe = indpen +c + if ( degre.eq.2 ) then + permp2 = indnp2 + endif +c + if ( mod(mailet,2).eq.0 .or. mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then + permim = indnim + endif +c + endif +c +c==== +c 3. reallocation des tableaux avec les nouvelles dimensions +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. reallocation ; codret', codret +#endif + if ( codret.eq.0 ) then +c + ndecfa = taopts(12) + iaux = 1 + if ( typcca.eq.26 .or .typcca.eq.46 ) then + extrus = .false. + elseif ( maextr.ne.0 ) then + extrus = .true. + else + extrus = .false. + endif + jaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMAL01', nompro +#endif + call cmal01 ( iaux, extrus, + > nomail, ndecfa, + > nbnoto, permno, + > nbarto, permar, + > nbtrto, permtr, + > nbquto, permqu, + > nbteto, permte, jaux, jaux, + > nbheto, permhe, jaux, jaux, + > nbpeto, permpe, jaux, jaux, + > nbpyto, permpy, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. mise a jour +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '4. mise a jour ; codret', codret +#endif + if ( codret.eq.0 ) then +c +c remise a jour des longueurs totales stockees +c + nbnoto = permno + nbarto = permar + nbtrto = permtr + nbquto = permqu + nbteto = permte + nbtecf = nbteto + nbteca = 0 + nbheto = permhe + nbhecf = nbheto + nbheca = 0 + nbpeto = permpe + nbpecf = nbpeto + nbpeca = 0 + nbpyto = permpy + nbpycf = nbpyto + nbpyca = 0 +c +c remise a jour des nombres d'entites permanentes +c (lorsque la conformite est supprimee, elles sont identiques +c aux nombres d'entites totales) +c + nbarpe = permar + nbtrpe = permtr + nbqupe = permqu + nbtepe = permte + nbhepe = permhe + nbpepe = permpe +c +c remise a jour des nombres d'entites 'nouvelles' +c + nouvno = nbnoto + nouvar = nbarto + nouvtr = nbtrto + nouvqu = nbquto + nouvte = nbteto + nouvtf = nouvte + nouvhe = nbheto + nouvhf = nouvhe + nouvpe = nbpeto + nouvpf = nouvpe +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmalra.F b/src/tool/Creation_Maillage/cmalra.F new file mode 100644 index 00000000..b0b8663c --- /dev/null +++ b/src/tool/Creation_Maillage/cmalra.F @@ -0,0 +1,283 @@ + subroutine cmalra ( nomail, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - ALlocation pour le RAffinement +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indnp2 . es . 1 . nombre de noeuds p2 en vigueur . +c . indnim . es . 1 . nombre de noeuds internes en vigueur . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMALRA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer nbsoan, nbsono + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpean, nbpeno + integer nbpyan, nbpyno +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ndecar, ndecfa +c + logical extrus +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' ALLOCATION MEMOIRE POUR LE DECOUPAGE STANDARD'')' + texte(1,5) = '(52(''=''),/)' +c + texte(2,4) = + > '(/,a6,'' MEMORY ALLOCATION FOR STANDARD REFINEMENT'')' + texte(2,5) = '(48(''=''),/)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. programmes generiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. programmes generiques ; codret', codret +#endif +c +c 3.1. ==> Base +c + ndecar = taopts(11) + ndecfa = taopts(12) +cgn call gmprsx(nompro, ndecar) +cgn call gmprsx(nompro, ndecfa) +c +c 3.2. ==> Nombre de valeurs +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL00', nompro +#endif + call utal00 ( iaux, jaux, + > nomail, ndecar, ndecfa, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > nbsoan, nbsono, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, + > nbhean, nbheno, + > nbpean, nbpeno, + > nbpyan, nbpyno, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Reallocation des tableaux avec les nouvelles dimensions +c + if ( codret.eq.0 ) then +c + iaux = 0 + if ( typcca.eq.26 .or .typcca.eq.46 ) then + extrus = .false. + elseif ( maextr.ne.0 ) then + extrus = .true. + else + extrus = .false. + endif + jaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMAL01', nompro +#endif + call cmal01 ( iaux, extrus, + > nomail, ndecfa, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, jaux, jaux, + > nbhean, nbheno, jaux, jaux, + > nbpean, nbpeno, jaux, jaux, + > nbpyan, nbpyno, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmcact.F b/src/tool/Creation_Maillage/cmcact.F new file mode 100644 index 00000000..fbdfdf98 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcact.F @@ -0,0 +1,399 @@ + subroutine cmcact ( hetnoe, + > filare, + > filtri, nivtri, + > filqua, nivqua, + > filtet, filhex, filpyr, filpen, + > nvacar, nvactr, nvacqu, + > nvacte, nvache, nvacpy, nvacpe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Comptage des entites ACTives du maillage +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nouvno . historique de l'etat des noeuds . +c . filare . e . nouvar . premiere fille des aretes . +c . filtri . e . nouvtr . premier fils des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . nivqua . e . nouvqu . niveau des quadrangles . +c . filtet . e . nouvte . premier fils des tetraedres . +c . filhex . e . nouvhe . premier fils des hexaedres . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . filpen . e . nouvpe . premier fils des pentaedres . +c . nvacar . s . 1 . nouveau nombre d'aretes actives . +c . nvactr . s . 1 . nouveau nombre de triangles actifs . +c . nvacqu . s . 1 . nouveau nombre de quadrangles actifs . +c . nvacte . s . 1 . nouveau nombre de tetraedres actifs . +c . nvache . s . 1 . nouveau nombre de hexaedres actifs . +c . nvacpy . s . 1 . nouveau nombre de pyramides actives . +c . nvacpe . s . 1 . nouveau nombre de pentaedres actifs . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCACT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombno.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer hetnoe(nouvno) + integer filare(nouvar) + integer filtri(nouvtr), nivtri(nouvtr) + integer filqua(nouvqu), nivqua(nouvqu) + integer filtet(nouvte), filhex(nouvhe) + integer filpyr(nouvpy), filpen(nouvpe) + integer nvacar, nvactr, nvacqu, nvacte, nvache, nvacpy, nvacpe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, ideb, ifin + integer nvmatr, nvmitr, niinct, nisuct + integer nvmaqu, nvmiqu, niincq, nisucq +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. numeros mini/maxi des noeuds p1 +c==== +c + do 21 , iaux = 1 , nouvno + if ( mod(hetnoe(iaux),10).eq.1 ) then + numip1 = iaux + goto 22 + endif + 21 continue +c + 22 continue +c + do 23 , iaux = nouvno, 1, -1 + if ( mod(hetnoe(iaux),10).eq.1 ) then + numap1 = iaux + goto 24 + endif + 23 continue +c + 24 continue +c +c==== +c 3. comptage des aretes actives +c==== +c + nvacar = provar + do 30 , iaux = 1 , permar + if ( filare(iaux).eq.0 ) then + nvacar = nvacar + 1 + endif + 30 continue +c +c==== +c 4. comptage des triangles actifs +c recuperation de leurs niveaux minimum et maximum +c==== +c + if ( nouvtr.ne.0 ) then +c +cgn write (ulsort,90002) 'permtr, provtr', permtr, provtr +c +c 4.1. ==> on initialise les niveaux extremes en cherchant le premier +c triangle actif parmi les permanents et les provisoires. +c cela permet d'englober les cas de maillages avec ou sans +c triangles au depart. +c remarque : ce triangle est revu par la suite et cela fait +c gaspiller un appel a min/max mais l'algorithme est plus +c lisible ainsi. +c + do 41 , iaux = 1 , permtr + if ( filtri(iaux).eq.0 ) then + nvmitr = nivtri(iaux) + nvmatr = nivtri(iaux) + ideb = iaux + goto 420 + endif + 41 continue +c + nvmitr = nbiter+1 + nvmatr = 0 + ideb = 1 +c +c 4.2. ==> examen des triangles permanents +c + 420 continue +c + nvactr = 0 + do 42 , iaux = ideb , permtr + if ( filtri(iaux).eq.0 ) then + nvactr = nvactr + 1 + endif + nvmitr = min( nvmitr, nivtri(iaux) ) + nvmatr = max( nvmatr, nivtri(iaux) ) + 42 continue +c + niinct = 10*nvmitr + nisuct = 10*nvmatr +c +c 4.3. ==> examen des triangles temporaires +c + ideb = permtr + 1 + ifin = permtr + provtr + do 43 , iaux = ideb , ifin + nvactr = nvactr + 1 + niinct = min( niinct, 10*nivtri(iaux) - 5 ) + nisuct = max( nisuct, 10*nivtri(iaux) - 5 ) + 43 continue +c + else +c + nvactr = 0 +c + endif +c +c==== +c 5. comptage des quadrangles actifs +c recuperation de leurs niveaux minimum et maximum +c==== +c + if ( nouvqu.ne.0 ) then +c +cgn write (ulsort,90002) 'permqu, provqu', permqu, provqu +c +c 5.1. ==> on initialise les niveaux extremes en cherchant le premier +c quadrangle actif parmi les permanents. +c remarque : ce quadrangle est revu par la suite et cela fait +c gaspiller un appel a min/max mais l'algorithme est plus +c lisible ainsi. +c + do 51 , iaux = 1 , permqu + if ( filqua(iaux).eq.0 ) then + nvmiqu = nivqua(iaux) + nvmaqu = nivqua(iaux) + ideb = iaux + goto 520 + endif + 51 continue +c + nvmiqu = nbiter+1 + nvmaqu = 0 + ideb = 1 +c +c 5.2. ==> examen des quadrangles permanents +c + 520 continue +c + nvacqu = 0 + do 52 , iaux = ideb , permqu + if ( filqua(iaux).eq.0 ) then + nvacqu = nvacqu + 1 + endif + nvmiqu = min( nvmiqu, nivqua(iaux) ) + nvmaqu = max( nvmaqu, nivqua(iaux) ) + 52 continue +c + niincq = 10*nvmiqu + nisucq = 10*nvmaqu +c +c 5.3. ==> examen des quadrangles temporaires +c + ideb = permqu + 1 + ifin = permqu + provqu + do 53 , iaux = ideb , ifin + nvacqu = nvacqu + 1 + niincq = min( niincq, 10*nivqua(iaux) - 5 ) + nisucq = max( nisucq, 10*nivqua(iaux) - 5 ) + 53 continue +c + else +c + nvacqu = 0 +c + endif +c +c==== +c 6. comptage des tetraedres actifs +c==== +c + if ( nouvte.ne.0 ) then +c + nvacte = provte + do 60 , iaux = 1 , permte + if ( filtet(iaux).eq.0 ) then + nvacte = nvacte + 1 + endif + 60 continue +c + else +c + nvacte = 0 +c + endif +c +c==== +c 7. comptage des hexaedres actifs +c==== +c + if ( nouvhe.ne.0 ) then +c + nvache = provhe + do 70 , iaux = 1 , permhe + if ( filhex(iaux).eq.0 ) then + nvache = nvache + 1 + endif + 70 continue +c + else +c + nvache = 0 +c + endif +c +c==== +c 8. comptage des pyramides actives +c==== +c + if ( nouvpy.ne.0 ) then +c + nvacpy = provpy + do 80 , iaux = 1 , permpy + if ( filpyr(iaux).eq.0 ) then + nvacpy = nvacpy + 1 + endif + 80 continue +c + else +c + nvacpy = 0 +c + endif +c +c==== +c 9. comptage des pentaedres actifs +c==== +c + if ( nouvpe.ne.0 ) then +c + nvacpe = provpe + do 90 , iaux = 1 , permpe + if ( filpen(iaux).eq.0 ) then + nvacpe = nvacpe + 1 + endif + 90 continue +c + else +c + nvacpe = 0 +c + endif +c +c==== +c 10. bilan sur les niveaux +c remarque : il y a toujours ou des triangles ou des quadrangles +c sinon la notion de niveau ne s'applique pas +c==== +c +cgn write (ulsort,90002) 'nvmatr, nvmitr, niinct, nisuct', +cgn > nvmatr, nvmitr, niinct, nisuct +cgn write (ulsort,90002) 'nvmaqu, nvmiqu, niincq, nisucq', +cgn > nvmaqu, nvmiqu, niincq, nisucq + if ( nouvqu.eq.0 ) then + nivinf = nvmitr + nivsup = nvmatr + niincf = niinct + nisucf = nisuct + elseif ( nouvtr.eq.0 ) then + nivinf = nvmiqu + nivsup = nvmaqu + niincf = niincq + nisucf = nisucq + else + nivinf = min(nvmiqu,nvmitr) + nivsup = max(nvmaqu,nvmatr) + niincf = max(niinct,niincq) + nisucf = max(nisuct,nisucq) + endif +cgn write (ulsort,90002) 'nivinf', nivinf +cgn write (ulsort,90002) 'nivsup', nivsup +cgn write (ulsort,90002) 'niincf', niincf +cgn write (ulsort,90002) 'nisucf', nisucf +c +c==== +c 11 la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdhb.F b/src/tool/Creation_Maillage/cmcdhb.F new file mode 100644 index 00000000..8e732c8c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdhb.F @@ -0,0 +1,438 @@ + subroutine cmcdhb ( indnoe, indare, indtri, indtet, indpyr, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hetqua, arequa, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > pthepe, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > pphepe, + > quahex, coquhe, hethex, + > filhex, fhpyte, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des Hexaedres +c - - - - - +c - selon des Boites +c - +c ______________________________________________________________________ +c +c but : decoupage des hexaedres pour mise en conformite +c remarque : description des fils par leurs faces +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . pthepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . pphepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . hethex . e . nouvhe . historique de l'etat des hexaedres . +c . filhex . e . nouvhe . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . famhex . e . nouvhe . famille des hexaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDHB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare, indtri, indtet, indpyr + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer pthepe(*) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer pphepe(*) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer hethex(nouvhe) + integer filhex(nouvhe), fhpyte(2,nbheco) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer fj + integer nbfad3, nbfad4 + integer etatfa(6) + integer lehexa + integer nbfihe, etahex +#ifdef _DEBUG_HOMARD_ + integer listar(12) +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Decoupage provisoire en '',a)' + texte(1,5) ='(''Les decisions de decoupage des aretes du'')' + texte(1,6) ='(''Les decisions de decoupage des faces du'')' + texte(1,7) ='(''hexaedre numero'',i10,'' sont incoherentes.'')' + texte(1,8) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' + texte(1,10) ='(i10,'' problemes ...'')' +c + texte(2,4) ='(''Temporary splitting by '',a)' + texte(2,5) ='(''Decisions for the edges of the'')' + texte(2,6) ='(''Decisions for the faces of the'')' + texte(2,7) ='(''hexahedron #'',i10,S''do not match.'')' + texte(2,8) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' + texte(2,10) ='(i10,'' problems ...'')' +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c + nbfihe = 0 +c +c==== +c 2. decoupage +c==== +c +cgn write(ulsort,90002) 'permhe',permhe + do 200 , iaux = 1 , permhe +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,*) 'hexa', iaux,' avec l''etat =',hethex(iaux) +c + if ( mod(hethex(iaux),1000).eq.0 ) then +c +c 2.1. ==> Recherche des etats des faces de l'hexaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro + call utarhe ( iaux, + > nouvqu, nouvhe, + > arequa, quahex, coquhe, + > listar ) + do 2121 , jaux = 1 , 12 + write (ulsort,91002) jaux,listar(jaux), somare(1,listar(jaux)), + > somare(2,listar(jaux)),hetare(listar(jaux)) + 2121 continue +#endif +c + etahex = 0 + lehexa = iaux +c + nbfad3 = 0 + nbfad4 = 0 + do 21 , jaux = 1 , 6 + fj = quahex(lehexa,jaux) + etatfa(jaux) = mod(hetqua(fj),100) +cgn write(ulsort,*) '. Etat de la ', jaux, '-ieme face :', +cgn > etatfa(jaux), ' (face ', fj, ')' + if ( etatfa(jaux).ge.31 .and. etatfa(jaux).le.34 ) then + nbfad3 = nbfad3 + 1 + elseif ( etatfa(jaux).eq.4 ) then + nbfad4 = nbfad4 + 1 + endif + 21 continue +cgn write(ulsort,*) nbfad3, nbfad4 +c +c 2.2. ==> Decoupage de conformite +c 2.2.1. ==> decoupage en 18 a partir de 3 aretes +c ------------------------------------ +c + if ( nbfad3.eq.6 .and. nbfad4.eq.0 ) then +c + nbfihe = nbfihe + 1 + fhpyte(1,nbfihe) = 0 + fhpyte(2,nbfihe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHA3', nompro +#endif +c + call cmcha3 ( lehexa, etahex, + > indnoe, indare, indtri, indtet, + > nbfihe, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 2.2.2. ==> decoupage en 14 a partir de 2 aretes +c ------------------------------------ +c + elseif ( nbfad3.eq.4 .and. nbfad4.eq.0 ) then +c + nbfihe = nbfihe + 1 + fhpyte(1,nbfihe) = indpyr + 1 + fhpyte(2,nbfihe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHA2', nompro +#endif +c + call cmcha2 ( lehexa, etahex, + > indnoe, indare, indtri, indtet, indpyr, + > nbfihe, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 2.2.3. ==> decoupage en 4 a partir d'1 arete +c --------------------------------- +c + elseif ( nbfad3.eq.2 ) then +c + nbfihe = nbfihe + 1 + fhpyte(1,nbfihe) = indpyr + 1 + fhpyte(2,nbfihe) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHA1', nompro +#endif +c + call cmcha1 ( lehexa, etahex, + > indare, indtri, indpyr, + > nbfihe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 2.2.4. ==> decoupage a partir d'une face +c ----------------------------- +c + elseif ( nbfad3.eq.4 .and. nbfad4.eq.1 ) then +c + nbfihe = nbfihe + 1 + fhpyte(1,nbfihe) = indpyr + 1 + fhpyte(2,nbfihe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHF0', nompro +#endif +c + call cmchf0 ( lehexa, etahex, etatfa, + > indare, indtri, indtet, indpyr, + > nbfihe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> Mise a jour de l'historique +c +cgn print *, 'etahex = ', etahex + if ( codret.eq.0 ) then +c + hethex(lehexa) = hethex(lehexa) + etahex +c + endif +c +c 2.4. ==> Mise a jour de la parente +c + if ( etahex.ne.0 ) then +c + if ( codret.eq.0 ) then +c + filhex(lehexa) = -nbfihe + pphepe(nbfihe) = lehexa + pthepe(nbfihe) = lehexa +c + endif +c + endif +c + endif +c + endif +c + 200 continue +cgn do 3 , iaux = 1 , nouvtr +cgn print 167,iaux,aretri(iaux,1),aretri(iaux,2),aretri(iaux,3) +cgn 3 continue +c +c==== +c 3. la fin +c==== +cgn write(ulsort,90002) 'pertet',(pertet(iaux),iaux=1,min(10,nbteto)) +cgn write(ulsort,90002) 'perpyr',(perpyr(iaux),iaux=1,min(10,nbpyto)) +cgn write(ulsort,90002) 'hethex',(hethex(iaux),iaux=1,min(10,permhe)) +cgn write(ulsort,90002) 'filhex',(filhex(iaux),iaux=1,min(10,permhe)) +cgn write(ulsort,90002) 'fhpyte',fhpyte(1,1),fhpyte(2,1) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdhe.F b/src/tool/Creation_Maillage/cmcdhe.F new file mode 100644 index 00000000..5557ba10 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdhe.F @@ -0,0 +1,1947 @@ + subroutine cmcdhe ( indnoe, indare, indtet, indpyr, indhex, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > pthepe, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > pphepe, + > hethex, arehex, + > filhex, fhpyte, perhex, + > famhex, cfahex, + > quahex, coquhe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des HExaedres +c - - - - -- +c ______________________________________________________________________ +c +c but : decoupage des hexaedres pour mise en conformite +c remarque : description des fils par leurs aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . pthepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . pphepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . fhpyte . es .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . famhex . es . nouvhe . famille des hexaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDHE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "nombhe.h" +#include "hexcf0.h" +#include "hexcf1.h" +#include "ope002.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare, indtet, indpyr, indhex + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer pthepe(*) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6), arehex(nouvha,12) + integer pphepe(*) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe), fhpyte(2,nbheco) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "hexcf3.h" +c + integer iaux + integer decbin, decbrf + integer lehexa, lehexo + integer nbfihe + integer listso(8), listar(12) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Code binaire du decoupage :'',i5)' + texte(1,5) = '(''==> Code binaire de reference :'',i5)' + texte(1,6) = '(''Permutation :'',i5)' + texte(1,7) = '(''Nouvel etat de l''''hexaedre :'',i5)' +c + texte(2,4) = '(''Binary code for the cutting:'',i5)' + texte(2,5) = '(''==> reference binary code :'',i5)' + texte(2,6) = '(''Permutation:'',i5)' + texte(2,7) = '(''New status for the hexahedron:'',i5)' +c +#include "impr03.h" +#include "impr04.h" +c +c 1.2. ==> variables de travail +c + codret = 0 +c + nbfihe = 0 +c +#include "hexcf2.h" +c +c Parcours des hexaedres actifs +c + do 200 , lehexo = 1 , permhe +c + lehexa = lehexo +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,90015) 'hethex(', lehexa,') =',hethex(lehexa) +c + if ( mod(hethex(lehexa),1000).eq.0 ) then +cgn if ( lehexa.le.-12 ) then +cgn write(ulsort,90002) 'faces', (quahex(lehexa,iaux),iaux=1,6) +cgn write(ulsort,90002) 'codes', (coquhe(lehexa,iaux),iaux=1,6) +cgn endif +c +c==== +c 2. Recherche des etats des aretes de l'hexaedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( lehexa, + > nouvqu, nouvhf, + > arequa, quahex, coquhe, + > listar ) +c + decbin = 0 + do 21 , iaux = 1, 12 +cgn write(ulsort,90015) 'hetare(',listar(iaux), ') =', +cgn > hetare(listar(iaux)) + if ( mod(hetare(listar(iaux)),10).eq.2 .or. + > mod(hetare(listar(iaux)),10).eq.9 ) then + decbin = decbin + 2**(iaux-1) + endif + 21 continue +c + decbrf = chbirf(decbin) +c + if ( decbrf.gt.0 .and. decbrf.lt.4095 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( lehexa.le.-12 ) then + write (ulsort,texte(langue,4)) decbin + write (ulsort,texte(langue,5)) decbrf + write (ulsort,texte(langue,6)) chperm(decbin) + endif +#endif +cgn write(15,*) 'Classe', chclas(decbin) +c +c==== +c 3. Les numeros globaux apres permutation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOHE', nompro +#endif + call utsohe ( somare, listar, listso ) +c +#include "hexcf4.h" +c +c==== +c 4. L'etat final de l'hexaedre +c==== +c + hethex(lehexa) = hethex(lehexa) + chetat(decbin) +#ifdef _DEBUG_HOMARD_ + if ( lehexa.le.-12 ) then + write (ulsort,texte(langue,7)) hethex(lehexa) + endif +#endif +c +c==== +c 5. La filiation : avec ou sans hexaedres ? +c==== +c +cgn write(ulsort,*) 'chnhe(',decbin,')=',chnhe(decbin) + if ( chnhe(decbin).gt.0 ) then +c + filhex(lehexa) = indhex + 1 +c + else +c + nbfihe = nbfihe + 1 + filhex(lehexa) = -nbfihe +cgn write(ulsort,90002)'nbfihe ',nbfihe +c + fhpyte(1,nbfihe) = 0 + fhpyte(2,nbfihe) = 0 +c + if ( nouvpy.ne.0 ) then + pphepe(nbfihe) = lehexa + if ( chnpy(decbin).gt.0 ) then + fhpyte(1,nbfihe) = indpyr + 1 + endif + endif +c + if ( nouvte.ne.0 ) then + pthepe(nbfihe) = lehexa + if ( chnte(decbin).gt.0 ) then + fhpyte(2,nbfihe) = indtet + 1 + endif + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002)'nbfihe',nbfihe + write(ulsort,90002)'fhpyte',fhpyte(1,nbfihe),fhpyte(2,nbfihe) +#endif +c + endif +c +c==== +c 6. Parcours des differents modes de decoupage +c==== +c +c 6.1 ==> Classe 1/00 +c + if ( decbrf.eq.1) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH100', nompro +#endif + call cmh100 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.2 ==> Classe 2/00 +c + elseif ( decbrf.eq.65) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH200', nompro +#endif + call cmh200 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.3 ==> Classe 2/01 +c + elseif ( decbrf.eq.129) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH201', nompro +#endif + call cmh201 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.4 ==> Classe 2/02 +c + elseif ( decbrf.eq.2049) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH202', nompro +#endif + call cmh202 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.5 ==> Classe 2/03 +c + elseif ( decbrf.eq.3) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH203', nompro +#endif + call cmh203 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.6 ==> Classe 2/04 +c + elseif ( decbrf.eq.9) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH204', nompro +#endif + call cmh204 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.7 ==> Classe 3/00 +c + elseif ( decbrf.eq.1089) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH300', nompro +#endif + call cmh300 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.8 ==> Classe 3/01 +c + elseif ( decbrf.eq.641) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH301', nompro +#endif + call cmh301 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.9 ==> Classe 3/02 +c + elseif ( decbrf.eq.19) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH302', nompro +#endif + call cmh302 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.10 ==> Classe 3/03 +c + elseif ( decbrf.eq.259) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH303', nompro +#endif + call cmh303 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.11 ==> Classe 3/04 +c + elseif ( decbrf.eq.515) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH304', nompro +#endif + call cmh304 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.12 ==> Classe 3/05 +c + elseif ( decbrf.eq.1027) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH305', nompro +#endif + call cmh305 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.13 ==> Classe 3/06 +c + elseif ( decbrf.eq.2051) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH306', nompro +#endif + call cmh306 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.14 ==> Classe 3/07 +c + elseif ( decbrf.eq.35) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH307', nompro +#endif + call cmh307 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.15 ==> Classe 3/08 +c + elseif ( decbrf.eq.67) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH308', nompro +#endif + call cmh308 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.16 ==> Classe 3/09 +c + elseif ( decbrf.eq.131) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH309', nompro +#endif + call cmh309 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.17 ==> Classe 3/10 +c + elseif ( decbrf.eq.265) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH310', nompro +#endif + call cmh310 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.18 ==> Classe 3/11 +c + elseif ( decbrf.eq.521) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH311', nompro +#endif + call cmh311 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.19 ==> Classe 4/00 +c + elseif ( decbrf.eq.15) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH400', nompro +#endif + call cmh400 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.20 ==> Classe 4/01 +c + elseif ( decbrf.eq.771) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH401', nompro +#endif + call cmh401 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.21 ==> Classe 4/02 +c + elseif ( decbrf.eq.1283) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH402', nompro +#endif + call cmh402 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.22 ==> Classe 4/03 +c + elseif ( decbrf.eq.2563) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH403', nompro +#endif + call cmh403 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.23 ==> Classe 4/04 +c + elseif ( decbrf.eq.3075) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH404', nompro +#endif + call cmh404 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.24 ==> Classe 4/05 +c + elseif ( decbrf.eq.163) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH405', nompro +#endif + call cmh405 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.25 ==> Classe 4/06 +c + elseif ( decbrf.eq.195) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH406', nompro +#endif + call cmh406 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.26 ==> Classe 4/07 +c + elseif ( decbrf.eq.387) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH407', nompro +#endif + call cmh407 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.27 ==> Classe 4/08 +c + elseif ( decbrf.eq.643) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH408', nompro +#endif + call cmh408 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.28 ==> Classe 4/09 +c + elseif ( decbrf.eq.2083) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH409', nompro +#endif + call cmh409 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.29 ==> Classe 4/10 +c + elseif ( decbrf.eq.1091) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH410', nompro +#endif + call cmh410 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.30 ==> Classe 4/11 +c + elseif ( decbrf.eq.99) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH411', nompro +#endif + call cmh411 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.31 ==> Classe 4/12 +c + elseif ( decbrf.eq.2307) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH412', nompro +#endif + call cmh412 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.32 ==> Classe 4/13 +c + elseif ( decbrf.eq.1539) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH413', nompro +#endif + call cmh413 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.33 ==> Classe 4/14 +c + elseif ( decbrf.eq.1155) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH414', nompro +#endif + call cmh414 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.34 ==> Classe 4/15 +c + elseif ( decbrf.eq.2179) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH415', nompro +#endif + call cmh415 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.35 ==> Classe 4/16 +c + elseif ( decbrf.eq.147) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH416', nompro +#endif + call cmh416 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.36 ==> Classe 4/17 +c + elseif ( decbrf.eq.1545) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH417', nompro +#endif + call cmh417 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.37 ==> Classe 4/18 +c + elseif ( decbrf.eq.2313) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH418', nompro +#endif + call cmh418 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.38 ==> Classe 5/00 +c + elseif ( decbrf.eq.2211) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH500', nompro +#endif + call cmh500 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.39 ==> Classe 5/01 +c + elseif ( decbrf.eq.1219) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH501', nompro +#endif + call cmh501 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.40 ==> Classe 5/02 +c + elseif ( decbrf.eq.2435) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH502', nompro +#endif + call cmh502 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.41 ==> Classe 5/03 +c + elseif ( decbrf.eq.1667) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH503', nompro +#endif + call cmh503 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.42 ==> Classe 5/04 +c + elseif ( decbrf.eq.227) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH504', nompro +#endif + call cmh504 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.43 ==> Classe 5/05 +c + elseif ( decbrf.eq.899) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH505', nompro +#endif + call cmh505 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.44 ==> Classe 5/06 +c + elseif ( decbrf.eq.675) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH506', nompro +#endif + call cmh506 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.45 ==> Classe 5/07 +c + elseif ( decbrf.eq.451) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH507', nompro +#endif + call cmh507 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.46 ==> Classe 5/08 +c + elseif ( decbrf.eq.1123) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH508', nompro +#endif + call cmh508 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.47 ==> Classe 5/09 +c + elseif ( decbrf.eq.2147) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH509', nompro +#endif + call cmh509 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.48 ==> Classe 5/10 +c + elseif ( decbrf.eq.1171) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH510', nompro +#endif + call cmh510 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.49 ==> Classe 5/11 +c + elseif ( decbrf.eq.31) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH511', nompro +#endif + call cmh511 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.50 ==> Classe 5/12 +c + elseif ( decbrf.eq.271) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH512', nompro +#endif + call cmh512 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.51 ==> Classe 6/00 +c + elseif ( decbrf.eq.3219) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH600', nompro +#endif + call cmh600 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.52 ==> Classe 6/01 +c + elseif ( decbrf.eq.783) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH601', nompro +#endif + call cmh601 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.53 ==> Classe 6/02 +c + elseif ( decbrf.eq.2319) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH602', nompro +#endif + call cmh602 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.54 ==> Classe 6/03 +c + elseif ( decbrf.eq.1055) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH603', nompro +#endif + call cmh603 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.55 ==> Classe 6/04 +c + elseif ( decbrf.eq.2079) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH604', nompro +#endif + call cmh604 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.56 ==> Classe 6/05 +c + elseif ( decbrf.eq.159) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH605', nompro +#endif + call cmh605 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.57 ==> Classe 6/06 +c + elseif ( decbrf.eq.3171) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH606', nompro +#endif + call cmh606 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.58 ==> Classe 6/07 +c + elseif ( decbrf.eq.2723) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH607', nompro +#endif + call cmh607 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.59 ==> Classe 6/08 +c + elseif ( decbrf.eq.1475) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH608', nompro +#endif + call cmh608 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.60 ==> Classe 7/00 +c + elseif ( decbrf.eq.319) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH700', nompro +#endif + call cmh700 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.61 ==> Classe 7/01 +c + elseif ( decbrf.eq.3103) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH701', nompro +#endif + call cmh701 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.62 ==> Classe 8/00 +c + elseif ( decbrf.eq.3855) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH800', nompro +#endif + call cmh800 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.63 ==> Classe 8/01 +c + elseif ( decbrf.eq.2367) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH801', nompro +#endif + call cmh801 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c +c 6.64 ==> Classe 9/00 +c + elseif ( decbrf.eq.895) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMH900', nompro +#endif + call cmh900 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, nbfihe, + > hepers(1,chperm(decbin)), hepera(1,chperm(decbin)), + > heperf(1,chperm(decbin)), heperc(1,chperm(decbin)), + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) + endif +c + endif +c + endif +c + endif +c + 200 continue +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/Creation_Maillage/cmcdpe.F b/src/tool/Creation_Maillage/cmcdpe.F new file mode 100644 index 00000000..00933bac --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdpe.F @@ -0,0 +1,532 @@ + subroutine cmcdpe ( indnoe, indare, indtri, indtet, indpyr, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hetqua, arequa, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > pthepe, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > pphepe, + > facpen, cofape, hetpen, + > filpen, fppyte, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des PEntaedres +c - - - - -- +c ______________________________________________________________________ +c +c but : decoupage des pentaedres pour mise en conformite +c remarque : on est forcement en 3d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . pthepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . pphepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . hetpen . e . nouvpe . historique de l'etat des pentaedres . +c . filpen . e . nouvpe . premier fils des pentaedres . +c . fppyte . e . 2** . fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDPE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare, indtri, indtet, indpyr + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer pthepe(*) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer pphepe(*) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer hetpen(nouvpe) + integer filpen(nouvpe), fppyte(2,*) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer fj + integer nbfad2, nbfad3, nbfat4, nbfaq4 + integer etatfa(5) + integer lepent + integer nbfipe, etapen + integer indptp +#ifdef _DEBUG_HOMARD_ + integer listar(9) +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Decoupage provisoire en '',a)' + texte(1,5) ='(''Les decisions de decoupage des aretes du'')' + texte(1,6) ='(''Les decisions de decoupage des faces du'')' + texte(1,7) ='(''pentaedre numero'',i10,'' sont incoherentes.'')' + texte(1,8) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' + texte(1,10) ='(i10,'' problemes ...'')' +c + texte(2,4) ='(''Temporary splitting by '',a)' + texte(2,5) ='(''Decisions for the edges of the'')' + texte(2,6) ='(''Decisions for the faces of the'')' + texte(2,7) ='(''pentahedron #'',i10,S''do not match.'')' + texte(2,8) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' + texte(2,10) ='(i10,'' problems ...'')' +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c + nbfipe = 0 +c +c==== +c 2. decoupage +c==== +c + do 200 , iaux = 1 , permpe +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,90015) 'penta', iaux,' avec l''etat ',hetpen(iaux) +c + if ( mod(hetpen(iaux),100).eq.0 ) then +c +c 2.1. ==> Recherche des etats des faces du pentaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro + call utarpe ( iaux, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) + do 2121 , jaux = 1 , 9 + write (ulsort,91002) jaux,listar(jaux), somare(1,listar(jaux)), + > somare(2,listar(jaux)),hetare(listar(jaux)) + 2121 continue +#endif +c + etapen = 0 + lepent = iaux +cgn write(ulsort,90015) 'penta', lepent,' avec les faces', +cgn > (facpen(lepent,jaux),jaux=1,5) +c + nbfad2 = 0 + nbfad3 = 0 + nbfat4 = 0 + nbfaq4 = 0 + do 211 , jaux = 1 , 2 + fj = facpen(lepent,jaux) + etatfa(jaux) = mod(hettri(fj),10) +cgn write(ulsort,*) '. Etat de la ', jaux, '-ieme face :', +cgn > etatfa(jaux), ' (face ', fj, ')' + if ( etatfa(jaux).ge.1 .and. etatfa(jaux).le.3 ) then + nbfad2 = nbfad2 + 1 + elseif ( etatfa(jaux).eq.4 ) then + nbfat4 = nbfat4 + 1 + endif + 211 continue + do 212 , jaux = 3 , 5 + fj = facpen(lepent,jaux) + etatfa(jaux) = mod(hetqua(fj),100) +cgn write(ulsort,*) '. Etat de la ', jaux, '-ieme face :', +cgn > etatfa(jaux), ' (face ', fj, ')' + if ( etatfa(jaux).ge.31 .and. etatfa(jaux).le.34 ) then + nbfad3 = nbfad3 + 1 + elseif ( etatfa(jaux).eq.4 ) then + nbfaq4 = nbfaq4 + 1 + endif + 212 continue +cgn write(ulsort,90002) 'nbfad2', nbfad2 +cgn write(ulsort,90002) 'nbfad3', nbfad3 +cgn write(ulsort,90002) 'nbfat4', nbfat4 +cgn write(ulsort,90002) 'nbfaq4', nbfaq4 +c +c 2.2. ==> Decoupage de conformite +c 2.2.1. ==> decoupage a partir d'1 arete de triangle +c ---------------------------------------- +c + if ( nbfad2.eq.1 .and. nbfad3.eq.1 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = indpyr + 1 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0A', nompro +#endif + call cmcp0a ( lepent, etapen, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 2.2.2 ==> decoupage a partir d'1 arete de quadrangle +c ------------------------------------------ +c + elseif ( nbfad2.eq.0 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = indpyr + 1 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1A', nompro +#endif + call cmcp1a ( lepent, etapen, + > indtri, indtet, indpyr, + > indptp, + > hetare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 2.2.3 ==> decoupage a partir de 1 arete de tria et +c 1 arete de quad +c ----------------------------------------- +c + elseif ( nbfad2.eq.1 .and. nbfad3.eq.3 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = 0 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2A', nompro +#endif + call cmcp2a ( lepent, etapen, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 2.2.4 ==> decoupage a partir de 2 aretes de tria +c ------------------------------------- +c + elseif ( nbfad2.eq.2 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = indpyr + 1 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3A', nompro +#endif + call cmcp3a ( lepent, etapen, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 2.2.5 ==> decoupage a partir de 1 face quad +c -------------------------------- +c + elseif ( nbfad2.eq.2 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.1 .and. nbfat4.eq.0 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = indpyr + 1 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4A', nompro +#endif + call cmcp4a ( lepent, etapen, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 2.2.6 ==> decoupage a partir de 1 face tria +c -------------------------------- +c + elseif ( nbfad2.eq.0 .and. nbfad3.eq.3 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.1 ) then +c + nbfipe = nbfipe + 1 + indptp = nbheco + nbfipe + fppyte(1,nbfipe) = 0 + fppyte(2,nbfipe) = indtet + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5A', nompro +#endif + call cmcp5a ( lepent, etapen, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> Mise a jour de l'historique +c +cgn print *, 'etapen = ', etapen + if ( codret.eq.0 ) then +c + hetpen(lepent) = hetpen(lepent) + etapen +c + endif +c +c 2.4. ==> Mise a jour de la parente +c + if ( etapen.ne.0 ) then +c + if ( codret.eq.0 ) then +c + filpen(lepent) = -nbfipe + pphepe(indptp) = lepent + pthepe(indptp) = lepent +c + endif +c + endif +c + endif +c + endif +c + 200 continue +cgn do 3 , iaux = 1 , nouvtr +cgn print 167,iaux,aretri(iaux,1),aretri(iaux,2),aretri(iaux,3) +cgn 3 continue +c +c==== +c 3. la fin +c==== +cgn write(ulsort,90002) 'famtet',(famtet(iaux),iaux= 1,10) +cgn write(ulsort,90002) 'famtet',(famtet(iaux),iaux=11,20) +cgn write(ulsort,90002) 'famtet',(famtet(iaux),iaux=21,29) +cgn write(ulsort,90002) 'fampyr',(fampyr(iaux),iaux= 1,10) +cgn write(ulsort,90002) 'fampyr',(fampyr(iaux),iaux=11,17) +cgn write(ulsort,90002) 'pertet',(pertet(iaux),iaux=1,min(10,nbteto)) +cgn write(ulsort,90002) 'perpyr',(perpyr(iaux),iaux=1,min(10,nbpyto)) +cgn write(ulsort,90002) 'hetpen',(hetpen(iaux),iaux=1,min(10,permpe)) +cgn write(ulsort,90002) 'filpen',(filpen(iaux),iaux=1,min(10,permpe)) +cgn write(ulsort,90002) 'fppyte',fppyte(1,1),fppyte(2,1) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdq2.F b/src/tool/Creation_Maillage/cmcdq2.F new file mode 100644 index 00000000..2782682e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdq2.F @@ -0,0 +1,298 @@ + subroutine cmcdq2 ( lequad, + > indare, indqua, + > hetare, somare, + > filare, merare, famare, + > hetqua, arequa, + > filqua, perqua, famqua, + > nivqua, + > cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des Quadrangles +c - - - - - +c en 2 quadrangles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . caracteristiques des aretes . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*3. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDQ2' ) +c +#include "nblang.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer lequad + integer indare, indqua + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), perqua(nouvqu), famqua(nouvqu) + integer nivqua(nouvqu) + integer cfaqua(nctfqu,nbfqua) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer aifj, aifl, ni + integer akfj, akfl, nk + integer saiaj, sajak, sakal, salai + integer nf1, nf2 + integer anink + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Les decisions de decoupage des aretes du'')' + texte(1,5) ='(''quadrangle numero'',i10,'' sont incoherentes :'')' + texte(1,6) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' +c + texte(2,4) ='(''Decisions for the edges of the'')' + texte(2,5) ='(''quadrangle #'',i10,''do not match :'')' + texte(2,6) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indqua', indqua + write (ulsort,90002) 'nouvqu', nouvqu +#endif +c + codret = 0 +c +c==== +c 2. decoupage en 2 quadrangles des quadrangles de decision 2 +c==== +c +c Quadrangle pere : +c ak = numero de la k-eme arete du quadrangle pere +c sajak = numero du noeud commun aux aretes aj et ak +c +c sa4a1 a4 sa3a4 +c ._________________________________________________. +c . . +c . . +c . . +c . . +c . . +c . . +c a1 . . a3 +c . . +c . . +c . . +c . . +c . . +c . . +c ._________________________________________________. +c sa1a2 a2 sa2a3 +c +c Remarque : on appelle ici le sens standard celui correspondant +c a l'enchainement (a1,a2,a3,a4) +c +c +c Quadrangles fils apres decoupages des aretes ai et ak +c +c saiaj aifj ai/ni aifl salai +c ._____________________________________________. +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c aj . nq1 .anink nq2 . al +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c ._____________________________________________. +c sajak akfj ak/nk akfl sakal +c +c 2.1. ==> determination des numeros d'aretes et de leurs numeros locaux +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +cgn print *,a1, a2, a3, a4 +c +c 2.2. ==> determination des aretes et des sommets, relativement +c au decoupage de l'arete +c + call utcoq2 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, + > aifj, aifl, ni, + > akfj, akfl, nk, + > saiaj, sajak, sakal, salai, + > ulsort, langue, codret ) +c +c 2.3. ==> decoupage du quadrangle en fonction des aretes coupees +c 2.3.1. ==> creation de l'arete interieure +c + if ( codret.eq.0 ) then +c +cgn print * ,ai, aj, ak, al +cgn print *,saiaj, sajak, sakal, salai +cgn print *,aifj, aifl +cgn print *,ni +c + indare = indare + 1 + anink = indare + somare(1,anink) = min(ni,nk) + somare(2,anink) = max(ni,nk) + jaux = cfaqua(cofafa,famqua(lequad)) + famare(anink) = jaux + hetare(anink) = 50 + merare(anink) = 0 + filare(anink) = 0 +c +c 2.3.2. ==> creation des deux quadrangles +c + nf1 = indqua + 1 + arequa(nf1,1) = aifj + arequa(nf1,2) = aj + arequa(nf1,3) = akfj + arequa(nf1,4) = anink +c + nf2 = indqua + 2 + arequa(nf2,1) = akfl + arequa(nf2,2) = al + arequa(nf2,3) = aifl + arequa(nf2,4) = anink +c + jaux = nivqua(lequad) + 1 + do 232 , iaux = nf1 , nf2 + famqua(iaux) = famqua(lequad) + hetqua(iaux) = 5500 + filqua(iaux) = 0 + perqua(iaux) = lequad + nivqua(iaux) = jaux + 232 continue +c +c 2.3.3. ==> modification des parametres du quadrangle +c + hetqua(lequad) = hetqua(lequad) + 20 + numdec + filqua(lequad) = nf1 +c + indqua = nf2 +c + else +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) lequad + write (ulsort,texte(langue,6)) 1, a1, hetare(a1) + write (ulsort,texte(langue,6)) 2, a2, hetare(a2) + write (ulsort,texte(langue,6)) 3, a3, hetare(a3) + write (ulsort,texte(langue,6)) 4, a4, hetare(a4) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdq3.F b/src/tool/Creation_Maillage/cmcdq3.F new file mode 100644 index 00000000..9f5bd12d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdq3.F @@ -0,0 +1,361 @@ + subroutine cmcdq3 ( lequad, + > indare, indtri, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hetqua, arequa, + > filqua, famqua, + > nivqua, + > cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des Quadrangles +c - - - - - +c en 3 triangles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . caracteristiques des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*3. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDQ3' ) +c +#include "nblang.h" +#include "coftfq.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer lequad + integer indare, indtri + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), famqua(nouvqu) + integer nivqua(nouvqu) + integer cfaqua(nctfqu,nbfqua) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer aifj, aifl + integer saiaj, sajak, sakal, salai + integer ni + integer nf1, nf2, nf3 + integer anijk, anikl + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Les decisions de decoupage des aretes du'')' + texte(1,5) ='(''quadrangle numero'',i10,'' sont incoherentes :'')' + texte(1,6) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' +c + texte(2,4) ='(''Decisions for the edges of the'')' + texte(2,5) ='(''quadrangle #'',i10,''do not match :'')' + texte(2,6) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'entree : indare', indare + write (ulsort,90002) 'entree : indtri', indtri + write (ulsort,90002) 'entree : nouvtr', nouvtr +#endif +c + codret = 0 +c +c==== +c 2. decoupage en 3 des quadrangles de decision 3 +c==== +c +c Quadrangle pere : +c ak = numero de la k-eme arete du quadrangle pere +c sajak = numero du noeud commun aux aretes aj et ak +c +c sa4a1 a4 sa3a4 +c ._________________________________________________. +c . . +c . . +c . . +c . . +c . . +c . . +c a1 . . a3 +c . . +c . . +c . . +c . . +c . . +c . . +c ._________________________________________________. +c sa1a2 a2 sa2a3 +c +c Remarque : on appelle ici le sens standard celui correspondant +c a l'enchainement (a1,a2,a3,a4) +c +c Triangles fils apres decoupage de l'arete ai : +c l'ordre (ai,aj,ak,al) est le meme que (a1,a2,a3,a4) +c nfk = numero du k-eme triangle fils +c la description des triangles doit se faire dans le meme sens +c que le quadrangle +c . le premier triangle est celui qui s'appuie sur le milieu +c de l'arete coupee, ai/ni, et sur l'arete opposee, ak : +c nf1 : (anijk,ak,anikl) +c . le deuxieme triangle, nf2, est celui qui s'appuie sur la fille +c de l'arete coupee allant vers saiaj et sur l'arete aj. +c nf2 : (aifj,aj,anijk) +c . le troisieme triangle, nf3, est celui qui s'appuie sur la fille +c de l'arete coupee allant vers salai et sur l'arete al. +c nf2 : (aifl,anikl,al) +c +c saiaj aifj ai/ni aifl salai +c ._____________________________________________. +c . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . nf2 . . nf3 . +c . . . . +c . . . . +c . . . . +c aj . . . . al +c . .anijk anikl. . +c . . . . +c . . . . +c . . . . +c . . . . +c . . nf1 . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ._____________________________________________. +c sajak ak sakal +c +c 2.1. ==> determination des numeros d'aretes et de leurs numeros locaux +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'arete 1', a1, hetare(a1) + write (ulsort,90002) 'arete 2', a2, hetare(a2) + write (ulsort,90002) 'arete 3', a3, hetare(a3) + write (ulsort,90002) 'arete 4', a4, hetare(a4) +#endif +c +c 2.2. ==> determination des aretes et des sommets, relativement +c au decoupage de l'arete +c + call utcoq3 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, aifj, aifl, + > saiaj, sajak, sakal, salai, ni, + > ulsort, langue, codret ) +c +c 2.3. ==> decoupage du quadrangle en fonction de l'arete coupee +c 2.3.1. ==> creation des deux aretes interieures +c + if ( codret.eq.0 ) then +c +cgn print * ,ai, aj, ak, al +cgn print *,saiaj, sajak, sakal, salai +cgn print *,aifj, aifl +cgn print *,ni +c + indare = indare + 1 + anijk = indare + somare(1,anijk) = min(sajak,ni) + somare(2,anijk) = max(sajak,ni) + jaux = cfaqua(cofafa,famqua(lequad)) + famare(anijk) = jaux + hetare(anijk) = 50 + merare(anijk) = 0 + filare(anijk) = 0 +c + indare = indare + 1 + anikl = indare + somare(1,anikl) = min(sakal,ni) + somare(2,anikl) = max(sakal,ni) + jaux = cfaqua(cofafa,famqua(lequad)) + famare(anikl) = jaux + hetare(anikl) = 50 + merare(anikl) = 0 + filare(anikl) = 0 +c +c 2.3.2. ==> creation des trois triangles +c + nf1 = indtri + 1 + aretri(nf1,1) = anijk + aretri(nf1,2) = ak + aretri(nf1,3) = anikl +c + nf2 = indtri + 2 + aretri(nf2,1) = aifj + aretri(nf2,2) = aj + aretri(nf2,3) = anijk +c + nf3 = indtri + 3 + aretri(nf3,1) = aifl + aretri(nf3,2) = anikl + aretri(nf3,3) = al +cgn write(ulsort,90002) 'Creation des triangles',nf1,nf2,nf3 +cgn write(ulsort,90002) 'famqua(lequad)',famqua(lequad) +cgn write(ulsort,90002) 'avec cfaqua', +cgn >(cfaqua(iaux,famqua(lequad)),iaux=1,nctfqu) +cgn write(ulsort,90002) '==> famtri', cfaqua(coftfq,famqua(lequad)) +c + jaux = nivqua(lequad) + 1 + kaux = cfaqua(coftfq,famqua(lequad)) + do 232 , iaux = nf1 , nf3 + famtri(iaux) = kaux + hettri(iaux) = 50 + filtri(iaux) = 0 + pertri(iaux) = -lequad + nivtri(iaux) = jaux + 232 continue +c +c 2.3.3. ==> modification des parametres du quadrangle +c + hetqua(lequad) = hetqua(lequad) + 30 + numdec + filqua(lequad) = -nf1 +c + indtri = nf3 +c + else +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) lequad + write (ulsort,texte(langue,6)) 1, a1, hetare(a1) + write (ulsort,texte(langue,6)) 2, a2, hetare(a2) + write (ulsort,texte(langue,6)) 3, a3, hetare(a3) + write (ulsort,texte(langue,6)) 4, a4, hetare(a4) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Sortie : indare', indare + write (ulsort,90002) 'Sortie : indtri', indtri +cgn write (ulsort,*) 'Sortie : nivtri', nivtri +cgn write (ulsort,*) 'Sortie : nivqua', nivqua +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdq5.F b/src/tool/Creation_Maillage/cmcdq5.F new file mode 100644 index 00000000..f6adbe74 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdq5.F @@ -0,0 +1,384 @@ + subroutine cmcdq5 ( lequad, + > indnoe, indare, indqua, + > coonoe, hetnoe, arenoe, famnoe, + > hetare, somare, + > filare, merare, famare, + > hetqua, arequa, + > filqua, perqua, famqua, + > nivqua, ninqua, + > cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des Quadrangles +c - - - - - +c en 3 quadrangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . caracteristiques des aretes . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*3. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . ninqua . es . nouvqu . noeud interne au quadrangle . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDQ5' ) +c +#include "nblang.h" +#include "cofatq.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer lequad + integer indnoe, indare, indqua + integer hetnoe(nouvno), arenoe(nouvno), famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), perqua(nouvqu), famqua(nouvqu) + integer nivqua(nouvqu) + integer ninqua(nouvqu) + integer cfaqua(nctfqu,nbfqua) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer aifj, aifl, ni + integer ajfi, ajfk, nj + integer n0 + integer saiaj, sajak, sakal, salai + integer nf1, nf2, nf3 + integer anin0, anjn0, ankln0 + integer iaux, jaux +c + logical noinma +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Les decisions de decoupage des aretes du'')' + texte(1,5) ='(''quadrangle numero'',i10,'' sont incoherentes :'')' + texte(1,6) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' + texte(1,7) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)' +c + texte(2,4) ='(''Decisions for the edges of the'')' + texte(2,5) ='(''quadrangle #'',i10,''do not match :'')' + texte(2,6) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' + texte(2,7) = '(''.. Central node'',i10,'', coor :'',3g15.7)' +c +#include "impr03.h" +c + codret = 0 +c + if ( mod(mailet,3).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c +c==== +c 2. decoupage en 3 quadrangles des quadrangles de decision 5 +c==== +c Quadrangle pere : +c ak = numero de la k-eme arete du quadrangle pere +c sajak = numero du noeud commun aux aretes aj et ak +c +c sa4a1 a4 sa3a4 +c ._________________________________________________. +c . . +c . . +c . . +c . . +c . . +c . . +c a1 . . a3 +c . . +c . . +c . . +c . . +c . . +c . . +c ._________________________________________________. +c sa1a2 a2 sa2a3 +c +c Remarque : on appelle ici le sens standard celui correspondant +c a l'enchainement (a1,a2,a3,a4) +c +c +c Quadrangles fils apres decoupages des aretes ai et aj +c +c saiaj aifj ai/ni aifl salai +c ._____________________________________________. +c . . . +c . . . +c . . . +c . .anin0 . +c ajfi . nq1 . . +c . . . +c . . . +c . . . +c . anjn0 . . +c aj/nj .----------------------.n0 nq3 . al +c . . . +c . . . +c . . . +c . . . +c ajfk . nq2 . . +c . ankln0 . . +c . . . +c . . . +c . . . +c ._____________________________________________. +c sajak ak sakal +c +c +c 2.1. ==> determination des numeros d'aretes et de leurs numeros locaux +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +cgn if ( lequad.eq.281 ) then +cgn write(ulsort,90002) 'aretes', a1, a2, a3, a4 +cgn endif +c +c 2.2. ==> determination des aretes et des sommets, relativement +c au decoupage de l'arete +c + call utcoq5 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, + > aifj, aifl, ni, + > ajfi, ajfk, nj, + > saiaj, sajak, sakal, salai, + > ulsort, langue, codret ) +cgn if ( lequad.eq.281 ) then +cgn write(ulsort,90002) 'numdec', numdec +cgn write(ulsort,90002) 'ai, aj, ak, al', ai, aj, ak, al +cgn write(ulsort,90002) 'aifj, aifl, ni', aifj, aifl, ni +cgn write(ulsort,90002) 'ajfi, ajfk, nj', ajfi, ajfk, nj +cgn write(ulsort,90002) 'saiaj, sajak, sakal, salai', +cgn > saiaj, sajak, sakal, salai +cgn endif +c +c 2.3. ==> decoupage du quadrangle en fonction des aretes coupees +c + if ( codret.eq.0 ) then +c +c 2.3.1. ==> le sommet central +c . on le cree au barycentre du quadrangle s'il n'existe pas +c . on le recupere sinon +c + if ( noinma ) then +c + n0 = ninqua(lequad) +c + else +c + n0 = indnoe + 1 + arenoe(n0) = 0 + coonoe(n0,1) = ( coonoe(saiaj,1) + + > coonoe(sajak,1) + + > coonoe(sakal,1) + + > coonoe(salai,1) ) * unsqu + coonoe(n0,2) = ( coonoe(saiaj,2) + + > coonoe(sajak,2) + + > coonoe(sakal,2) + + > coonoe(salai,2) ) * unsqu + if ( sdim.eq.3 ) then + coonoe(n0,3) = ( coonoe(saiaj,3) + + > coonoe(sajak,3) + + > coonoe(sakal,3) + + > coonoe(salai,3) ) * unsqu + endif + famnoe(n0) = 1 + hetnoe(n0) = 51 + indnoe = n0 +c + endif +#ifdef _DEBUG_HOMARD_ + if ( sdim.eq.3 ) then + write (ulsort,texte(langue,7)) n0, + > coonoe(n0,1),coonoe(n0,2),coonoe(n0,3) + else + write (ulsort,texte(langue,7)) n0, + > coonoe(n0,1),coonoe(n0,2) + endif +#endif +c +c 2.3.2. ==> creation des trois aretes interieures +c + anin0 = indare + 1 + somare(1,anin0) = ni +c + anjn0 = indare + 2 + somare(1,anjn0) = nj +c + ankln0 = indare + 3 + somare(1,ankln0) = sakal +c + jaux = cfaqua(cofafa,famqua(lequad)) + do 232 , iaux = anin0 , ankln0 + somare(2,iaux) = n0 + famare(iaux) = jaux + hetare(iaux) = 50 + filare(iaux) = 0 + merare(iaux) = 0 + 232 continue +c + indare = ankln0 +c +c 2.3.3. ==> creation des trois quadrangles +c + nf1 = indqua + 1 + arequa(nf1,1) = aifj + arequa(nf1,2) = ajfi + arequa(nf1,3) = anjn0 + arequa(nf1,4) = anin0 +c + nf2 = indqua + 2 + arequa(nf2,1) = ajfk + arequa(nf2,2) = ak + arequa(nf2,3) = ankln0 + arequa(nf2,4) = anjn0 +c + nf3 = indqua + 3 + arequa(nf3,1) = aifl + arequa(nf3,2) = anin0 + arequa(nf3,3) = ankln0 + arequa(nf3,4) = al +c + jaux = nivqua(lequad) + 1 + do 233 , iaux = nf1 , nf3 + famqua(iaux) = famqua(lequad) + hetqua(iaux) = 5500 + filqua(iaux) = 0 + perqua(iaux) = lequad + nivqua(iaux) = jaux + 233 continue +c +c 2.3.4. ==> modification des parametres du quadrangle +c + hetqua(lequad) = hetqua(lequad) + 40 + numdec + filqua(lequad) = nf1 +c + indqua = nf3 +c + else +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) lequad + write (ulsort,texte(langue,6)) 1, a1, hetare(a1) + write (ulsort,texte(langue,6)) 2, a2, hetare(a2) + write (ulsort,texte(langue,6)) 3, a3, hetare(a3) + write (ulsort,texte(langue,6)) 4, a4, hetare(a4) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdqu.F b/src/tool/Creation_Maillage/cmcdqu.F new file mode 100644 index 00000000..ed741dfe --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdqu.F @@ -0,0 +1,254 @@ + subroutine cmcdqu ( indnoe, indare, indtri, indqua, decfac, + > coonoe, hetnoe, arenoe, famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hetqua, arequa, + > filqua, perqua, famqua, + > nivqua, ninqua, + > cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des QUadrangles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . caracteristiques des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . arequa . es .nouvqu*3. numeros des 4 aretes des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . ninqua . es . nouvqu . noeud interne au quadrangle . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDQU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer indnoe, indare, indtri, indqua + integer decfac(-permqu:permtr) + integer hetnoe(nouvno), arenoe(nouvno), famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer hetqua(nouvqu), arequa(nouvqu,4) + integer filqua(nouvqu), perqua(nouvqu), famqua(nouvqu) + integer nivqua(nouvqu) + integer ninqua(nouvqu) + integer cfaqua(nctfqu,nbfqua) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lequad + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'au debut de'//nompro//', indnoe= ', indnoe + write (ulsort,90002) 'au debut de'//nompro//', indare= ', indare +#endif +c==== +c 2. Parcours des quadrangles +c==== +c + do 200 , iaux = 1 , permqu +cgn print *,iaux,decfac(-iaux) +c + if ( codret.eq.0 ) then +c + lequad = iaux +c +c 2.1. ==> decoupage en 2 quadrangles des quadrangles +c + if ( decfac(-iaux).eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDQ2', nompro +#endif + call cmcdq2 ( lequad, + > indare, indqua, + > hetare, somare, + > filare, merare, famare, + > hetqua, arequa, + > filqua, perqua, famqua, + > nivqua, + > cfaqua, + > ulsort, langue, codret) +c +c 2.2. ==> decoupage en 3 triangles des quadrangles +c + elseif ( decfac(-iaux).eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDQ3', nompro +#endif + call cmcdq3 ( lequad, + > indare, indtri, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hetqua, arequa, + > filqua, famqua, + > nivqua, + > cfaqua, + > ulsort, langue, codret) +c +c 2.3. ==> decoupage en 3 quadrangles des quadrangles +c + elseif ( decfac(-iaux).eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDQ5', nompro +#endif + call cmcdq5 ( lequad, + > indnoe, indare, indqua, + > coonoe, hetnoe, arenoe, famnoe, + > hetare, somare, + > filare, merare, famare, + > hetqua, arequa, + > filqua, perqua, famqua, + > nivqua, ninqua, + > cfaqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 200 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'a la fin de'//nompro//', indnoe= ', indnoe + write (ulsort,90002) 'a la fin de'//nompro//', indare= ', indare +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +cgn print *,'fin de ',nompro,', indtri = ',indtri +cgn print *,'fin de ',nompro,', indqua = ',indqua +cgn print *,'fin de ',nompro,', nivtri = ',nivtri +cgn print *,'fin de ',nompro,', nivqua = ',nivqua +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdte.F b/src/tool/Creation_Maillage/cmcdte.F new file mode 100644 index 00000000..513b224b --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdte.F @@ -0,0 +1,1826 @@ + subroutine cmcdte ( indare, indtri, indtet, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des TEtraedres +c - - - - -- +c ______________________________________________________________________ +c +c but : decoupage en 2 et en 4 des tetraedres pour mise en conformite +c remarque : on est forcement en 3d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDTE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "i1i2i3.h" +#include "demitr.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indare, indtri, indtet + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer adiag, letetr + integer nbfad2, nbfad4, fj + integer etatfa(4) + integer niveau, cf1, cf2, cf3, cf4, f1, f2, f3, f4 + integer codefa, codef1, codef2, codef3, codef4 + integer a1, a2, a3, a4, a5, a6 + integer a4ff1, a5ff1, a6ff1, a2ff2, a3ff2, a6ff2 + integer a1ff3, a3ff3, a5ff3, a1ff4, a2ff4, a4ff4 + integer as1n1, as1n2, as1n3, as1n4, as1n5, as1n6 + integer as2n1, as2n2, as2n3, as2n4, as2n5, as2n6 + integer as3n1, as3n2, as3n3, as3n4, as3n5, as3n6 + integer as4n1, as4n2, as4n3, as4n4, as4n5, as4n6 + integer ff1, ff2, ff3, ff4, n1, n2, n3, n4, n5, n6 + integer fa1n6, fa2n5, fa3n4, fa4n3, fa5n2, fa6n1 + integer fd16s1, fd16s2, fd16s3, fd16s4 + integer fd25s1, fd25s2, fd25s3, fd25s4 + integer fd34s1, fd34s2, fd34s3, fd34s4 + integer ff1d4, ff1d5, ff1d6, ff2d2, ff2d3, ff2d6 + integer ff3d1, ff3d3, ff3d5, ff4d1, ff4d2, ff4d4 + integer f4ff1, f5ff1, f6ff1, f2ff2, f3ff2, f6ff2 + integer f1ff3, f3ff3, f5ff3, f1ff4, f2ff4, f4ff4 + integer fpara1, fpara2, fpara3, fpara4, fpara5, fpara6 + integer ti0ff1, ti1ff1, ti2ff1, ti3ff1 + integer ti0ff2, ti1ff2, ti2ff2, ti3ff2 + integer ti0ff3, ti1ff3, ti2ff3, ti3ff3 + integer ti0ff4, ti1ff4, ti2ff4, ti3ff4 + integer ta1f1, ta1f2, ta2f1, ta2f3, ta3f1, ta3f4 + integer ta4f2, ta4f3, ta5f2, ta5f4, ta6f3, ta6f4 + integer td16a2, td16a3, td16a4, td16a5 + integer td25a1, td25a3, td25a4, td25a6 + integer td34a1, td34a2, td34a5, td34a6 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Decoupage provisoire en '',a)' + texte(1,5) ='(''Les decisions de decoupage des aretes du'')' + texte(1,6) ='(''Les decisions de decoupage des faces du'')' + texte(1,7) ='(''tetraedre numero'',i10,'' sont incoherentes.'')' + texte(1,8) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' + texte(1,9) = + >'(42(''=''),/,''Arret premature, apres '',i9,'' problemes'')' + texte(1,10) ='(i10,'' problemes ...'')' +c + texte(2,4) ='(''Temporary splitting by '',a)' + texte(2,5) ='(''Decisions for the edges of the'')' + texte(2,6) ='(''Decisions for the faces of the'')' + texte(2,7) ='(''tetrahedron #'',i10,S''do not match.'')' + texte(2,8) ='(''Edge #'',i2,'' :'',i10,'' state :'',i10)' + texte(2,9) = + >'(42(''=''),/,''Anticipated stop, after '',i9,'' problems'')' + texte(2,10) ='(i10,'' problems ...'')' +c + codret = 0 +c +c==== +c 2. decoupage +c==== +c + do 200 , letetr = 1 , permte +c + if ( mod(hettet(letetr),100).eq.0 ) then +c +c 2.1. ==> Recherche des etats des faces du tetraedre +c +cgn write(ulsort,*) 'tetraedre ', letetr + nbfad2 = 0 + nbfad4 = 0 + do 21 , jaux = 1 , 4 + fj = tritet(letetr,jaux) + etatfa(jaux) = mod(hettri(fj),10) +cgn write(ulsort,*) '. Etat de la ', jaux, '-ieme face :', +cgn > etatfa(jaux), ' (face ', fj, ')' + if ( etatfa(jaux).ge.1 .and. etatfa(jaux).le.3 ) then + nbfad2 = nbfad2 + 1 + elseif ( etatfa(jaux).eq.4 ) then + nbfad4 = nbfad4 + 1 + endif + 21 continue +c +c reperage des 4 faces du tetraedre +c + f1 = tritet(letetr,1) + f2 = tritet(letetr,2) + f3 = tritet(letetr,3) + f4 = tritet(letetr,4) +c +c recuperation des codes des 4 faces du tetraedre +c + cf1 = cotrte(letetr,1) + cf2 = cotrte(letetr,2) + cf3 = cotrte(letetr,3) + cf4 = cotrte(letetr,4) +c +c famille du tetraedre +c + iaux = famtet(letetr) +c + if ( nbfad2.eq.3 .and. nbfad4.eq.1 ) then +c +c==== +c 3. decoupage en 4 des tetraedres selon une face +c . 1 face coupee en 4 +c . 3 autres faces coupees en 2 +c==== +c + if ( etatfa(1).eq.4 ) then +c +c 3.1. decoupage a partir de la face 1 +c +c 3.1.1. description des 4 faces du tetraedre +c +c 3.1.1.1. description de la face 1 +c +c 3.1.1.1.1.reperage des 4 triangles fils +c + ff1 = filtri(f1) + f4ff1 = ff1 + i1(cf1) + f5ff1 = ff1 + i2(cf1) + f6ff1 = ff1 + i3(cf1) +c +c 3.1.1.1.2.reperage des 3 aretes internes +c + a4ff1 = aretri(ff1,i1(cf1)) + a5ff1 = aretri(ff1,i2(cf1)) + a6ff1 = aretri(ff1,i3(cf1)) +c +c 3.1.1.2. description de la face 2 +c +c 3.1.1.2.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i3(cf2),i1(cf2)) + ff2d3 = filtri(f2) + nutrde(i3(cf2),i2(cf2)) +c +c 3.1.1.2.2.reperage de l'arete interne +c + as1n6 = aretri(ff2d2,i2(cf2)) +c +c 3.1.1.3. description de la face 3 +c +c 3.1.1.3.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i3(cf3),i1(cf3)) + ff3d3 = filtri(f3) + nutrde(i3(cf3),i2(cf3)) +c +c 3.1.1.3.2.reperage de l'arete interne +c + as1n5 = aretri(ff3d1,i2(cf3)) +c +c 3.1.1.4. description de la face 4 +c +c 3.1.1.4.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i3(cf4),i1(cf4)) + ff4d2 = filtri(f4) + nutrde(i3(cf4),i2(cf4)) +c +c 3.1.1.4.2.reperage de l'arete interne +c + as1n4 = aretri(ff4d1,i2(cf4)) +c +c 3.1.2. creation des 3 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1) + codefa = 1 +c + fpara4 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara4, as1n6, as1n5, a4ff1, + > codefa, niveau ) +c + fpara5 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara5, as1n6, as1n4, a5ff1, + > codefa, niveau ) +c + fpara6 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara6, as1n5, as1n4, a6ff1, + > codefa, niveau ) +c + indtri = fpara6 +c +c 3.1.3. creation des tetraedres +c + ti0ff1 = indtet + 1 + codef1 = cf1 + codef2 = 1 + codef3 = 1 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1, fpara6, fpara5, fpara4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti0ff1 ) +c + ti1ff1 = indtet + 2 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 6 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f4ff1, ff2d3, ff3d3, fpara4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti1ff1 ) +c + ti2ff1 = indtet + 3 + codef1 = cf1 + codef2 = cf2 + codef3 = 6 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f5ff1, ff2d2, fpara5, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti2ff1 ) +c + ti3ff1 = indtet + 4 + codef1 = cf1 + codef2 = 6 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f6ff1, fpara6, ff3d1, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti3ff1 ) +c + indtet = ti3ff1 +c +c 3.1.4. mise a jour du tetredre courant +c + filtet(letetr) = ti0ff1 + hettet(letetr) = hettet(letetr) + 41 +c +c + elseif ( etatfa(2).eq.4 ) then +c +c 3.2. decoupage a partir de la face 2 +c +c 3.2.1. description des 4 faces du tetraedre +c +c 3.2.1.1. description de la face 1 +c +c 3.2.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i3(cf1),i1(cf1)) + ff1d5 = filtri(f1) + nutrde(i3(cf1),i2(cf1)) +c +c 3.2.1.1.2.reperage de l'arete interne +c + as2n6 = aretri(ff1d4,i2(cf1)) +c +c 3.2.1.2. description de la face 2 +c +c 3.2.1.2.1.reperage des 4 triangles fils +c + ff2 = filtri(f2) + f2ff2 = ff2 + i1(cf2) + f3ff2 = ff2 + i2(cf2) + f6ff2 = ff2 + i3(cf2) +c +c 3.2.1.2.2.reperage des 3 aretes internes +c + a2ff2 = aretri(ff2,i1(cf2)) + a3ff2 = aretri(ff2,i2(cf2)) + a6ff2 = aretri(ff2,i3(cf2)) +c +c 3.2.1.3. description de la face 3 +c +c 3.2.1.3.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i2(cf3),i1(cf3)) + ff3d5 = filtri(f3) + nutrde(i2(cf3),i3(cf3)) +c +c 3.2.1.3.2.reperage de l'arete interne +c + as2n3 = aretri(ff3d1,i3(cf3)) +c +c 3.2.1.4. description de la face 4 +c +c 3.2.1.4.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i2(cf4),i1(cf4)) + ff4d4 = filtri(f4) + nutrde(i2(cf4),i3(cf4)) +c +c 3.2.1.4.2.reperage de l'arete interne +c + as2n2 = aretri(ff4d1,i3(cf4)) +c +c 3.2.2. creation des 3 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff2) + codefa = 1 +c + fpara2 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara2, as2n6, a2ff2, as2n3, + > codefa, niveau ) +c + fpara3 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara3, as2n6, a3ff2, as2n2, + > codefa, niveau ) +c + fpara6 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara6, as2n3, as2n2, a6ff2, + > codefa, niveau ) +c + indtri = fpara6 +c +c 3.2.3. creation des tetraedres +c + ti0ff2 = indtet + 1 + codef1 = 1 + codef2 = cf2 + codef3 = 1 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara6, ff2, fpara3, fpara2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti0ff2 ) +c + ti1ff2 = indtet + 2 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 5 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, f2ff2, ff3d5, fpara2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti1ff2 ) +c + ti2ff2 = indtet + 3 + codef1 = cf1 + codef2 = cf2 + codef3 = 5 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, f3ff2, fpara3, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti2ff2 ) +c + ti3ff2 = indtet + 4 + codef1 = 6 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara6, f6ff2, ff3d1, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti3ff2 ) +c + indtet = ti3ff2 +c +c 3.2.4. mise a jour du tetredre courant +c + filtet(letetr) = ti0ff2 + hettet(letetr) = hettet(letetr) + 42 +c +c + elseif ( etatfa(3).eq.4 ) then +c +c 3.3. decoupage a partir de la face 3 +c +c 3.3.1. description des 4 faces du tetraedre +c +c 3.3.1.1. description de la face 1 +c +c 3.3.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i2(cf1),i1(cf1)) + ff1d6 = filtri(f1) + nutrde(i2(cf1),i3(cf1)) +c +c 3.3.1.1.2.reperage de l'arete interne +c + as3n5 = aretri(ff1d4,i3(cf1)) +c +c 3.3.1.2. description de la face 2 +c +c 3.3.1.2.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i2(cf2),i1(cf2)) + ff2d6 = filtri(f2) + nutrde(i2(cf2),i3(cf2)) +c +c 3.3.1.2.2.reperage de l'arete interne +c + as3n3 = aretri(ff2d2,i3(cf2)) +c +c 3.3.1.3. description de la face 3 +c +c 3.3.1.3.1.reperage des 4 triangles fils +c + ff3 = filtri(f3) + f1ff3 = ff3 + i1(cf3) + f3ff3 = ff3 + i2(cf3) + f5ff3 = ff3 + i3(cf3) +c +c 3.3.1.3.2.reperage des 3 aretes internes +c + a1ff3 = aretri(ff3,i1(cf3)) + a3ff3 = aretri(ff3,i2(cf3)) + a5ff3 = aretri(ff3,i3(cf3)) +c +c 3.3.1.4. description de la face 4 +c +c 3.3.1.4.1.reperage des 2 triangles fils +c + ff4d2 = filtri(f4) + nutrde(i1(cf4),i2(cf4)) + ff4d4 = filtri(f4) + nutrde(i1(cf4),i3(cf4)) +c +c 3.3.1.4.2.reperage de l'arete interne +c + as3n1 = aretri(ff4d2,i3(cf4)) +c +c 3.3.2. creation des 3 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff3) + codefa = 1 +c + fpara1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara1, a1ff3, as3n5, as3n3, + > codefa, niveau ) +c + fpara3 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara3, as3n5, a3ff3, as3n1, + > codefa, niveau ) +c + fpara5 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara5, as3n3, a5ff3, as3n1, + > codefa, niveau ) +c + indtri = fpara5 +c +c 3.3.3. creation des tetraedres +c + ti0ff3 = indtet + 1 + codef1 = 1 + codef2 = 1 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara5, fpara3, ff3, fpara1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti0ff3 ) +c + ti1ff3 = indtet + 2 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, ff2d6, f1ff3, fpara1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti1ff3 ) +c + ti2ff3 = indtet + 3 + codef1 = cf1 + codef2 = 5 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, fpara3, f3ff3, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti2ff3 ) +c + ti3ff3 = indtet + 4 + codef1 = 5 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara5, ff2d2, f5ff3, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti3ff3 ) +c + indtet = ti3ff3 +c +c 3.3.4. mise a jour du tetredre courant +c + filtet(letetr) = ti0ff3 + hettet(letetr) = hettet(letetr) + 43 +c +c + elseif ( etatfa(4).eq.4 ) then +c +c 3.4. decoupage a partir de la face 4 +c +c 3.4.1. description des 4 faces du tetraedre +c +c 3.4.1.1. description de la face 1 +c +c 3.4.1.1.1.reperage des 2 triangles fils +c + ff1d5 = filtri(f1) + nutrde(i1(cf1),i2(cf1)) + ff1d6 = filtri(f1) + nutrde(i1(cf1),i3(cf1)) +c +c 3.4.1.1.2.reperage de l'arete interne +c + as4n4 = aretri(ff1d5,i3(cf1)) +c +c 3.4.1.2. description de la face 2 +c +c 3.4.1.2.1.reperage des 2 triangles fils +c + ff2d3 = filtri(f2) + nutrde(i1(cf2),i2(cf2)) + ff2d6 = filtri(f2) + nutrde(i1(cf2),i3(cf2)) +c +c 3.4.1.2.2.reperage de l'arete interne +c + as4n2 = aretri(ff2d3,i3(cf2)) +c +c 3.4.1.3. description de la face 3 +c +c 3.4.1.3.1.reperage des 2 triangles fils +c + ff3d3 = filtri(f3) + nutrde(i1(cf3),i2(cf3)) + ff3d5 = filtri(f3) + nutrde(i1(cf3),i3(cf3)) +c +c 3.4.1.3.2.reperage de l'arete interne +c + as4n1 = aretri(ff3d3,i3(cf3)) +c +c 3.4.1.4. description de la face 4 +c +c 3.4.1.4.1.reperage des 4 triangles fils +c + ff4 = filtri(f4) + f1ff4 = ff4 + i1(cf4) + f2ff4 = ff4 + i2(cf4) + f4ff4 = ff4 + i3(cf4) +c +c 3.4.1.4.2.reperage des 3 aretes internes +c + a1ff4 = aretri(ff4,i1(cf4)) + a2ff4 = aretri(ff4,i2(cf4)) + a4ff4 = aretri(ff4,i3(cf4)) +c +c 3.4.2. creation des 3 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff4) + codefa = 1 +c + fpara1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara1, a1ff4, as4n4, as4n2, + > codefa, niveau ) +c + fpara2 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara2, a2ff4, as4n4, as4n1, + > codefa, niveau ) +c + fpara4 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fpara4, a4ff4, as4n2, as4n1, + > codefa, niveau ) +c + indtri = fpara4 +c +c 3.4.3. creation des tetraedres +c + ti0ff4 = indtet + 1 + codef1 = 1 + codef2 = 1 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara4, fpara2, fpara1, ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti0ff4 ) +c + ti1ff4 = indtet + 2 + codef1 = cf1 + codef2 = cf2 + codef3 = 4 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, ff2d6, fpara1, f1ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti1ff4 ) +c + ti2ff4 = indtet + 3 + codef1 = cf1 + codef2 = 4 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, fpara2, ff3d5, f2ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti2ff4 ) +c + ti3ff4 = indtet + 4 + codef1 = 4 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fpara4, ff2d3, ff3d3, f4ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ti3ff4 ) +c + indtet = ti3ff4 +c +c 3.4.4. mise a jour du tetredre courant +c + filtet(letetr) = ti0ff4 + hettet(letetr) = hettet(letetr) + 44 +c +c + else +c + write (ulsort,texte(langue,4)) '4' + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,7)) letetr +c + codret = codret + 1 +c + endif +c + elseif ( nbfad2.eq.4 .and. nbfad4.eq.0 ) then +c +c==== +c 4. Decoupage en 4 des tetraedres selon 2 aretes en vis-a-vis +c . 0 face coupee en 4 +c . 4 autres faces coupees en 2 +c==== +c +c 4.1. recuperation des 6 aretes du tetraedre +c + a1 = aretri(f3,i1(cf3)) + a2 = aretri(f2,i1(cf2)) + a3 = aretri(f2,i2(cf2)) + a4 = aretri(f1,i1(cf1)) + a5 = aretri(f1,i2(cf1)) + a6 = aretri(f1,i3(cf1)) +c + if ( mod(hetare(a1),10).eq.2 .and. + > mod(hetare(a6),10).eq.2 ) then +c +c 4.2. decoupage a partir de la diagonale n1-n6 +c +c 4.2.1. description des 4 faces decoupees +c +c 4.2.1.1. description de la face 1 +c +c 4.2.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i3(cf1),i1(cf1)) + ff1d5 = filtri(f1) + nutrde(i3(cf1),i2(cf1)) +c +c 4.2.1.1.2.reperage de l'arete interne +c + as2n6 = aretri(ff1d4,i2(cf1)) +c +c 4.2.1.2. description de la face 2 +c +c 4.2.1.2.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i3(cf2),i1(cf2)) + ff2d3 = filtri(f2) + nutrde(i3(cf2),i2(cf2)) +c +c 4.2.1.2.2.reperage de l'arete interne +c + as1n6 = aretri(ff2d2,i2(cf2)) +c +c 4.2.1.3. description de la face 3 +c +c 4.2.1.3.1.reperage des 2 triangles fils +c + ff3d3 = filtri(f3) + nutrde(i1(cf3),i2(cf3)) + ff3d5 = filtri(f3) + nutrde(i1(cf3),i3(cf3)) +c +c 4.2.1.3.2.reperage de l'arete interne +c + as4n1 = aretri(ff3d3,i3(cf3)) +c +c 4.2.1.4. description de la face 4 +c +c 4.2.1.4.1.reperage des 2 triangles fils +c + ff4d2 = filtri(f4) + nutrde(i1(cf4),i2(cf4)) + ff4d4 = filtri(f4) + nutrde(i1(cf4),i3(cf4)) +c +c 4.2.1.4.2.reperage de l'arete interne +c + as3n1 = aretri(ff4d2,i3(cf4)) +c +c 4.2.2. reperage des aretes filles +c + as1n1 = aretri(ff3d3,i1(cf3)) + as2n1 = aretri(ff3d5,i1(cf3)) + as3n6 = aretri(ff1d4,i3(cf1)) + as4n6 = aretri(ff2d3,i3(cf2)) +c +c 4.2.3. reperage des noeuds milieux des 2 aretes coupees +c + n1 = somare(2,as1n1) + n6 = somare(2,as3n6) +c +c 4.2.4. creation de l'arete diagonale +c + adiag = indare + 1 + indare = adiag +c + somare(1,adiag) = min ( n1 , n6 ) + somare(2,adiag) = max ( n1 , n6 ) +c + famare(adiag) = 1 +c + hetare(adiag) = 50 + merare(adiag) = 0 + filare(adiag) = 0 +c +c 4.2.5. creation des 4 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1d4) + codefa = 1 +c + fd16s1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16s1, as1n1, as1n6, adiag, + > codefa, niveau ) +c + fd16s2 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16s2, as2n1, adiag, as2n6, + > codefa, niveau ) +c + fd16s3 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16s3, as3n1, adiag, as3n6, + > codefa, niveau ) +c + fd16s4 = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16s4, adiag, as4n1, as4n6, + > codefa, niveau ) +c + indtri = fd16s4 +c +c 4.2.6. creation des 4 tetraedres +c + td16a2 = indtet + 1 + codef1 = 1 + codef2 = cf2 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd16s3, ff2d2, fd16s1, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td16a2 ) +c + td16a3 = indtet + 2 + codef1 = 1 + codef2 = cf2 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd16s4, ff2d3, ff3d3, fd16s1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td16a3 ) +c + td16a4 = indtet + 3 + codef1 = cf1 + codef2 = 1 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, fd16s3, fd16s2, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td16a4 ) +c + td16a5 = indtet + 4 + codef1 = cf1 + codef2 = 1 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, fd16s4, ff3d5, fd16s2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td16a5 ) +c + indtet = td16a5 +c +c 4.2.7. mise a jour du tetredre courant +c + filtet(letetr) = td16a2 + hettet(letetr) = hettet(letetr) + 45 +c +c + elseif ( mod(hetare(a2),10).eq.2 .and. + > mod(hetare(a5),10).eq.2 ) then +c +c 4.3. decoupage a partir de la diagonale n2-n5 +c +c 4.3.1. description des 4 faces decoupees +c +c 4.3.1.1. description de la face 1 +c +c 4.3.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i2(cf1),i1(cf1)) + ff1d6 = filtri(f1) + nutrde(i2(cf1),i3(cf1)) +c +c 4.3.1.1.2.reperage de l'arete interne +c + as3n5 = aretri(ff1d4,i3(cf1)) +c +c 4.3.1.2. description de la face 2 +c +c 4.3.1.2.1.reperage des 2 triangles fils +c + ff2d3 = filtri(f2) + nutrde(i1(cf2),i2(cf2)) + ff2d6 = filtri(f2) + nutrde(i1(cf2),i3(cf2)) +c +c 4.3.1.2.2.reperage de l'arete interne +c + as4n2 = aretri(ff2d3,i3(cf2)) +c +c 4.3.1.3. description de la face 3 +c +c 4.3.1.3.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i3(cf3),i1(cf3)) + ff3d3 = filtri(f3) + nutrde(i3(cf3),i2(cf3)) +c +c 4.3.1.3.2.reperage de l'arete interne +c + as1n5 = aretri(ff3d1,i2(cf3)) +c +c 4.3.1.4. description de la face 4 +c +c 4.3.1.4.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i2(cf4),i1(cf4)) + ff4d4 = filtri(f4) + nutrde(i2(cf4),i3(cf4)) +c +c 4.3.1.4.2.reperage de l'arete interne +c + as2n2 = aretri(ff4d1,i3(cf4)) +c +c 4.3.2. reperage des aretes filles +c + as1n2 = aretri(ff2d3,i1(cf2)) + as2n5 = aretri(ff3d1,i3(cf3)) + as3n2 = aretri(ff2d6,i1(cf2)) + as4n5 = aretri(ff1d6,i2(cf1)) +c +c 4.3.3. reperage des noeuds milieux des 2 aretes coupees +c + n2 = somare(2,as1n2) + n5 = somare(2,as2n5) +c +c 4.3.4. creation de l'arete diagonale +c + adiag = indare + 1 + indare = adiag +c + somare(1,adiag) = min ( n2 , n5 ) + somare(2,adiag) = max ( n2 , n5 ) +c + famare(adiag) = 1 +c + hetare(adiag) = 50 + merare(adiag) = 0 + filare(adiag) = 0 +c +c 4.3.5. creation des 4 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1d4) + codefa = 1 +c + fd25s1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25s1, as1n2, as1n5, adiag, + > codefa, niveau ) +c + fd25s2 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25s2, as2n2, as2n5, adiag, + > codefa, niveau ) +c + fd25s3 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25s3, as3n2, adiag, as3n5, + > codefa, niveau ) +c + fd25s4 = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25s4, adiag, as4n5, as4n2, + > codefa, niveau ) +c + indtri = fd25s4 +c +c 4.3.6. creation des 4 tetraedres +c + td25a1 = indtet + 1 + codef1 = 1 + codef2 = 1 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd25s2, fd25s1, ff3d1, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td25a1 ) +c + td25a3 = indtet + 2 + codef1 = 1 + codef2 = cf2 + codef3 = cf3 + codef4 = 6 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd25s4, ff2d3, ff3d3, fd25s1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td25a3 ) +c + td25a4 = indtet + 3 + codef1 = cf1 + codef2 = 1 + codef3 = 4 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, fd25s3, fd25s2, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td25a4 ) +c + td25a6 = indtet + 4 + codef1 = cf1 + codef2 = cf2 + codef3 = 4 + codef4 = 6 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, ff2d6, fd25s4, fd25s3, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td25a6 ) +c + indtet = td25a6 +c +c 4.3.7. mise a jour du tetredre courant +c + filtet(letetr) = td25a1 + hettet(letetr) = hettet(letetr) + 46 +c +c + elseif ( mod(hetare(a3),10).eq.2 .and. + > mod(hetare(a4),10).eq.2 ) then +c +c 4.4. decoupage a partir de la diagonale n3-n4 +c +c +c 4.4.1. description des 4 faces decoupees +c +c 4.4.1.1. description de la face 1 +c +c 4.4.1.1.1.reperage des 2 triangles fils +c + ff1d5 = filtri(f1) + nutrde(i1(cf1),i2(cf1)) + ff1d6 = filtri(f1) + nutrde(i1(cf1),i3(cf1)) +c +c 4.4.1.1.2.reperage de l'arete interne +c + as4n4 = aretri(ff1d5,i3(cf1)) +c +c 4.4.1.2. description de la face 2 +c +c 4.4.1.2.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i2(cf2),i1(cf2)) + ff2d6 = filtri(f2) + nutrde(i2(cf2),i3(cf2)) +c +c 4.4.1.2.2.reperage de l'arete interne +c + as3n3 = aretri(ff2d2,i3(cf2)) +c +c 4.4.1.3. description de la face 3 +c +c 4.4.1.3.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i2(cf3),i1(cf3)) + ff3d5 = filtri(f3) + nutrde(i2(cf3),i3(cf3)) +c +c 4.4.1.3.2.reperage de l'arete interne +c + as2n3 = aretri(ff3d1,i3(cf3)) +c +c 4.4.1.4. description de la face 4 +c +c 4.4.1.4.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i3(cf4),i1(cf4)) + ff4d2 = filtri(f4) + nutrde(i3(cf4),i2(cf4)) +c +c 4.4.1.4.2.reperage de l'arete interne +c + as1n4 = aretri(ff4d1,i2(cf4)) +c +c 4.4.2. reperage des aretes filles +c + as1n3 = aretri(ff3d1,i2(cf3)) + as2n4 = aretri(ff4d1,i3(cf4)) + as3n4 = aretri(ff4d2,i3(cf4)) + as4n3 = aretri(ff2d6,i2(cf2)) +c +c 4.4.3. reperage des noeuds milieux des 2 aretes coupees +c + n3 = somare(2,as1n3) + n4 = somare(2,as2n4) +c +c 4.4.4. creation de l'arete diagonale +c + adiag = indare + 1 + indare = adiag +c + somare(1,adiag) = min ( n3 , n4 ) + somare(2,adiag) = max ( n3 , n4 ) +c + famare(adiag) = 1 +c + hetare(adiag) = 50 + merare(adiag) = 0 + filare(adiag) = 0 +c +c 4.4.5. creation des 4 faces internes +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1d5) + codefa = 1 +c + fd34s1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34s1, as1n4, as1n3, adiag, + > codefa, niveau ) +c + fd34s2 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34s2, as2n4, as2n3, adiag, + > codefa, niveau ) +c + fd34s3 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34s3, as3n4, adiag, as3n3, + > codefa, niveau ) +c + fd34s4 = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34s4, adiag, as4n3, as4n4, + > codefa, niveau ) +c + indtri = fd34s4 +c +c 4.4.6. creation des 4 tetraedres +c + td34a1 = indtet + 1 + codef1 = 1 + codef2 = 1 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd34s2, fd34s1, ff3d1, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td34a1 ) +c + td34a2 = indtet + 2 + codef1 = 1 + codef2 = cf2 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd34s3, ff2d2, fd34s1, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td34a2 ) +c + td34a5 = indtet + 3 + codef1 = cf1 + codef2 = 1 + codef3 = cf3 + codef4 = 3 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, fd34s4, ff3d5, fd34s2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td34a5 ) +c + td34a6 = indtet + 4 + codef1 = cf1 + codef2 = cf2 + codef3 = 1 + codef4 = 3 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, ff2d6, fd34s4, fd34s3, + > codef1, codef2, codef3, codef4, + > letetr, iaux, td34a6 ) +c + indtet = td34a6 +c +c 4.4.7. mise a jour du tetredre courant +c + filtet(letetr) = td34a1 + hettet(letetr) = hettet(letetr) + 47 +c +c + else +c + write (ulsort,texte(langue,4)) '2 fois 2' + write (ulsort,texte(langue,5)) + write (ulsort,texte(langue,7)) letetr + write(ulsort,10210) + > nouvar, nouvtr, nouvno, nouvp2, nouvim, nouvte, + > permar, permtr, permno, permp2, permim, permte, + > provar, provtr, provp2, provim, provte + write(ulsort,10201) f1, f2, f3, f4 + write(ulsort,10202) (etatfa(jaux),jaux=1,4) + write(ulsort,10203) a1, a2, a3, a4, a5, a6 + write(ulsort,10202) hetare(a1), hetare(a2), hetare(a3), + > hetare(a4), hetare(a5), hetare(a6) +10201 format(1x,'faces : ',4i10) +10202 format(1x,'etats : ',6i10) +10203 format(1x,'aretes : ',6i10) +10210 format(1x, + > /1x,' nouvar, nouvtr, nouvno, nouvp2, nouvim, nouvte,', + > /1x,' permar, permtr, permno, permp2, permim, permte,', + > /1x,' provar, provtr, , provp2, provim, provte', + > /1x,6i8, + > /1x,6i8, + > /1x,2i8,8x,3i8) +c + codret = codret + 1 +c + endif +c + elseif ( nbfad2.eq.2 .and. nbfad4.eq.0 ) then +c +c==== +c 5. decoupage en 2 des tetraedres selon 1 arete +c . 0 face coupee en 4 +c . 2 faces coupees en 2 +c==== +c + if ( etatfa(3).gt.0 .and. etatfa(4).gt.0 ) then +c +c 5.1. decoupage a partir de l'arete 1 +c +c 5.1.1. description des 2 faces decoupees +c +c 5.1.1.1. description de la face 3 +c +c 5.1.1.1.1.reperage des 2 triangles fils +c + ff3d3 = filtri(f3) + nutrde(i1(cf3),i2(cf3)) + ff3d5 = filtri(f3) + nutrde(i1(cf3),i3(cf3)) +c +c 5.1.1.1.2.reperage de l'arete interne +c + as4n1 = aretri(ff3d3,i3(cf3)) +c +c 5.1.1.2. description de la face 4 +c +c 5.1.1.2.1.reperage des 2 triangles fils +c + ff4d2 = filtri(f4) + nutrde(i1(cf4),i2(cf4)) + ff4d4 = filtri(f4) + nutrde(i1(cf4),i3(cf4)) +c +c 5.1.1.2.2.reperage de l'arete interne +c + as3n1 = aretri(ff4d2,i3(cf4)) +c +c 5.1.2. reperage de l'arete du tetraedre commune au deux fils +c + a6 = aretri(f1,i3(cf1)) +c +c 5.1.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff3d3) +c + fa6n1 = indtri + 1 + indtri = fa6n1 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa6n1, as3n1, as4n1, a6, + > codefa, niveau ) +c +c 5.1.4. creation des tetraedres +c + ta1f1 = indtet + 1 + codef1 = cf1 + codef2 = 1 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, fa6n1, ff3d5, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta1f1 ) +c + ta1f2 = indtet + 2 + codef1 = 1 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fa6n1, f2, ff3d3, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta1f2 ) +c + indtet = ta1f2 +c +c 5.1.5. mise a jour du tetredre courant +c + filtet(letetr) = ta1f1 + hettet(letetr) = hettet(letetr) + 21 +c +c + elseif ( etatfa(2).gt.0 .and. etatfa(4).gt.0 ) then +c +c 5.2. decoupage a partir de l'arete 2 +c +c 5.2.1. description des 2 faces decoupees +c +c 5.2.1.1. description de la face 2 +c +c 5.2.1.1.1.reperage des 2 triangles fils +c + ff2d3 = filtri(f2) + nutrde(i1(cf2),i2(cf2)) + ff2d6 = filtri(f2) + nutrde(i1(cf2),i3(cf2)) +c +c 5.2.1.1.2.reperage de l'arete interne +c + as4n2 = aretri(ff2d3,i3(cf2)) +c +c 5.2.1.2. description de la face 4 +c +c 5.2.1.2.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i2(cf4),i1(cf4)) + ff4d4 = filtri(f4) + nutrde(i2(cf4),i3(cf4)) +c +c 5.2.1.2.2.reperage de l'arete interne +c + as2n2 = aretri(ff4d1,i3(cf4)) +c +c 5.2.2. reperage de l'arete du tetraedre commune au deux fils +c + a5 = aretri(f1,i2(cf1)) +c +c 5.2.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff2d3) +c + fa5n2 = indtri + 1 + indtri = fa5n2 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa5n2, as2n2, as4n2, a5, + > codefa, niveau ) +c +c 5.2.4. creation des tetraedres +c + ta2f1 = indtet + 1 + codef1 = cf1 + codef2 = cf2 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, ff2d6, fa5n2, ff4d4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta2f1 ) +c + ta2f3 = indtet + 2 + codef1 = 4 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fa5n2, ff2d3, f3, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta2f3 ) +c + indtet = ta2f3 +c +c 5.2.5. mise a jour du tetredre courant +c + filtet(letetr) = ta2f1 + hettet(letetr) = hettet(letetr) + 22 +c +c + elseif ( etatfa(2).gt.0 .and. etatfa(3).gt.0 ) then +c +c 5.3. decoupage a partir de l'arete 3 +c +c 5.3.1. description des 2 faces decoupees +c +c 5.3.1.1. description de la face 2 +c +c 5.3.1.1.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i2(cf2),i1(cf2)) + ff2d6 = filtri(f2) + nutrde(i2(cf2),i3(cf2)) +c +c 5.3.1.1.2.reperage de l'arete interne +c + as3n3 = aretri(ff2d2,i3(cf2)) +c +c 5.3.1.2. description de la face 3 +c +c 5.3.1.2.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i2(cf3),i1(cf3)) + ff3d5 = filtri(f3) + nutrde(i2(cf3),i3(cf3)) +c +c 5.3.1.2.2.reperage de l'arete interne +c + as2n3 = aretri(ff3d1,i3(cf3)) +c +c 5.3.2. reperage de l'arete du tetraedre commune au deux fils +c + a4 = aretri(f1,i1(cf1)) +c +c 5.3.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff2d2) +c + fa4n3 = indtri + 1 + indtri = fa4n3 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa4n3, as2n3, as3n3, a4, + > codefa, niveau ) +c +c 5.3.4. creation des tetraedres +c + ta3f1 = indtet + 1 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, ff2d6, ff3d5, fa4n3, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta3f1 ) +c + ta3f4 = indtet + 2 + codef1 = 2 + codef2 = cf2 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fa4n3, ff2d2, ff3d1, f4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta3f4 ) +c + indtet = ta3f4 +c +c 5.3.5. mise a jour du tetredre courant +c + filtet(letetr) = ta3f1 + hettet(letetr) = hettet(letetr) + 23 +c +c + elseif ( etatfa(1).gt.0 .and. etatfa(4).gt.0 ) then +c +c 5.4. decoupage a partir de l'arete 4 +c +c 5.4.1. description des 2 faces decoupees +c +c 5.4.1.1. description de la face 1 +c +c 5.4.1.1.1.reperage des 2 triangles fils +c + ff1d5 = filtri(f1) + nutrde(i1(cf1),i2(cf1)) + ff1d6 = filtri(f1) + nutrde(i1(cf1),i3(cf1)) +c +c 5.4.1.1.2.reperage de l'arete interne +c + as4n4 = aretri(ff1d5,i3(cf1)) +c +c 5.4.1.2. description de la face 4 +c +c 5.4.1.2.1.reperage des 2 triangles fils +c + ff4d1 = filtri(f4) + nutrde(i3(cf4),i1(cf4)) + ff4d2 = filtri(f4) + nutrde(i3(cf4),i2(cf4)) +c +c 5.4.1.2.2.reperage de l'arete interne +c + as1n4 = aretri(ff4d1,i2(cf4)) +c +c 5.4.2. reperage de l'arete du tetraedre commune au deux fils +c + a3 = aretri(f2,i2(cf2)) +c +c 5.4.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1d5) +c + fa3n4 = indtri + 1 + indtri = fa3n4 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa3n4, as1n4, a3, as4n4, + > codefa, niveau ) +c +c 5.4.4. creation des tetraedres +c + ta4f2 = indtet + 1 + codef1 = cf1 + codef2 = cf2 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, f2, fa3n4, ff4d2, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta4f2 ) +c + ta4f3 = indtet + 2 + codef1 = cf1 + codef2 = 1 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, fa3n4, f3, ff4d1, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta4f3 ) +c + indtet = ta4f3 +c +c 5.4.5. mise a jour du tetredre courant +c + filtet(letetr) = ta4f2 + hettet(letetr) = hettet(letetr) + 24 +c +c + elseif ( etatfa(1).gt.0 .and. etatfa(3).gt.0 ) then +c +c 5.5. decoupage a partir de l'arete 5 +c +c 5.5.1. description des 2 faces decoupees +c +c 5.5.1.1. description de la face 1 +c +c 5.5.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i2(cf1),i1(cf1)) + ff1d6 = filtri(f1) + nutrde(i2(cf1),i3(cf1)) +c +c 5.5.1.1.2.reperage de l'arete interne +c + as3n5 = aretri(ff1d4,i3(cf1)) +c +c 5.5.1.2. description de la face 3 +c +c 5.5.1.2.1.reperage des 2 triangles fils +c + ff3d1 = filtri(f3) + nutrde(i3(cf3),i1(cf3)) + ff3d3 = filtri(f3) + nutrde(i3(cf3),i2(cf3)) +c +c 5.5.1.2.2.reperage de l'arete interne +c + as1n5 = aretri(ff3d1,i2(cf3)) +c +c 5.5.2. reperage de l'arete du tetraedre commune au deux fils +c + a2 = aretri(f2,i1(cf2)) +c +c 5.5.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff1d4) +c + fa2n5 = indtri + 1 + indtri = fa2n5 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa2n5, as1n5, a2, as3n5, + > codefa, niveau ) +c +c 5.5.4. creation des tetraedres +c + ta5f2 = indtet + 1 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d6, f2, ff3d3, fa2n5, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta5f2 ) +c + ta5f4 = indtet + 2 + codef1 = cf1 + codef2 = 6 + codef3 = cf3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, fa2n5, ff3d1, f4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta5f4 ) +c + indtet = ta5f4 +c +c 5.5.5. mise a jour du tetredre courant +c + filtet(letetr) = ta5f2 + hettet(letetr) = hettet(letetr) + 25 +c +c + elseif ( etatfa(1).gt.0 .and. etatfa(2).gt.0 ) then +c +c 5.6. decoupage a partir de l'arete 6 +c +c 5.6.1. description des 2 faces decoupees +c +c 5.6.1.1. description de la face 1 +c +c 5.6.1.1.1.reperage des 2 triangles fils +c + ff1d4 = filtri(f1) + nutrde(i3(cf1),i1(cf1)) + ff1d5 = filtri(f1) + nutrde(i3(cf1),i2(cf1)) +c +c 5.6.1.1.2.reperage de l'arete interne +c + as2n6 = aretri(ff1d4,i2(cf1)) +c +c 5.6.1.2. description de la face 2 +c +c 5.6.1.2.1.reperage des 2 triangles fils +c + ff2d2 = filtri(f2) + nutrde(i3(cf2),i1(cf2)) + ff2d3 = filtri(f2) + nutrde(i3(cf2),i2(cf2)) +c +c 5.6.1.2.2.reperage de l'arete interne +c + as1n6 = aretri(ff2d2,i2(cf2)) +c +c 5.6.2. reperage de l'arete du tetraedre commune au deux fils +c + a1 = aretri(f3,i1(cf3)) +c +c 5.6.3. creation de la face interne +c le niveau est le meme que les triangles fils sur l'exterieur +c + niveau = nivtri(ff2d2) +c + fa1n6 = indtri + 1 + indtri = fa1n6 + codefa = 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fa1n6, a1, as1n6, as2n6, + > codefa, niveau ) +c +c 5.6.4. creation des tetraedres +c + ta6f3 = indtet + 1 + codef1 = cf1 + codef2 = cf2 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d5, ff2d3, f3, fa1n6, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta6f3 ) +c + ta6f4 = indtet + 2 + codef1 = cf1 + codef2 = cf2 + codef3 = 1 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1d4, ff2d2, fa1n6, f4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, ta6f4 ) +c + indtet = ta6f4 +c +c 5.6.5. mise a jour du tetredre courant +c + filtet(letetr) = ta6f3 + hettet(letetr) = hettet(letetr) + 26 +c + else +c + write (ulsort,texte(langue,4)) '2' + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,7)) letetr +c + codret = codret + 1 +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +#else + if ( codret.eq.10 ) then + write (ulsort,texte(langue,9)) codret + goto 60 + endif +#endif +c + 200 continue +c +c==== +c 6. la fin +c==== +#ifdef _DEBUG_HOMARD_ +#else + 60 continue +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcdtr.F b/src/tool/Creation_Maillage/cmcdtr.F new file mode 100644 index 00000000..c36c4d47 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcdtr.F @@ -0,0 +1,362 @@ + subroutine cmcdtr ( indare, indtri, decfac, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > cfatri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - Decoupage des TRiangles +c - - - - -- +c ______________________________________________________________________ +c +c but : decoupage des triangles en 2 pour mise en conformite du maillage +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . caracteristiques des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCDTR' ) +c +#include "nblang.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "demitr.h" +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer indare, indtri + integer decfac(-permqu:permtr) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer cfatri(nctftr,nbftri) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letria + integer s1, s2, s3 + integer as1s2, as1s3, as2s3, arinte, nf1, nf2, niv + integer as1n2, as1n3, as2n1, as2n3, as3n1, as3n2 +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) ='(''Les decisions de decoupage des aretes du'')' + texte(1,5) ='(''triangle numero'',i10,'' sont incoherentes :'')' + texte(1,6) ='(''Arete'',i2,'' :'',i10,'' et historique :'',i10)' + texte(1,10) ='(i10,'' problemes ...'')' +c + texte(2,4) ='(''Decisions for the edges of the'')' + texte(2,5) ='(''triangle #'',i10,''do not match:'')' + texte(2,6) ='(''Edge #'',i2,'':'',i10,'' state:'',i10)' + texte(2,10) ='(i10,'' problems ...'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. decoupage en 2 des triangles de decision 2 +c==== +c + do 200 , letria = 1 , permtr +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.830 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop .eq. 1 ) then + write (ulsort,*) '. Triangle ', letria, + > ', de decision ',decfac(letria), + > ', d''etat ',hettri(letria) + do 222 , iaux =1,3 + write (ulsort,*) '. Arete ', aretri(letria,iaux), + > ', d''etat ',hetare(aretri(letria,iaux)) + 222 continue + endif +#endif + if ( decfac(letria).eq.2 ) then +cgn write(ulsort,*) ' ' +cgn write(ulsort,*) 'letria =',letria, nompro +c +c 2.1. ==> determination des numeros d'aretes +c + as2s3 = aretri(letria,1) + as1s3 = aretri(letria,2) + as1s2 = aretri(letria,3) +c +c 2.2. ==> determination des sommets du triangle +c + call utsotr ( somare, as2s3, as1s3, as1s2, s3, s1, s2 ) +c +c 2.3. ==> decoupage du triangle en fonction de l'arete coupee +c la determination des aretes filles est celle de utaftr +c + indtri = indtri + 1 +c + if ( mod(hetare(as1s2),10).eq.2 ) then +c +c 2.3.1. l'arete numero 3 du triplet est coupee +c + iaux = filare(as1s2) + if ( somare(1,iaux).eq.s1 ) then + as1n3 = iaux + as2n3 = iaux + 1 + else + as1n3 = iaux + 1 + as2n3 = iaux + endif +cgn write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3) +cgn write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3) +30000 format('arete ',a5,' :',i3,' de',i3,' a',i3) +c +c 2.3.1.1. creation de l'arete interne +c + arinte = indare + 1 + indare = arinte + somare(1,arinte) = s3 + somare(2,arinte) = somare(2,as1n3) +c +c 2.3.1.2. creation de l'un des deux triangles fils +c + nf1 = indtri + nutrde(3,2) + aretri(nf1,1) = arinte + aretri(nf1,2) = as1s3 + aretri(nf1,3) = as1n3 +c +c 2.3.1.3. creation de l'autre des deux triangles fils +c + nf2 = indtri + nutrde(3,1) + aretri(nf2,1) = as2s3 + aretri(nf2,2) = arinte + aretri(nf2,3) = as2n3 +c + hettri(letria) = hettri(letria) + 3 +c + elseif ( mod(hetare(as1s3),10).eq.2 ) then +c +c 2.3.2. l'arete numero 2 du triplet est coupee +c + iaux = filare(as1s3) + if ( somare(1,iaux).eq.s1 ) then + as1n2 = iaux + as3n2 = iaux + 1 + else + as1n2 = iaux + 1 + as3n2 = iaux + endif +c +c 2.3.2.1. creation de l'arete interne +c + arinte = indare + 1 + indare = arinte + somare(1,arinte) = s2 + somare(2,arinte) = somare(2,as1n2) +c +c 2.3.2.2. creation de l'un des deux triangles fils +c + nf1 = indtri + nutrde(2,1) + aretri(nf1,1) = as2s3 + aretri(nf1,2) = as3n2 + aretri(nf1,3) = arinte +c +c 2.3.2.3. creation de l'autre des deux triangles fils +c + nf2 = indtri + nutrde(2,3) + aretri(nf2,1) = arinte + aretri(nf2,2) = as1n2 + aretri(nf2,3) = as1s2 +c + hettri(letria) = hettri(letria) + 2 +c + elseif ( mod(hetare(as2s3),10).eq.2 ) then +c +c 2.3.3. l'arete numero 1 du triplet est coupee +c + iaux = filare(as2s3) + if ( somare(1,iaux).eq.s2 ) then + as2n1 = iaux + as3n1 = iaux + 1 + else + as2n1 = iaux + 1 + as3n1 = iaux + endif +c +c 2.3.3.1. creation de l'arete interne +c + arinte = indare + 1 + indare = arinte + somare(1,arinte) = s1 + somare(2,arinte) = somare(2,as2n1) +c +c 2.3.3.2. creation de l'un des deux triangles fils +c + nf1 = indtri + nutrde(1,2) + aretri(nf1,1) = as3n1 + aretri(nf1,2) = as1s3 + aretri(nf1,3) = arinte +c +c 2.3.3.3. creation de l'autre des deux triangles fils +c + nf2 = indtri + nutrde(1,3) + aretri(nf2,1) = as2n1 + aretri(nf2,2) = arinte + aretri(nf2,3) = as1s2 +c + hettri(letria) = hettri(letria) + 1 +c + else +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) letria + write (ulsort,texte(langue,6)) 1, as1s2, hetare(as1s2) + write (ulsort,texte(langue,6)) 2, as1s3, hetare(as1s3) + write (ulsort,texte(langue,6)) 3, as2s3, hetare(as2s3) +c + codret = codret + 1 +c + endif +c +c 2.4. ==> mise a jour des autres proprietes de la nouvelle arete +c + jaux = cfatri(cofafa,famtri(letria)) + famare(arinte) = jaux + hetare(arinte) = 50 + merare(arinte) = 0 + filare(arinte) = 0 +c +c 2.5. ==> mise a jour des autres proprietes des deux triangles fils +c + famtri(nf1) = famtri(letria) + famtri(nf2) = famtri(letria) + hettri(nf1) = 50 + hettri(nf2) = 50 + filtri(nf1) = 0 + filtri(nf2) = 0 + pertri(nf1) = letria + pertri(nf2) = letria + niv = nivtri(letria) + 1 + nivtri(nf1) = niv + nivtri(nf2) = niv +c +c 2.6. ==> mise a jour du triangle pere +c + filtri(letria) = indtri + indtri = indtri + 1 +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch01.F b/src/tool/Creation_Maillage/cmch01.F new file mode 100644 index 00000000..dca8e41e --- /dev/null +++ b/src/tool/Creation_Maillage/cmch01.F @@ -0,0 +1,495 @@ + subroutine cmch01 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 01 +c -- +c Decoupage par les aretes 1 et 7 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S8 +c lesnoe(2) = S5 +c lesnoe(3) = S2 +c lesnoe(4) = S3 +c lesnoe(5) = S7 +c lesnoe(6) = S6 +c lesnoe(7) = S1 +c lesnoe(8) = S4 +c lesnoe( 9) = N1 +c lesnoe(10) = N7 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(8) + lesnoe(2) = listso(5) + lesnoe(3) = listso(2) + lesnoe(4) = listso(3) + lesnoe(5) = listso(7) + lesnoe(6) = listso(6) + lesnoe(7) = listso(1) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 7 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(1) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(7) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS5N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS3N1 +c areqtr(2,2) : AS4N1 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS8N7 +c areqtr(3,2) : AS3N7 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS6N7 +c areqtr(4,2) : AS1N7 +c + nulofa(1) = 2 + nulofa(2) = 1 + nulofa(3) = 5 + nulofa(4) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS8N0 +c areint( 2) : AS5N0 +c areint( 3) : AS2N0 +c areint( 4) : AS3N0 +c areint( 5) : AS7N0 +c areint( 6) : AS6N0 +c areint( 7) : AS1N0 +c areint( 8) : AS4N0 +c areint( 9) : AN1N0 +c areint(10) : AN7N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA11 +c triint( 2) : FA6 +c triint( 3) : FA3 +c triint( 4) : FA8 +c triint( 5) : FA12 +c triint( 6) : FA10 +c triint( 7) : FA9 +c triint( 8) : FA2 (F2/F4) +c triint( 9) : FA5 (F1/F4) +c triint(10) : FA4 (F2/F3) +c triint(11) : FS5N1 +c triint(12) : FS3N1 +c triint(13) : FS8N7 +c triint(14) : FS6N7 +c triint(15) : FS6N1 +c triint(16) : FS4N1 +c triint(17) : FS3N7 +c triint(18) : FS1N7 +c triint(19) : FS2N1 +c triint(20) : FS7N7 +c triint(21) : FS1N1 +c triint(22) : FS4N7 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(11) + lesare( 2) = listar(6) + lesare( 3) = listar(3) + lesare( 4) = listar(8) + lesare( 5) = listar(12) + lesare( 6) = listar(10) + lesare( 7) = listar(9) + lesare( 8) = listar(2) + lesare( 9) = listar(5) + lesare(10) = listar(4) +c + tab1(1) = 1 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 1 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch02.F b/src/tool/Creation_Maillage/cmch02.F new file mode 100644 index 00000000..57a4e92b --- /dev/null +++ b/src/tool/Creation_Maillage/cmch02.F @@ -0,0 +1,495 @@ + subroutine cmch02 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 02 +c -- +c Decoupage par les aretes 1 et 8 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S6 +c lesnoe(2) = S7 +c lesnoe(3) = S4 +c lesnoe(4) = S1 +c lesnoe(5) = S5 +c lesnoe(6) = S8 +c lesnoe(7) = S3 +c lesnoe(8) = S2 +c lesnoe( 9) = N1 +c lesnoe(10) = N8 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(6) + lesnoe(2) = listso(7) + lesnoe(3) = listso(4) + lesnoe(4) = listso(1) + lesnoe(5) = listso(5) + lesnoe(6) = listso(8) + lesnoe(7) = listso(3) + lesnoe(8) = listso(2) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 8 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(1) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(8) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF2 + 1/2 +c areqtr(2,1) : AS6N1 +c areqtr(2,2) : AS5N1 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS5N8 +c areqtr(3,2) : AS2N8 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS7N8 +c areqtr(4,2) : AS4N8 +c + nulofa(1) = 1 + nulofa(2) = 2 + nulofa(3) = 4 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS6N0 +c areint( 2) : AS7N0 +c areint( 3) : AS4N0 +c areint( 4) : AS1N0 +c areint( 5) : AS5N0 +c areint( 6) : AS8N0 +c areint( 7) : AS3N0 +c areint( 8) : AS2N0 +c areint( 9) : AN1N0 +c areint(10) : AN8N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA10 +c triint( 2) : FA7 +c triint( 3) : FA2 +c triint( 4) : FA5 +c triint( 5) : FA9 +c triint( 6) : FA11 +c triint( 7) : FA12 +c triint( 8) : FA3 (F1/F3) +c triint( 9) : FA4 (F1/F4) +c triint(10) : FA6 (F2/F3) +c triint(11) : FS4N1 +c triint(12) : FS6N1 +c triint(13) : FS5N8 +c triint(14) : FS7N8 +c triint(15) : FS3N1 +c triint(16) : FS5N1 +c triint(17) : FS2N8 +c triint(18) : FS4N8 +c triint(19) : FS1N1 +c triint(20) : FS8N8 +c triint(21) : FS2N1 +c triint(22) : FS3N8 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(10) + lesare( 2) = listar(7) + lesare( 3) = listar(2) + lesare( 4) = listar(5) + lesare( 5) = listar(9) + lesare( 6) = listar(11) + lesare( 7) = listar(12) + lesare( 8) = listar(3) + lesare( 9) = listar(4) + lesare(10) = listar(6) +c + tab1(1) = 2 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 5 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch03.F b/src/tool/Creation_Maillage/cmch03.F new file mode 100644 index 00000000..f5deb0f7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch03.F @@ -0,0 +1,495 @@ + subroutine cmch03 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 03 +c -- +c Decoupage par les aretes 1 et 10 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S8 +c lesnoe(3) = S5 +c lesnoe(4) = S2 +c lesnoe(5) = S4 +c lesnoe(6) = S7 +c lesnoe(7) = S6 +c lesnoe(8) = S1 +c lesnoe( 9) = N1 +c lesnoe(10) = N10 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(8) + lesnoe(3) = listso(5) + lesnoe(4) = listso(2) + lesnoe(5) = listso(4) + lesnoe(6) = listso(7) + lesnoe(7) = listso(6) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 10 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(1) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(10) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS5N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS3N1 +c areqtr(2,2) : AS4N1 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 2/1 +c areqtr(3,1) : AS4N10 +c areqtr(3,2) : AS1N10 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS8N10 +c areqtr(4,2) : AS5N10 +c + nulofa(1) = 2 + nulofa(2) = 1 + nulofa(3) = 3 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS8N0 +c areint( 3) : AS5N0 +c areint( 4) : AS2N0 +c areint( 5) : AS4N0 +c areint( 6) : AS7N0 +c areint( 7) : AS6N0 +c areint( 8) : AS1N0 +c areint( 9) : AN1N0 +c areint(10) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA8 +c triint( 2) : FA11 +c triint( 3) : FA6 +c triint( 4) : FA3 +c triint( 5) : FA4 +c triint( 6) : FA7 +c triint( 7) : FA12 +c triint( 8) : FA5 (F1/F3) +c triint( 9) : FA9 (F1/F4) +c triint(10) : FA2 (F2/F3) +c triint(11) : FS5N1 +c triint(12) : FS3N1 +c triint(13) : FS4N10 +c triint(14) : FS8N10 +c triint(15) : FS6N1 +c triint(16) : FS4N1 +c triint(17) : FS5N10 +c triint(18) : FS1N10 +c triint(19) : FS2N1 +c triint(20) : FS7N10 +c triint(21) : FS1N1 +c triint(22) : FS6N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(8) + lesare( 2) = listar(11) + lesare( 3) = listar(6) + lesare( 4) = listar(3) + lesare( 5) = listar(4) + lesare( 6) = listar(7) + lesare( 7) = listar(12) + lesare( 8) = listar(5) + lesare( 9) = listar(9) + lesare(10) = listar(2) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 3 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch04.F b/src/tool/Creation_Maillage/cmch04.F new file mode 100644 index 00000000..f8aa07ff --- /dev/null +++ b/src/tool/Creation_Maillage/cmch04.F @@ -0,0 +1,495 @@ + subroutine cmch04 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 04 +c -- +c Decoupage par les aretes 1 et 11 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S7 +c lesnoe(2) = S4 +c lesnoe(3) = S1 +c lesnoe(4) = S6 +c lesnoe(5) = S8 +c lesnoe(6) = S3 +c lesnoe(7) = S2 +c lesnoe(8) = S5 +c lesnoe( 9) = N1 +c lesnoe(10) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(7) + lesnoe(2) = listso(4) + lesnoe(3) = listso(1) + lesnoe(4) = listso(6) + lesnoe(5) = listso(8) + lesnoe(6) = listso(3) + lesnoe(7) = listso(2) + lesnoe(8) = listso(5) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 11 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(1) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(11) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF2 + 1/2 +c areqtr(2,1) : AS6N1 +c areqtr(2,2) : AS5N1 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS7N11 +c areqtr(3,2) : AS6N11 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS3N11 +c areqtr(4,2) : AS2N11 +c + nulofa(1) = 1 + nulofa(2) = 2 + nulofa(3) = 6 + nulofa(4) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS7N0 +c areint( 2) : AS4N0 +c areint( 3) : AS1N0 +c areint( 4) : AS6N0 +c areint( 5) : AS8N0 +c areint( 6) : AS3N0 +c areint( 7) : AS2N0 +c areint( 8) : AS5N0 +c areint( 9) : AN1N0 +c areint(10) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA7 +c triint( 2) : FA2 +c triint( 3) : FA5 +c triint( 4) : FA10 +c triint( 5) : FA12 +c triint( 6) : FA8 +c triint( 7) : FA4 +c triint( 8) : FA6 (F2/F4) +c triint( 9) : FA3 (F1/F4) +c triint(10) : FA9 (F2/F3) +c triint(11) : FS4N1 +c triint(12) : FS6N1 +c triint(13) : FS7N11 +c triint(14) : FS3N11 +c triint(15) : FS3N1 +c triint(16) : FS5N1 +c triint(17) : FS6N11 +c triint(18) : FS2N11 +c triint(19) : FS1N1 +c triint(20) : FS8N11 +c triint(21) : FS2N1 +c triint(22) : FS5N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(7) + lesare( 2) = listar(2) + lesare( 3) = listar(5) + lesare( 4) = listar(10) + lesare( 5) = listar(12) + lesare( 6) = listar(8) + lesare( 7) = listar(4) + lesare( 8) = listar(6) + lesare( 9) = listar(3) + lesare(10) = listar(9) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 2 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch05.F b/src/tool/Creation_Maillage/cmch05.F new file mode 100644 index 00000000..59cbb207 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch05.F @@ -0,0 +1,495 @@ + subroutine cmch05 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 05 +c -- +c Decoupage par les aretes 2 et 6 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S7 +c lesnoe(2) = S8 +c lesnoe(3) = S3 +c lesnoe(4) = S4 +c lesnoe(5) = S6 +c lesnoe(6) = S5 +c lesnoe(7) = S2 +c lesnoe(8) = S1 +c lesnoe( 9) = N2 +c lesnoe(10) = N6 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(7) + lesnoe(2) = listso(8) + lesnoe(3) = listso(3) + lesnoe(4) = listso(4) + lesnoe(5) = listso(6) + lesnoe(6) = listso(5) + lesnoe(7) = listso(2) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 6 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(2) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(6) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS3N2 +c areqtr(1,2) : AS2N2 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF3 + 1/2 +c areqtr(2,1) : AS7N2 +c areqtr(2,2) : AS6N2 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1 +c areqtr(3,1) : AS6N6 +c areqtr(3,2) : AS1N6 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS8N6 +c areqtr(4,2) : AS3N6 +c + nulofa(1) = 1 + nulofa(2) = 3 + nulofa(3) = 2 + nulofa(4) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS7N0 +c areint( 2) : AS8N0 +c areint( 3) : AS3N0 +c areint( 4) : AS4N0 +c areint( 5) : AS6N0 +c areint( 6) : AS5N0 +c areint( 7) : AS2N0 +c areint( 8) : AS1N0 +c areint( 9) : AN2N0 +c areint(10) : AN6N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA12 +c triint( 2) : FA8 +c triint( 3) : FA4 +c triint( 4) : FA7 +c triint( 5) : FA10 +c triint( 6) : FA9 +c triint( 7) : FA11 +c triint( 8) : FA1 (F1/F3) +c triint( 9) : FA3 (F1/F4) +c triint(10) : FA5 (F2/F3) +c triint(11) : FS3N2 +c triint(12) : FS7N2 +c triint(13) : FS6N6 +c triint(14) : FS8N6 +c triint(15) : FS2N2 +c triint(16) : FS6N2 +c triint(17) : FS1N6 +c triint(18) : FS3N6 +c triint(19) : FS4N2 +c triint(20) : FS5N6 +c triint(21) : FS1N2 +c triint(22) : FS2N6 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(12) + lesare( 2) = listar(8) + lesare( 3) = listar(4) + lesare( 4) = listar(7) + lesare( 5) = listar(10) + lesare( 6) = listar(9) + lesare( 7) = listar(11) + lesare( 8) = listar(1) + lesare( 9) = listar(3) + lesare(10) = - listar(5) +c + tab1(1) = 2 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(6), 3, + > triint(7), 3, + > triint(1), 5, + > triint(5), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 6 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch06.F b/src/tool/Creation_Maillage/cmch06.F new file mode 100644 index 00000000..1a09ba4c --- /dev/null +++ b/src/tool/Creation_Maillage/cmch06.F @@ -0,0 +1,495 @@ + subroutine cmch06 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 06 +c -- +c Decoupage par les aretes 2 et 8 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S5 +c lesnoe(2) = S6 +c lesnoe(3) = S1 +c lesnoe(4) = S2 +c lesnoe(5) = S8 +c lesnoe(6) = S7 +c lesnoe(7) = S4 +c lesnoe(8) = S3 +c lesnoe( 9) = N2 +c lesnoe(10) = N8 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(5) + lesnoe(2) = listso(6) + lesnoe(3) = listso(1) + lesnoe(4) = listso(2) + lesnoe(5) = listso(8) + lesnoe(6) = listso(7) + lesnoe(7) = listso(4) + lesnoe(8) = listso(3) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 8 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(2) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(8) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS6N2 +c areqtr(1,2) : AS7N2 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS2N2 +c areqtr(2,2) : AS3N2 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS5N8 +c areqtr(3,2) : AS2N8 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS7N8 +c areqtr(4,2) : AS4N8 +c + nulofa(1) = 3 + nulofa(2) = 1 + nulofa(3) = 4 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS5N0 +c areint( 2) : AS6N0 +c areint( 3) : AS1N0 +c areint( 4) : AS2N0 +c areint( 5) : AS8N0 +c areint( 6) : AS7N0 +c areint( 7) : AS4N0 +c areint( 8) : AS3N0 +c areint( 9) : AN2N0 +c areint(10) : AN8N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA9 +c triint( 2) : FA5 +c triint( 3) : FA1 +c triint( 4) : FA6 +c triint( 5) : FA11 +c triint( 6) : FA12 +c triint( 7) : FA10 +c triint( 8) : FA4 (F2/F4) +c triint( 9) : FA7 (F1/F4) +c triint(10) : FA3 (F2/F3) +c triint(11) : FS6N2 +c triint(12) : FS2N2 +c triint(13) : FS5N8 +c triint(14) : FS7N8 +c triint(15) : FS7N2 +c triint(16) : FS3N2 +c triint(17) : FS2N8 +c triint(18) : FS4N8 +c triint(19) : FS1N2 +c triint(20) : FS8N8 +c triint(21) : FS4N2 +c triint(22) : FS3N8 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(9) + lesare( 2) = listar(5) + lesare( 3) = listar(1) + lesare( 4) = listar(6) + lesare( 5) = listar(11) + lesare( 6) = listar(12) + lesare( 7) = listar(10) + lesare( 8) = listar(4) + lesare( 9) = listar(7) + lesare(10) = listar(3) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 3 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch07.F b/src/tool/Creation_Maillage/cmch07.F new file mode 100644 index 00000000..38697170 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch07.F @@ -0,0 +1,495 @@ + subroutine cmch07 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 07 +c -- +c Decoupage par les aretes 2 et 9 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH07' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S8 +c lesnoe(3) = S5 +c lesnoe(4) = S2 +c lesnoe(5) = S4 +c lesnoe(6) = S7 +c lesnoe(7) = S6 +c lesnoe(8) = S1 +c lesnoe( 9) = N2 +c lesnoe(10) = N9 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(8) + lesnoe(3) = listso(5) + lesnoe(4) = listso(2) + lesnoe(5) = listso(4) + lesnoe(6) = listso(7) + lesnoe(7) = listso(6) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 9 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 2 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(9) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(2) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF6 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF6 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF6 + 2/1 +c areqtr(1,1) : AS8N9 +c areqtr(1,2) : AS7N9 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF2 + 1/2 +c areqtr(2,1) : AS2N9 +c areqtr(2,2) : AS1N9 +c +c trifad(3,0) = triangle central de la face 3 : FF1 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF1 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF1 + 2/1 +c areqtr(3,1) : AS3N2 +c areqtr(3,2) : AS2N2 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS7N2 +c areqtr(4,2) : AS6N2 +c + nulofa(1) = 6 + nulofa(2) = 2 + nulofa(3) = 1 + nulofa(4) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS8N0 +c areint( 3) : AS5N0 +c areint( 4) : AS2N0 +c areint( 5) : AS4N0 +c areint( 6) : AS7N0 +c areint( 7) : AS6N0 +c areint( 8) : AS1N0 +c areint( 9) : AN9N0 +c areint(10) : AN2N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA8 +c triint( 2) : FA11 +c triint( 3) : FA6 +c triint( 4) : FA3 +c triint( 5) : FA4 +c triint( 6) : FA7 +c triint( 7) : FA12 +c triint( 8) : FA5 (F2/F4) +c triint( 9) : FA10 (F1/F4) +c triint(10) : FA1 (F2/F3) +c triint(11) : FS8N9 +c triint(12) : FS2N9 +c triint(13) : FS3N2 +c triint(14) : FS7N2 +c triint(15) : FS7N9 +c triint(16) : FS1N9 +c triint(17) : FS2N2 +c triint(18) : FS6N2 +c triint(19) : FS5N9 +c triint(20) : FS4N2 +c triint(21) : FS6N9 +c triint(22) : FS1N2 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(8) + lesare( 2) = listar(11) + lesare( 3) = listar(6) + lesare( 4) = listar(3) + lesare( 5) = listar(4) + lesare( 6) = listar(7) + lesare( 7) = listar(12) + lesare( 8) = listar(5) + lesare( 9) = -listar(10) + lesare(10) = -listar(1) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 4 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch08.F b/src/tool/Creation_Maillage/cmch08.F new file mode 100644 index 00000000..f5580a91 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch08.F @@ -0,0 +1,495 @@ + subroutine cmch08 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 08 +c -- +c Decoupage par les aretes 2 et 12 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH08' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S5 +c lesnoe(3) = S6 +c lesnoe(4) = S1 +c lesnoe(5) = S3 +c lesnoe(6) = S8 +c lesnoe(7) = S7 +c lesnoe(8) = S4 +c lesnoe( 9) = N2 +c lesnoe(10) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(5) + lesnoe(3) = listso(6) + lesnoe(4) = listso(1) + lesnoe(5) = listso(3) + lesnoe(6) = listso(8) + lesnoe(7) = listso(7) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 12 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(2) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(12) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS6N2 +c areqtr(1,2) : AS7N2 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS2N2 +c areqtr(2,2) : AS3N2 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS3N12 +c areqtr(3,2) : AS4N12 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS5N12 +c areqtr(4,2) : AS6N12 +c + nulofa(1) = 3 + nulofa(2) = 1 + nulofa(3) = 5 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS5N0 +c areint( 3) : AS6N0 +c areint( 4) : AS1N0 +c areint( 5) : AS3N0 +c areint( 6) : AS8N0 +c areint( 7) : AS7N0 +c areint( 8) : AS4N0 +c areint( 9) : AN2N0 +c areint(10) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA6 +c triint( 2) : FA9 +c triint( 3) : FA5 +c triint( 4) : FA1 +c triint( 5) : FA3 +c triint( 6) : FA8 +c triint( 7) : FA11 +c triint( 8) : FA7 (F1/F3) +c triint( 9) : FA10 (F1/F4) +c triint(10) : FA4 (F2/F3) +c triint(11) : FS6N2 +c triint(12) : FS2N2 +c triint(13) : FS3N12 +c triint(14) : FS5N12 +c triint(15) : FS7N2 +c triint(16) : FS3N2 +c triint(17) : FS4N12 +c triint(18) : FS6N12 +c triint(19) : FS1N2 +c triint(20) : FS8N12 +c triint(21) : FS4N2 +c triint(22) : FS7N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(6) + lesare( 2) = listar(9) + lesare( 3) = listar(5) + lesare( 4) = listar(1) + lesare( 5) = listar(3) + lesare( 6) = listar(8) + lesare( 7) = listar(11) + lesare( 8) = listar(7) + lesare( 9) = listar(10) + lesare(10) = listar(4) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 3 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch09.F b/src/tool/Creation_Maillage/cmch09.F new file mode 100644 index 00000000..5b338c3d --- /dev/null +++ b/src/tool/Creation_Maillage/cmch09.F @@ -0,0 +1,495 @@ + subroutine cmch09 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 09 +c -- +c Decoupage par les aretes 3 et 5 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH09' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S7 +c lesnoe(2) = S8 +c lesnoe(3) = S3 +c lesnoe(4) = S4 +c lesnoe(5) = S6 +c lesnoe(6) = S5 +c lesnoe(7) = S2 +c lesnoe(8) = S1 +c lesnoe( 9) = N3 +c lesnoe(10) = N5 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(7) + lesnoe(2) = listso(8) + lesnoe(3) = listso(3) + lesnoe(4) = listso(4) + lesnoe(5) = listso(6) + lesnoe(6) = listso(5) + lesnoe(7) = listso(2) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 5 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(3) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(5) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS8N3 +c areqtr(1,2) : AS5N3 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS4N3 +c areqtr(2,2) : AS1N3 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 2/1 +c areqtr(3,1) : AS7N5 +c areqtr(3,2) : AS4N5 +c +c trifad(4,0) = triangle central de la face 4 : FF2 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF2 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF2 + 1/2 +c areqtr(4,1) : AS5N5 +c areqtr(4,2) : AS2N5 +c + nulofa(1) = 4 + nulofa(2) = 1 + nulofa(3) = 3 + nulofa(4) = 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS7N0 +c areint( 2) : AS8N0 +c areint( 3) : AS3N0 +c areint( 4) : AS4N0 +c areint( 5) : AS6N0 +c areint( 6) : AS5N0 +c areint( 7) : AS2N0 +c areint( 8) : AS1N0 +c areint( 9) : AN3N0 +c areint(10) : AN5N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA12 +c triint( 2) : FA8 +c triint( 3) : FA4 +c triint( 4) : FA7 +c triint( 5) : FA10 +c triint( 6) : FA9 +c triint( 7) : FA11 +c triint( 8) : FA1 (F2/F4) +c triint( 9) : FA6 (F1/F4) +c triint(10) : FA2 (F2/F3) +c triint(11) : FS8N3 +c triint(12) : FS4N3 +c triint(13) : FS7N5 +c triint(14) : FS5N5 +c triint(15) : FS5N3 +c triint(16) : FS1N3 +c triint(17) : FS4N5 +c triint(18) : FS2N5 +c triint(19) : FS3N3 +c triint(20) : FS6N5 +c triint(21) : FS2N3 +c triint(22) : FS1N5 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(12) + lesare( 2) = listar(8) + lesare( 3) = listar(4) + lesare( 4) = listar(7) + lesare( 5) = listar(10) + lesare( 6) = listar(9) + lesare( 7) = listar(11) + lesare( 8) = listar(1) + lesare( 9) = -listar(6) + lesare(10) = listar(2) +c + tab1(1) = 1 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(6), 3, + > triint(7), 3, + > triint(1), 5, + > triint(5), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 5 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch10.F b/src/tool/Creation_Maillage/cmch10.F new file mode 100644 index 00000000..8292fb2b --- /dev/null +++ b/src/tool/Creation_Maillage/cmch10.F @@ -0,0 +1,495 @@ + subroutine cmch10 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 10 +c -- +c Decoupage par les aretes 3 et 7 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH10' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S5 +c lesnoe(2) = S6 +c lesnoe(3) = S1 +c lesnoe(4) = S2 +c lesnoe(5) = S8 +c lesnoe(6) = S7 +c lesnoe(7) = S4 +c lesnoe(8) = S3 +c lesnoe( 9) = N3 +c lesnoe(10) = N7 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(5) + lesnoe(2) = listso(6) + lesnoe(3) = listso(1) + lesnoe(4) = listso(2) + lesnoe(5) = listso(8) + lesnoe(6) = listso(7) + lesnoe(7) = listso(4) + lesnoe(8) = listso(3) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 7 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(3) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(7) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF4 + 1/2 +c areqtr(2,1) : AS5N3 +c areqtr(2,2) : AS8N3 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS8N7 +c areqtr(3,2) : AS3N7 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS6N7 +c areqtr(4,2) : AS1N7 +c + nulofa(1) = 1 + nulofa(2) = 4 + nulofa(3) = 5 + nulofa(4) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS5N0 +c areint( 2) : AS6N0 +c areint( 3) : AS1N0 +c areint( 4) : AS2N0 +c areint( 5) : AS8N0 +c areint( 6) : AS7N0 +c areint( 7) : AS4N0 +c areint( 8) : AS3N0 +c areint( 9) : AN3N0 +c areint(10) : AN7N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA9 +c triint( 2) : FA5 +c triint( 3) : FA1 +c triint( 4) : FA6 +c triint( 5) : FA11 +c triint( 6) : FA12 +c triint( 7) : FA10 +c triint( 8) : FA4 (F1/F3) +c triint( 9) : FA2 (F1/F4) +c triint(10) : FA8 (F2/F3) +c triint(11) : FS1N3 +c triint(12) : FS5N3 +c triint(13) : FS7N7 +c triint(14) : FS6N7 +c triint(15) : FS4N3 +c triint(16) : FS8N3 +c triint(17) : FS3N7 +c triint(18) : FS1N7 +c triint(19) : FS2N3 +c triint(20) : FS7N7 +c triint(21) : FS3N3 +c triint(22) : FS4N7 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(9) + lesare( 2) = listar(5) + lesare( 3) = listar(1) + lesare( 4) = listar(6) + lesare( 5) = listar(11) + lesare( 6) = listar(12) + lesare( 7) = listar(10) + lesare( 8) = listar(4) + lesare( 9) = listar(2) + lesare(10) = listar(8) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 1 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch11.F b/src/tool/Creation_Maillage/cmch11.F new file mode 100644 index 00000000..6d1a9f31 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch11.F @@ -0,0 +1,495 @@ + subroutine cmch11 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 11 +c -- +c Decoupage par les aretes 3 et 9 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH11' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S7 +c lesnoe(2) = S4 +c lesnoe(3) = S1 +c lesnoe(4) = S6 +c lesnoe(5) = S8 +c lesnoe(6) = S3 +c lesnoe(7) = S2 +c lesnoe(8) = S5 +c lesnoe( 9) = N9 +c lesnoe(10) = N3 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(7) + lesnoe(2) = listso(4) + lesnoe(3) = listso(1) + lesnoe(4) = listso(6) + lesnoe(5) = listso(8) + lesnoe(6) = listso(3) + lesnoe(7) = listso(2) + lesnoe(8) = listso(5) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 9 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 3 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(9) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(3) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS1N9 +c areqtr(1,2) : AS2N9 +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF6 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF6 + 1/2 +c areqtr(2,1) : AS7N9 +c areqtr(2,2) : AS8N9 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS8N3 +c areqtr(3,2) : AS5N3 +c +c trifad(4,0) = triangle central de la face 4 : FF1 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF1 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF1 + 1/2 +c areqtr(4,1) : AS4N3 +c areqtr(4,2) : AS1N3 +c + nulofa(1) = 2 + nulofa(2) = 6 + nulofa(3) = 4 + nulofa(4) = 1 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS7N0 +c areint( 2) : AS4N0 +c areint( 3) : AS1N0 +c areint( 4) : AS6N0 +c areint( 5) : AS8N0 +c areint( 6) : AS3N0 +c areint( 7) : AS2N0 +c areint( 8) : AS5N0 +c areint( 9) : AN9N0 +c areint(10) : AN3N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA7 +c triint( 2) : FA2 +c triint( 3) : FA5 +c triint( 4) : FA10 +c triint( 5) : FA12 +c triint( 6) : FA8 +c triint( 7) : FA4 +c triint( 8) : FA6 (F1/F3) +c triint( 9) : FA1 (F1/F4) +c triint(10) : FA11 (F2/F3) +c triint(11) : FS1N9 +c triint(12) : FS7N9 +c triint(13) : FS8N3 +c triint(14) : FS4N3 +c triint(15) : FS2N9 +c triint(16) : FS8N9 +c triint(17) : FS5N3 +c triint(18) : FS1N3 +c triint(19) : FS6N9 +c triint(20) : FS3N3 +c triint(21) : FS5N9 +c triint(22) : FS2N3 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(7) + lesare( 2) = listar(2) + lesare( 3) = listar(5) + lesare( 4) = listar(10) + lesare( 5) = listar(12) + lesare( 6) = listar(8) + lesare( 7) = listar(4) + lesare( 8) = listar(6) + lesare( 9) = -listar(1) + lesare(10) = -listar(11) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 7 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch12.F b/src/tool/Creation_Maillage/cmch12.F new file mode 100644 index 00000000..0611b092 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch12.F @@ -0,0 +1,495 @@ + subroutine cmch12 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 12 +c -- +c Decoupage par les aretes 3 et 12 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH12' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S6 +c lesnoe(2) = S1 +c lesnoe(3) = S2 +c lesnoe(4) = S5 +c lesnoe(5) = S7 +c lesnoe(6) = S4 +c lesnoe(7) = S3 +c lesnoe(8) = S8 +c lesnoe( 9) = N3 +c lesnoe(10) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(6) + lesnoe(2) = listso(1) + lesnoe(3) = listso(2) + lesnoe(4) = listso(5) + lesnoe(5) = listso(7) + lesnoe(6) = listso(4) + lesnoe(7) = listso(3) + lesnoe(8) = listso(8) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 12 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(3) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(12) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF4 + 1/2 +c areqtr(2,1) : AS5N3 +c areqtr(2,2) : AS8N3 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS6N12 +c areqtr(3,2) : AS5N12 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS4N12 +c areqtr(4,2) : AS3N12 +c + nulofa(1) = 1 + nulofa(2) = 4 + nulofa(3) = 6 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS6N0 +c areint( 2) : AS1N0 +c areint( 3) : AS2N0 +c areint( 4) : AS5N0 +c areint( 5) : AS7N0 +c areint( 6) : AS4N0 +c areint( 7) : AS3N0 +c areint( 8) : AS8N0 +c areint( 9) : AN3N0 +c areint(10) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA5 +c triint( 2) : FA1 +c triint( 3) : FA6 +c triint( 4) : FA9 +c triint( 5) : FA10 +c triint( 6) : FA7 +c triint( 7) : FA2 +c triint( 8) : FA8 (F2/F4) +c triint( 9) : FA4 (F1/F4) +c triint(10) : FA11 (F2/F3) +c triint(11) : FS1N3 +c triint(12) : FS5N3 +c triint(13) : FS6N12 +c triint(14) : FS4N12 +c triint(15) : FS4N3 +c triint(16) : FS8N3 +c triint(17) : FS5N12 +c triint(18) : FS3N12 +c triint(19) : FS2N3 +c triint(20) : FS7N12 +c triint(21) : FS3N3 +c triint(22) : FS8N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(5) + lesare( 2) = listar(1) + lesare( 3) = listar(6) + lesare( 4) = listar(9) + lesare( 5) = listar(10) + lesare( 6) = listar(7) + lesare( 7) = listar(2) + lesare( 8) = listar(8) + lesare( 9) = listar(4) + lesare(10) = listar(11) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 2 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch13.F b/src/tool/Creation_Maillage/cmch13.F new file mode 100644 index 00000000..1b9ef378 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch13.F @@ -0,0 +1,495 @@ + subroutine cmch13 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 13 +c -- +c Decoupage par les aretes 4 et 5 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH13' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S8 +c lesnoe(2) = S5 +c lesnoe(3) = S2 +c lesnoe(4) = S3 +c lesnoe(5) = S7 +c lesnoe(6) = S6 +c lesnoe(7) = S1 +c lesnoe(8) = S4 +c lesnoe( 9) = N4 +c lesnoe(10) = N5 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(8) + lesnoe(2) = listso(5) + lesnoe(3) = listso(2) + lesnoe(4) = listso(3) + lesnoe(5) = listso(7) + lesnoe(6) = listso(6) + lesnoe(7) = listso(1) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 4 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 5 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(4) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(5) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF1 + 2/1 +c areqtr(1,1) : AS2N4 +c areqtr(1,2) : AS1N4 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF5 + 1/2 +c areqtr(2,1) : AS8N4 +c areqtr(2,2) : AS7N4 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 2/1 +c areqtr(3,1) : AS7N5 +c areqtr(3,2) : AS4N5 +c +c trifad(4,0) = triangle central de la face 4 : FF2 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF2 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF2 + 1/2 +c areqtr(4,1) : AS5N5 +c areqtr(4,2) : AS2N5 +c + nulofa(1) = 1 + nulofa(2) = 5 + nulofa(3) = 3 + nulofa(4) = 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS8N0 +c areint( 2) : AS5N0 +c areint( 3) : AS2N0 +c areint( 4) : AS3N0 +c areint( 5) : AS7N0 +c areint( 6) : AS6N0 +c areint( 7) : AS1N0 +c areint( 8) : AS4N0 +c areint( 9) : AN4N0 +c areint(10) : AN5N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA11 +c triint( 2) : FA6 +c triint( 3) : FA3 +c triint( 4) : FA8 +c triint( 5) : FA12 +c triint( 6) : FA10 +c triint( 7) : FA9 +c triint( 8) : FA2 (F1/F3) +c triint( 9) : FA1 (F1/F4) +c triint(10) : FA7 (F2/F3) +c triint(11) : FS2N4 +c triint(12) : FS8N4 +c triint(13) : FS7N5 +c triint(14) : FS5N5 +c triint(15) : FS1N4 +c triint(16) : FS7N4 +c triint(17) : FS4N5 +c triint(18) : FS2N5 +c triint(19) : FS3N4 +c triint(20) : FS6N5 +c triint(21) : FS4N4 +c triint(22) : FS1N5 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(11) + lesare( 2) = listar(6) + lesare( 3) = listar(3) + lesare( 4) = listar(8) + lesare( 5) = listar(12) + lesare( 6) = listar(10) + lesare( 7) = listar(9) + lesare( 8) = listar(2) + lesare( 9) = listar(1) + lesare(10) = -listar(7) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 4 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch14.F b/src/tool/Creation_Maillage/cmch14.F new file mode 100644 index 00000000..c96689b1 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch14.F @@ -0,0 +1,495 @@ + subroutine cmch14 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 14 +c -- +c Decoupage par les aretes 4 et 6 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH14' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S6 +c lesnoe(2) = S7 +c lesnoe(3) = S4 +c lesnoe(4) = S1 +c lesnoe(5) = S5 +c lesnoe(6) = S8 +c lesnoe(7) = S3 +c lesnoe(8) = S2 +c lesnoe( 9) = N4 +c lesnoe(10) = N6 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(6) + lesnoe(2) = listso(7) + lesnoe(3) = listso(4) + lesnoe(4) = listso(1) + lesnoe(5) = listso(5) + lesnoe(6) = listso(8) + lesnoe(7) = listso(3) + lesnoe(8) = listso(2) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 4 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 6 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(4) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(6) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1 +c areqtr(1,1) : AS7N4 +c areqtr(1,2) : AS8N4 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS1N4 +c areqtr(2,2) : AS2N4 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1 +c areqtr(3,1) : AS6N6 +c areqtr(3,2) : AS1N6 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS8N6 +c areqtr(4,2) : AS3N6 +c + nulofa(1) = 5 + nulofa(2) = 1 + nulofa(3) = 2 + nulofa(4) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS6N0 +c areint( 2) : AS7N0 +c areint( 3) : AS4N0 +c areint( 4) : AS1N0 +c areint( 5) : AS5N0 +c areint( 6) : AS8N0 +c areint( 7) : AS3N0 +c areint( 8) : AS2N0 +c areint( 9) : AN4N0 +c areint(10) : AN6N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA10 +c triint( 2) : FA7 +c triint( 3) : FA2 +c triint( 4) : FA5 +c triint( 5) : FA9 +c triint( 6) : FA11 +c triint( 7) : FA12 +c triint( 8) : FA3 (F2/F4) +c triint( 9) : FA8 (F1/F4) +c triint(10) : FA1 (F2/F3) +c triint(11) : FS7N4 +c triint(12) : FS1N4 +c triint(13) : FS6N6 +c triint(14) : FS8N6 +c triint(15) : FS8N4 +c triint(16) : FS2N4 +c triint(17) : FS1N6 +c triint(18) : FS3N6 +c triint(19) : FS4N4 +c triint(20) : FS5N6 +c triint(21) : FS3N4 +c triint(22) : FS2N6 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(10) + lesare( 2) = listar(7) + lesare( 3) = listar(2) + lesare( 4) = listar(5) + lesare( 5) = listar(9) + lesare( 6) = listar(11) + lesare( 7) = listar(12) + lesare( 8) = listar(3) + lesare( 9) = -listar(8) + lesare(10) = listar(1) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,6) + codfac = coquhe(lehexa,6) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 6 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch15.F b/src/tool/Creation_Maillage/cmch15.F new file mode 100644 index 00000000..324809ab --- /dev/null +++ b/src/tool/Creation_Maillage/cmch15.F @@ -0,0 +1,495 @@ + subroutine cmch15 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 15 +c -- +c Decoupage par les aretes 4 et 10 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH15' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S5 +c lesnoe(3) = S6 +c lesnoe(4) = S1 +c lesnoe(5) = S3 +c lesnoe(6) = S8 +c lesnoe(7) = S7 +c lesnoe(8) = S4 +c lesnoe( 9) = N10 +c lesnoe(10) = N4 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(5) + lesnoe(3) = listso(6) + lesnoe(4) = listso(1) + lesnoe(5) = listso(3) + lesnoe(6) = listso(8) + lesnoe(7) = listso(7) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 10 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 4 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(10) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(4) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF6 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF6 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF6 + 2/1 +c areqtr(1,1) : AS5N10 +c areqtr(1,2) : AS8N10 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF3 + 1/2 +c areqtr(2,1) : AS1N10 +c areqtr(2,2) : AS4N10 +c +c trifad(3,0) = triangle central de la face 3 : FF1 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF1 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF1 + 2/1 +c areqtr(3,1) : AS2N4 +c areqtr(3,2) : AS1N4 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS8N4 +c areqtr(4,2) : AS7N4 +c + nulofa(1) = 6 + nulofa(2) = 3 + nulofa(3) = 1 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS5N0 +c areint( 3) : AS6N0 +c areint( 4) : AS1N0 +c areint( 5) : AS3N0 +c areint( 6) : AS8N0 +c areint( 7) : AS7N0 +c areint( 8) : AS4N0 +c areint( 9) : AN10N0 +c areint(10) : AN4N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA6 +c triint( 2) : FA9 +c triint( 3) : FA5 +c triint( 4) : FA1 +c triint( 5) : FA3 +c triint( 6) : FA8 +c triint( 7) : FA11 +c triint( 8) : FA7 (F2/F4) +c triint( 9) : FA12 (F1/F4) +c triint(10) : FA2 (F2/F3) +c triint(11) : FS5N10 +c triint(12) : FS1N10 +c triint(13) : FS2N4 +c triint(14) : FS8N4 +c triint(15) : FS8N10 +c triint(16) : FS4N10 +c triint(17) : FS1N4 +c triint(18) : FS7N4 +c triint(19) : FS6N10 +c triint(20) : FS3N4 +c triint(21) : FS7N10 +c triint(22) : FS4N4 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(6) + lesare( 2) = listar(9) + lesare( 3) = listar(5) + lesare( 4) = listar(1) + lesare( 5) = listar(3) + lesare( 6) = listar(8) + lesare( 7) = listar(11) + lesare( 8) = listar(7) + lesare( 9) = -listar(12) + lesare(10) = -listar(2) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(6), 3, + > triint(7), 3, + > triint(1), 6, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 4 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch16.F b/src/tool/Creation_Maillage/cmch16.F new file mode 100644 index 00000000..262a2473 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch16.F @@ -0,0 +1,495 @@ + subroutine cmch16 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 16 +c -- +c Decoupage par les aretes 4 et 11 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH16' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S6 +c lesnoe(2) = S1 +c lesnoe(3) = S2 +c lesnoe(4) = S5 +c lesnoe(5) = S7 +c lesnoe(6) = S4 +c lesnoe(7) = S3 +c lesnoe(8) = S8 +c lesnoe( 9) = N11 +c lesnoe(10) = N4 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(6) + lesnoe(2) = listso(1) + lesnoe(3) = listso(2) + lesnoe(4) = listso(5) + lesnoe(5) = listso(7) + lesnoe(6) = listso(4) + lesnoe(7) = listso(3) + lesnoe(8) = listso(8) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 11 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 4 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(11) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(4) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS2N11 +c areqtr(1,2) : AS3N11 +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF6 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF6 + 1/2 +c areqtr(2,1) : AS6N11 +c areqtr(2,2) : AS7N11 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS7N4 +c areqtr(3,2) : AS8N4 +c +c trifad(4,0) = triangle central de la face 4 : FF1 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF1 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF1 + 1/2 +c areqtr(4,1) : AS1N4 +c areqtr(4,2) : AS2N4 +c + nulofa(1) = 4 + nulofa(2) = 6 + nulofa(3) = 5 + nulofa(4) = 1 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS6N0 +c areint( 2) : AS1N0 +c areint( 3) : AS2N0 +c areint( 4) : AS5N0 +c areint( 5) : AS7N0 +c areint( 6) : AS4N0 +c areint( 7) : AS3N0 +c areint( 8) : AS8N0 +c areint( 9) : AN11N0 +c areint(10) : AN4N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA5 +c triint( 2) : FA1 +c triint( 3) : FA6 +c triint( 4) : FA9 +c triint( 5) : FA10 +c triint( 6) : FA7 +c triint( 7) : FA2 +c triint( 8) : FA8 (F1/F3) +c triint( 9) : FA3 (F1/F4) +c triint(10) : FA12 (F2/F3) +c triint(11) : FS2N11 +c triint(12) : FS6N11 +c triint(13) : FS7N4 +c triint(14) : FS1N4 +c triint(15) : FS3N11 +c triint(16) : FS7N11 +c triint(17) : FS8N4 +c triint(18) : FS2N4 +c triint(19) : FS5N11 +c triint(20) : FS4N4 +c triint(21) : FS8N11 +c triint(22) : FS3N4 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(5) + lesare( 2) = listar(1) + lesare( 3) = listar(6) + lesare( 4) = listar(9) + lesare( 5) = listar(10) + lesare( 6) = listar(7) + lesare( 7) = listar(2) + lesare( 8) = listar(8) + lesare( 9) = -listar(3) + lesare(10) = -listar(12) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(7), 3, + > triint(1), 5, + > triint(5), 3, + > triint(6), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 7 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch17.F b/src/tool/Creation_Maillage/cmch17.F new file mode 100644 index 00000000..140296d0 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch17.F @@ -0,0 +1,495 @@ + subroutine cmch17 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 17 +c -- +c Decoupage par les aretes 5 et 11 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH17' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S3 +c lesnoe(3) = S2 +c lesnoe(4) = S1 +c lesnoe(5) = S7 +c lesnoe(6) = S8 +c lesnoe(7) = S5 +c lesnoe(8) = S6 +c lesnoe( 9) = N5 +c lesnoe(10) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(4) + lesnoe(2) = listso(3) + lesnoe(3) = listso(2) + lesnoe(4) = listso(1) + lesnoe(5) = listso(7) + lesnoe(6) = listso(8) + lesnoe(7) = listso(5) + lesnoe(8) = listso(6) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 5 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 11 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(5) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(11) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF3 + 1/2 +c areqtr(2,1) : AS4N5 +c areqtr(2,2) : AS7N5 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS7N11 +c areqtr(3,2) : AS6N11 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS3N11 +c areqtr(4,2) : AS2N11 +c + nulofa(1) = 2 + nulofa(2) = 3 + nulofa(3) = 6 + nulofa(4) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS4N0 +c areint( 2) : AS3N0 +c areint( 3) : AS2N0 +c areint( 4) : AS1N0 +c areint( 5) : AS7N0 +c areint( 6) : AS8N0 +c areint( 7) : AS5N0 +c areint( 8) : AS6N0 +c areint( 9) : AN5N0 +c areint(10) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA4 +c triint( 2) : FA3 +c triint( 3) : FA1 +c triint( 4) : FA2 +c triint( 5) : FA7 +c triint( 6) : FA12 +c triint( 7) : FA8 +c triint( 8) : FA9 (F1/F3) +c triint( 9) : FA6 (F1/F4) +c triint(10) : FA10 (F2/F3) +c triint(11) : FS2N5 +c triint(12) : FS4N5 +c triint(13) : FS7N11 +c triint(14) : FS3N11 +c triint(15) : FS5N5 +c triint(16) : FS7N5 +c triint(17) : FS6N11 +c triint(18) : FS2N11 +c triint(19) : FS1N5 +c triint(20) : FS8N11 +c triint(21) : FS6N5 +c triint(22) : FS5N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(4) + lesare( 2) = listar(3) + lesare( 3) = listar(1) + lesare( 4) = listar(2) + lesare( 5) = listar(7) + lesare( 6) = listar(12) + lesare( 7) = listar(8) + lesare( 8) = listar(9) + lesare( 9) = listar(6) + lesare(10) = listar(10) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 1 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch18.F b/src/tool/Creation_Maillage/cmch18.F new file mode 100644 index 00000000..680741c3 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch18.F @@ -0,0 +1,495 @@ + subroutine cmch18 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 18 +c -- +c Decoupage par les aretes 5 et 12 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH18' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S2 +c lesnoe(3) = S1 +c lesnoe(4) = S4 +c lesnoe(5) = S8 +c lesnoe(6) = S5 +c lesnoe(7) = S6 +c lesnoe(8) = S7 +c lesnoe( 9) = N5 +c lesnoe(10) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(2) + lesnoe(3) = listso(1) + lesnoe(4) = listso(4) + lesnoe(5) = listso(8) + lesnoe(6) = listso(5) + lesnoe(7) = listso(6) + lesnoe(8) = listso(7) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 5 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 12 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(5) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(12) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF3 + 1/2 +c areqtr(2,1) : AS4N5 +c areqtr(2,2) : AS7N5 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS3N12 +c areqtr(3,2) : AS4N12 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS5N12 +c areqtr(4,2) : AS6N12 +c + nulofa(1) = 2 + nulofa(2) = 3 + nulofa(3) = 5 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS2N0 +c areint( 3) : AS1N0 +c areint( 4) : AS4N0 +c areint( 5) : AS8N0 +c areint( 6) : AS5N0 +c areint( 7) : AS6N0 +c areint( 8) : AS7N0 +c areint( 9) : AN5N0 +c areint(10) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA3 +c triint( 2) : FA1 +c triint( 3) : FA2 +c triint( 4) : FA4 +c triint( 5) : FA8 +c triint( 6) : FA11 +c triint( 7) : FA6 +c triint( 8) : FA10 (F2/F4) +c triint( 9) : FA9 (F1/F4) +c triint(10) : FA7 (F2/F3) +c triint(11) : FS2N5 +c triint(12) : FS4N5 +c triint(13) : FS3N12 +c triint(14) : FS5N12 +c triint(15) : FS5N5 +c triint(16) : FS7N5 +c triint(17) : FS4N12 +c triint(18) : FS6N12 +c triint(19) : FS1N5 +c triint(20) : FS8N12 +c triint(21) : FS6N5 +c triint(22) : FS7N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(3) + lesare( 2) = listar(1) + lesare( 3) = listar(2) + lesare( 4) = listar(4) + lesare( 5) = listar(8) + lesare( 6) = listar(11) + lesare( 7) = listar(6) + lesare( 8) = listar(10) + lesare( 9) = listar(9) + lesare(10) = listar(7) +c + tab1(1) = 2 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 7 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch19.F b/src/tool/Creation_Maillage/cmch19.F new file mode 100644 index 00000000..49d1be4e --- /dev/null +++ b/src/tool/Creation_Maillage/cmch19.F @@ -0,0 +1,495 @@ + subroutine cmch19 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 19 +c -- +c Decoupage par les aretes 6 et 10 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH19' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S3 +c lesnoe(3) = S2 +c lesnoe(4) = S1 +c lesnoe(5) = S7 +c lesnoe(6) = S8 +c lesnoe(7) = S5 +c lesnoe(8) = S6 +c lesnoe( 9) = N6 +c lesnoe(10) = N10 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(4) + lesnoe(2) = listso(3) + lesnoe(3) = listso(2) + lesnoe(4) = listso(1) + lesnoe(5) = listso(7) + lesnoe(6) = listso(8) + lesnoe(7) = listso(5) + lesnoe(8) = listso(6) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 6 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 10 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(6) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(10) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS3N6 +c areqtr(1,2) : AS8N6 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF2 + 1/2 +c areqtr(2,1) : AS1N6 +c areqtr(2,2) : AS6N6 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 2/1 +c areqtr(3,1) : AS4N10 +c areqtr(3,2) : AS1N10 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS8N10 +c areqtr(4,2) : AS5N10 +c + nulofa(1) = 4 + nulofa(2) = 2 + nulofa(3) = 3 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS4N0 +c areint( 2) : AS3N0 +c areint( 3) : AS2N0 +c areint( 4) : AS1N0 +c areint( 5) : AS7N0 +c areint( 6) : AS8N0 +c areint( 7) : AS5N0 +c areint( 8) : AS6N0 +c areint( 9) : AN6N0 +c areint(10) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA4 +c triint( 2) : FA3 +c triint( 3) : FA1 +c triint( 4) : FA2 +c triint( 5) : FA7 +c triint( 6) : FA12 +c triint( 7) : FA8 +c triint( 8) : FA9 (F2/F4) +c triint( 9) : FA11 (F1/F4) +c triint(10) : FA5 (F2/F3) +c triint(11) : FS3N6 +c triint(12) : FS1N6 +c triint(13) : FS4N10 +c triint(14) : FS8N10 +c triint(15) : FS8N6 +c triint(16) : FS6N6 +c triint(17) : FS1N10 +c triint(18) : FS5N10 +c triint(19) : FS2N6 +c triint(20) : FS7N10 +c triint(21) : FS5N6 +c triint(22) : FS6N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(4) + lesare( 2) = listar(3) + lesare( 3) = listar(1) + lesare( 4) = listar(2) + lesare( 5) = listar(7) + lesare( 6) = listar(12) + lesare( 7) = listar(8) + lesare( 8) = listar(9) + lesare( 9) = listar(11) + lesare(10) = listar(5) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(4), 3, + > triint(1), 3, + > triint(2), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,5) + codfac = coquhe(lehexa,5) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 3 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch20.F b/src/tool/Creation_Maillage/cmch20.F new file mode 100644 index 00000000..837a5561 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch20.F @@ -0,0 +1,495 @@ + subroutine cmch20 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 20 +c -- +c Decoupage par les aretes 6 et 12 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH20' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S4 +c lesnoe(3) = S3 +c lesnoe(4) = S2 +c lesnoe(5) = S6 +c lesnoe(6) = S7 +c lesnoe(7) = S8 +c lesnoe(8) = S5 +c lesnoe( 9) = N6 +c lesnoe(10) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(4) + lesnoe(3) = listso(3) + lesnoe(4) = listso(2) + lesnoe(5) = listso(6) + lesnoe(6) = listso(7) + lesnoe(7) = listso(8) + lesnoe(8) = listso(5) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 6 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 12 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(6) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(12) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS3N6 +c areqtr(1,2) : AS8N6 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF2 + 1/2 +c areqtr(2,1) : AS1N6 +c areqtr(2,2) : AS6N6 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS6N12 +c areqtr(3,2) : AS5N12 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS4N12 +c areqtr(4,2) : AS3N12 +c + nulofa(1) = 4 + nulofa(2) = 2 + nulofa(3) = 6 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS1N0 +c areint( 2) : AS4N0 +c areint( 3) : AS3N0 +c areint( 4) : AS2N0 +c areint( 5) : AS6N0 +c areint( 6) : AS7N0 +c areint( 7) : AS8N0 +c areint( 8) : AS5N0 +c areint( 9) : AN6N0 +c areint(10) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA2 +c triint( 2) : FA4 +c triint( 3) : FA3 +c triint( 4) : FA1 +c triint( 5) : FA5 +c triint( 6) : FA10 +c triint( 7) : FA7 +c triint( 8) : FA11 (F1/F3) +c triint( 9) : FA8 (F1/F4) +c triint(10) : FA9 (F2/F3) +c triint(11) : FS3N6 +c triint(12) : FS1N6 +c triint(13) : FS6N12 +c triint(14) : FS4N12 +c triint(15) : FS8N6 +c triint(16) : FS6N6 +c triint(17) : FS5N12 +c triint(18) : FS3N12 +c triint(19) : FS2N6 +c triint(20) : FS7N12 +c triint(21) : FS5N6 +c triint(22) : FS8N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(2) + lesare( 2) = listar(4) + lesare( 3) = listar(3) + lesare( 4) = listar(1) + lesare( 5) = listar(5) + lesare( 6) = listar(10) + lesare( 7) = listar(7) + lesare( 8) = listar(11) + lesare( 9) = listar(8) + lesare(10) = listar(9) +c + tab1(1) = 1 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 8 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch21.F b/src/tool/Creation_Maillage/cmch21.F new file mode 100644 index 00000000..792d8694 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch21.F @@ -0,0 +1,495 @@ + subroutine cmch21 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 21 +c -- +c Decoupage par les aretes 7 et 9 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH21' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S2 +c lesnoe(3) = S1 +c lesnoe(4) = S4 +c lesnoe(5) = S8 +c lesnoe(6) = S5 +c lesnoe(7) = S6 +c lesnoe(8) = S7 +c lesnoe( 9) = N7 +c lesnoe(10) = N9 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(2) + lesnoe(3) = listso(1) + lesnoe(4) = listso(4) + lesnoe(5) = listso(8) + lesnoe(6) = listso(5) + lesnoe(7) = listso(6) + lesnoe(8) = listso(7) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 7 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 9 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(7) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(9) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS1N7 +c areqtr(1,2) : AS6N7 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF5 + 1/2 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS8N7 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS8N9 +c areqtr(3,2) : AS7N9 +c +c trifad(4,0) = triangle central de la face 4 : FF2 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF2 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF2 + 1/2 +c areqtr(4,1) : AS2N9 +c areqtr(4,2) : AS1N9 +c + nulofa(1) = 3 + nulofa(2) = 5 + nulofa(3) = 6 + nulofa(4) = 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS2N0 +c areint( 3) : AS1N0 +c areint( 4) : AS4N0 +c areint( 5) : AS8N0 +c areint( 6) : AS5N0 +c areint( 7) : AS6N0 +c areint( 8) : AS7N0 +c areint( 9) : AN7N0 +c areint(10) : AN9N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA3 +c triint( 2) : FA1 +c triint( 3) : FA2 +c triint( 4) : FA4 +c triint( 5) : FA8 +c triint( 6) : FA11 +c triint( 7) : FA6 +c triint( 8) : FA10 (F1/F3) +c triint( 9) : FA5 (F1/F4) +c triint(10) : FA12 (F2/F3) +c triint(11) : FS1N7 +c triint(12) : FS3N7 +c triint(13) : FS8N9 +c triint(14) : FS2N9 +c triint(15) : FS6N7 +c triint(16) : FS8N7 +c triint(17) : FS7N9 +c triint(18) : FS2N9 +c triint(19) : FS4N7 +c triint(20) : FS5N9 +c triint(21) : FS7N7 +c triint(22) : FS6N9 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(3) + lesare( 2) = listar(1) + lesare( 3) = listar(2) + lesare( 4) = listar(4) + lesare( 5) = listar(8) + lesare( 6) = listar(11) + lesare( 7) = listar(6) + lesare( 8) = listar(10) + lesare( 9) = -listar(5) + lesare(10) = listar(12) +c + tab1(1) = 2 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(3), 3, + > triint(4), 3, + > triint(1), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,4) + codfac = coquhe(lehexa,4) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 9 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch22.F b/src/tool/Creation_Maillage/cmch22.F new file mode 100644 index 00000000..ccca11e5 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch22.F @@ -0,0 +1,495 @@ + subroutine cmch22 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 22 +c -- +c Decoupage par les aretes 7 et 11 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH22' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S1 +c lesnoe(3) = S4 +c lesnoe(4) = S3 +c lesnoe(5) = S5 +c lesnoe(6) = S6 +c lesnoe(7) = S7 +c lesnoe(8) = S8 +c lesnoe( 9) = N7 +c lesnoe(10) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(4) + lesnoe(4) = listso(3) + lesnoe(5) = listso(5) + lesnoe(6) = listso(6) + lesnoe(7) = listso(7) + lesnoe(8) = listso(8) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 7 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 11 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(7) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(11) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS1N7 +c areqtr(1,2) : AS6N7 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF5 + 1/2 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS8N7 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS2N11 +c areqtr(3,2) : AS3N11 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS6N11 +c areqtr(4,2) : AS7N11 +c + nulofa(1) = 3 + nulofa(2) = 5 + nulofa(3) = 4 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS1N0 +c areint( 3) : AS4N0 +c areint( 4) : AS3N0 +c areint( 5) : AS5N0 +c areint( 6) : AS6N0 +c areint( 7) : AS7N0 +c areint( 8) : AS8N0 +c areint( 9) : AN7N0 +c areint(10) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA1 +c triint( 2) : FA2 +c triint( 3) : FA4 +c triint( 4) : FA3 +c triint( 5) : FA6 +c triint( 6) : FA9 +c triint( 7) : FA5 +c triint( 8) : FA12 (F2/F4) +c triint( 9) : FA10 (F1/F4) +c triint(10) : FA8 (F2/F3) +c triint(11) : FS1N7 +c triint(12) : FS3N7 +c triint(13) : FS2N11 +c triint(14) : FS6N11 +c triint(15) : FS6N7 +c triint(16) : FS8N7 +c triint(17) : FS3N11 +c triint(18) : FS7N11 +c triint(19) : FS4N7 +c triint(20) : FS5N11 +c triint(21) : FS7N7 +c triint(22) : FS8N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(1) + lesare( 2) = listar(2) + lesare( 3) = listar(4) + lesare( 4) = listar(3) + lesare( 5) = listar(6) + lesare( 6) = listar(9) + lesare( 7) = listar(5) + lesare( 8) = listar(12) + lesare( 9) = listar(10) + lesare(10) = -listar(8) +c + tab1(1) = 2 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > triint(2), 3, + > triint(3), 3, + > triint(4), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 8 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch23.F b/src/tool/Creation_Maillage/cmch23.F new file mode 100644 index 00000000..d9eb25e9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch23.F @@ -0,0 +1,495 @@ + subroutine cmch23 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 23 +c -- +c Decoupage par les aretes 8 et 9 +c Serie A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH23' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S4 +c lesnoe(3) = S3 +c lesnoe(4) = S2 +c lesnoe(5) = S6 +c lesnoe(6) = S7 +c lesnoe(7) = S8 +c lesnoe(8) = S5 +c lesnoe( 9) = N8 +c lesnoe(10) = N9 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(4) + lesnoe(3) = listso(3) + lesnoe(4) = listso(2) + lesnoe(5) = listso(6) + lesnoe(6) = listso(7) + lesnoe(7) = listso(8) + lesnoe(8) = listso(5) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 8 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 9 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(8) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(9) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1 +c areqtr(1,1) : AS4N8 +c areqtr(1,2) : AS7N8 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF4 + 1/2 +c areqtr(2,1) : AS2N8 +c areqtr(2,2) : AS5N8 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1 +c areqtr(3,1) : AS1N9 +c areqtr(3,2) : AS2N9 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF6 + 1/2 +c areqtr(4,1) : AS7N9 +c areqtr(4,2) : AS8N9 +c + nulofa(1) = 5 + nulofa(2) = 4 + nulofa(3) = 2 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS1N0 +c areint( 2) : AS4N0 +c areint( 3) : AS3N0 +c areint( 4) : AS2N0 +c areint( 5) : AS6N0 +c areint( 6) : AS7N0 +c areint( 7) : AS8N0 +c areint( 8) : AS5N0 +c areint( 9) : AN8N0 +c areint(10) : AN9N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA2 +c triint( 2) : FA4 +c triint( 3) : FA3 +c triint( 4) : FA1 +c triint( 5) : FA5 +c triint( 6) : FA10 +c triint( 7) : FA7 +c triint( 8) : FA11 (F2/F4) +c triint( 9) : FA12 (F1/F4) +c triint(10) : FA6 (F2/F3) +c triint(11) : FS4N8 +c triint(12) : FS2N8 +c triint(13) : FS1N9 +c triint(14) : FS7N9 +c triint(15) : FS7N8 +c triint(16) : FS5N8 +c triint(17) : FS2N9 +c triint(18) : FS8N9 +c triint(19) : FS3N8 +c triint(20) : FS6N9 +c triint(21) : FS8N8 +c triint(22) : FS5N9 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(2) + lesare( 2) = listar(4) + lesare( 3) = listar(3) + lesare( 4) = listar(1) + lesare( 5) = listar(5) + lesare( 6) = listar(10) + lesare( 7) = listar(7) + lesare( 8) = listar(11) + lesare( 9) = listar(12) + lesare(10) = -listar(6) +c + tab1(1) = 1 + tab1(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAH', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4), 3, + > triint(1), 3, + > triint(2), 3, + > triint(3), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,3) + codfac = coquhe(lehexa,3) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAI', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 9 + call cmchai ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch24.F b/src/tool/Creation_Maillage/cmch24.F new file mode 100644 index 00000000..37526643 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch24.F @@ -0,0 +1,495 @@ + subroutine cmch24 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 24 +c -- +c Decoupage par les aretes 8 et 10 +c Serie B +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH24' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux, jaux + integer laface, codfac + integer lesnoe(10), lesare(10) + integer tab1(2) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S3 +c lesnoe(3) = S2 +c lesnoe(4) = S1 +c lesnoe(5) = S7 +c lesnoe(6) = S8 +c lesnoe(7) = S5 +c lesnoe(8) = S6 +c lesnoe( 9) = N5 +c lesnoe(10) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(4) + lesnoe(4) = listso(3) + lesnoe(5) = listso(5) + lesnoe(6) = listso(6) + lesnoe(7) = listso(7) + lesnoe(8) = listso(8) +c +c iaux = numero local de la 1ere arete coupee : celle qui partage un +c sommet avec la 1ere pyramide + iaux = 8 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee : celle qui partage un +c sommet avec la 2nde pyramide + iaux = 10 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listso = ', listso + write(ulsort,*) 'arete 1 = ', listar(8) + write(ulsort,*) 'lesnoe(9) = ', lesnoe(9) + write(ulsort,*) 'arete 2 = ', listar(10) + write(ulsort,*) 'lesnoe(10) = ', lesnoe(10) + write(ulsort,*) 'lesnoe(1) = ', lesnoe(1), + > ', lesnoe(2) = ', lesnoe(2) + write(ulsort,*) 'lesnoe(3) = ', lesnoe(3), + > ', lesnoe(4) = ', lesnoe(4) + write(ulsort,*) 'lesnoe(5) = ', lesnoe(5), + > ', lesnoe(6) = ', lesnoe(6) + write(ulsort,*) 'lesnoe(7) = ', lesnoe(7), + > ', lesnoe(8) = ', lesnoe(8) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1 +c areqtr(1,1) : AS4N8 +c areqtr(1,2) : AS7N8 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF4 + 1/2 +c areqtr(2,1) : AS2N8 +c areqtr(2,2) : AS5N8 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF6 + 2/1 +c areqtr(3,1) : AS5N10 +c areqtr(3,2) : AS8N10 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS1N10 +c areqtr(4,2) : AS4N10 +c + nulofa(1) = 5 + nulofa(2) = 4 + nulofa(3) = 6 + nulofa(4) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS1N0 +c areint( 3) : AS4N0 +c areint( 4) : AS3N0 +c areint( 5) : AS5N0 +c areint( 6) : AS6N0 +c areint( 7) : AS7N0 +c areint( 8) : AS8N0 +c areint( 9) : AN8N0 +c areint(10) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,*) '.. noeud ', indnoe+1 + write (ulsort,*) '.. aretes de ', indare+1, ' a ', indare+10 +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA1 +c triint( 2) : FA2 +c triint( 3) : FA4 +c triint( 4) : FA3 +c triint( 5) : FA6 +c triint( 6) : FA9 +c triint( 7) : FA5 +c triint( 8) : FA12 (F1/F3) +c triint( 9) : FA7 (F1/F4) +c triint(10) : FA11 (F2/F3) +c triint(11) : FS4N8 +c triint(12) : FS2N8 +c triint(13) : FS5N10 +c triint(14) : FS1N10 +c triint(15) : FS7N8 +c triint(16) : FS5N8 +c triint(17) : FS8N10 +c triint(18) : FS4N10 +c triint(19) : FS3N8 +c triint(20) : FS6N10 +c triint(21) : FS8N8 +c triint(22) : FS7N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(1) + lesare( 2) = listar(2) + lesare( 3) = listar(4) + lesare( 4) = listar(3) + lesare( 5) = listar(6) + lesare( 6) = listar(9) + lesare( 7) = listar(5) + lesare( 8) = listar(12) + lesare( 9) = -listar(7) + lesare(10) = listar(11) +c + tab1(1) = 1 + tab1(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAF', nompro + write (ulsort,*) '.. triangles de ', indtri+1, ' a ', indtri+10 +#endif + call cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. pyramides de ', indpyr+1, ' a ', indpyr+2 +#endif +c + laface = quahex(lehexa,1) + codfac = coquhe(lehexa,1) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > triint(2), 3, + > triint(3), 3, + > triint(4), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,2) + codfac = coquhe(lehexa,2) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(6), 3, + > triint(7), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAG', nompro + write (ulsort,*) '.. tetraedres de ', indtet+1, ' a ', indtet+12 +#endif +c + iaux = 2 + call cmchag ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch31.F b/src/tool/Creation_Maillage/cmch31.F new file mode 100644 index 00000000..a8b7ab71 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch31.F @@ -0,0 +1,477 @@ + subroutine cmch31 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 31 +c -- +c Decoupage par les aretes 1 et 12 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH31' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S6 +c lesnoe(3) = S7 +c lesnoe(4) = S4 +c lesnoe(5) = S2 +c lesnoe(6) = S5 +c lesnoe(7) = S8 +c lesnoe(8) = S3 +c lesnoe( 9) = N1 +c lesnoe(10) = N12 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 12 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(6) + lesnoe(3) = listso(7) + lesnoe(4) = listso(4) + lesnoe(5) = listso(2) + lesnoe(6) = listso(5) + lesnoe(7) = listso(8) + lesnoe(8) = listso(3) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF1 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF2 + 1/2 +c areqtr(2,1) : AS6N1 +c areqtr(2,2) : AS5N1 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF6 + 2/1 +c areqtr(3,1) : AS6N12 +c areqtr(3,2) : AS5N12 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF5 + 1/2 +c areqtr(4,1) : AS4N12 +c areqtr(4,2) : AS3N12 +c + nulofa(1) = 1 + nulofa(2) = 2 + nulofa(3) = 6 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS1N0 +c areint(2) : AS6N0 +c areint(3) : AS7N0 +c areint(4) : AS4N0 +c areint(5) : AS2N0 +c areint(6) : AS5N0 +c areint(7) : AS8N0 +c areint(8) : AS3N0 +c areint( 9) : AN1N0 +c areint(10) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA2 +c triint(2) : FA5 +c triint(3) : FA10 +c triint(4) : FA7 +c triint(5) : FA3 +c triint(6) : FA6 +c triint(7) : FA11 +c triint(8) : FA8 +c triint(9) : FA9 +c triint(10) : FA4 +c triint(11) : FS4N1 +c triint(12) : FS6N1 +c triint(13) : FS6N12 +c triint(14) : FS4N12 +c triint(15) : FS3N1 +c triint(16) : FS5N1 +c triint(17) : FS5N12 +c triint(18) : FS3N12 +c triint(19) : FS1N1 +c triint(20) : FS7N12 +c triint(21) : FS2N1 +c triint(22) : FS8N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) + lesare(2) = listar(5) + lesare(3) = listar(10) + lesare(4) = listar(7) + lesare(5) = listar(3) + lesare(6) = listar(6) + lesare(7) = listar(11) + lesare(8) = listar(8) + lesare(9) = listar(9) + lesare(10) = listar(4) +c + tab1(1) = areint(9) + tab2(1) = areint(1) + tab1(2) = areint(3) + tab2(2) = areint(10) + tab1(3) = areint(5) + tab2(3) = areint(9) + tab1(4) = areint(10) + tab2(4) = areint(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + tab1(1) = 0 + tab1(2) = -2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 1 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch32.F b/src/tool/Creation_Maillage/cmch32.F new file mode 100644 index 00000000..bd8f3b60 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch32.F @@ -0,0 +1,477 @@ + subroutine cmch32 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 32 +c -- +c Decoupage par les aretes 2 et 11 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH32' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S2 +c lesnoe(3) = S5 +c lesnoe(4) = S6 +c lesnoe(5) = S4 +c lesnoe(6) = S3 +c lesnoe(7) = S8 +c lesnoe(8) = S7 +c lesnoe( 9) = N2 +c lesnoe(10) = N11 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 11 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(2) + lesnoe(3) = listso(5) + lesnoe(4) = listso(6) + lesnoe(5) = listso(4) + lesnoe(6) = listso(3) + lesnoe(7) = listso(8) + lesnoe(8) = listso(7) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF3 + 2/1 +c areqtr(1,1) : AS6N2 +c areqtr(1,2) : AS7N2 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF1 + 1/2 +c areqtr(2,1) : AS2N2 +c areqtr(2,2) : AS3N2 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF4 + 2/1 +c areqtr(3,1) : AS2N11 +c areqtr(3,2) : AS3N11 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF6 + 1/2 +c areqtr(4,1) : AS6N11 +c areqtr(4,2) : AS7N11 +c + nulofa(1) = 3 + nulofa(2) = 1 + nulofa(3) = 4 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS1N0 +c areint(2) : AS2N0 +c areint(3) : AS5N0 +c areint(4) : AS6N0 +c areint(5) : AS4N0 +c areint(6) : AS3N0 +c areint(7) : AS8N0 +c areint(8) : AS7N0 +c areint( 9) : AN2N0 +c areint(10) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA5 +c triint(2) : FA1 +c triint(3) : FA6 +c triint(4) : FA9 +c triint(5) : FA7 +c triint(6) : FA4 +c triint(7) : FA8 +c triint(8) : FA12 +c triint(9) : FA3 +c triint(10) : FA10 +c triint(11) : FS6N2 +c triint(12) : FS2N2 +c triint(13) : FS2N11 +c triint(14) : FS6N11 +c triint(15) : FS7N2 +c triint(16) : FS3N2 +c triint(17) : FS3N11 +c triint(18) : FS7N11 +c triint(19) : FS1N2 +c triint(20) : FS5N11 +c triint(21) : FS4N2 +c triint(22) : FS8N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(5) + lesare(2) = listar(1) + lesare(3) = listar(6) + lesare(4) = listar(9) + lesare(5) = listar(7) + lesare(6) = listar(4) + lesare(7) = listar(8) + lesare(8) = listar(12) + lesare(9) = listar(3) + lesare(10) = listar(10) +c + tab1(1) = areint(1) + tab2(1) = areint(9) + tab1(2) = areint(10) + tab2(2) = areint(3) + tab1(3) = areint(9) + tab2(3) = areint(5) + tab1(4) = areint(7) + tab2(4) = areint(10) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 2 + nulofa(2) = 5 + tab1(1) = 1 + tab1(2) = -5 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 2 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch33.F b/src/tool/Creation_Maillage/cmch33.F new file mode 100644 index 00000000..3f9fe141 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch33.F @@ -0,0 +1,477 @@ + subroutine cmch33 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 33 +c -- +c Decoupage par les aretes 3 et 10 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH33' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S5 +c lesnoe(3) = S6 +c lesnoe(4) = S1 +c lesnoe(5) = S3 +c lesnoe(6) = S8 +c lesnoe(7) = S7 +c lesnoe(8) = S4 +c lesnoe( 9) = N3 +c lesnoe(10) = N10 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 10 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(5) + lesnoe(3) = listso(6) + lesnoe(4) = listso(1) + lesnoe(5) = listso(3) + lesnoe(6) = listso(8) + lesnoe(7) = listso(7) + lesnoe(8) = listso(4) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF1 + 2/1 +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF4 + 1/2 +c areqtr(2,1) : AS5N3 +c areqtr(2,2) : AS8N3 +c +c trifad(3,0) = triangle central de la face 3 : FF6 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF6 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF6 + 2/1 +c areqtr(3,1) : AS5N10 +c areqtr(3,2) : AS8N10 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF3 + 1/2 +c areqtr(4,1) : AS1N10 +c areqtr(4,2) : AS4N10 +c + nulofa(1) = 1 + nulofa(2) = 4 + nulofa(3) = 6 + nulofa(4) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS2N0 +c areint(2) : AS5N0 +c areint(3) : AS6N0 +c areint(4) : AS1N0 +c areint(5) : AS3N0 +c areint(6) : AS8N0 +c areint(7) : AS7N0 +c areint(8) : AS4N0 +c areint( 9) : AN3N0 +c areint(10) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA1 +c triint(2) : FA6 +c triint(3) : FA9 +c triint(4) : FA5 +c triint(5) : FA4 +c triint(6) : FA8 +c triint(7) : FA12 +c triint(8) : FA7 +c triint(9) : FA11 +c triint(10) : FA2 +c triint(11) : FS1N3 +c triint(12) : FS5N3 +c triint(13) : FS5N10 +c triint(14) : FS1N10 +c triint(15) : FS4N3 +c triint(16) : FS8N3 +c triint(17) : FS8N10 +c triint(18) : FS4N10 +c triint(19) : FS2N3 +c triint(20) : FS6N10 +c triint(21) : FS3N3 +c triint(22) : FS7N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(6) + lesare(3) = listar(9) + lesare(4) = listar(5) + lesare(5) = listar(4) + lesare(6) = listar(8) + lesare(7) = listar(12) + lesare(8) = listar(7) + lesare(9) = listar(11) + lesare(10) = listar(2) +c + tab1(1) = areint(9) + tab2(1) = areint(1) + tab1(2) = areint(3) + tab2(2) = areint(10) + tab1(3) = areint(5) + tab2(3) = areint(9) + tab1(4) = areint(10) + tab2(4) = areint(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 2 + nulofa(2) = 5 + tab1(1) = 0 + tab1(2) = -2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 1 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch34.F b/src/tool/Creation_Maillage/cmch34.F new file mode 100644 index 00000000..ce4ee952 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch34.F @@ -0,0 +1,477 @@ + subroutine cmch34 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 34 +c -- +c Decoupage par les aretes 4 et 9 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH34' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S1 +c lesnoe(3) = S6 +c lesnoe(4) = S7 +c lesnoe(5) = S3 +c lesnoe(6) = S2 +c lesnoe(7) = S5 +c lesnoe(8) = S8 +c lesnoe( 9) = N4 +c lesnoe(10) = N9 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 4 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 9 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(4) + lesnoe(2) = listso(1) + lesnoe(3) = listso(6) + lesnoe(4) = listso(7) + lesnoe(5) = listso(3) + lesnoe(6) = listso(2) + lesnoe(7) = listso(5) + lesnoe(8) = listso(8) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF5 + 2/1 +c areqtr(1,1) : AS7N4 +c areqtr(1,2) : AS8N4 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF1 + 1/2 +c areqtr(2,1) : AS1N4 +c areqtr(2,2) : AS2N4 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF2 + 2/1 +c areqtr(3,1) : AS1N9 +c areqtr(3,2) : AS2N9 +c +c trifad(4,0) = triangle central de la face 4 : FF6 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF6 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF6 + 1/2 +c areqtr(4,1) : AS7N9 +c areqtr(4,2) : AS8N9 +c + nulofa(1) = 5 + nulofa(2) = 1 + nulofa(3) = 2 + nulofa(4) = 6 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS4N0 +c areint(2) : AS1N0 +c areint(3) : AS6N0 +c areint(4) : AS7N0 +c areint(5) : AS3N0 +c areint(6) : AS2N0 +c areint(7) : AS5N0 +c areint(8) : AS8N0 +c areint( 9) : AN4N0 +c areint(10) : AN9N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA7 +c triint(2) : FA2 +c triint(3) : FA5 +c triint(4) : FA10 +c triint(5) : FA8 +c triint(6) : FA3 +c triint(7) : FA6 +c triint(8) : FA11 +c triint(9) : FA1 +c triint(10) : FA12 +c triint(11) : FS7N4 +c triint(12) : FS1N4 +c triint(13) : FS1N9 +c triint(14) : FS7N9 +c triint(15) : FS8N4 +c triint(16) : FS2N4 +c triint(17) : FS2N9 +c triint(18) : FS8N9 +c triint(19) : FS4N4 +c triint(20) : FS7N12 +c triint(21) : FS3N4 +c triint(22) : FS5N9 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(7) + lesare(2) = listar(2) + lesare(3) = listar(5) + lesare(4) = listar(10) + lesare(5) = listar(8) + lesare(6) = listar(3) + lesare(7) = listar(6) + lesare(8) = listar(11) + lesare(9) = listar(1) + lesare(10) = listar(12) +c + tab1(1) = areint(1) + tab2(1) = areint(9) + tab1(2) = areint(10) + tab2(2) = areint(3) + tab1(3) = areint(9) + tab2(3) = areint(5) + tab1(4) = areint(7) + tab2(4) = areint(10) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + tab1(1) = 1 + tab1(2) = -5 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 7 +c tetraedre 9 +c tetraedre 8 +c tetraedre 1 +c tetraedre 3 +c tetraedre 2 +c tetraedre 4 +c tetraedre 6 +c tetraedre 5 +c tetraedre 10 +c tetraedre 12 +c tetraedre 11 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 2 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch35.F b/src/tool/Creation_Maillage/cmch35.F new file mode 100644 index 00000000..092a3570 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch35.F @@ -0,0 +1,477 @@ + subroutine cmch35 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 35 +c -- +c Decoupage par les aretes 5 et 8 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH35' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S4 +c lesnoe(3) = S3 +c lesnoe(4) = S2 +c lesnoe(5) = S6 +c lesnoe(6) = S7 +c lesnoe(7) = S8 +c lesnoe(8) = S5 +c lesnoe(9) = N5 +c lesnoe(10) = N8 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 5 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 8 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(4) + lesnoe(3) = listso(3) + lesnoe(4) = listso(2) + lesnoe(5) = listso(6) + lesnoe(6) = listso(7) + lesnoe(7) = listso(8) + lesnoe(8) = listso(5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF2 + 2/1 +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF3 + 1/2 +c areqtr(2,1) : AS4N5 +c areqtr(2,2) : AS7N5 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF5 + 2/1 +c areqtr(3,1) : AS4N8 +c areqtr(3,2) : AS7N8 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF4 + 1/2 +c areqtr(4,1) : AS2N8 +c areqtr(4,2) : AS5N8 +c + nulofa(1) = 2 + nulofa(2) = 3 + nulofa(3) = 5 + nulofa(4) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS1N0 +c areint(2) : AS4N0 +c areint(3) : AS3N0 +c areint(4) : AS2N0 +c areint(5) : AS6N0 +c areint(6) : AS7N0 +c areint(7) : AS8N0 +c areint(8) : AS5N0 +c areint(9) : AN5N0 +c areint(10) : AN8N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA1 +c triint(2) : FA2 +c triint(3) : FA4 +c triint(4) : FA3 +c triint(5) : FA9 +c triint(6) : FA10 +c triint(7) : FA12 +c triint(8) : FA11 +c triint(9) : FA7 +c triint(10) : FA6 +c triint(11) : FS2N5 +c triint(12) : FS4N5 +c triint(13) : FS4N8 +c triint(14) : FS2N8 +c triint(15) : FS5N5 +c triint(16) : FS7N5 +c triint(17) : FS7N8 +c triint(18) : FS5N8 +c triint(19) : FS1N5 +c triint(20) : FS3N8 +c triint(21) : FS6N5 +c triint(22) : FS8N8 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(2) + lesare(3) = listar(4) + lesare(4) = listar(3) + lesare(5) = listar(9) + lesare(6) = listar(10) + lesare(7) = listar(12) + lesare(8) = listar(11) + lesare(9) = listar(7) + lesare(10) = listar(6) +c + tab1(1) = areint(9) + tab2(1) = areint(1) + tab1(2) = areint(3) + tab2(2) = areint(10) + tab1(3) = areint(5) + tab2(3) = areint(9) + tab1(4) = areint(10) + tab2(4) = areint(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 1 + nulofa(2) = 6 + tab1(1) = 0 + tab1(2) = -2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 1 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch36.F b/src/tool/Creation_Maillage/cmch36.F new file mode 100644 index 00000000..1127051c --- /dev/null +++ b/src/tool/Creation_Maillage/cmch36.F @@ -0,0 +1,477 @@ + subroutine cmch36 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - etat 36 +c -- +c Decoupage par les aretes 6 et 7 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH36' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(10), lesare(10) + integer tab1(4), tab2(4) + integer nulofa(4) + integer areint(10) + integer areqtr(4,2) + integer triint(22) + integer trifad(4,0:2), cotrvo(4,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S1 +c lesnoe(3) = S4 +c lesnoe(4) = S3 +c lesnoe(5) = S5 +c lesnoe(6) = S6 +c lesnoe(7) = S7 +c lesnoe(8) = S8 +c lesnoe(9) = N6 +c lesnoe(10) = N7 +c==== +c iaux = numero local de la 1ere arete coupee + iaux = 6 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +c +c iaux = numero local de la 2eme arete coupee + iaux = 7 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +c +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(4) + lesnoe(4) = listso(3) + lesnoe(5) = listso(5) + lesnoe(6) = listso(6) + lesnoe(7) = listso(7) + lesnoe(8) = listso(8) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'arete 1', listar(iaux) + write(ulsort,2000) 'lesnoe(9)', lesnoe(9) + write(ulsort,2000) 'arete 2', listar(iaux) + write(ulsort,2000) 'lesnoe(10)', lesnoe(10) + write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) + write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) + write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) + write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. Idem pour 3/4. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide 1 +c trifad(p,2) : triangle bordant la pyramide 2 +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF4 + 2/1 +c areqtr(1,1) : AS3N6 +c areqtr(1,2) : AS8N6 +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF2 + 1/2 +c areqtr(2,1) : AS1N6 +c areqtr(2,2) : AS6N6 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF3 + 2/1 +c areqtr(3,1) : AS1N7 +c areqtr(3,2) : AS6N7 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF5 + 1/2 +c areqtr(4,1) : AS3N7 +c areqtr(4,2) : AS8N7 +c + nulofa(1) = 4 + nulofa(2) = 2 + nulofa(3) = 3 + nulofa(4) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAA', nompro +#endif + call cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c noecen : N0 +c areint(1) : AS2N0 +c areint(2) : AS1N0 +c areint(3) : AS4N0 +c areint(4) : AS3N0 +c areint(5) : AS5N0 +c areint(6) : AS6N0 +c areint(7) : AS7N0 +c areint(8) : AS8N0 +c areint(9) : AN6N0 +c areint(10) : AN7N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+10 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 10 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint(1) : FA3 +c triint(2) : FA1 +c triint(3) : FA2 +c triint(4) : FA4 +c triint(5) : FA11 +c triint(6) : FA9 +c triint(7) : FA10 +c triint(8) : FA12 +c triint(9) : FA5 +c triint(10) : FA8 +c triint(11) : FS3N6 +c triint(12) : FS1N6 +c triint(13) : FS1N7 +c triint(14) : FS3N7 +c triint(15) : FS8N6 +c triint(16) : FS6N6 +c triint(17) : FS6N7 +c triint(18) : FS8N7 +c triint(19) : FS2N6 +c triint(20) : FS4N7 +c triint(21) : FS5N6 +c triint(22) : FS7N7 +c==== +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(1) + lesare(3) = listar(2) + lesare(4) = listar(4) + lesare(5) = listar(11) + lesare(6) = listar(9) + lesare(7) = listar(10) + lesare(8) = listar(12) + lesare(9) = listar(5) + lesare(10) = listar(8) +c + tab1(1) = areint(1) + tab2(1) = areint(9) + tab1(2) = areint(10) + tab2(2) = areint(3) + tab1(3) = areint(9) + tab2(3) = areint(5) + tab1(4) = areint(7) + tab2(4) = areint(10) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAC', nompro + write (ulsort,4000) indtri+1, indtri+10 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des deux pyramides +c==== +c + if ( codret.eq.0 ) then +c + nulofa(1) = 1 + nulofa(2) = 6 + tab1(1) = 1 + tab1(2) = -5 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAD', nompro + write (ulsort,5000) indpyr+1, indpyr+2 + 5000 format('.. pyramides de',i10,' a',i10) +#endif + call cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation des douze tetraedres dans l'ordre suivant : +c tetraedre 7 +c tetraedre 8 +c tetraedre 9 +c tetraedre 1 +c tetraedre 2 +c tetraedre 3 +c tetraedre 4 +c tetraedre 5 +c tetraedre 6 +c tetraedre 10 +c tetraedre 11 +c tetraedre 12 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAE', nompro + write (ulsort,6000) indtet+1, indtet+12 + 6000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 2 + call cmchae ( lehexa, indtet, indptp, iaux, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch40.F b/src/tool/Creation_Maillage/cmch40.F new file mode 100644 index 00000000..b1360058 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch40.F @@ -0,0 +1,359 @@ + subroutine cmch40 ( lehexa, nulofa, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 4x +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . nulofa . e . 1 . numero local de la face couppe en 4 . +c . tabaux . e . 4 . numeros locaux des faces coupees en 3, . +c . . . . dans l'ordre des pyramides p/p1+1 . +c . somm . e . 1 . sommets de la face non decoupee . +c . arexti . e . 1 . aretes de la face non decoupee . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . trigpy . s . 4 . triangle de la grande pyramide . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH40' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, nulofa, tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer indare, indtri, indtet, indpyr, indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) + integer trigpy(4) + integer facnde, cofnde +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer noefac + integer areint(4) + integer facdec, cofdec + integer quabas(4) + integer arefad(4), areqtr(4,2) + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(4,2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHFA', nompro +#endif + call cmchfa ( facdec, cofdec, facnde, cofnde, + > niveau, noefac, + > quabas, arefad, + > trifad, cotrvo, areqtr, + > lehexa, nulofa, + > somare, aretri, nivtri, + > arequa, filqua, + > quahex, coquhe, + > tabaux, + > ulsort, langue, codret ) +c +c==== +c 3. Creation des quatres aretes internes +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c==== +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , 4 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noefac , somm(iaux) ) + somare(2,areint(iaux)) = max ( noefac , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + 3100 format('. Arete interne',i10,' de',i10,' a',i10) + write(ulsort,3100) indare, + > somare(1,areint(iaux)), somare(2,areint(iaux)) +#endif +c + 31 continue +c + endif +c +c==== +c 4. Creation des dix triangles internes +c par convention, le niveau est le meme que les quadrangles fils +c sur l'exterieur +c==== +c +c 4.1. ==> triangles s'appuyant sur la face decoupee +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHFB', nompro +cgn write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+8 +#endif + call cmchfb ( indtri, triint, + > hettri, aretri, nivtri, + > filtri, pertri, famtri, + > areint, arefad, areqtr, niveau, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + iaux = indtri-7 + write(ulsort,1789) 'TRIANGLE = ', iaux + write(ulsort,1789) 'arete = ', aretri(iaux,1), + > ' de ',somare(1,aretri(iaux,1)), + > ' a ',somare(2,aretri(iaux,1)) + write(ulsort,1789) 'arete = ', aretri(iaux,2), + > ' de ',somare(1,aretri(iaux,2)), + > ' a ',somare(2,aretri(iaux,2)) + write(ulsort,1789) 'arete = ', aretri(iaux,3), + > ' de ',somare(1,aretri(iaux,3)), + > ' a ',somare(2,aretri(iaux,3)) +#endif +c +c 4.2. ==> triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHFC', nompro +cgn write (ulsort,*) '.. triangles de ', indtri + 1, ' a ', indtri+4 +#endif + call cmchfc ( indtri, trigpy, + > hettri, aretri, nivtri, + > filtri, pertri, famtri, + > areint, arext1, arext2, arext3, arext4, + > niveau, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 4 pyramides dans les coins +c==== +c + iaux = cfahex(cofpfh,famhex(lehexa)) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHFD', nompro +#endif + call cmchfd ( indpyr, + > facpyr, cofapy, fampyr, + > hetpyr, filpyr, perpyr, + > trifad, cotrvo, triint, quabas, cofdec, + > indptp, iaux ) +c +#ifdef _DEBUG_HOMARD_ + do 5333 , iaux = indpyr-3, indpyr + write(ulsort,1792) iaux, (facpyr(iaux,jaux),jaux=1,5) + 5333 continue + 1792 format('pyramide ',i6,' : ',5i6) +#endif +c + endif +c +c==== +c 6. Creation des tetraedres +c==== +c + iaux = cfahex(coftfh,famhex(lehexa)) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHFE', nompro +#endif + call cmchfe ( indtet, indptp, + > tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad, cotrvo, triint, trigpy, + > iaux ) +c +#ifdef _DEBUG_HOMARD_ + do 6333 , iaux = indtet-3, indtet + write(ulsort,1793) iaux, (tritet(iaux,jaux),jaux=1,4) + 6333 continue + 1793 format('tetraedre ',i6,' : ',4i6) +#endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch41.F b/src/tool/Creation_Maillage/cmch41.F new file mode 100644 index 00000000..211fcf22 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch41.F @@ -0,0 +1,373 @@ + subroutine cmch41 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 41 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH41' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 1 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p+1 +c + tabaux(1) = 3 + tabaux(2) = 5 + tabaux(3) = 4 + tabaux(4) = 2 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.3. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(6) + somm(2) = listso(7) + somm(3) = listso(8) + somm(4) = listso(5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar(10) + arext2 = listar(12) + arext3 = listar(11) + arext4 = listar( 9) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF1 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S6 +c somm(2) : S7 +c somm(3) : S8 +c somm(4) : S5 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F1S1 +c quabas(2) : F1S4 +c quabas(3) : F1S3 +c quabas(4) : F1S2 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN2NF1 +c arefad(2) : AN4NF1 +c arefad(3) : AN3NF1 +c arefad(4) : AN1NF1 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF3 +c trifad(1,1) : FF3 + 1/2 +c trifad(1,2) : FF3 + 2/1 +c areqtr(1,1) : AS6N2 +c areqtr(1,2) : AS7N2 +c +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 1/2 +c trifad(2,2) : FF5 + 2/1 +c areqtr(2,1) : AS7N4 +c areqtr(2,2) : AS8N4 +c +c trifad(3,0) : FF4 +c trifad(3,1) : FF4 + 1/2 +c trifad(3,2) : FF4 + 2/1 +c areqtr(3,1) : AS8N3 +c areqtr(3,2) : AS5N3 +c +c trifad(4,0) : FF2 +c trifad(4,1) : FF2 + 1/2 +c trifad(4,2) : FF2 + 2/1 +c areqtr(4,1) : AS5N1 +c areqtr(4,2) : AS6N1 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS6N1 +c areint(2) : AS7N1 +c areint(3) : AS8N1 +c areint(4) : AS5N1 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P1A1S6 +c triint(1,2) : P1A1S7 +c triint(2,1) : P1A2S7 +c triint(2,2) : P1A2S8 +c triint(3,1) : P1A1S8 +c triint(3,2) : P1A1S5 +c triint(4,1) : P1A2S5 +c triint(4,2) : P1A2S6 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA10F1 +c trigpy(2) : PA12F1 +c trigpy(3) : PA11F1 +c trigpy(4) : PA9F1 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_41', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_41', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 3, + > trigpy(1), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch42.F b/src/tool/Creation_Maillage/cmch42.F new file mode 100644 index 00000000..530ec852 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch42.F @@ -0,0 +1,373 @@ + subroutine cmch42 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 42 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH42' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 2 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p+1 +c + tabaux(1) = 1 + tabaux(2) = 4 + tabaux(3) = 6 + tabaux(4) = 3 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.3. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(4) + somm(2) = listso(3) + somm(3) = listso(8) + somm(4) = listso(7) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar( 4) + arext2 = listar( 8) + arext3 = listar(12) + arext4 = listar( 7) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF2 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S3 +c somm(2) : S4 +c somm(3) : S7 +c somm(4) : S8 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F2S1 +c quabas(2) : F2S2 +c quabas(3) : F2S5 +c quabas(4) : F2S6 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN1NF2 +c arefad(2) : AN6NF2 +c arefad(3) : AN9NF2 +c arefad(4) : AN5NF2 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 +c +c trifad(2,0) : FF4 +c trifad(2,1) : FF4 + 1/2 +c trifad(2,2) : FF4 + 2/1 +c areqtr(2,1) : AS3N6 +c areqtr(2,2) : AS8N6 +c +c trifad(3,0) : FF6 +c trifad(3,1) : FF6 + 1/2 +c trifad(3,2) : FF6 + 2/1 +c areqtr(3,1) : AS8N9 +c areqtr(3,2) : AS7N9 +c +c trifad(4,0) : FF3 +c trifad(4,1) : FF3 + 1/2 +c trifad(4,2) : FF3 + 2/1 +c areqtr(4,1) : AS7N5 +c areqtr(4,2) : AS4N5 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS4NF2 +c areint(2) : AS3NF2 +c areint(3) : AS8NF2 +c areint(4) : AS7NF2 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P2A5S4 +c triint(1,2) : P2A5S3 +c triint(2,1) : P2A1S3 +c triint(2,2) : P2A1S8 +c triint(3,1) : P2A5S8 +c triint(3,2) : P2A5S7 +c triint(4,1) : P2A1S7 +c triint(4,2) : P2A1S4 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA4F2 +c trigpy(2) : PA8F2 +c trigpy(3) : PA12F2 +c trigpy(4) : PA7F2 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_42', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_42', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(1), 3, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch43.F b/src/tool/Creation_Maillage/cmch43.F new file mode 100644 index 00000000..65b5c1bb --- /dev/null +++ b/src/tool/Creation_Maillage/cmch43.F @@ -0,0 +1,373 @@ + subroutine cmch43 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 43 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH43' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 3 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p+1 +c + tabaux(1) = 2 + tabaux(2) = 6 + tabaux(3) = 5 + tabaux(4) = 1 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.3. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(2) + somm(2) = listso(5) + somm(3) = listso(8) + somm(4) = listso(3) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar( 6) + arext2 = listar(11) + arext3 = listar( 8) + arext4 = listar( 3) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF3 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S2 +c somm(2) : S5 +c somm(3) : S8 +c somm(4) : S3 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F3S1 +c quabas(2) : F3S6 +c quabas(3) : F3S7 +c quabas(4) : F3S4 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN5NF3 +c arefad(2) : AN10NF3 +c arefad(3) : AN7NF3 +c arefad(4) : AN2NF3 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF2 +c trifad(1,1) : FF2 + 1/2 +c trifad(1,2) : FF2 + 2/1 +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 +c +c trifad(2,0) : FF6 +c trifad(2,1) : FF6 + 1/2 +c trifad(2,2) : FF6 + 2/1 +c areqtr(2,1) : AS5N10 +c areqtr(2,2) : AS8N10 +c +c trifad(3,0) : FF5 +c trifad(3,1) : FF5 + 1/2 +c trifad(3,2) : FF5 + 2/1 +c areqtr(3,1) : AS8N7 +c areqtr(3,2) : AS3N7 +c +c trifad(4,0) : FF1 +c trifad(4,1) : FF1 + 1/2 +c trifad(4,2) : FF1 + 2/1 +c areqtr(4,1) : AS3N2 +c areqtr(4,2) : AS2N2 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS2NF3 +c areint(2) : AS5NF3 +c areint(3) : AS8NF3 +c areint(4) : AS3NF3 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P2A5S4 +c triint(1,2) : P2A5S3 +c triint(2,1) : P2A1S3 +c triint(2,2) : P2A1S8 +c triint(3,1) : P2A5S8 +c triint(3,2) : P2A5S7 +c triint(4,1) : P2A1S7 +c triint(4,2) : P2A1S4 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA6F3 +c trigpy(2) : PA11F3 +c trigpy(3) : PA8F3 +c trigpy(4) : PA3F3 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_43', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_43', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 3, + > trigpy(1), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch44.F b/src/tool/Creation_Maillage/cmch44.F new file mode 100644 index 00000000..6bfdc2ba --- /dev/null +++ b/src/tool/Creation_Maillage/cmch44.F @@ -0,0 +1,373 @@ + subroutine cmch44 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 44 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH44' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 4 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p1+1 +c + tabaux(1) = 1 + tabaux(2) = 5 + tabaux(3) = 6 + tabaux(4) = 2 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.2. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(1) + somm(2) = listso(4) + somm(3) = listso(7) + somm(4) = listso(6) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar( 2) + arext2 = listar( 7) + arext3 = listar(10) + arext4 = listar( 5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF5 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S1 +c somm(2) : S4 +c somm(3) : S7 +c somm(4) : S6 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F4S2 +c quabas(2) : F4S3 +c quabas(3) : F4S8 +c quabas(4) : F4S5 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN3NF4 +c arefad(2) : AN8NF4 +c arefad(3) : AN11NF4 +c arefad(4) : AN6NF4 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 +c +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 1/2 +c trifad(2,2) : FF5 + 2/1 +c areqtr(2,1) : AS4N8 +c areqtr(2,2) : AS7N8 +c +c trifad(3,0) : FF6 +c trifad(3,1) : FF6 + 1/2 +c trifad(3,2) : FF6 + 2/1 +c areqtr(3,1) : AS7N11 +c areqtr(3,2) : AS6N11 +c +c trifad(4,0) : FF2 +c trifad(4,1) : FF2 + 1/2 +c trifad(4,2) : FF2 + 2/1 +c areqtr(4,1) : AS6N6 +c areqtr(4,2) : AS1N6 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS1NF4 +c areint(2) : AS4NF4 +c areint(3) : AS7NF4 +c areint(4) : AS6NF4 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P4A5S1 +c triint(1,2) : P4A5S4 +c triint(2,1) : P4A2S4 +c triint(2,2) : P4A2S7 +c triint(3,1) : P4A5S7 +c triint(3,2) : P4A5S6 +c triint(4,1) : P4A2S6 +c triint(4,2) : P4A2S1 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA2F4 +c trigpy(2) : PA7F4 +c trigpy(3) : PA10F4 +c trigpy(4) : PA5F4 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_44', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_44', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 3, + > trigpy(1), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch45.F b/src/tool/Creation_Maillage/cmch45.F new file mode 100644 index 00000000..0c739fda --- /dev/null +++ b/src/tool/Creation_Maillage/cmch45.F @@ -0,0 +1,373 @@ + subroutine cmch45 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 45 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH45' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 5 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p+1 +c + tabaux(1) = 1 + tabaux(2) = 3 + tabaux(3) = 6 + tabaux(4) = 4 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.3. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(2) + somm(2) = listso(1) + somm(3) = listso(6) + somm(4) = listso(5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar( 1) + arext2 = listar( 5) + arext3 = listar( 9) + arext4 = listar( 6) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF5 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S2 +c somm(2) : S1 +c somm(3) : S6 +c somm(4) : S5 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F5S3 +c quabas(2) : F5S4 +c quabas(3) : F5S7 +c quabas(4) : F5S8 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN4NF5 +c arefad(2) : AN7NF5 +c arefad(3) : AN12NF5 +c arefad(4) : AN8NF5 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c areqtr(1,1) : AS3N4 +c areqtr(1,2) : AS4N4 +c +c trifad(2,0) : FF3 +c trifad(2,1) : FF3 + 1/2 +c trifad(2,2) : FF3 + 2/1 +c areqtr(2,1) : AS4N7 +c areqtr(2,2) : AS7N7 +c +c trifad(3,0) : FF6 +c trifad(3,1) : FF6 + 1/2 +c trifad(3,2) : FF6 + 2/1 +c areqtr(3,1) : AS7N12 +c areqtr(3,2) : AS8N12 +c +c trifad(4,0) : FF4 +c trifad(4,1) : FF4 + 1/2 +c trifad(4,2) : FF4 + 2/1 +c areqtr(4,1) : AS8N8 +c areqtr(4,2) : AS3N8 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS2NF5 +c areint(2) : AS1NF5 +c areint(3) : AS6NF5 +c areint(4) : AS5NF5 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P2A5S4 +c triint(1,2) : P2A5S3 +c triint(2,1) : P2A1S3 +c triint(2,2) : P2A1S8 +c triint(3,1) : P2A5S8 +c triint(3,2) : P2A5S7 +c triint(4,1) : P2A1S7 +c triint(4,2) : P2A1S4 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA1F5 +c trigpy(2) : PA5F5 +c trigpy(3) : PA9F5 +c trigpy(4) : PA6F5 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_45', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_45', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(1), 3, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch46.F b/src/tool/Creation_Maillage/cmch46.F new file mode 100644 index 00000000..93ee1355 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch46.F @@ -0,0 +1,373 @@ + subroutine cmch46 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - etat 46 +c - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH46' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tabaux(4) + integer somm(4) + integer arext1, arext2, arext3, arext4 + integer trigpy(4) + integer facnde, cofnde +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> le numero local de la face coupee en 4 +c + iaux = 6 +c +c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre +c des pyramides p/p+1 +c + tabaux(1) = 4 + tabaux(2) = 5 + tabaux(3) = 3 + tabaux(4) = 2 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'tabaux(1) = ', tabaux(1), + > 'tabaux(2) = ', tabaux(2), + > 'tabaux(3) = ', tabaux(3), + > 'tabaux(4) = ', tabaux(4) +#endif +c +c 2.3. ==> Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c + somm(1) = listso(2) + somm(2) = listso(3) + somm(3) = listso(4) + somm(4) = listso(1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2), + > 'somm(3) = ', somm(3),'somm(4) = ', somm(4) +#endif +c +c 2.4. ==> Aretes de la face opposee a la face coupee +c arextp relie les pyramides p et p+1 +c + arext1 = listar( 3) + arext2 = listar( 4) + arext3 = listar( 2) + arext4 = listar( 1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2, + > 'arext3 = ', arext3, 'arext4 = ', arext4 +#endif +c +c==== +c 3. Creation +c Noeud central de la face coupee en 4 +c noefac : NF6 +c Sommets de la face opposee a la face coupee +c somm(p) est la pointe de la pyramide fille numero p +c somm(1) : S2 +c somm(2) : S3 +c somm(3) : S4 +c somm(4) : S1 +c Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c quabas(1) : F6S5 +c quabas(2) : F6S8 +c quabas(3) : F6S7 +c quabas(4) : F6S6 +c Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles +c numero p et p+1 +c arefad(1) : AN11NF6 +c arefad(2) : AN12NF6 +c arefad(3) : AN10NF6 +c arefad(4) : AN9NF6 +c Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) : FF4 +c trifad(1,1) : FF4 + 1/2 +c trifad(1,2) : FF4 + 2/1 +c areqtr(1,1) : AS2N11 +c areqtr(1,2) : AS3N11 +c +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 1/2 +c trifad(2,2) : FF5 + 2/1 +c areqtr(2,1) : AS3N12 +c areqtr(2,2) : AS4N12 +c +c trifad(3,0) : FF3 +c trifad(3,1) : FF3 + 1/2 +c trifad(3,2) : FF3 + 2/1 +c areqtr(3,1) : AS4N10 +c areqtr(3,2) : AS1N10 +c +c trifad(4,0) : FF2 +c trifad(4,1) : FF2 + 1/2 +c trifad(4,2) : FF2 + 2/1 +c areqtr(4,1) : AS1N9 +c areqtr(4,2) : AS2N9 +c +c areint(p) relie le sommet somm(p) (de la pyramide fille p) +c au centre de la face coupee +c areint(1) : AS2NF6 +c areint(2) : AS3NF6 +c areint(3) : AS4NF6 +c areint(4) : AS1NF6 +c +c Triangles s'appuyant sur la face decoupee +c triint(p,1) : triangle contenant arefad(p) et de la pyramide p +c triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1 +c triint(1,1) : P6A1S2 +c triint(1,2) : P6A1S3 +c triint(2,1) : P6A2S3 +c triint(2,2) : P6A2S4 +c triint(3,1) : P6A1S4 +c triint(3,2) : P6A1S1 +c triint(4,1) : P6A2S1 +c triint(4,2) : P6A2S2 +c +c Triangles s'appuyant sur les aretes de la face non decoupee +c Ce sont ceux qui bordent la grande pyramide +c trigpy(t) : triangle appuyant sur le tetraedre t +c trigpy(1) : PA3F6 +c trigpy(2) : PA4F6 +c trigpy(3) : PA2F6 +c trigpy(4) : PA1F6 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH40_46', nompro +#endif + call cmch40 ( lehexa, iaux, tabaux, + > somm, arext1, arext2, arext3, arext4, + > indare, indtri, indtet, indpyr, indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > trigpy, facnde, cofnde, + > ulsort, langue, codret ) +c +c==== +c 4. Pyramide s'appuyant sur la face non decoupee, +c dite la 'grosse pyramide' +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_46', nompro +#endif + iaux = fampyr(indpyr) + jaux = -indptp + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trigpy(4), 3, + > trigpy(3), 3, + > trigpy(2), 3, + > trigpy(1), 2, + > facnde, cofnde, + > jaux, iaux, indpyr ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch61.F b/src/tool/Creation_Maillage/cmch61.F new file mode 100644 index 00000000..e7ac62d7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch61.F @@ -0,0 +1,509 @@ + subroutine cmch61 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 61 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH61' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 1 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(7) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(8) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de S1 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S2 : FF1 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 + laface = f1 + coface = cf1 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF2 +c trifad(2,1) = triangle de la face 2 du cote de S1 : FF2 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S2 : FF2 + 1/2 +c areqtr(2,1) : AS6N1 +c areqtr(2,2) : AS5N1 + laface = f2 + coface = cf2 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N1 +c somm(1) : S7 +c somm(2) : S8 +c areint(1) : AS7N1 +c areint(2) : AS8N1 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS3N1 +c areqtr(2,1) : AS6N1 +c areqtr(2,2) : AS5N1 +c areint(1) : AS7N1 +c areint(2) : AS8N1 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN1A7 +c triint(2) : FN1A8 +c triint(3) : FN1A10 +c triint(4) : FN1A11 +c triint(5) : FN1A12 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_61', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 7), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 8), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar(10), areqtr(2,1), areint(1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(11), areqtr(2,2), areint(2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar(12), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'triint(5) = ', triint(5), + > ' a1 ',aretri(triint(5),1), + > ' a2 ',aretri(triint(5),2), + > ' a3 ',aretri(triint(5),3) + write(ulsort,1789) 'triint(4) = ', triint(4), + > ' a1 ',aretri(triint(4),1), + > ' a2 ',aretri(triint(4),2), + > ' a3 ',aretri(triint(4),3) + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > ' a1 ',aretri(trifad(2,0),1), + > ' a2 ',aretri(trifad(2,0),2), + > ' a3 ',aretri(trifad(2,0),3) + write(ulsort,1789) 'triint(3) = ', triint(3), + > ' a1 ',aretri(triint(3),1), + > ' a2 ',aretri(triint(3),2), + > ' a3 ',aretri(triint(3),3) +#endif +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c trifad(2,0) : FF2 +c trifad(2,1) : FF2 + 2/1 +c trifad(2,2) : FF2 + 1/2 +c triint(1) : FN1A7 +c triint(2) : FN1A8 +c triint(3) : FN1A10 +c triint(4) : FN1A11 +c triint(5) : FN1A12 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_61', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 3, + > triint(1), 6, + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > triint(2), 3, + > triint(4), 5, + > trifad(2,2), cotrvo(2,2), + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,0), cotrvo(1,0), + > triint(1), 3, + > triint(5), 3, + > triint(2), 6, + > f5, cf5, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(2,0), cotrvo(2,0), + > triint(4), 3, + > triint(5), 5, + > triint(3), 6, + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch62.F b/src/tool/Creation_Maillage/cmch62.F new file mode 100644 index 00000000..ddc045af --- /dev/null +++ b/src/tool/Creation_Maillage/cmch62.F @@ -0,0 +1,491 @@ + subroutine cmch62 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 62 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH62' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 2 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(5) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(8) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF1 + 2/1 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF1 + 1/2 +c areqtr(1,1) : AS2N2 +c areqtr(1,2) : AS3N2 + laface = f1 + coface = cf1 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de S2 : FF3 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S3 : FF3 + 2/1 +c areqtr(2,1) : AS6N2 +c areqtr(2,2) : AS7N2 + laface = f3 + coface = cf3 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 1 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 5 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N2 +c somm(1) : S5 +c somm(2) : S8 +c areint(1) : AS5N2 +c areint(2) : AS8N2 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N2 +c areqtr(1,2) : AS3N2 +c areqtr(2,1) : AS6N2 +c areqtr(2,2) : AS7N2 +c areint(1) : AS5N2 +c areint(2) : AS8N2 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN2A6 +c triint(2) : FN2A8 +c triint(3) : FN2A9 +c triint(4) : FN2A12 +c triint(5) : FN2A11 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_62', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 6), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 8), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 9), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(12), areqtr(2,2), areint(2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar(11), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 2/1 +c trifad(1,2) : FF1 + 1/2 +c trifad(2,0) : FF3 +c trifad(2,1) : FF3 + 1/2 +c trifad(2,2) : FF3 + 2/1 +c triint(1) : FN2A6 +c triint(2) : FN2A8 +c triint(3) : FN2A9 +c triint(4) : FN2A12 +c triint(5) : FN2A11 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_62', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > triint(1), 3, + > triint(3), 3, + > trifad(2,1), cotrvo(2,1), + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,0), cotrvo(1,0), + > triint(2), 3, + > triint(5), 5, + > triint(1), 6, + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 3, + > triint(2), 6, + > f5, cf5, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 5, + > triint(5), 3, + > triint(4), 5, + > trifad(2,0), cotrvo(2,0), + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch63.F b/src/tool/Creation_Maillage/cmch63.F new file mode 100644 index 00000000..f3bf99a0 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch63.F @@ -0,0 +1,491 @@ + subroutine cmch63 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 63 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH63' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 3 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(6) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(7) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF1 + 2/1 +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 + laface = f1 + coface = cf1 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de S2 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S3 : FF4 + 1/2 +c areqtr(2,1) : AS5N3 +c areqtr(2,2) : AS8N3 + laface = f4 + coface = cf4 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N3 +c somm(1) : S6 +c somm(2) : S7 +c areint(1) : AS6N3 +c areint(2) : AS7N3 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS1N3 +c areqtr(1,2) : AS4N3 +c areqtr(2,1) : AS5N3 +c areqtr(2,2) : AS8N3 +c areint(1) : AS6N3 +c areint(2) : AS7N3 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN3A5 +c triint(2) : FN3A7 +c triint(3) : FN3A9 +c triint(4) : FN3A12 +c triint(5) : FN3A10 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_63', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 5), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 7), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 9), areqtr(2,1), areint(1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(12), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar(10), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c trifad(2,0) : FF4 +c trifad(2,1) : FF4 + 2/1 +c trifad(2,2) : FF4 + 1/2 +c triint(1) : FN3A5 +c triint(2) : FN3A7 +c triint(3) : FN3A9 +c triint(4) : FN3A12 +c triint(5) : FN3A10 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_63', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 3, + > triint(1), 6, + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,0), cotrvo(1,0), + > triint(1), 3, + > triint(5), 3, + > triint(2), 6, + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > triint(2), 3, + > triint(4), 3, + > trifad(2,2), cotrvo(2,2), + > f5, cf5, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 5, + > trifad(2,0), cotrvo(2,0), + > triint(4), 5, + > triint(5), 6, + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch64.F b/src/tool/Creation_Maillage/cmch64.F new file mode 100644 index 00000000..9bfca44d --- /dev/null +++ b/src/tool/Creation_Maillage/cmch64.F @@ -0,0 +1,491 @@ + subroutine cmch64 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 64 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH64' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 4 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(5) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(6) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF1 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF1 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF1 + 2/1 +c areqtr(1,1) : AS2N4 +c areqtr(1,2) : AS1N4 + laface = f1 + coface = cf1 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de S3 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S4 : FF5 + 1/2 +c areqtr(2,1) : AS8N4 +c areqtr(2,2) : AS7N4 + laface = f5 + coface = cf5 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N4 +c somm(1) : S5 +c somm(2) : S6 +c areint(1) : AS5N4 +c areint(2) : AS6N4 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N4 +c areqtr(1,2) : AS1N4 +c areqtr(2,1) : AS8N4 +c areqtr(2,2) : AS7N4 +c areint(1) : AS5N4 +c areint(2) : AS6N4 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN4A6 +c triint(2) : FN4A5 +c triint(3) : FN4A11 +c triint(4) : FN4A10 +c triint(5) : FN4A9 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_64', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 6), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 5), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar(11), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(10), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 9), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF1 +c trifad(1,1) : FF1 + 1/2 +c trifad(1,2) : FF1 + 2/1 +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 2/1 +c trifad(2,2) : FF5 + 1/2 +c triint(1) : FN4A6 +c triint(2) : FN4A5 +c triint(3) : FN4A11 +c triint(4) : FN4A10 +c triint(5) : FN4A9 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_64', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,0), cotrvo(1,0), + > triint(1), 3, + > triint(5), 3, + > triint(2), 6, + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > triint(2), 3, + > triint(4), 3, + > trifad(2,2), cotrvo(2,2), + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 5, + > triint(1), 6, + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 5, + > triint(3), 3, + > trifad(2,0), cotrvo(2,0), + > triint(4), 6, + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch65.F b/src/tool/Creation_Maillage/cmch65.F new file mode 100644 index 00000000..a124964f --- /dev/null +++ b/src/tool/Creation_Maillage/cmch65.F @@ -0,0 +1,491 @@ + subroutine cmch65 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 65 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH65' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 5 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(3) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(8) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de S1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S6 : FF2 + 2/1 +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 + laface = f2 + coface = cf2 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 1 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 5 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de S1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S6 : FF3 + 1/2 +c areqtr(2,1) : AS4N5 +c areqtr(2,2) : AS7N5 + laface = f3 + coface = cf3 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N5 +c somm(1) : S4 +c somm(2) : S7 +c areint(1) : AS3N5 +c areint(2) : AS8N5 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N5 +c areqtr(1,2) : AS5N5 +c areqtr(2,1) : AS4N5 +c areqtr(2,2) : AS7N5 +c areint(1) : AS3N5 +c areint(2) : AS8N5 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN5A3 +c triint(2) : FN5A11 +c triint(3) : FN5A4 +c triint(4) : FN5A12 +c triint(5) : FN5A8 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_65', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 3), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar(11), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 4), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(12), areqtr(2,2), areint(2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 8), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF2 +c trifad(1,1) : FF2 + 1/2 +c trifad(1,2) : FF2 + 2/1 +c trifad(2,0) : FF3 +c trifad(2,1) : FF3 + 2/1 +c trifad(2,2) : FF3 + 1/2 +c triint(1) : FN5A3 +c triint(2) : FN5A11 +c triint(3) : FN5A4 +c triint(4) : FN5A12 +c triint(5) : FN5A8 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_65', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 5, + > triint(1), 6, + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > triint(5), 3, + > triint(2), 5, + > trifad(1,0), cotrvo(1,0), + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > trifad(2,0), cotrvo(2,0), + > triint(4), 3, + > triint(5), 6, + > f5, cf5, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > triint(2), 3, + > triint(4), 5, + > trifad(2,2), cotrvo(2,2), + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch66.F b/src/tool/Creation_Maillage/cmch66.F new file mode 100644 index 00000000..be86f263 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch66.F @@ -0,0 +1,474 @@ + subroutine cmch66 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 66 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH66' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 6 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(4) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(7) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S5 : FF2 + 2/1 +c areqtr(1,1) : AS1N6 +c areqtr(1,2) : AS6N6 + laface = f2 + coface = cf2 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de S2 : FF4 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S5 : FF4 + 2/1 +c areqtr(2,1) : AS3N6 +c areqtr(2,2) : AS8N6 + laface = f4 + coface = cf4 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 1 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 5 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N6 +c somm(1) : S4 +c somm(2) : S7 +c areint(1) : AS4N6 +c areint(2) : AS7N6 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS1N6 +c areqtr(1,2) : AS6N6 +c areqtr(2,1) : AS3N6 +c areqtr(2,2) : AS8N6 +c areint(1) : AS4N6 +c areint(2) : AS7N6 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN6A2 +c triint(2) : FN6A10 +c triint(3) : FN6A4 +c triint(4) : FN6A12 +c triint(5) : FN6A7 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_66', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 2), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar(10), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 4), areqtr(2,1), areint(1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(12), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 7), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF2 +c trifad(1,1) : FF2 + 1/2 +c trifad(1,2) : FF2 + 2/1 +c trifad(2,0) : FF4 +c trifad(2,1) : FF4 + 1/2 +c trifad(2,2) : FF4 + 2/1 +c triint(1) : FN6A2 +c triint(2) : FN6A10 +c triint(3) : FN6A4 +c triint(4) : FN6A12 +c triint(5) : FN6A7 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_66', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > triint(1), 3, + > triint(3), 5, + > trifad(2,1), cotrvo(2,1), + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > trifad(1,0), cotrvo(1,0), + > triint(2), 3, + > triint(5), 6, + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > triint(5), 3, + > triint(4), 3, + > trifad(2,0), cotrvo(2,0), + > f5, cf5, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 5, + > triint(2), 6, + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch67.F b/src/tool/Creation_Maillage/cmch67.F new file mode 100644 index 00000000..b0f228a6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch67.F @@ -0,0 +1,491 @@ + subroutine cmch67 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 67 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH67' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 7 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(2) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(5) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S4 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S7 : FF3 + 2/1 +c areqtr(1,1) : AS1N7 +c areqtr(1,2) : AS6N7 + laface = f3 + coface = cf3 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 1 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 3 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 5 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 5 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de S4 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S7 : FF5 + 1/2 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS8N7 + laface = f5 + coface = cf5 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N7 +c somm(1) : S2 +c somm(2) : S5 +c areint(1) : AS2N7 +c areint(2) : AS5N7 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS1N7 +c areqtr(1,2) : AS6N7 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS8N7 +c areint(1) : AS2N7 +c areint(2) : AS5N7 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN7A1 +c triint(2) : FN7A9 +c triint(3) : FN7A3 +c triint(4) : FN7A11 +c triint(5) : FN7A6 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_67', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 1), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 9), areint(2), areqtr(1,2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 3), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(11), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 6), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF3 +c trifad(1,1) : FF3 + 1/2 +c trifad(1,2) : FF3 + 2/1 +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 2/1 +c trifad(2,2) : FF5 + 1/2 +c triint(1) : FN7A1 +c triint(2) : FN7A9 +c triint(3) : FN7A3 +c triint(4) : FN7A11 +c triint(5) : FN7A6 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_67', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 6, + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > triint(5), 3, + > triint(2), 3, + > trifad(1,0), cotrvo(1,0), + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 3, + > trifad(2,0), cotrvo(2,0), + > triint(4), 5, + > triint(5), 6, + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 5, + > triint(4), 3, + > trifad(2,2), cotrvo(2,2), + > trifad(1,2), cotrvo(1,2), + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch68.F b/src/tool/Creation_Maillage/cmch68.F new file mode 100644 index 00000000..855e8c0c --- /dev/null +++ b/src/tool/Creation_Maillage/cmch68.F @@ -0,0 +1,474 @@ + subroutine cmch68 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 68 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH68' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 8 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(1) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(6) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S3 : FF4 + 2/1 +c trifad(1,2) = triangle de la face 1 du cote de S8 : FF4 + 1/2 +c areqtr(1,1) : AS2N8 +c areqtr(1,2) : AS5N8 + laface = f4 + coface = cf4 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 3 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 5 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de S3 : FF5 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S8 : FF5 + 2/1 +c areqtr(2,1) : AS4N8 +c areqtr(2,2) : AS7N8 + laface = f5 + coface = cf5 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 1 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 5 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N8 +c somm(1) : S1 +c somm(2) : S6 +c areint(1) : AS1N8 +c areint(2) : AS6N8 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N8 +c areqtr(1,2) : AS5N8 +c areqtr(2,1) : AS4N8 +c areqtr(2,2) : AS7N8 +c areint(1) : AS1N8 +c areint(2) : AS6N8 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN8A1 +c triint(2) : FN8A9 +c triint(3) : FN8A2 +c triint(4) : FN8A10 +c triint(5) : FN8A5 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_68', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 1), areint(1), areqtr(1,1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 9), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 2), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar(10), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 5), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF4 +c trifad(1,1) : FF4 + 2/1 +c trifad(1,2) : FF4 + 1/2 +c trifad(2,0) : FF5 +c trifad(2,1) : FF5 + 1/2 +c trifad(2,2) : FF5 + 2/1 +c triint(1) : FN8A1 +c triint(2) : FN8A9 +c triint(3) : FN8A2 +c triint(4) : FN8A10 +c triint(5) : FN8A5 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_68', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(3), 3, + > trifad(2,1), cotrvo(2,1), + > trifad(1,1), cotrvo(1,1), + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > trifad(1,0), cotrvo(1,0), + > triint(2), 3, + > triint(5), 6, + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(3), 5, + > triint(5), 3, + > triint(4), 3, + > trifad(2,0), cotrvo(2,0), + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 5, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 6, + > f6, cf6, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch69.F b/src/tool/Creation_Maillage/cmch69.F new file mode 100644 index 00000000..d234c1f7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch69.F @@ -0,0 +1,509 @@ + subroutine cmch69 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 69 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH69' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 9 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(3) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(4) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 du cote de S5 : FF2 + 2/1 +c trifad(1,2) = triangle de la face 1 du cote de S6 : FF2 + 1/2 +c areqtr(1,1) : AS2N9 +c areqtr(1,2) : AS1N9 + laface = f2 + coface = cf2 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 3 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 5 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de S5 : FF6 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S6 : FF6 + 2/1 +c areqtr(2,1) : AS8N9 +c areqtr(2,2) : AS7N9 + laface = f6 + coface = cf6 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N9 +c somm(1) : S3 +c somm(2) : S4 +c areint(1) : AS3N9 +c areint(2) : AS4N9 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N9 +c areqtr(1,2) : AS1N9 +c areqtr(2,1) : AS8N9 +c areqtr(2,2) : AS7N9 +c areint(1) : AS3N9 +c areint(2) : AS4N9 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN9A3 +c triint(2) : FN9A2 +c triint(3) : FN9A8 +c triint(4) : FN9A7 +c triint(5) : FN9A4 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_69', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 3), areint(1), areqtr(1,1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 2), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 8), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar( 7), areqtr(2,2), areint(2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 4), areint(2), areint(1), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF2 +c trifad(1,1) : FF2 + 2/1 +c trifad(1,2) : FF2 + 1/2 +c trifad(2,0) : FF6 +c trifad(2,1) : FF6 + 1/2 +c trifad(2,2) : FF6 + 2/1 +c triint(1) : FN9A3 +c triint(2) : FN9A2 +c triint(3) : FN9A8 +c triint(4) : FN9A7 +c triint(5) : FN9A4 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_69', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,0), cotrvo(1,0), + > triint(2), 3, + > triint(5), 3, + > triint(1), 2, + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 5, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 6, + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(3), 3, + > trifad(2,1), cotrvo(2,1), + > trifad(1,1), cotrvo(1,1), + > f4, cf4, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'triint(5) = ', triint(5), + > ' a1 ',aretri(triint(5),1), + > ' a2 ',aretri(triint(5),2), + > ' a3 ',aretri(triint(5),3) + write(ulsort,1789) 'triint(4) = ', triint(4), + > ' a1 ',aretri(triint(4),1), + > ' a2 ',aretri(triint(4),2), + > ' a3 ',aretri(triint(4),3) + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > ' a1 ',aretri(trifad(2,0),1), + > ' a2 ',aretri(trifad(2,0),2), + > ' a3 ',aretri(trifad(2,0),3) + write(ulsort,1789) 'triint(3) = ', triint(3), + > ' a1 ',aretri(triint(3),1), + > ' a2 ',aretri(triint(3),2), + > ' a3 ',aretri(triint(3),3) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 5, + > triint(4), 5, + > trifad(2,0), cotrvo(2,0), + > triint(3), 6, + > f5, cf5, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch70.F b/src/tool/Creation_Maillage/cmch70.F new file mode 100644 index 00000000..36884090 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch70.F @@ -0,0 +1,491 @@ + subroutine cmch70 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 70 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH70' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 10 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(2) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(3) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S5 : FF3 + 2/1 +c trifad(1,2) = triangle de la face 1 du cote de S8 : FF3 + 1/2 +c areqtr(1,1) : AS1N10 +c areqtr(1,2) : AS4N10 + laface = f3 + coface = cf3 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 3 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 5 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de S5 : FF6 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S8 : FF6 + 2/1 +c areqtr(2,1) : AS5N10 +c areqtr(2,2) : AS8N10 + laface = f6 + coface = cf6 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N10 +c somm(1) : S2 +c somm(2) : S3 +c areint(1) : AS2N10 +c areint(2) : AS3N10 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS1N10 +c areqtr(1,2) : AS4N10 +c areqtr(2,1) : AS5N10 +c areqtr(2,2) : AS8N10 +c areint(1) : AS2N10 +c areint(2) : AS3N10 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN10A1 +c triint(2) : FN10A4 +c triint(3) : FN10A6 +c triint(4) : FN10A8 +c triint(5) : FN10A3 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_70', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 1), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 4), areint(2), areqtr(1,2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 6), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar( 8), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 3), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF3 +c trifad(1,1) : FF3 + 2/1 +c trifad(1,2) : FF3 + 1/2 +c trifad(2,0) : FF6 +c trifad(2,1) : FF6 + 1/2 +c trifad(2,2) : FF6 + 2/1 +c triint(1) : FN10A1 +c triint(2) : FN10A4 +c triint(3) : FN10A6 +c triint(4) : FN10A8 +c triint(5) : FN10A3 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_70', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > trifad(1,0), cotrvo(1,0), + > triint(2), 5, + > triint(5), 6, + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > triint(3), 3, + > trifad(2,1), cotrvo(2,1), + > trifad(1,1), cotrvo(1,1), + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(4), 3, + > trifad(2,0), cotrvo(2,0), + > triint(3), 6, + > f4, cf4, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 6, + > f5, cf5, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch71.F b/src/tool/Creation_Maillage/cmch71.F new file mode 100644 index 00000000..3b4183d4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch71.F @@ -0,0 +1,491 @@ + subroutine cmch71 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 71 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH71' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 11 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(1) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(4) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S5 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S8 : FF4 + 2/1 +c areqtr(1,1) : AS2N11 +c areqtr(1,2) : AS3N11 + laface = f4 + coface = cf4 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 1 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 3 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 5 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 5 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de S5 : FF6 + 2/1 +c trifad(2,2) = triangle de la face 2 du cote de S8 : FF6 + 1/2 +c areqtr(2,1) : AS6N11 +c areqtr(2,2) : AS7N11 + laface = f6 + coface = cf6 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N11 +c somm(1) : S1 +c somm(2) : S4 +c areint(1) : AS1N11 +c areint(2) : AS4N11 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS2N11 +c areqtr(1,2) : AS3N11 +c areqtr(2,1) : AS6N11 +c areqtr(2,2) : AS7N11 +c areint(1) : AS1N11 +c areint(2) : AS4N11 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN11A1 +c triint(2) : FN11A4 +c triint(3) : FN11A5 +c triint(4) : FN11A7 +c triint(5) : FN11A2 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_71', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 1), areint(1), areqtr(1,1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 4), areqtr(1,2), areint(2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 5), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar( 7), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 2), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF4 +c trifad(1,1) : FF4 + 1/2 +c trifad(1,2) : FF4 + 2/1 +c trifad(2,0) : FF6 +c trifad(2,1) : FF6 + 2/1 +c trifad(2,2) : FF6 + 1/2 +c triint(1) : FN11A1 +c triint(2) : FN11A4 +c triint(3) : FN11A5 +c triint(4) : FN11A7 +c triint(5) : FN11A2 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_71', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(5), 3, + > triint(2), 5, + > trifad(1,0), cotrvo(1,0), + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 3, + > trifad(1,1), cotrvo(1,1), + > trifad(2,1), cotrvo(2,1), + > triint(3), 6, + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 5, + > triint(3), 3, + > trifad(2,0), cotrvo(2,0), + > triint(4), 6, + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > triint(4), 3, + > trifad(2,2), cotrvo(2,2), + > trifad(1,2), cotrvo(1,2), + > f5, cf5, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch72.F b/src/tool/Creation_Maillage/cmch72.F new file mode 100644 index 00000000..d32aeab7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch72.F @@ -0,0 +1,491 @@ + subroutine cmch72 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - etat 72 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH72' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nlarco, nuarco + integer noemil, somm(2) + integer areint(2) + integer areqtr(2,2) + integer triint(5) + integer f1, f2, f3, f4, f5, f6 + integer cf1, cf2, cf3, cf4, cf5, cf6 + integer trifad(2,0:2), cotrvo(2,0:2) + integer niveau + integer laface, coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c 1.2. ==> grandeurs independantes du cas traite (phase 1) +c les faces de l'hexaedre et leurs codes +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) + cf1 = coquhe(lehexa,1) + cf2 = coquhe(lehexa,2) + cf3 = coquhe(lehexa,3) + cf4 = coquhe(lehexa,4) + cf5 = coquhe(lehexa,5) + cf6 = coquhe(lehexa,6) +c +c 1.3. ==> grandeurs dependant du cas traite +c nlarco = numero local de l'arete coupee + nlarco = 12 +c +c nuarco = numero global de l'arete coupee + nuarco = listar(nlarco) +c +c noemil = noeud milieu de l'arete coupee + noemil = somare(2,filare(nuarco)) +c +c somm(1) = sommet a joindre au milieu de l'arete coupee pour +c definir la 1ere arete interne + somm(1) = listso(1) +c somm(2) = sommet a joindre au milieu de l'arete coupee pour +c definir la 2nde arete interne + somm(2) = listso(2) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2000) 'listso', listso + write(ulsort,2000) 'nuarco', nuarco + write(ulsort,2000) 'noemil', noemil + write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2) + 2000 format(a,10i10) + 2001 format(a,i10,', ',a,i10) +#endif +c +c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3 +c L'arete coupee s'appuie sur deux faces de l'hexaedre. +c trifad(1,*) se rapporte a celle de plus petit numero local +c trifad(2,*) se rapporte a celle de plus grand numero local +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a +c le plus petit numero local +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description de la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de S7 : FF5 + 2/1 +c trifad(1,2) = triangle de la face 1 du cote de S8 : FF5 + 1/2 +c areqtr(1,1) : AS4N12 +c areqtr(1,2) : AS3N12 + laface = f5 + coface = cf5 + trifad(1,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 3 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 5 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c trifad(2,0) = triangle central de la face 2 : FF6 +c trifad(2,1) = triangle de la face 2 du cote de S5 : FF6 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de S8 : FF6 + 2/1 +c areqtr(2,1) : AS6N12 +c areqtr(2,2) : AS5N12 + laface = f6 + coface = cf6 + trifad(2,0) = -filqua(laface) + if ( coface.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', laface,', coface = ', coface + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 1.4. ==> grandeurs independantes du cas traite (phase 2) +c +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1400) niveau + 1400 format('niveau =',i3) +#endif +c +c==== +c 2. Creation des deux aretes internes +c noemil : N12 +c somm(1) : S1 +c somm(2) : S2 +c areint(1) : AS1N12 +c areint(2) : AS2N12 +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noemil , somm(iaux) ) + somare(2,areint(iaux)) = max ( noemil , somm(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 21 continue +c + endif +c +c==== +c 3. Creation des cinq triangles internes +c areqtr(1,1) : AS4N12 +c areqtr(1,2) : AS3N12 +c areqtr(2,1) : AS6N12 +c areqtr(2,2) : AS5N12 +c areint(1) : AS1N12 +c areint(2) : AS2N12 +c triint(1) : le triangle contenant l'arete areqtr(1,1) +c triint(3) : le triangle contenant l'arete areqtr(1,2) +c triint(2) : le triangle contenant l'arete areqtr(2,1) +c triint(4) : le triangle contenant l'arete areqtr(2,2) +c triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete +c coupee ; il ne touche donc pas les faces coupees +c triint(1) : FN12A2 +c triint(2) : FN12A3 +c triint(3) : FN12A5 +c triint(4) : FN12A6 +c triint(5) : FN12A1 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_72', nompro + write (ulsort,3000) indtri+1, indtri+5 + 3000 format('.. triangles de',i10,' a',i10) +#endif + triint(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1), listar( 2), areint(1), areqtr(1,1), + > iaux, niveau ) +c + triint(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2), listar( 3),areint(2), areqtr(1,2), + > iaux, niveau ) +c + triint(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3), listar( 5), areint(1), areqtr(2,1), + > iaux, niveau ) +c + triint(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4), listar( 6), areint(2), areqtr(2,2), + > iaux, niveau ) +c + triint(5) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(5), listar( 1), areint(1), areint(2), + > iaux, niveau ) +c + indtri = triint(5) +c +c==== +c 4. Creation des quatre pyramides +c Elles arrivent dans l'ordre de numerotation locale de leur +c quadrangle dans l'hexaedre +c trifad(1,0) : FF5 +c trifad(1,1) : FF5 + 2/1 +c trifad(1,2) : FF5 + 1/2 +c trifad(2,0) : FF6 +c trifad(2,1) : FF6 + 1/2 +c trifad(2,2) : FF6 + 2/1 +c triint(1) : FN12A2 +c triint(2) : FN12A3 +c triint(3) : FN12A5 +c triint(4) : FN12A6 +c triint(5) : FN12A1 +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) + iaux = -indptp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_72', nompro + write (ulsort,4000) indpyr+1, indpyr+4 + 4000 format('.. pyramides de',i10,' a',i10) +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 5, + > triint(1), 3, + > trifad(1,0), cotrvo(1,0), + > triint(2), 6, + > f1, cf1, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(5), 3, + > triint(4), 3, + > trifad(2,0), cotrvo(2,0), + > triint(3), 6, + > f2, cf2, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 5, + > triint(3), 3, + > trifad(2,1), cotrvo(2,1), + > trifad(1,1), cotrvo(1,1), + > f3, cf3, + > iaux, jaux, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(2), 3, + > trifad(1,2), cotrvo(1,2), + > trifad(2,2), cotrvo(2,2), + > triint(4), 6, + > f4, cf4, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch81.F b/src/tool/Creation_Maillage/cmch81.F new file mode 100644 index 00000000..b53028cb --- /dev/null +++ b/src/tool/Creation_Maillage/cmch81.F @@ -0,0 +1,479 @@ + subroutine cmch81 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 81 +c -- +c Decoupage par les aretes 1, 7 et 11 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH81' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S2 +c lesnoe(3) = S7 +c lesnoe(4) = S4 +c lesnoe(5) = S5 +c lesnoe(6) = S8 +c lesnoe(7) = S6 +c lesnoe(8) = S3 +c lesnoe( 9) = N1 +c lesnoe(10) = N7 +c lesnoe(11) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(2) + lesnoe(3) = listso(7) + lesnoe(4) = listso(4) + lesnoe(5) = listso(5) + lesnoe(6) = listso(8) + lesnoe(7) = listso(6) + lesnoe(8) = listso(3) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 7 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 11 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS6N1 +c areqtr(1,2) : AS5N1 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS4N1 +c areqtr(2,2) : AS3N1 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF3 + 2/1 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 1/2 +c areqtr(3,1) : AS6N7 +c areqtr(3,2) : AS1N7 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF5 + 1/2 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 2/1 +c areqtr(4,1) : AS8N7 +c areqtr(4,2) : AS3N7 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS6N11 +c areqtr(5,2) : AS7N11 +c +c trifad(6,0) = triangle central de la face 6 : FF4 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF4 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF4 + 2/1 +c areqtr(6,1) : AS2N11 +c areqtr(6,2) : AS3N11 +c + nulofa(1) = 2 + nulofa(2) = 1 + nulofa(3) = 3 + nulofa(4) = 5 + nulofa(5) = 6 + nulofa(6) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAL', nompro +#endif + call cmchal ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS1N0 +c areint( 2) : AS2N0 +c areint( 3) : AS7N0 +c areint( 4) : AS4N0 +c areint( 5) : AS5N0 +c areint( 6) : AS8N0 +c areint( 7) : AS6N0 +c areint( 8) : AS3N0 +c areint( 9) : AN1N0 +c areint(10) : AN7N0 +c areint(11) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA9 +c triint( 2) : FA4 +c triint( 3) : FA5 +c triint( 4) : FA8 +c triint( 5) : FA10 +c triint( 6) : FA3 +c triint( 7) : FA12 +c triint( 8) : FA6 +c triint( 9) : FA2 +c triint(10) : FS6N1 +c triint(11) : FS5N1 +c triint(12) : FS4N1 +c triint(13) : FS3N1 +c triint(14) : FS6N7 +c triint(15) : FS1N7 +c triint(16) : FS8N7 +c triint(17) : FS3N7 +c triint(18) : FS6N11 +c triint(19) : FS7N11 +c triint(20) : FS2N11 +c triint(21) : FS3N11 +c triint(22) : FS1N1 +c triint(23) : FS2N1 +c triint(24) : FS7N7 +c triint(25) : FS4N7 +c triint(26) : FS5N11 +c triint(27) : FS8N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(9) + lesare( 2) = listar(4) + lesare( 3) = listar(5) + lesare( 4) = listar(8) + lesare( 5) = listar(10) + lesare( 6) = listar(3) + lesare( 7) = listar(12) + lesare( 8) = listar(6) + lesare( 9) = listar(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAP', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchap ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAN', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 81 + call cmchan ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch82.F b/src/tool/Creation_Maillage/cmch82.F new file mode 100644 index 00000000..af006ab3 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch82.F @@ -0,0 +1,479 @@ + subroutine cmch82 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 82 +c -- +c Decoupage par les aretes 1, 8 et 10 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH82' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S1 +c lesnoe(3) = S8 +c lesnoe(4) = S3 +c lesnoe(5) = S6 +c lesnoe(6) = S7 +c lesnoe(7) = S5 +c lesnoe(8) = S4 +c lesnoe( 9) = N1 +c lesnoe(10) = N8 +c lesnoe(11) = N10 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(8) + lesnoe(4) = listso(3) + lesnoe(5) = listso(6) + lesnoe(6) = listso(7) + lesnoe(7) = listso(5) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 1 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 8 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 10 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF2 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF2 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF2 + 2/1 +c areqtr(1,1) : AS5N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS3N1 +c areqtr(2,2) : AS4N1 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS5N8 +c areqtr(3,2) : AS2N8 +c +c trifad(4,0) = triangle central de la face 4 : FF5 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF5 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF5 + 1/2 +c areqtr(4,1) : AS7N8 +c areqtr(4,2) : AS4N8 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS5N10 +c areqtr(5,2) : AS8N10 +c +c trifad(6,0) = triangle central de la face 6 : FF3 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF3 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF3 + 2/1 +c areqtr(6,1) : AS1N10 +c areqtr(6,2) : AS4N10 +c + nulofa(1) = 2 + nulofa(2) = 1 + nulofa(3) = 4 + nulofa(4) = 5 + nulofa(5) = 6 + nulofa(6) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAK', nompro +#endif + call cmchak ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS1N0 +c areint( 3) : AS8N0 +c areint( 4) : AS3N0 +c areint( 5) : AS6N0 +c areint( 6) : AS7N0 +c areint( 7) : AS5N0 +c areint( 8) : AS4N0 +c areint( 9) : AN1N0 +c areint(10) : AN8N0 +c areint(11) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA9 +c triint( 2) : FA4 +c triint( 3) : FA6 +c triint( 4) : FA7 +c triint( 5) : FA11 +c triint( 6) : FA2 +c triint( 7) : FA12 +c triint( 8) : FA5 +c triint( 9) : FA3 +c triint(10) : FS5N1 +c triint(11) : FS6N1 +c triint(12) : FS3N1 +c triint(13) : FS4N1 +c triint(14) : FS5N8 +c triint(15) : FS2N8 +c triint(16) : FS7N8 +c triint(17) : FS4N8 +c triint(18) : FS5N10 +c triint(19) : FS8N10 +c triint(20) : FS1N10 +c triint(21) : FS4N10 +c triint(22) : FS2N1 +c triint(23) : FS1N1 +c triint(24) : FS8N8 +c triint(25) : FS3N8 +c triint(26) : FS6N10 +c triint(27) : FS7N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(9) + lesare( 2) = listar(4) + lesare( 3) = listar(6) + lesare( 4) = listar(7) + lesare( 5) = listar(11) + lesare( 6) = listar(2) + lesare( 7) = listar(12) + lesare( 8) = listar(5) + lesare( 9) = listar(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAT', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchat ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAM', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 82 + call cmcham ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch83.F b/src/tool/Creation_Maillage/cmch83.F new file mode 100644 index 00000000..5c6320a1 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch83.F @@ -0,0 +1,479 @@ + subroutine cmch83 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 83 +c -- +c Decoupage par les aretes 2, 6 et 12 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH83' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S1 +c lesnoe(2) = S4 +c lesnoe(3) = S5 +c lesnoe(4) = S2 +c lesnoe(5) = S7 +c lesnoe(6) = S8 +c lesnoe(7) = S6 +c lesnoe(8) = S3 +c lesnoe( 9) = N2 +c lesnoe(10) = N6 +c lesnoe(11) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(1) + lesnoe(2) = listso(4) + lesnoe(3) = listso(5) + lesnoe(4) = listso(2) + lesnoe(5) = listso(7) + lesnoe(6) = listso(8) + lesnoe(7) = listso(6) + lesnoe(8) = listso(3) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 6 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 12 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS6N2 +c areqtr(1,2) : AS7N2 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS2N2 +c areqtr(2,2) : AS3N2 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1 +c areqtr(3,1) : AS6N6 +c areqtr(3,2) : AS1N6 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS8N6 +c areqtr(4,2) : AS3N6 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS6N12 +c areqtr(5,2) : AS5N12 +c +c trifad(6,0) = triangle central de la face 6 : FF5 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF5 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF5 + 2/1 +c areqtr(6,1) : AS4N12 +c areqtr(6,2) : AS3N12 +c + nulofa(1) = 3 + nulofa(2) = 1 + nulofa(3) = 2 + nulofa(4) = 4 + nulofa(5) = 6 + nulofa(6) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAK', nompro +#endif + call cmchak ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS1N0 +c areint( 2) : AS4N0 +c areint( 3) : AS5N0 +c areint( 4) : AS2N0 +c areint( 5) : AS7N0 +c areint( 6) : AS8N0 +c areint( 7) : AS6N0 +c areint( 8) : AS3N0 +c areint( 9) : AN2N0 +c areint(10) : AN6N0 +c areint(11) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA10 +c triint( 2) : FA3 +c triint( 3) : FA5 +c triint( 4) : FA8 +c triint( 5) : FA9 +c triint( 6) : FA4 +c triint( 7) : FA11 +c triint( 8) : FA7 +c triint( 9) : FA1 +c triint(10) : FS6N2 +c triint(11) : FS7N2 +c triint(12) : FS2N2 +c triint(13) : FS3N2 +c triint(14) : FS6N6 +c triint(15) : FS1N6 +c triint(16) : FS8N6 +c triint(17) : FS3N6 +c triint(18) : FS6N12 +c triint(19) : FS5N12 +c triint(20) : FS4N12 +c triint(21) : FS3N12 +c triint(22) : FS1N2 +c triint(23) : FS4N2 +c triint(24) : FS5N6 +c triint(25) : FS2N6 +c triint(26) : FS7N12 +c triint(27) : FS8N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(10) + lesare( 2) = listar(3) + lesare( 3) = listar(5) + lesare( 4) = listar(8) + lesare( 5) = listar(9) + lesare( 6) = listar(4) + lesare( 7) = listar(11) + lesare( 8) = listar(7) + lesare( 9) = listar(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAU', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchau ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAM', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 83 + call cmcham ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch84.F b/src/tool/Creation_Maillage/cmch84.F new file mode 100644 index 00000000..ddf03196 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch84.F @@ -0,0 +1,479 @@ + subroutine cmch84 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 84 +c -- +c Decoupage par les aretes 2, 8 et 9 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH84' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S1 +c lesnoe(3) = S8 +c lesnoe(4) = S3 +c lesnoe(5) = S6 +c lesnoe(6) = S5 +c lesnoe(7) = S7 +c lesnoe(8) = S2 +c lesnoe( 9) = N2 +c lesnoe(10) = N8 +c lesnoe(11) = N9 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(4) + lesnoe(2) = listso(1) + lesnoe(3) = listso(8) + lesnoe(4) = listso(3) + lesnoe(5) = listso(6) + lesnoe(6) = listso(5) + lesnoe(7) = listso(7) + lesnoe(8) = listso(2) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 2 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 8 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 9 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF3 + 2/1 +c areqtr(1,1) : AS7N2 +c areqtr(1,2) : AS6N2 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS3N2 +c areqtr(2,2) : AS2N2 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS7N8 +c areqtr(3,2) : AS4N8 +c +c trifad(4,0) = triangle central de la face 4 : FF4 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF4 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF4 + 1/2 +c areqtr(4,1) : AS5N8 +c areqtr(4,2) : AS2N8 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS7N9 +c areqtr(5,2) : AS8N9 +c +c trifad(6,0) = triangle central de la face 6 : FF2 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF2 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF2 + 2/1 +c areqtr(6,1) : AS1N9 +c areqtr(6,2) : AS2N9 +c + nulofa(1) = 3 + nulofa(2) = 1 + nulofa(3) = 5 + nulofa(4) = 4 + nulofa(5) = 6 + nulofa(6) = 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAL', nompro +#endif + call cmchal ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS4N0 +c areint( 2) : AS1N0 +c areint( 3) : AS8N0 +c areint( 4) : AS3N0 +c areint( 5) : AS6N0 +c areint( 6) : AS5N0 +c areint( 7) : AS7N0 +c areint( 8) : AS2N0 +c areint( 9) : AN2N0 +c areint(10) : AN8N0 +c areint(11) : AN9N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA10 +c triint( 2) : FA3 +c triint( 3) : FA7 +c triint( 4) : FA4 +c triint( 5) : FA12 +c triint( 6) : FA1 +c triint( 7) : FA11 +c triint( 8) : FA5 +c triint( 9) : FA4 +c triint(10) : FS7N2 +c triint(11) : FS6N2 +c triint(12) : FS3N2 +c triint(13) : FS2N2 +c triint(14) : FS7N8 +c triint(15) : FS4N8 +c triint(16) : FS5N8 +c triint(17) : FS2N8 +c triint(18) : FS7N9 +c triint(19) : FS8N9 +c triint(20) : FS1N9 +c triint(21) : FS2N9 +c triint(22) : FS4N2 +c triint(23) : FS1N2 +c triint(24) : FS8N8 +c triint(25) : FS3N8 +c triint(26) : FS6N9 +c triint(27) : FS5N9 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(10) + lesare( 2) = listar(3) + lesare( 3) = listar(7) + lesare( 4) = listar(6) + lesare( 5) = listar(12) + lesare( 6) = listar(1) + lesare( 7) = listar(11) + lesare( 8) = listar(5) + lesare( 9) = listar(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAQ', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchaq ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAN', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 84 + call cmchan ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch85.F b/src/tool/Creation_Maillage/cmch85.F new file mode 100644 index 00000000..a2879655 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch85.F @@ -0,0 +1,479 @@ + subroutine cmch85 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 85 +c -- +c Decoupage par les aretes 3, 5 et 12 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH85' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S2 +c lesnoe(2) = S3 +c lesnoe(3) = S6 +c lesnoe(4) = S1 +c lesnoe(5) = S8 +c lesnoe(6) = S7 +c lesnoe(7) = S5 +c lesnoe(8) = S4 +c lesnoe( 9) = N3 +c lesnoe(10) = N5 +c lesnoe(11) = N12 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(2) + lesnoe(2) = listso(3) + lesnoe(3) = listso(6) + lesnoe(4) = listso(1) + lesnoe(5) = listso(8) + lesnoe(6) = listso(7) + lesnoe(7) = listso(5) + lesnoe(8) = listso(4) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 5 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 12 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS5N3 +c areqtr(1,2) : AS8N3 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS1N3 +c areqtr(2,2) : AS4N3 +c +c trifad(3,0) = triangle central de la face 3 : FF2 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF2 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF2 + 2/1 +c areqtr(3,1) : AS5N5 +c areqtr(3,2) : AS2N5 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS7N5 +c areqtr(4,2) : AS4N5 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS5N12 +c areqtr(5,2) : AS6N12 +c +c trifad(6,0) = triangle central de la face 6 : FF5 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF5 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF5 + 2/1 +c areqtr(6,1) : AS3N12 +c areqtr(6,2) : AS4N12 +c + nulofa(1) = 4 + nulofa(2) = 1 + nulofa(3) = 2 + nulofa(4) = 3 + nulofa(5) = 6 + nulofa(6) = 5 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAL', nompro +#endif + call cmchal ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS2N0 +c areint( 2) : AS3N0 +c areint( 3) : AS6N0 +c areint( 4) : AS1N0 +c areint( 5) : AS8N0 +c areint( 6) : AS7N0 +c areint( 7) : AS5N0 +c areint( 8) : AS4N0 +c areint( 9) : AN3N0 +c areint(10) : AN5N0 +c areint(11) : AN12N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA11 +c triint( 2) : FA2 +c triint( 3) : FA6 +c triint( 4) : FA7 +c triint( 5) : FA9 +c triint( 6) : FA4 +c triint( 7) : FA10 +c triint( 8) : FA8 +c triint( 9) : FA1 +c triint(10) : FS5N3 +c triint(11) : FS8N3 +c triint(12) : FS1N3 +c triint(13) : FS4N3 +c triint(14) : FS5N5 +c triint(15) : FS2N5 +c triint(16) : FS7N5 +c triint(17) : FS4N5 +c triint(18) : FS5N12 +c triint(19) : FS6N12 +c triint(20) : FS3N12 +c triint(21) : FS4N12 +c triint(22) : FS2N3 +c triint(23) : FS3N3 +c triint(24) : FS6N5 +c triint(25) : FS1N5 +c triint(26) : FS8N12 +c triint(27) : FS7N12 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(11) + lesare( 2) = listar(2) + lesare( 3) = listar(6) + lesare( 4) = listar(7) + lesare( 5) = listar(9) + lesare( 6) = listar(4) + lesare( 7) = listar(10) + lesare( 8) = listar(8) + lesare( 9) = listar(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAR', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchar ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAN', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 85 + call cmchan ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch86.F b/src/tool/Creation_Maillage/cmch86.F new file mode 100644 index 00000000..b5f97827 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch86.F @@ -0,0 +1,479 @@ + subroutine cmch86 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 86 +c -- +c Decoupage par les aretes 3, 7 et 9 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH86' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S2 +c lesnoe(3) = S7 +c lesnoe(4) = S4 +c lesnoe(5) = S5 +c lesnoe(6) = S6 +c lesnoe(7) = S8 +c lesnoe(8) = S1 +c lesnoe( 9) = N3 +c lesnoe(10) = N7 +c lesnoe(11) = N9 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(2) + lesnoe(3) = listso(7) + lesnoe(4) = listso(4) + lesnoe(5) = listso(5) + lesnoe(6) = listso(6) + lesnoe(7) = listso(8) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 3 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 7 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 9 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF4 + 2/1 +c areqtr(1,1) : AS8N3 +c areqtr(1,2) : AS5N3 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS4N3 +c areqtr(2,2) : AS1N3 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF5 + 2/1 +c areqtr(3,1) : AS8N7 +c areqtr(3,2) : AS3N7 +c +c trifad(4,0) = triangle central de la face 4 : FF3 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF3 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF3 + 1/2 +c areqtr(4,1) : AS6N7 +c areqtr(4,2) : AS1N7 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS8N9 +c areqtr(5,2) : AS7N9 +c +c trifad(6,0) = triangle central de la face 6 : FF2 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF2 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF2 + 2/1 +c areqtr(6,1) : AS2N9 +c areqtr(6,2) : AS1N9 +c + nulofa(1) = 4 + nulofa(2) = 1 + nulofa(3) = 5 + nulofa(4) = 3 + nulofa(5) = 6 + nulofa(6) = 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAK', nompro +#endif + call cmchak ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS2N0 +c areint( 3) : AS7N0 +c areint( 4) : AS4N0 +c areint( 5) : AS5N0 +c areint( 6) : AS6N0 +c areint( 7) : AS8N0 +c areint( 8) : AS1N0 +c areint( 9) : AN3N0 +c areint(10) : AN7N0 +c areint(11) : AN9N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA11 +c triint( 2) : FA2 +c triint( 3) : FA8 +c triint( 4) : FA5 +c triint( 5) : FA12 +c triint( 6) : FA1 +c triint( 7) : FA10 +c triint( 8) : FA6 +c triint( 9) : FA4 +c triint(10) : FS8N3 +c triint(11) : FS5N3 +c triint(12) : FS4N3 +c triint(13) : FS1N3 +c triint(14) : FS8N7 +c triint(15) : FS3N7 +c triint(16) : FS6N7 +c triint(17) : FS1N7 +c triint(18) : FS8N9 +c triint(19) : FS7N9 +c triint(20) : FS2N9 +c triint(21) : FS1N9 +c triint(22) : FS3N3 +c triint(23) : FS2N3 +c triint(24) : FS7N7 +c triint(25) : FS4N7 +c triint(26) : FS5N9 +c triint(27) : FS6N9 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(11) + lesare( 2) = listar(2) + lesare( 3) = listar(8) + lesare( 4) = listar(5) + lesare( 5) = listar(12) + lesare( 6) = listar(1) + lesare( 7) = listar(10) + lesare( 8) = listar(6) + lesare( 9) = listar(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAV', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchav ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAM', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 86 + call cmcham ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch87.F b/src/tool/Creation_Maillage/cmch87.F new file mode 100644 index 00000000..d24fbf31 --- /dev/null +++ b/src/tool/Creation_Maillage/cmch87.F @@ -0,0 +1,479 @@ + subroutine cmch87 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 87 +c -- +c Decoupage par les aretes 4, 5 et 11 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH87' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S4 +c lesnoe(2) = S3 +c lesnoe(3) = S6 +c lesnoe(4) = S1 +c lesnoe(5) = S8 +c lesnoe(6) = S5 +c lesnoe(7) = S7 +c lesnoe(8) = S2 +c lesnoe( 9) = N4 +c lesnoe(10) = N5 +c lesnoe(11) = N11 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(4) + lesnoe(2) = listso(3) + lesnoe(3) = listso(6) + lesnoe(4) = listso(1) + lesnoe(5) = listso(8) + lesnoe(6) = listso(5) + lesnoe(7) = listso(7) + lesnoe(8) = listso(2) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 4 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 5 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 11 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1 +c areqtr(1,1) : AS7N4 +c areqtr(1,2) : AS8N4 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS1N4 +c areqtr(2,2) : AS2N4 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF3 + 2/1 +c areqtr(3,1) : AS7N5 +c areqtr(3,2) : AS4N5 +c +c trifad(4,0) = triangle central de la face 4 : FF2 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF2 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF2 + 1/2 +c areqtr(4,1) : AS5N5 +c areqtr(4,2) : AS2N5 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS7N11 +c areqtr(5,2) : AS6N11 +c +c trifad(6,0) = triangle central de la face 6 : FF4 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF4 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF4 + 2/1 +c areqtr(6,1) : AS3N11 +c areqtr(6,2) : AS2N11 +c + nulofa(1) = 5 + nulofa(2) = 1 + nulofa(3) = 3 + nulofa(4) = 2 + nulofa(5) = 6 + nulofa(6) = 4 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAK', nompro +#endif + call cmchak ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS4N0 +c areint( 2) : AS3N0 +c areint( 3) : AS6N0 +c areint( 4) : AS1N0 +c areint( 5) : AS8N0 +c areint( 6) : AS5N0 +c areint( 7) : AS7N0 +c areint( 8) : AS2N0 +c areint( 9) : AN4N0 +c areint(10) : AN5N0 +c areint(11) : AN11N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA12 +c triint( 2) : FA1 +c triint( 3) : FA7 +c triint( 4) : FA6 +c triint( 5) : FA10 +c triint( 6) : FA3 +c triint( 7) : FA9 +c triint( 8) : FA8 +c triint( 9) : FA2 +c triint(10) : FS7N4 +c triint(11) : FS8N4 +c triint(12) : FS1N4 +c triint(13) : FS2N4 +c triint(14) : FS7N5 +c triint(15) : FS4N5 +c triint(16) : FS5N5 +c triint(17) : FS2N5 +c triint(18) : FS7N11 +c triint(19) : FS6N11 +c triint(20) : FS3N11 +c triint(21) : FS2N11 +c triint(22) : FS4N4 +c triint(23) : FS3N4 +c triint(24) : FS6N5 +c triint(25) : FS1N5 +c triint(26) : FS8N11 +c triint(27) : FS5N11 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(12) + lesare( 2) = listar(1) + lesare( 3) = listar(7) + lesare( 4) = listar(6) + lesare( 5) = listar(10) + lesare( 6) = listar(3) + lesare( 7) = listar(9) + lesare( 8) = listar(8) + lesare( 9) = listar(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAW', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchaw ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAM', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 87 + call cmcham ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmch88.F b/src/tool/Creation_Maillage/cmch88.F new file mode 100644 index 00000000..d857a71f --- /dev/null +++ b/src/tool/Creation_Maillage/cmch88.F @@ -0,0 +1,479 @@ + subroutine cmch88 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - etat 88 +c -- +c Decoupage par les aretes 4, 6, 10 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . +c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCH88' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer listar(12), listso(8) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 8 ) +c + integer iaux + integer lesnoe(11), lesare(9) + integer nulofa(6) + integer areint(11) + integer areqtr(6,2) + integer triint(27) + integer trifad(6,0:2), cotrvo(6,0:2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. grandeurs dependant du cas traite +c lesnoe(1) = S3 +c lesnoe(2) = S4 +c lesnoe(3) = S5 +c lesnoe(4) = S2 +c lesnoe(5) = S7 +c lesnoe(6) = S6 +c lesnoe(7) = S8 +c lesnoe(8) = S1 +c lesnoe( 9) = N4 +c lesnoe(10) = N6 +c lesnoe(11) = N10 +c==== +c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour +c definir la ieme arete interne + lesnoe(1) = listso(3) + lesnoe(2) = listso(4) + lesnoe(3) = listso(5) + lesnoe(4) = listso(2) + lesnoe(5) = listso(7) + lesnoe(6) = listso(6) + lesnoe(7) = listso(8) + lesnoe(8) = listso(1) +c +c iaux = numero local de la 1ere arete coupee +c + iaux = 4 +c +c lesnoe(9) = noeud milieu de la 1ere arete coupee + lesnoe(9) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2001) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2002) lesnoe(9) + 2001 format('arete 1 = ',i10,', de filles',2i10) + 2002 format('lesnoe(9)',i10) +#endif +c +c iaux = numero local de la 2eme arete coupee +c + iaux = 6 +c +c lesnoe(10) = noeud milieu de la 2eme arete coupee + lesnoe(10) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2003) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2004) lesnoe(10) + 2003 format('arete 2 = ',i10,', de filles',2i10) + 2004 format('lesnoe(10)',i10) +#endif +c +c iaux = numero local de la 3eme arete coupee +c + iaux = 10 +c +c lesnoe(11) = noeud milieu de la 3eme arete coupee + lesnoe(11) = somare(2,filare(listar(iaux))) +#ifdef _DEBUG_HOMARD_ + write(ulsort,2005) listar(iaux), + > filare(listar(iaux)), filare(listar(iaux))+1 + write(ulsort,2006) lesnoe(11) + 2005 format('arete 3 = ',i10,', de filles',2i10) + 2006 format('lesnoe(11)',i10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,2100) lesnoe(1), lesnoe(2), + > lesnoe(3), lesnoe(4), + > lesnoe(5), lesnoe(6), + > lesnoe(7), lesnoe(8) + 2100 format('lesnoe(1)',i10,', lesnoe(2) = ',i10, + > /,'lesnoe(3)',i10,', lesnoe(4) = ',i10, + > /,'lesnoe(5)',i10,', lesnoe(6) = ',i10, + > /,'lesnoe(7)',i10,', lesnoe(8) = ',i10) +#endif +c +c Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . la 3eme et la 4eme partagent la 2nde arete coupee +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . la 5eme et la 6eme partagent la 3eme arete coupee +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FF5 + 2/1 +c areqtr(1,1) : AS8N4 +c areqtr(1,2) : AS7N4 +c +c trifad(2,0) = triangle central de la face 2 : FF1 +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FF1 + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FF1 + 1/2 +c areqtr(2,1) : AS2N4 +c areqtr(2,2) : AS1N4 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FF4 + 2/1 +c areqtr(3,1) : AS8N4 +c areqtr(3,2) : AS3N4 +c +c trifad(4,0) = triangle central de la face 4 : FF2 +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FF2 + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FF2 + 1/2 +c areqtr(4,1) : AS6N4 +c areqtr(4,2) : AS1N4 +c +c trifad(5,0) = triangle central de la face 5 : FF6 +c trifad(5,1) = triangle de la face 5 vers le sommet 5 : FF6 + 2/1 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FF6 + 1/2 +c areqtr(5,1) : AS8N10 +c areqtr(5,2) : AS5N10 +c +c trifad(6,0) = triangle central de la face 6 : FF3 +c trifad(6,1) = triangle de la face 6 vers le sommet 5 : FF3 + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FF3 + 2/1 +c areqtr(6,1) : AS4N10 +c areqtr(6,2) : AS1N10 +c + nulofa(1) = 5 + nulofa(2) = 1 + nulofa(3) = 4 + nulofa(4) = 2 + nulofa(5) = 6 + nulofa(6) = 3 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAL', nompro +#endif + call cmchal ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c noecen : N0 +c areint( 1) : AS3N0 +c areint( 2) : AS4N0 +c areint( 3) : AS5N0 +c areint( 4) : AS2N0 +c areint( 5) : AS7N0 +c areint( 6) : AS6N0 +c areint( 7) : AS8N0 +c areint( 8) : AS1N0 +c areint( 9) : AN4N0 +c areint(10) : AN6N0 +c areint(11) : AN10N0 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAB', nompro + write (ulsort,3001) indnoe+1 + 3001 format('.. noeud',i10) + write (ulsort,3002) indare+1, indare+11 + 3002 format('.. aretes de',i10,' a',i10) +#endif + iaux = 11 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation des triangles internes +c triint( 1) : FA12 +c triint( 2) : FA1 +c triint( 3) : FA8 +c triint( 4) : FA5 +c triint( 5) : FA11 +c triint( 6) : FA2 +c triint( 7) : FA9 +c triint( 8) : FA7 +c triint( 9) : FA3 +c triint(10) : FS8N4 +c triint(11) : FS7N4 +c triint(12) : FS2N4 +c triint(13) : FS1N4 +c triint(14) : FS8N6 +c triint(15) : FS3N6 +c triint(16) : FS6N6 +c triint(17) : FS1N6 +c triint(18) : FS8N10 +c triint(19) : FS5N10 +c triint(20) : FS4N10 +c triint(21) : FS1N10 +c triint(22) : FS3N4 +c triint(23) : FS4N4 +c triint(24) : FS5N6 +c triint(25) : FS2N6 +c triint(26) : FS7N10 +c triint(27) : FS6N10 +c==== +c + if ( codret.eq.0 ) then +c + lesare( 1) = listar(12) + lesare( 2) = listar(1) + lesare( 3) = listar(8) + lesare( 4) = listar(5) + lesare( 5) = listar(11) + lesare( 6) = listar(2) + lesare( 7) = listar(9) + lesare( 8) = listar(7) + lesare( 9) = listar(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAS', nompro + write (ulsort,4000) indtri+1, indtri+2 + 4000 format('.. triangles de',i10,' a',i10) +#endif + call cmchas ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des dix-huit tetraedres +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHAN', nompro + write (ulsort,5000) indtet+1, indtet+18 + 5000 format('.. tetraedres de',i10,' a',i10) +#endif +c + iaux = 88 + call cmchan ( lehexa, iaux, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcha1.F b/src/tool/Creation_Maillage/cmcha1.F new file mode 100644 index 00000000..7966994c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcha1.F @@ -0,0 +1,494 @@ + subroutine cmcha1 ( lehexa, etahex, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Arete - pilotage +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . s . 1 . etat final de l'hexaedre . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHA1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex + integer indare, indtri, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12), listso(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,1000) 'indare', indare + write (ulsort,1000) 'indtri', indtri + write (ulsort,1000) 'indpyr', indpyr + 1000 format (a6,' =',i10) +#endif +c + texte(1,4) ='(''Aucune arete ne correspond.'')' +c + texte(2,4) ='(''No Edge is good.'')' +c + codret = 0 +c +c==== +c 2. Recherche des aretes et des sommets +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( lehexa, + > nouvqu, nouvhe, + > arequa, quahex, coquhe, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOHE', nompro +#endif + call utsohe ( somare, listar, listso ) +c +c==== +c 3. Recherche de l'arete decoupee +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listar(1) = ', listar(1), + > ' de ',somare(1,listar(1)), + > ' a ',somare(2,listar(1)) + write(ulsort,*) 'listar(2) = ', listar(2), + > ' de ',somare(1,listar(2)), + > ' a ',somare(2,listar(2)) + write(ulsort,*) 'listar(3) = ', listar(3), + > ' de ',somare(1,listar(3)), + > ' a ',somare(2,listar(3)) + write(ulsort,*) 'listar(4) = ', listar(4), + > ' de ',somare(1,listar(4)), + > ' a ',somare(2,listar(4)) + write(ulsort,*) 'listar(9) = ', listar(9), + > ' de ',somare(1,listar(9)), + > ' a ',somare(2,listar(9)) + write(ulsort,*) 'listar(11) = ', listar(11), + > ' de ',somare(1,listar(11)), + > ' a ',somare(2,listar(11)) +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> C'est l'arete 1 qui est coupee +c + if ( mod(hetare(listar(1)),10).eq.2 ) then + etahex = 11 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH61', nompro +#endif + call cmch61 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.2. ==> C'est l'arete 2 qui est coupee +c + elseif ( mod(hetare(listar(2)),10).eq.2 ) then + etahex = 12 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH62', nompro +#endif + call cmch62 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.3. ==> C'est l'arete 3 qui est coupee +c + elseif ( mod(hetare(listar(3)),10).eq.2 ) then + etahex = 13 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH63', nompro +#endif + call cmch63 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.4. ==> C'est l'arete 4 qui est coupee +c + elseif ( mod(hetare(listar(4)),10).eq.2 ) then + etahex = 14 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH64', nompro +#endif + call cmch64 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.5. ==> C'est l'arete 5 qui est coupee +c + elseif ( mod(hetare(listar(5)),10).eq.2 ) then + etahex = 15 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH65', nompro +#endif + call cmch65 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.6. ==> C'est l'arete 6 qui est coupee +c + elseif ( mod(hetare(listar(6)),10).eq.2 ) then + etahex = 16 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH66', nompro +#endif + call cmch66 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.7. ==> C'est l'arete 7 qui est coupee +c + elseif ( mod(hetare(listar(7)),10).eq.2 ) then + etahex = 17 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH67', nompro +#endif + call cmch67 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.8. ==> C'est l'arete 8 qui est coupee +c + elseif ( mod(hetare(listar(8)),10).eq.2 ) then + etahex = 18 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH68', nompro +#endif + call cmch68 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.9. ==> C'est l'arete 9 qui est coupee +c + elseif ( mod(hetare(listar(9)),10).eq.2 ) then + etahex = 19 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH69', nompro +#endif + call cmch69 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.10. ==> C'est l'arete 10 qui est coupee +c + elseif ( mod(hetare(listar(10)),10).eq.2 ) then + etahex = 20 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH70', nompro +#endif + call cmch70 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.11. ==> C'est l'arete 11 qui est coupee +c + elseif ( mod(hetare(listar(11)),10).eq.2 ) then + etahex = 21 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH71', nompro +#endif + call cmch71 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.12. ==> C'est l'arete 12 qui est coupee +c + elseif ( mod(hetare(listar(12)),10).eq.2 ) then + etahex = 22 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH72', nompro +#endif + call cmch72 ( lehexa, listar, listso, + > indare, indtri, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.13. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcha2.F b/src/tool/Creation_Maillage/cmcha2.F new file mode 100644 index 00000000..d6ceede9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcha2.F @@ -0,0 +1,1065 @@ + subroutine cmcha2 ( lehexa, etahex, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - pilotage +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . s . 1 . etat final de l'hexaedre . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHA2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12), listso(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,1000) 'indnoe', indnoe + write (ulsort,1000) 'indtri', indtri + write (ulsort,1000) 'indtet', indtet + write (ulsort,1000) 'indpyr', indpyr + 1000 format (a6,' =',i10) +#endif +c + texte(1,4) = '(''Aucune paire d''''aretes ne correspond.'')' +c + texte(2,4) = '(''No couple of edges is good.'')' +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( lehexa, + > nouvqu, nouvhe, + > arequa, quahex, coquhe, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOHE', nompro +#endif + call utsohe ( somare, listar, listso ) +c +c==== +c 3. Recherche des 2 aretes decoupees +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listar(1) = ', listar(1), + > ' de ',somare(1,listar(1)), + > ' a ',somare(2,listar(1)) + write(ulsort,*) 'listar(2) = ', listar(2), + > ' de ',somare(1,listar(2)), + > ' a ',somare(2,listar(2)) + write(ulsort,*) 'listar(3) = ', listar(3), + > ' de ',somare(1,listar(3)), + > ' a ',somare(2,listar(3)) + write(ulsort,*) 'listar(4) = ', listar(4), + > ' de ',somare(1,listar(4)), + > ' a ',somare(2,listar(4)) + write(ulsort,*) 'listar(6) = ', listar(6), + > ' de ',somare(1,listar(6)), + > ' a ',somare(2,listar(6)) + write(ulsort,*) 'listar(11) = ', listar(11), + > ' de ',somare(1,listar(11)), + > ' a ',somare(2,listar(11)) +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Ce sont les aretes 1 et 7 qui sont coupees +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 ) then + etahex = 23 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH01', nompro +#endif + call cmch01 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.2. ==> Ce sont les aretes 1 et 8 qui sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etahex = 35 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH02', nompro +#endif + call cmch02 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.3. ==> Ce sont les aretes 1 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 36 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH03', nompro +#endif + call cmch03 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.4. ==> Ce sont les aretes 1 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 24 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH04', nompro +#endif + call cmch04 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.5. ==> Ce sont les aretes 2 et 6 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 ) then + etahex = 37 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH05', nompro +#endif + call cmch05 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.6. ==> Ce sont les aretes 2 et 8 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etahex = 25 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH06', nompro +#endif + call cmch06 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.7. ==> Ce sont les aretes 2 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 26 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH07', nompro +#endif + call cmch07 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.8. ==> Ce sont les aretes 2 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 38 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH08', nompro +#endif + call cmch08 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.9. ==> Ce sont les aretes 3 et 5 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 ) then + etahex = 27 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH09', nompro +#endif + call cmch09 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.10. ==> Ce sont les aretes 3 et 7 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 ) then + etahex = 39 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH10', nompro +#endif + call cmch10 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.11. ==> Ce sont les aretes 3 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 40 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH11', nompro +#endif + call cmch11 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.12. ==> Ce sont les aretes 3 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 28 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH12', nompro +#endif + call cmch12 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.13. ==> Ce sont les aretes 4 et 5 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 ) then + etahex = 41 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH13', nompro +#endif + call cmch13 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.14. ==> Ce sont les aretes 4 et 6 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 ) then + etahex = 29 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH14', nompro +#endif + call cmch14 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.15. ==> Ce sont les aretes 4 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 30 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH15', nompro +#endif + call cmch15 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.16. ==> Ce sont les aretes 4 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 42 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH16', nompro +#endif + call cmch16 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.17. ==> Ce sont les aretes 5 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 43 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH17', nompro +#endif + call cmch17 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.18 ==> Ce sont les aretes 5 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 31 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH18', nompro +#endif + call cmch18 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.19. ==> Ce sont les aretes 6 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 32 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH19', nompro +#endif + call cmch19 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.20. ==> Ce sont les aretes 6 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 44 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH20', nompro +#endif + call cmch20 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.21. ==> Ce sont les aretes 7 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 45 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH21', nompro +#endif + call cmch21 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.22. ==> Ce sont les aretes 7 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 33 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH22', nompro +#endif + call cmch22 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.23. ==> Ce sont les aretes 8 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(8)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 34 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH23', nompro +#endif + call cmch23 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.24. ==> Ce sont les aretes 8 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(8)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 46 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH24', nompro +#endif + call cmch24 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.31. ==> Ce sont les aretes 1 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 47 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH31', nompro +#endif + call cmch31 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.32. ==> Ce sont les aretes 2 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 48 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH32', nompro +#endif + call cmch32 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.33. ==> Ce sont les aretes 3 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 49 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH33', nompro +#endif + call cmch33 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.34. ==> Ce sont les aretes 4 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 50 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH34', nompro +#endif + call cmch34 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.35. ==> Ce sont les aretes 5 et 8 qui sont coupees +c + elseif ( mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etahex = 51 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH35', nompro +#endif + call cmch35 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.36. ==> Ce sont les aretes 6 et 7 qui sont coupees +c + elseif ( mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 ) then + etahex = 52 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH36', nompro +#endif + call cmch36 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.13. ==> Lesquelles ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcha3.F b/src/tool/Creation_Maillage/cmcha3.F new file mode 100644 index 00000000..59c6d79e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcha3.F @@ -0,0 +1,450 @@ + subroutine cmcha3 ( lehexa, etahex, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - pilotage +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . s . 1 . etat final de l'hexaedre . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12), listso(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet +#endif +c + texte(1,4) = '(''Aucune paire d''''aretes ne correspond.'')' +c + texte(2,4) = '(''No couple of edges is good.'')' +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( lehexa, + > nouvqu, nouvhe, + > arequa, quahex, coquhe, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOHE', nompro +#endif + call utsohe ( somare, listar, listso ) +c +c==== +c 3. Recherche des 3 aretes decoupees +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listar(1) = ', listar(1), + > ' de ',somare(1,listar(1)), + > ' a ',somare(2,listar(1)) + write(ulsort,*) 'listar(2) = ', listar(2), + > ' de ',somare(1,listar(2)), + > ' a ',somare(2,listar(2)) + write(ulsort,*) 'listar(3) = ', listar(3), + > ' de ',somare(1,listar(3)), + > ' a ',somare(2,listar(3)) + write(ulsort,*) 'listar(4) = ', listar(4), + > ' de ',somare(1,listar(4)), + > ' a ',somare(2,listar(4)) + write(ulsort,*) 'listar(6) = ', listar(6), + > ' de ',somare(1,listar(6)), + > ' a ',somare(2,listar(6)) + write(ulsort,*) 'listar(11) = ', listar(11), + > ' de ',somare(1,listar(11)), + > ' a ',somare(2,listar(11)) +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Ce sont les aretes 1, 7 et 11 qui sont coupees +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 89 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH81', nompro +#endif + call cmch81 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.2. ==> Ce sont les aretes 1, 8 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 93 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH82', nompro +#endif + call cmch82 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.3. ==> Ce sont les aretes 2, 6 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 94 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH83', nompro +#endif + call cmch83 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.4. ==> Ce sont les aretes 2, 8 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 90 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH84', nompro +#endif + call cmch84 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.5. ==> Ce sont les aretes 3, 5 et 12 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(12)),10).eq.2 ) then + etahex = 91 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH85', nompro +#endif + call cmch85 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.6. ==> Ce sont les aretes 3, 7 et 9 qui sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etahex = 95 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH86', nompro +#endif + call cmch86 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.7. ==> Ce sont les aretes 4, 5 et 11 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(11)),10).eq.2 ) then + etahex = 96 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH87', nompro +#endif + call cmch87 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.8. ==> Ce sont les aretes 4, 6 et 10 qui sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(10)),10).eq.2 ) then + etahex = 92 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH88', nompro +#endif + call cmch88 ( lehexa, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.9. ==> Lesquelles ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchaa.F b/src/tool/Creation_Maillage/cmchaa.F new file mode 100644 index 00000000..4f36ee2e --- /dev/null +++ b/src/tool/Creation_Maillage/cmchaa.F @@ -0,0 +1,367 @@ + subroutine cmchaa ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - phase A +c - - +c Remarque : cmchaa, cmchak et cmchal sont des clones +c cmchak et cmchal sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lehexa . e . 1 . hexaedre a decouper . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . areqtr . s . (4,2) . aretes tracees sur les faces decoupees . +c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:2) . code des triangles dans les volumes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, nulofa(4) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr) + integer filqua(nouvqu) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer niveau + integer areqtr(4,2) + integer trifad(4,0:2), cotrvo(4,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les faces coupees en 3 +c La premiere pyramide s'appuie sur celle des 2 faces de +c l'hexaedre qui est non decoupee et de plus petit numero +c local. Le positionnement de la pyramide a defini une +c orientation de sa face quadrangulaire. +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . la 1ere et la 2eme partagent la 1ere arete coupee +c . la 3eme et la 4eme partagent la 2nde arete coupee +c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a +c l'orientation de la pyramide numero 1. +c . Pour 2 aretes en vis-a-vis : +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 1. +c . Pour 2 aretes non en vis-a-vis : +c Le choix de la 3eme est tel que l'ordre 3/4 corresponde a +c l'orientation de la pyramide numero 2. +c trifad(p,0) : triangle central de ce decoupage +c . Pour 2 aretes en vis-a-vis : +c trifad(p,1) : triangle bordant l'arete non decoupee qui +c appartient a la pyramide 1 +c trifad(p,2) : triangle bordant l'arete non decoupee qui +c appartient a la pyramide 2 +c . Pour 2 aretes non en vis-a-vis : +c trifad(p,1) : triangle ayant une arete commune a une pyramide +c trifad(p,2) : triangle sans arete commune avec une pyramide +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c +c 2.1. ==> Face 1 +c trifad(1,0) = triangle central de la face 1 : FFi +c . Pour 2 aretes en vis-a-vis : +c trifad(1,1) = triangle de la face 1 bordant PYR1 : FFi + 1/2 +c trifad(1,2) = triangle de la face 1 bordant PYR2 : FFi + 2/1 +c . Pour 2 aretes non en vis-a-vis : +c trifad(1,1) = triangle de la face 1 du cote de PYR1 : FFi + 1/2 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FFi + 2/1 +c areqtr(1,1) +c areqtr(1,2) + iaux = quahex(lehexa,nulofa(1)) + jaux = coquhe(lehexa,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', iaux,', coface = ', jaux + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c 2.2. ==> Face 2 +c trifad(2,0) = triangle central de la face 2 : FFi +c . Pour 2 aretes en vis-a-vis : +c trifad(2,1) = triangle de la face 2 bordant PYR1 : FFi + 2/1 +c trifad(2,2) = triangle de la face 2 bordant PYR2 : FFi + 1/2 +c . Pour 2 aretes non en vis-a-vis : +c trifad(2,1) = triangle de la face 2 du cote de PYR1 : FFi + 2/1 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FFi + 1/2 +c areqtr(2,1) +c areqtr(2,2) + iaux = quahex(lehexa,nulofa(2)) + jaux = coquhe(lehexa,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', iaux,', coface = ', jaux + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 2.3. ==> Face 3 +c trifad(3,0) = triangle central de la face 3 : FFi +c . Pour 2 aretes en vis-a-vis : +c trifad(3,1) = triangle de la face 3 bordant PYR1 : FFi + 1/2 +c trifad(3,2) = triangle de la face 3 bordant PYR2 : FFi + 2/1 +c . Pour 2 aretes non en vis-a-vis : +c trifad(3,1) = triangle de la face 3 du cote de PYR2 : FFi + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FFi + 2/1 +c areqtr(3,1) +c areqtr(3,2) + iaux = quahex(lehexa,nulofa(3)) + jaux = coquhe(lehexa,nulofa(3)) + trifad(3,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(3,0) = 4 + trifad(3,1) = trifad(3,0) + 1 + cotrvo(3,1) = 4 + trifad(3,2) = trifad(3,0) + 2 + cotrvo(3,2) = 6 + areqtr(3,1) = aretri(trifad(3,0),1) + areqtr(3,2) = aretri(trifad(3,0),3) + else + cotrvo(3,0) = 2 + trifad(3,1) = trifad(3,0) + 2 + cotrvo(3,1) = 1 + trifad(3,2) = trifad(3,0) + 1 + cotrvo(3,2) = 2 + areqtr(3,1) = aretri(trifad(3,0),3) + areqtr(3,2) = aretri(trifad(3,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', iaux,', coface = ', jaux + write(ulsort,1789) 'trifad(3,0) = ', trifad(3,0), + > 'trifad(3,1) = ', trifad(3,1), + > 'trifad(3,2) = ', trifad(3,2) + write(ulsort,1789) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1), + > 'cotrvo(3,2) = ', cotrvo(3,2) + write(ulsort,1789) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) + write(ulsort,1789) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 2.4. ==> Face 4 +c trifad(4,0) = triangle central de la face 4 : FFi +c . Pour 2 aretes en vis-a-vis : +c trifad(4,1) = triangle de la face 4 bordant PYR1 : FFi + 2/1 +c trifad(4,2) = triangle de la face 4 bordant PYR2 : FFi + 1/2 +c . Pour 2 aretes non en vis-a-vis : +c trifad(4,1) = triangle de la face 4 du cote de PYR2 : FFi + 2/1 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FFi + 1/2 +c areqtr(4,1) +c areqtr(4,2) + iaux = quahex(lehexa,nulofa(4)) + jaux = coquhe(lehexa,nulofa(4)) + trifad(4,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(4,0) = 4 + trifad(4,1) = trifad(4,0) + 2 + cotrvo(4,1) = 6 + trifad(4,2) = trifad(4,0) + 1 + cotrvo(4,2) = 4 + areqtr(4,1) = aretri(trifad(4,0),3) + areqtr(4,2) = aretri(trifad(4,0),1) + else + cotrvo(4,0) = 2 + trifad(4,1) = trifad(4,0) + 1 + cotrvo(4,1) = 2 + trifad(4,2) = trifad(4,0) + 2 + cotrvo(4,2) = 1 + areqtr(4,1) = aretri(trifad(4,0),1) + areqtr(4,2) = aretri(trifad(4,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'laface = ', iaux,', coface = ', jaux + write(ulsort,1789) 'trifad(4,0) = ', trifad(4,0), + > 'trifad(4,1) = ', trifad(4,1), + > 'trifad(4,2) = ', trifad(4,2) + write(ulsort,1789) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1), + > 'cotrvo(4,2) = ', cotrvo(4,2) + write(ulsort,1789) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) + write(ulsort,1789) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c==== +c 3. grandeurs independantes du cas traite (phase 2) +c==== +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,3000) niveau + 3000 format('niveau =',i3) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchac.F b/src/tool/Creation_Maillage/cmchac.F new file mode 100644 index 00000000..b668aa40 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchac.F @@ -0,0 +1,277 @@ + subroutine cmchac ( indtri, triint, + > lesare, tab1, tab2, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - phase C +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-8 = bordant la pyramide 2 . +c . . . . 9-10 = s'appuyant sur les 2 autres aretes . +c . . . . non decoupees . +c . . . . 11-14 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 1. +c . . . . 15-18 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 2. +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 10 . liste des aretes de l'hexaedre utiles . +c . . . . 1-4 = les aretes de la pyramide 1 . +c . . . . 5-8 = les aretes de la pyramide 2 . +c . . . . 9 = arete non decoupee, entre face 2 et 3 . +c . . . . 10 = arete non decoupee, entre face 4 et 1. +c . tab1,2 . e . 4 . numeros magiques des aretes dans areint . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 10 . aretes internes a l'hexaedre . +c . areqtr . e . (4,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(22) + integer lesare(10) + integer tab1(4), tab2(4) + integer trifad(4,0:2) + integer areint(10) + integer areqtr(4,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codetr + integer tb1(8), tb2(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data tb1 / 9, 2, 10, 4, 8, 9, 6, 10 / + data tb2 / 4, 9, 2, 10, 9, 6, 10, 8 / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles de la pyramide 1, puis de la pyramide 2 +c par convention, le niveau est le meme que les triangles fils +c sur l'exterieur +c==== +c + do 21 , iaux = 1 , 4 +c + jaux = per1a4(-1,iaux) +c +c 2.1. ==> les triangles bordant la pyramide 1 +c triint(1) = triangle bordant la pyramide 1 selon l'arete areint(1) +c triint(2) = triangle bordant la pyramide 1 selon l'arete areint(2) +c idem pour 3 et 4 +c + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(jaux), areint(iaux), + > codetr, niveau ) +c +c 2.2. ==> les triangles bordant la pyramide 2 +c triint(5) = triangle bordant la pyramide 2 selon l'arete areint(5) +c idem pour 6, 7 et 8 +c + kaux = iaux + 4 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(kaux), areint(kaux),areint(jaux+4), + > codetr, niveau ) +c +c 2.3. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, du cote de la pyramide 1 +c + kaux = iaux + 10 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,1), areint(tb1(iaux)), + > areint(tb2(iaux)), + > codetr, niveau ) +c +c 2.4. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, du cote de la pyramide 2 +c + kaux = iaux + 14 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,2), areint(tb1(iaux+4)), + > areint(tb2(iaux+4)), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. Les triangles s'appuyant sur les 2 aretes non decoupees +c triint(9) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 2 et 3 dans l'ordre choisi dans CMCH3x +c triint(10) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 4 et 1 dans l'ordre choisi dans CMCH3x +c==== +c + indtri = indtri + 1 + triint(9) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(9), areint(6), areint(2), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(10) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(10), areint(4),areint(8), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur les filles des aretes coupees +c . iaux represente les pyramides +c . jaux represente la boucle sur les faces +c==== +c + kaux = 0 +c + do 41 , iaux = 1 , 2 +c + do 411 , jaux = 2 , 3 +c + kaux = kaux + 1 + indtri = indtri + 1 + triint(kaux+18) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(jaux,iaux),1), + > tab1(kaux), tab2(kaux), + > codetr, niveau ) +c + 411 continue +c + 41 continue +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = 1, 22 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + 4333 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchad.F b/src/tool/Creation_Maillage/cmchad.F new file mode 100644 index 00000000..8b38f146 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchad.F @@ -0,0 +1,204 @@ + subroutine cmchad ( nulofa, lehexa, + > indpyr, indptp, + > triint, tab1, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - phase D +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 2 . numero local des faces quadrangles . +c . lehexa . e . 1 . hexaedre a decouper . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . triint . e . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-8 = bordant la pyramide 2 . +c . . . . 9-10 = s'appuyant sur les 2 autres aretes . +c . . . . non decoupees . +c . . . . 11-14 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 1. +c . . . . 15-18 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 2. +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . tab1 . e . 2 . code de la permutation circulaire des 4 . +c . . . . faces definissant la pyramide . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer lehexa, nulofa(2) + integer indpyr, indptp + integer triint(22), tab1(2) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer laface + integer codfac +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. Creation des deux pyramides +c==== +c +c 2.1. ==> Le pere des pyramides et leur famille +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro + write (ulsort,2100) indpyr+1, indpyr+2 + 2100 format( '.. pyramides de',i10,' a',i10) +#endif +c + laface = quahex(lehexa,nulofa(1)) + codfac = coquhe(lehexa,nulofa(1)) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(per1a4(tab1(1),1)), 3, + > triint(per1a4(tab1(1),2)), 3, + > triint(per1a4(tab1(1),3)), 3, + > triint(per1a4(tab1(1),4)), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c + laface = quahex(lehexa,nulofa(2)) + codfac = coquhe(lehexa,nulofa(2)) + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(4+per1a4(tab1(2),1)), 3, + > triint(4+per1a4(tab1(2),2)), 3, + > triint(4+per1a4(tab1(2),3)), 3, + > triint(4+per1a4(tab1(2),4)), 2, + > laface, codfac, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 4333 , iaux = indpyr-1, indpyr + write(ulsort,1789) iaux, (facpyr(iaux,jaux),jaux=1,5) + 4333 continue + 1789 format('pyramide ',i6,' : ',5i6) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchae.F b/src/tool/Creation_Maillage/cmchae.F new file mode 100644 index 00000000..b3e6dd89 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchae.F @@ -0,0 +1,319 @@ + subroutine cmchae ( lehexa, indtet, indptp, tcod, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes en vis-a-vis - phase E +c - - +c Remarque : cmchae, cmchag, cmchai, cmchan et cmcham sont des clones +c cmchan et cmcham sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . tcod . e . 1 . type des codes des triangles dans les . +c . . . . tetraedres . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-8 = bordant la pyramide 2 . +c . . . . 9-10 = s'appuyant sur les 2 autres aretes . +c . . . . non decoupees . +c . . . . 11-14 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 1. +c . . . . 15-18 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 2. +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indtet, indptp, tcod + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(22) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer tb11(2,2), tb12(2,2) + integer tb21(2,2), tb22(2,2) + integer tb31(2,2), tb32(2,2) + integer tb41(2,2), tb42(2,2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c tbij contient les codes pour le tetraedre de la face i qui +c est du cote de la pyramide j +c tbij(1,tcod) = code du 3-eme triangle +c tbij(2,tcod) = code du 4-eme triangle +c tcod = 1 tcod = 2 +c (1,1) (2,1) (1,2) (2,2) + data tb11 / 3, 3, 3, 5 / + data tb12 / 5, 5, 3, 5 / + data tb21 / 3, 5, 5, 5 / + data tb22 / 3, 5, 3, 3 / + data tb31 / 3, 5, 3, 3 / + data tb32 / 3, 5, 5, 5 / + data tb41 / 5, 5, 3, 5 / + data tb42 / 3, 3, 3, 5 / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +cgn print *,tb11(1,tcod),tb11(2,tcod) +cgn print *,tb12(1,tcod),tb12(2,tcod) +cgn print *,tb21(1,tcod),tb21(2,tcod) +cgn print *,tb22(1,tcod),tb22(2,tcod) +cgn print *,tb31(1,tcod),tb31(2,tcod) +cgn print *,tb32(1,tcod),tb32(2,tcod) +cgn print *,tb41(1,tcod),tb41(2,tcod) +cgn print *,tb42(1,tcod),tb42(2,tcod) +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHxx', nompro + write (ulsort,1200) indtet+1, indtet+12 + 1200 format( '.. tetraedres de',i10,' a',i10) +#endif +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(10), triint(15), triint(11), + > cotrvo(1,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre du cote de la pyramide 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(1), triint(11), triint(19), + > cotrvo(1,1), 5, tb11(1,tcod), tb11(2,tcod), + > nupere, nufami, indtet ) +c +c 2.3. ==> tetraedre du cote de la pyramide 2 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(5), triint(21), triint(15), + > cotrvo(1,2), 5, tb12(1,tcod), tb12(2,tcod), + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint( 9), triint(12), triint(16), + > cotrvo(2,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 3.2. ==> tetraedre du cote de la pyramide 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(2), triint(19), triint(12), + > cotrvo(2,1), 5, tb21(1,tcod), tb21(2,tcod), + > nupere, nufami, indtet ) +c +c 3.3. ==> tetraedre du cote de la pyramide 2 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(6), triint(16), triint(21), + > cotrvo(2,2), 5, tb22(1,tcod), tb22(2,tcod), + > nupere, nufami, indtet ) +c +c==== +c 4. Face 3 +c==== +c 4.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(9), triint(17), triint(13), + > cotrvo(3,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote de la pyramide 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(3), triint(13), triint(20), + > cotrvo(3,1), 5, tb31(1,tcod), tb31(2,tcod), + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre du cote de la pyramide 2 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,2), triint(7), triint(22), triint(17), + > cotrvo(3,2), 5, tb32(1,tcod), tb32(2,tcod), + > nupere, nufami, indtet ) +c +c==== +c 5. Face 4 +c==== +c 5.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(10), triint(14), triint(18), + > cotrvo(4,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote de la pyramide 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(4), triint(20), triint(14), + > cotrvo(4,1), 5, tb41(1,tcod), tb41(2,tcod), + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre du cote de la pyramide 2 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,2), triint(8), triint(18), triint(22), + > cotrvo(4,2), 5, tb42(1,tcod), tb42(2,tcod), + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 2222 , iaux = indtet-11, indtet + write(ulsort,1789) iaux, (tritet(iaux,tcod),tcod=1,4), + > (cotrte(iaux,tcod),tcod=1,4) + 2222 continue + 1789 format('tetraedre ',i6,' : ',4i6,4i2) +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchaf.F b/src/tool/Creation_Maillage/cmchaf.F new file mode 100644 index 00000000..f5f310c8 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchaf.F @@ -0,0 +1,370 @@ + subroutine cmchaf ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - phase F +c - - +c Remarque : cmchaf, cmchah sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-7 = bordant la pyramide 2 . +c . . . . 8,9,10 = s'appuyant sur les 3 autres . +c . . . . aretes non decoupees . +c . . . . 11-18 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 10 . liste des aretes de l'hexaedre utiles . +c . . . . 1-4 = les aretes de la pyramide 1 . +c . . . . 5-7 = les aretes de la pyramide 2 . +c . . . . 8 = arete non decoupee, entre face 1 et 3 . +c . . . . 9 = arete non decoupee, entre face 1 et 4 . +c . . . . 10 = arete non decoupee, entre face 2 et 3. +c . . . . Pour 8, 9, 10, le signe de lesare(i) . +c . . . . definit l'ordre des aretes 2 et 3 . +c . tab1 . e . 2 . numeros magiques des aretes dans areint . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 10 . aretes internes a l'hexaedre . +c . areqtr . e . (4,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(22) + integer lesare(10) + integer tab1(2) + integer trifad(4,0:2) + integer areint(10) + integer areqtr(4,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer aret2, aret3 + integer codetr + integer nuarl2(2,2,2), nuarl3(2,2,2) + integer tbar2(8), tbar3(8) +c + logical prem +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c tbar2 contient les numeros locaux des 2-emes aretes pour les +c triangles crees a partir des faces coupees +c tbar3 contient les numeros locaux des 3-emes aretes pour les +c triangles crees a partir des faces coupees +c + data tbar2 / 9, 1, 10, 2, 7, 9, 8, 10 / + data tbar3 / 3, 9, 5, 10, 9, 5, 10, 3 / +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c 1.2. ==> indirection pour les numeros locaux des aretes definissant +c les triangles s'appuyant sur les filles des aretes coupees +c nuarl2(i,j,k) pour la 2eme arete du triangle +c nuarl3(i,j,k) pour la 3eme arete du triangle +c i : numero de la face d'exploration +c j : numero de l'arete coupee +c k : numero du code retenu +c + if ( prem ) then +c + nuarl2(1,1,1) = 4 + nuarl3(1,1,1) = 9 + nuarl2(2,1,1) = 9 + nuarl3(2,1,1) = 8 + nuarl2(1,1,2) = 9 + nuarl3(1,1,2) = 4 + nuarl2(2,1,2) = 8 + nuarl3(2,1,2) = 9 +c + nuarl2(1,2,1) = 6 + nuarl3(1,2,1) = 10 + nuarl2(2,2,1) = 10 + nuarl3(2,2,1) = 7 + nuarl2(1,2,2) = 10 + nuarl3(1,2,2) = 6 + nuarl2(2,2,2) = 7 + nuarl3(2,2,2) = 10 +c + prem = .false. +c + endif +c +c==== +c 2. 1-4 : les triangles de la pyramide 1 +c triint(i) = triangle bordant la pyramide 1 et contenant les aretes +c areint(i) et areint(i+1) +c==== +c + do 21 , iaux = 1 , 4 +c + jaux = per1a4(1,iaux) +c + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(iaux), areint(jaux), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. 5-7 : les 3 autres triangles de la pyramide 2 : les suivants apres +c triint(1) dans l'ordre entrant de la pyramide +c==== +c + indtri = indtri + 1 + triint(5) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(5), areint(1), areint(5), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(6) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(6), areint(5), areint(6), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(7) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(7), areint(6), areint(2), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur les 4 aretes non decoupees +c triint(8) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 1 et 3 dans l'ordre choisi dans CMCHxx +c triint(9) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 1 et 4 dans l'ordre choisi dans CMCHxx +c triint(10) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 2 et 3 dans l'ordre choisi dans CMCHxx +c==== +c + indtri = indtri + 1 + triint(8) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(8), areint(7), areint(8), + > codetr, niveau ) +c + if ( lesare(9).gt.0 ) then + iaux = lesare(9) + jaux = areint(3) + kaux = areint(7) + else + iaux = -lesare(9) + jaux = areint(7) + kaux = areint(3) + endif + indtri = indtri + 1 + triint(9) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, iaux, jaux, kaux, + > codetr, niveau ) +c + if ( lesare(10).gt.0 ) then + iaux = lesare(10) + jaux = areint(8) + kaux = areint(5) + else + iaux = -lesare(10) + jaux = areint(5) + kaux = areint(8) + endif + indtri = indtri + 1 + triint(10) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, iaux, jaux, kaux, + > codetr, niveau ) +c +c==== +c 5. 11-18 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c==== +c + do 51 , iaux = 1 , 4 +c +c 5.1. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, du cote de la pyramide +c + kaux = iaux + 10 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,1), areint(tbar2(iaux)), + > areint(tbar3(iaux)), + > codetr, niveau ) +c +c 5.1. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, de l'autre cote +c + kaux = iaux + 14 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,2), areint(tbar2(iaux+4)), + > areint(tbar3(iaux+4)), + > codetr, niveau ) +c + 51 continue +c +c==== +c 6. 19-22 : les triangles s'appuyant sur les filles des aretes coupees +c . iaux represente les pyramides +c . jaux represente la boucle sur les aretes coupees +c==== +c + kaux = 0 +c + do 61 , iaux = 1 , 2 +c + do 611 , jaux = 1 , 2 +c + aret2 = areint(nuarl2(iaux,jaux,tab1(jaux))) + aret3 = areint(nuarl3(iaux,jaux,tab1(jaux))) +c + kaux = kaux + 1 + indtri = indtri + 1 + triint(kaux+18) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(jaux+1,iaux),1), + > aret2, aret3, + > codetr, niveau ) + + 611 continue +c + 61 continue +c +#ifdef _DEBUG_HOMARD_ + do 6666 , iaux = 1, 22 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + 6666 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchag.F b/src/tool/Creation_Maillage/cmchag.F new file mode 100644 index 00000000..ca2f1698 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchag.F @@ -0,0 +1,334 @@ + subroutine cmchag ( lehexa, indtet, indptp, tcod, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes non en vis-a-vis - phase G +c - - +c Remarque : cmchae, cmchag, cmchai, cmchan et cmcham sont des clones +c cmchan et cmcham sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . tcod . e . 1 . type des codes des triangles dans les . +c . . . . tetraedres . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-8 = bordant la pyramide 2 . +c . . . . 9-10 = s'appuyant sur les 2 autres aretes . +c . . . . non decoupees . +c . . . . 11-14 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 1. +c . . . . 15-18 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 2. +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indtet, indptp, tcod + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(22) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer tb10(3,9), tb11(3,9), tb12(3,9) + integer tb20(3,9), tb21(3,9), tb22(3,9) + integer tb30(3,9), tb31(3,9), tb32(3,9) + integer tb40(3,9), tb41(3,9), tb42(3,9) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c tbi0 contient les codes pour le tetraedre central de la face i +c tbi1 contient les codes pour le tetraedre de la face i qui +c est du cote de la pyramide +c tbi2 contient les codes pour le tetraedre de la face i qui +c est de l'autre cote +c tbij(1,tcod) = code du 2-eme triangle +c tbij(2,tcod) = code du 3-eme triangle +c tbij(3,tcod) = code du 4-eme triangle +c tco=1 tco=2 tco=3 tco=4 tco=5 tco=6 tco=7 tco=8 tco=9 +c 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 + data tb10/3,5,3,5,5,3, 3,5,3,3,5,3, 3,5,3,3,5,3,5,5,3,3,5,3,5,5,3/ + data tb11/5,3,3,5,3,5, 5,3,5,5,3,3, 5,3,3,5,3,3,5,3,3,5,3,5,5,3,3/ + data tb12/3,5,5,3,3,5, 3,3,5,3,5,5, 3,5,5,3,5,5,3,5,5,3,3,5,3,5,5/ +c + data tb20/5,5,3,5,5,3, 5,5,3,5,5,3, 5,5,3,5,5,3,5,5,3,5,5,3,5,5,3/ + data tb21/5,3,5,5,5,5, 5,5,5,5,3,5, 5,3,5,5,3,5,5,3,5,5,5,5,5,3,5/ + data tb22/3,3,5,3,3,3, 3,3,3,5,3,5, 3,3,5,5,3,5,5,3,5,3,3,3,3,3,5/ +c + data tb30/5,5,3,5,5,3, 5,5,3,3,5,3, 5,5,3,3,5,3,3,5,3,5,5,3,5,5,3/ + data tb31/5,3,5,5,3,5, 5,3,3,5,3,5, 5,3,3,5,3,3,5,3,5,5,3,5,5,3,5/ + data tb32/5,3,5,5,3,5, 5,5,5,5,3,5, 5,5,5,5,5,5,5,3,5,5,3,5,5,3,5/ +c + data tb40/5,5,3,5,5,3, 5,5,3,5,5,3, 5,5,3,5,5,3,5,5,3,5,5,3,5,5,3/ + data tb41/5,5,5,5,5,5, 5,3,5,5,5,5, 5,3,5,5,3,5,5,5,5,5,5,5,5,5,5/ + data tb42/5,3,3,3,3,3, 5,3,5,5,3,3, 5,3,5,5,3,5,3,3,3,5,3,3,3,3,3/ +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +cgn print *,tb10(1,tcod),tb10(2,tcod),tb10(3,tcod) +cgn print *,tb11(1,tcod),tb11(3,tcod) +cgn print *,tb12(1,tcod),tb12(3,tcod) +cgn print *,tb20(1,tcod),tb20(2,tcod),tb20(3,tcod) +cgn print *,tb21(1,tcod),tb21(3,tcod) +cgn print *,tb22(1,tcod),tb22(3,tcod) +cgn print *,tb30(1,tcod),tb30(2,tcod),tb30(3,tcod) +cgn print *,tb31(1,tcod),tb31(3,tcod) +cgn print *,tb32(1,tcod),tb32(3,tcod) +cgn print *,tb40(1,tcod),tb40(2,tcod),tb40(3,tcod) +cgn print *,tb41(1,tcod),tb41(3,tcod) +cgn print *,tb42(1,tcod),tb42(3,tcod) +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHxx', nompro + write (ulsort,1200) indtet+1, indtet+12 + 1200 format( '.. tetraedres de',i10,' a',i10) +#endif +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(9), triint(15), triint(11), + > cotrvo(1,0), tb10(1,tcod),tb10(2,tcod),tb10(3,tcod), + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(3), triint(11), triint(19), + > cotrvo(1,1), tb11(1,tcod),tb11(2,tcod),tb11(3,tcod), + > nupere, nufami, indtet ) +c +c 2.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(8), triint(21), triint(15), + > cotrvo(1,2), tb12(1,tcod),tb12(2,tcod),tb12(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(5), triint(12), triint(16), + > cotrvo(2,0), tb20(1,tcod),tb20(2,tcod),tb20(3,tcod), + > nupere, nufami, indtet ) +c +c 3.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(4), triint(19), triint(12), + > cotrvo(2,1), tb21(1,tcod),tb21(2,tcod),tb21(3,tcod), + > nupere, nufami, indtet ) +c +c 3.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(10), triint(16), triint(21), + > cotrvo(2,2), tb22(1,tcod),tb22(2,tcod),tb22(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 4. Face 3 +c==== +c 4.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(10), triint(17), triint(13), + > cotrvo(3,0), tb30(1,tcod),tb30(2,tcod),tb30(3,tcod), + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(6), triint(13), triint(20), + > cotrvo(3,1), tb31(1,tcod),tb31(2,tcod),tb31(3,tcod), + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,2), triint(8), triint(22), triint(17), + > cotrvo(3,2), tb32(1,tcod),tb32(2,tcod),tb32(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 5. Face 4 +c==== +c 5.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(2), triint(14), triint(18), + > cotrvo(4,0), tb40(1,tcod),tb40(2,tcod),tb40(3,tcod), + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(7), triint(20), triint(14), + > cotrvo(4,1), tb41(1,tcod),tb41(2,tcod),tb41(3,tcod), + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,2), triint(9), triint(18), triint(22), + > cotrvo(4,2), tb42(1,tcod),tb42(2,tcod),tb42(3,tcod), + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 2222 , iaux = indtet-11, indtet + write(ulsort,1789) iaux, (tritet(iaux,tcod),tcod=1,4), + > (cotrte(iaux,tcod),tcod=1,4) + 2222 continue + 1789 format('tetraedre ',i6,' : ',4i6,4i2) +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchah.F b/src/tool/Creation_Maillage/cmchah.F new file mode 100644 index 00000000..450cc6b2 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchah.F @@ -0,0 +1,370 @@ + subroutine cmchah ( indtri, triint, + > lesare, tab1, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes - phase H +c - - +c Remarque : cmchaf, cmchah sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-7 = bordant la pyramide 2 . +c . . . . 8,9,10 = s'appuyant sur les 3 autres . +c . . . . aretes non decoupees . +c . . . . 11-18 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 10 . liste des aretes de l'hexaedre utiles . +c . . . . 1-4 = les aretes de la pyramide 1 . +c . . . . 5-7 = les aretes de la pyramide 2 . +c . . . . 8 = arete non decoupee, entre face 1 et 3 . +c . . . . 9 = arete non decoupee, entre face 1 et 4 . +c . . . . 10 = arete non decoupee, entre face 2 et 3. +c . . . . Pour 8, 9, 10, le signe de lesare(i) . +c . . . . definit l'ordre des aretes 2 et 3 . +c . tab1 . e . 2 . numeros magiques des aretes dans areint . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 10 . aretes internes a l'hexaedre . +c . areqtr . e . (4,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(22) + integer lesare(10) + integer tab1(2) + integer trifad(4,0:2) + integer areint(10) + integer areqtr(4,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer aret2, aret3 + integer codetr + integer nuarl2(2,2,2), nuarl3(2,2,2) + integer tbar2(8), tbar3(8) +c + logical prem +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c tbar2 contient les numeros locaux des 2-emes aretes pour les +c triangles crees a partir des faces coupees +c tbar3 contient les numeros locaux des 3-emes aretes pour les +c triangles crees a partir des faces coupees +c + data tbar2 / 9, 4, 10, 6, 6, 9, 4, 10 / + data tbar3 / 2, 9, 1, 10, 9, 8, 10, 7 / +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c 1.2. ==> indirection pour les numeros locaux des aretes definissant +c les triangles s'appuyant sur les filles des aretes coupees +c nuarl2(i,j,k) pour la 2eme arete du triangle +c nuarl3(i,j,k) pour la 3eme arete du triangle +c i : numero de la face d'exploration +c j : numero de l'arete coupee +c k : numero du code retenu +c + if ( prem ) then +c + nuarl2(1,1,1) = 3 + nuarl3(1,1,1) = 9 + nuarl2(2,1,1) = 9 + nuarl3(2,1,1) = 7 + nuarl2(1,1,2) = 9 + nuarl3(1,1,2) = 3 + nuarl2(2,1,2) = 7 + nuarl3(2,1,2) = 9 +c + nuarl2(1,2,1) = 5 + nuarl3(1,2,1) = 10 + nuarl2(2,2,1) = 10 + nuarl3(2,2,1) = 8 + nuarl2(1,2,2) = 10 + nuarl3(1,2,2) = 5 + nuarl2(2,2,2) = 8 + nuarl3(2,2,2) = 10 +c + prem = .false. +c + endif +c +c==== +c 2. 1-4 : les triangles de la pyramide 1 +c triint(i) = triangle bordant la pyramide 1 et contenant les aretes +c areint(i) et areint(i+1) +c==== +c + do 21 , iaux = 1 , 4 +c + jaux = per1a4(1,iaux) +c + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(iaux), areint(jaux), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. 5-7 : les 3 autres triangles de la pyramide 2 : les suivants apres +c triint(1) dans l'ordre entrant de la pyramide +c==== +c + indtri = indtri + 1 + triint(5) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(5), areint(1), areint(5), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(6) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(6), areint(5), areint(6), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(7) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(7), areint(6), areint(2), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur les 4 aretes non decoupees +c triint(8) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 2 et 4 dans l'ordre choisi dans CMCHxx +c triint(9) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 1 et 4 dans l'ordre choisi dans CMCHxx +c triint(10) = triangle s'appuyant sur l'arete non decoupee, situee +c entre les faces 2 et 3 dans l'ordre choisi dans CMCHxx +c==== +c + indtri = indtri + 1 + triint(8) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(8), areint(7), areint(8), + > codetr, niveau ) +c + if ( lesare(9).gt.0 ) then + iaux = lesare(9) + jaux = areint(6) + kaux = areint(7) + else + iaux = -lesare(9) + jaux = areint(7) + kaux = areint(6) + endif + indtri = indtri + 1 + triint(9) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, iaux, jaux, kaux, + > codetr, niveau ) +c + if ( lesare(10).gt.0 ) then + iaux = lesare(10) + jaux = areint(8) + kaux = areint(4) + else + iaux = -lesare(10) + jaux = areint(4) + kaux = areint(8) + endif + indtri = indtri + 1 + triint(10) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, iaux, jaux, kaux, + > codetr, niveau ) +c +c==== +c 5. 11-18 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c==== +c + do 51 , iaux = 1 , 4 +c +c 5.1. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, du cote de la pyramide +c + kaux = iaux + 10 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,1), areint(tbar2(iaux)), + > areint(tbar3(iaux)), + > codetr, niveau ) +c +c 5.1. ==> les triangles s'appuyant sur l'arete interne a la face +c coupee, de l'autre cote +c + kaux = iaux + 14 + indtri = indtri + 1 + triint(kaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(iaux,2), areint(tbar2(iaux+4)), + > areint(tbar3(iaux+4)), + > codetr, niveau ) +c + 51 continue +c +c==== +c 6. 19-22 : les triangles s'appuyant sur les filles des aretes coupees +c . iaux represente les pyramides +c . jaux represente la boucle sur les aretes coupees +c==== +c + kaux = 0 +c + do 61 , iaux = 1 , 2 +c + do 611 , jaux = 1 , 2 +c + aret2 = areint(nuarl2(iaux,jaux,tab1(jaux))) + aret3 = areint(nuarl3(iaux,jaux,tab1(jaux))) +c + kaux = kaux + 1 + indtri = indtri + 1 + triint(kaux+18) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(jaux+1,iaux),1), + > aret2, aret3, + > codetr, niveau ) + + 611 continue +c + 61 continue +c +#ifdef _DEBUG_HOMARD_ + do 6666 , iaux = 1, 22 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + 6666 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchai.F b/src/tool/Creation_Maillage/cmchai.F new file mode 100644 index 00000000..c75c7d87 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchai.F @@ -0,0 +1,336 @@ + subroutine cmchai ( lehexa, indtet, indptp, tcod, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 2 Aretes non en vis-a-vis - phase I +c - - +c Remarque : cmchae, cmchag, cmchai, cmchan et cmcham sont des clones +c cmchan et cmcham sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . tcod . e . 1 . type des codes des triangles dans les . +c . . . . tetraedres . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 22 . triangles internes a l'hexaedre . +c . . . . 1-4 = bordant la pyramide 1 . +c . . . . 5-8 = bordant la pyramide 2 . +c . . . . 9-10 = s'appuyant sur les 2 autres aretes . +c . . . . non decoupees . +c . . . . 11-14 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 1. +c . . . . 15-18 = appuyes sur une arete interne a . +c . . . . une face coupee, du cote de la pyramide 2. +c . . . . 19-22 = appuyes sur les filles des aretes . +c . . . . coupees . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indtet, indptp, tcod + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(22) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer tb10(3,9), tb11(3,9), tb12(3,9) + integer tb20(3,9), tb21(3,9), tb22(3,9) + integer tb30(3,9), tb31(3,9), tb32(3,9) + integer tb40(3,9), tb41(3,9), tb42(3,9) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c tbi0 contient les codes pour le tetraedre central de la face i +c tbi1 contient les codes pour le tetraedre de la face i qui +c est du cote de la pyramide +c tbi2 contient les codes pour le tetraedre de la face i qui +c est de l'autre cote +c tbij(1,tcod) = code du 2-eme triangle +c tbij(2,tcod) = code du 3-eme triangle +c tbij(3,tcod) = code du 4-eme triangle +c tco=1 tco=2 tco=3 tco=4 tco=5 tco=6 tco=7 tco=8 tco=9 +c 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 + data tb10/5,5,3,5,5,3, 5,5,3,5,5,3, 5,5,3,5,5,3,5,5,3,5,5,3,5,5,3/ + data tb11/5,3,5,5,3,3, 5,3,5,5,3,5, 5,3,5,5,3,5,5,3,3,5,3,3,5,3,5/ + data tb12/3,3,5,3,5,5, 3,3,5,5,3,5, 5,3,5,5,3,5,3,5,5,3,5,5,3,3,5/ +c + data tb20/3,5,3,3,5,3, 3,5,3,5,5,3, 3,5,3,3,5,3,3,5,3,5,5,3,5,5,3/ + data tb21/5,5,5,5,3,5, 5,5,5,5,5,5, 5,5,5,5,5,5,5,3,5,5,3,5,5,5,5/ + data tb22/3,3,3,3,3,5, 3,3,3,3,3,3, 3,3,3,3,3,3,3,3,5,3,3,5,3,3,3/ +c + data tb30/5,5,3,5,5,3, 5,5,3,5,5,3, 5,5,3,5,5,3,5,5,3,5,5,3,5,5,3/ + data tb31/5,3,5,5,3,5, 5,3,3,5,3,3, 5,3,5,5,3,3,5,3,3,5,3,3,5,3,3/ + data tb32/5,3,5,5,3,5, 5,5,5,3,5,5, 5,3,5,5,5,5,5,5,5,3,5,5,3,5,5/ +c + data tb40/5,5,3,5,5,3, 5,5,3,3,5,3, 3,5,3,3,5,5,5,5,3,5,5,3,5,5,3/ + data tb41/5,5,5,5,5,5, 5,3,5,5,3,5, 5,5,5,5,3,5,5,3,5,5,3,5,5,3,5/ + data tb42/5,3,3,5,3,3, 5,3,5,5,3,5, 5,3,3,5,3,5,5,3,5,5,3,5,5,3,5/ +c 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 1 2 3 +c tco=1 tco=2 tco=3 tco=4 tco=5 tco=6 tco=7 tco=8 tco=9 +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +cgn print *,tb10(1,tcod),tb10(2,tcod),tb10(3,tcod) +cgn print *,tb11(1,tcod),tb11(3,tcod) +cgn print *,tb12(1,tcod),tb12(3,tcod) +cgn print *,tb20(1,tcod),tb20(2,tcod),tb20(3,tcod) +cgn print *,tb21(1,tcod),tb21(3,tcod) +cgn print *,tb22(1,tcod),tb22(3,tcod) +cgn print *,tb30(1,tcod),tb30(2,tcod),tb30(3,tcod) +cgn print *,tb31(1,tcod),tb31(3,tcod) +cgn print *,tb32(1,tcod),tb32(3,tcod) +cgn print *,tb40(1,tcod),tb40(2,tcod),tb40(3,tcod) +cgn print *,tb41(1,tcod),tb41(3,tcod) +cgn print *,tb42(1,tcod),tb42(3,tcod) +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHxx', nompro + write (ulsort,1200) indtet+1, indtet+12 + 1200 format( '.. tetraedres de',i10,' a',i10) +#endif +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(7), triint(15), triint(11), + > cotrvo(1,0), tb10(1,tcod),tb10(2,tcod),tb10(3,tcod), + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(2), triint(11), triint(19), + > cotrvo(1,1), tb11(1,tcod),tb11(2,tcod),tb11(3,tcod), + > nupere, nufami, indtet ) +c +c 2.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(9), triint(21), triint(15), + > cotrvo(1,2), tb12(1,tcod),tb12(2,tcod),tb12(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(10), triint(12), triint(16), + > cotrvo(2,0), tb20(1,tcod),tb20(2,tcod),tb20(3,tcod), + > nupere, nufami, indtet ) +c +c 3.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(3), triint(19), triint(12), + > cotrvo(2,1), tb21(1,tcod),tb21(2,tcod),tb21(3,tcod), + > nupere, nufami, indtet ) +c +c 3.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(8), triint(16), triint(21), + > cotrvo(2,2), tb22(1,tcod),tb22(2,tcod),tb22(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 4. Face 3 +c==== +c 4.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(4), triint(17), triint(13), + > cotrvo(3,0), tb30(1,tcod),tb30(2,tcod),tb30(3,tcod), + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(5), triint(13), triint(20), + > cotrvo(3,1), tb31(1,tcod),tb31(2,tcod),tb31(3,tcod), + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,2), triint(10), triint(22), triint(17), + > cotrvo(3,2), tb32(1,tcod),tb32(2,tcod),tb32(3,tcod), + > nupere, nufami, indtet ) +c +c==== +c 5. Face 4 +c==== +c 5.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(9), triint(14), triint(18), + > cotrvo(4,0), tb40(1,tcod),tb40(2,tcod),tb40(3,tcod), + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(6), triint(20), triint(14), + > cotrvo(4,1), tb41(1,tcod),tb41(2,tcod),tb41(3,tcod), + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,2), triint(8), triint(18), triint(22), + > cotrvo(4,2), tb42(1,tcod),tb42(2,tcod),tb42(3,tcod), + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 2222 , iaux = indtet-11, indtet + write(ulsort,1789) iaux, (tritet(iaux,tcod),tcod=1,4), + > (cotrte(iaux,tcod),tcod=1,4) + 2222 continue + 1789 format('tetraedre ',i6,' : ',4i6,4i2) +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchak.F b/src/tool/Creation_Maillage/cmchak.F new file mode 100644 index 00000000..956955e3 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchak.F @@ -0,0 +1,453 @@ + subroutine cmchak ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase K +c - - +c Remarque : cmchaa, cmchak et cmchal sont des clones +c cmchak et cmchal sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 6 . numero local des faces a traiter . +c . lehexa . e . 1 . hexaedre a decouper . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . areqtr . s . (6,2) . aretes tracees sur les faces decoupees . +c . trifad . s .(6,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(6,0:2) . code des triangles dans les volumes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAK' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, nulofa(6) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr) + integer filqua(nouvqu) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer niveau + integer areqtr(6,2) + integer trifad(6,0:2), cotrvo(6,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . La 1ere et la 2eme partagent la 1ere arete coupee. +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . La 3eme et la 4eme partagent la 2nde arete coupee. +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . La 5eme et la 6eme partagent la 3eme arete coupee. +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c On traite les sommets de l'hexaedre comme suit : +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c +c 2.1. ==> Face 1 +c trifad(1,0) = triangle central de la face 1 : FFi +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FFi + 2/1 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FFi + 1/2 +c areqtr(1,1) +c areqtr(1,2) + iaux = quahex(lehexa,nulofa(1)) + jaux = coquhe(lehexa,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + areqtr(1,2) = aretri(trifad(1,0),3) + areqtr(1,1) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + areqtr(1,2) = aretri(trifad(1,0),1) + areqtr(1,1) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 1' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c 2.2. ==> Face 2 +c trifad(2,0) = triangle central de la face 2 : FFi +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FFi + 1/2 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FFi + 2/1 +c areqtr(2,1) +c areqtr(2,2) + iaux = quahex(lehexa,nulofa(2)) + jaux = coquhe(lehexa,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + areqtr(2,2) = aretri(trifad(2,0),1) + areqtr(2,1) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + areqtr(2,2) = aretri(trifad(2,0),3) + areqtr(2,1) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 2' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 2.3. ==> Face 3 +c trifad(3,0) = triangle central de la face 3 : FFi +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FFi + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FFi + 2/1 +c areqtr(3,1) +c areqtr(3,2) + iaux = quahex(lehexa,nulofa(3)) + jaux = coquhe(lehexa,nulofa(3)) + trifad(3,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(3,0) = 4 + trifad(3,2) = trifad(3,0) + 2 + cotrvo(3,2) = 6 + trifad(3,1) = trifad(3,0) + 1 + cotrvo(3,1) = 4 + areqtr(3,2) = aretri(trifad(3,0),3) + areqtr(3,1) = aretri(trifad(3,0),1) + else + cotrvo(3,0) = 2 + trifad(3,2) = trifad(3,0) + 1 + cotrvo(3,2) = 2 + trifad(3,1) = trifad(3,0) + 2 + cotrvo(3,1) = 1 + areqtr(3,2) = aretri(trifad(3,0),1) + areqtr(3,1) = aretri(trifad(3,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 3' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(3,0) = ', trifad(3,0), + > 'trifad(3,1) = ', trifad(3,1), + > 'trifad(3,2) = ', trifad(3,2) + write(ulsort,1789) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1), + > 'cotrvo(3,2) = ', cotrvo(3,2) + write(ulsort,1789) '1 = ', aretri(trifad(3,0),1), + > '2 = ', aretri(trifad(3,0),2), + > '3 = ', aretri(trifad(3,0),3) + write(ulsort,1789) '1 = ', aretri(trifad(3,1),1), + > '2 = ', aretri(trifad(3,1),2), + > '3 = ', aretri(trifad(3,1),3) + write(ulsort,1789) '1 = ', aretri(trifad(3,2),1), + > '2 = ', aretri(trifad(3,2),2), + > '3 = ', aretri(trifad(3,2),3) + write(ulsort,1789) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) + write(ulsort,1789) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 2.4. ==> Face 4 +c trifad(4,0) = triangle central de la face 4 : FFi +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FFi + 1/2 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FFi + 2/1 +c areqtr(4,1) +c areqtr(4,2) + iaux = quahex(lehexa,nulofa(4)) + jaux = coquhe(lehexa,nulofa(4)) + trifad(4,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(4,0) = 4 + trifad(4,2) = trifad(4,0) + 1 + cotrvo(4,2) = 4 + trifad(4,1) = trifad(4,0) + 2 + cotrvo(4,1) = 6 + areqtr(4,2) = aretri(trifad(4,0),1) + areqtr(4,1) = aretri(trifad(4,0),3) + else + cotrvo(4,0) = 2 + trifad(4,2) = trifad(4,0) + 2 + cotrvo(4,2) = 1 + trifad(4,1) = trifad(4,0) + 1 + cotrvo(4,1) = 2 + areqtr(4,2) = aretri(trifad(4,0),3) + areqtr(4,1) = aretri(trifad(4,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 4' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(4,0) = ', trifad(4,0), + > 'trifad(4,1) = ', trifad(4,1), + > 'trifad(4,2) = ', trifad(4,2) + write(ulsort,1789) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1), + > 'cotrvo(4,2) = ', cotrvo(4,2) + write(ulsort,1789) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) + write(ulsort,1789) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c 2.5. ==> Face 5 +c trifad(5,0) = triangle central de la face 5 : FFi +c trifad(5,1) = triangle de la face 5 du cote du sommet 5 : FFi + 1/2 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FFi + 2/1 +c areqtr(5,1) +c areqtr(5,2) + iaux = quahex(lehexa,nulofa(5)) + jaux = coquhe(lehexa,nulofa(5)) + trifad(5,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(5,0) = 4 + trifad(5,2) = trifad(5,0) + 2 + cotrvo(5,2) = 6 + trifad(5,1) = trifad(5,0) + 1 + cotrvo(5,1) = 4 + areqtr(5,2) = aretri(trifad(5,0),3) + areqtr(5,1) = aretri(trifad(5,0),1) + else + cotrvo(5,0) = 2 + trifad(5,2) = trifad(5,0) + 1 + cotrvo(5,2) = 2 + trifad(5,1) = trifad(5,0) + 2 + cotrvo(5,1) = 1 + areqtr(5,2) = aretri(trifad(5,0),1) + areqtr(5,1) = aretri(trifad(5,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 5' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(5,0) = ', trifad(5,0), + > 'trifad(5,1) = ', trifad(5,1), + > 'trifad(5,2) = ', trifad(5,2) + write(ulsort,1789) 'cotrvo(5,0) = ', cotrvo(5,0), + > 'cotrvo(5,1) = ', cotrvo(5,1), + > 'cotrvo(5,2) = ', cotrvo(5,2) + write(ulsort,1789) 'areqtr(5,1) = ', areqtr(5,1), + > ' de ',somare(1,areqtr(5,1)), + > ' a ',somare(2,areqtr(5,1)) + write(ulsort,1789) 'areqtr(5,2) = ', areqtr(5,2), + > ' de ',somare(1,areqtr(5,2)), + > ' a ',somare(2,areqtr(5,2)) +#endif +c +c 2.6. ==> Face 6 +c trifad(6,0) = triangle central de la face 6 : FFi +c trifad(6,1) = triangle de la face 6 du cote du sommet 5 : FFi + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FFi + 2/1 +c areqtr(6,1) +c areqtr(6,2) + iaux = quahex(lehexa,nulofa(6)) + jaux = coquhe(lehexa,nulofa(6)) + trifad(6,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(6,0) = 4 + trifad(6,2) = trifad(6,0) + 1 + cotrvo(6,2) = 4 + trifad(6,1) = trifad(6,0) + 2 + cotrvo(6,1) = 6 + areqtr(6,2) = aretri(trifad(6,0),1) + areqtr(6,1) = aretri(trifad(6,0),3) + else + cotrvo(6,0) = 2 + trifad(6,2) = trifad(6,0) + 2 + cotrvo(6,2) = 1 + trifad(6,1) = trifad(6,0) + 1 + cotrvo(6,1) = 2 + areqtr(6,2) = aretri(trifad(6,0),3) + areqtr(6,1) = aretri(trifad(6,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 6' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(6,0) = ', trifad(6,0), + > 'trifad(6,1) = ', trifad(6,1), + > 'trifad(6,2) = ', trifad(6,2) + write(ulsort,1789) 'cotrvo(6,0) = ', cotrvo(6,0), + > 'cotrvo(6,1) = ', cotrvo(6,1), + > 'cotrvo(6,2) = ', cotrvo(6,2) + write(ulsort,1789) 'areqtr(6,1) = ', areqtr(6,1), + > ' de ',somare(1,areqtr(6,1)), + > ' a ',somare(2,areqtr(6,1)) + write(ulsort,1789) 'areqtr(6,2) = ', areqtr(6,2), + > ' de ',somare(1,areqtr(6,2)), + > ' a ',somare(2,areqtr(6,2)) +#endif +c +c==== +c 3. grandeurs independantes du cas traite (phase 2) +c==== +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,3000) niveau + 3000 format('niveau =',i3) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchal.F b/src/tool/Creation_Maillage/cmchal.F new file mode 100644 index 00000000..df1668b7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchal.F @@ -0,0 +1,453 @@ + subroutine cmchal ( nulofa, lehexa, + > somare, + > aretri, nivtri, + > filqua, + > quahex, coquhe, + > niveau, areqtr, + > trifad, cotrvo, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase L +c - - +c Remarque : cmchaa, cmchak et cmchal sont des clones +c cmchak et cmchal sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 6 . numero local des faces a traiter . +c . lehexa . e . 1 . hexaedre a decouper . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . areqtr . s . (6,2) . aretes tracees sur les faces decoupees . +c . trifad . s .(6,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(6,0:2) . code des triangles dans les volumes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAL' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa, nulofa(6) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr) + integer filqua(nouvqu) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer niveau + integer areqtr(6,2) + integer trifad(6,0:2), cotrvo(6,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les faces coupees en 3 +c On traite les faces de l'hexaedre coupees en 3 comme suit : +c . La 1ere et la 2eme partagent la 1ere arete coupee. +c La 1ere face est celle qui n'a pas de point commun +c avec la 2eme arete coupee. +c . La 3eme et la 4eme partagent la 2nde arete coupee. +c La 3eme face est celle qui n'a pas de point commun +c avec la 3eme arete coupee. +c . La 5eme et la 6eme partagent la 3eme arete coupee. +c La 5eme face est celle qui n'a pas de point commun +c avec la 1ere arete coupee. +c On traite les sommets de l'hexaedre comme suit : +c . le 1er et le 2eme sommet sont les extremites de la 1ere +c arete coupee ; le 1er est celui appartenant a +c la 3eme face. +c . le 3eme et le 4eme sommet sont les extremites de la 2eme +c arete coupee ; le 3eme est celui appartenant a +c la 5eme face. +c . le 5eme et le 6eme sommet sont les extremites de la 3eme +c arete coupee ; le 5eme est celui appartenant a +c la 1ere face. +c . le 7eme sommet est le dernier sommet de la 1ere face +c . le 8eme sommet est le dernier sommet de la 2eme face +c Sur la p-eme face : +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee du cote du +c sommet de plus petit numero dans lesnoe +c trifad(p,2) : triangle bordant l'arete non decoupee du cote du +c sommet de grand petit numero dans lesnoe +c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description du tetraedre voisin +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c +c 2.1. ==> Face 1 +c trifad(1,0) = triangle central de la face 1 : FFi +c trifad(1,1) = triangle de la face 1 vers le sommet 1 : FFi + 2/1 +c trifad(1,2) = triangle de la face 1 de l'autre cote : FFi + 1/2 +c areqtr(1,1) +c areqtr(1,2) + iaux = quahex(lehexa,nulofa(1)) + jaux = coquhe(lehexa,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 1' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0), + > 'trifad(1,1) = ', trifad(1,1), + > 'trifad(1,2) = ', trifad(1,2) + write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c 2.2. ==> Face 2 +c trifad(2,0) = triangle central de la face 2 : FFi +c trifad(2,1) = triangle de la face 2 vers le sommet 1 : FFi + 1/2 +c trifad(2,2) = triangle de la face 2 de l'autre cote : FFi + 2/1 +c areqtr(2,1) +c areqtr(2,2) + iaux = quahex(lehexa,nulofa(2)) + jaux = coquhe(lehexa,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 2' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0), + > 'trifad(2,1) = ', trifad(2,1), + > 'trifad(2,2) = ', trifad(2,2) + write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c 2.3. ==> Face 3 +c trifad(3,0) = triangle central de la face 3 : FFi +c trifad(3,1) = triangle de la face 3 vers le sommet 3 : FFi + 1/2 +c trifad(3,2) = triangle de la face 3 de l'autre cote : FFi + 2/1 +c areqtr(3,1) +c areqtr(3,2) + iaux = quahex(lehexa,nulofa(3)) + jaux = coquhe(lehexa,nulofa(3)) + trifad(3,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(3,0) = 4 + trifad(3,1) = trifad(3,0) + 2 + cotrvo(3,1) = 6 + trifad(3,2) = trifad(3,0) + 1 + cotrvo(3,2) = 4 + areqtr(3,1) = aretri(trifad(3,0),3) + areqtr(3,2) = aretri(trifad(3,0),1) + else + cotrvo(3,0) = 2 + trifad(3,1) = trifad(3,0) + 1 + cotrvo(3,1) = 2 + trifad(3,2) = trifad(3,0) + 2 + cotrvo(3,2) = 1 + areqtr(3,1) = aretri(trifad(3,0),1) + areqtr(3,2) = aretri(trifad(3,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 3' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(3,0) = ', trifad(3,0), + > 'trifad(3,1) = ', trifad(3,1), + > 'trifad(3,2) = ', trifad(3,2) + write(ulsort,1789) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1), + > 'cotrvo(3,2) = ', cotrvo(3,2) + write(ulsort,1789) '1 = ', aretri(trifad(3,0),1), + > '2 = ', aretri(trifad(3,0),2), + > '3 = ', aretri(trifad(3,0),3) + write(ulsort,1789) '1 = ', aretri(trifad(3,1),1), + > '2 = ', aretri(trifad(3,1),2), + > '3 = ', aretri(trifad(3,1),3) + write(ulsort,1789) '1 = ', aretri(trifad(3,2),1), + > '2 = ', aretri(trifad(3,2),2), + > '3 = ', aretri(trifad(3,2),3) + write(ulsort,1789) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) + write(ulsort,1789) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 2.4. ==> Face 4 +c trifad(4,0) = triangle central de la face 4 : FFi +c trifad(4,1) = triangle de la face 4 vers le sommet 3 : FFi + 1/2 +c trifad(4,2) = triangle de la face 4 de l'autre cote : FFi + 2/1 +c areqtr(4,1) +c areqtr(4,2) + iaux = quahex(lehexa,nulofa(4)) + jaux = coquhe(lehexa,nulofa(4)) + trifad(4,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(4,0) = 4 + trifad(4,1) = trifad(4,0) + 1 + cotrvo(4,1) = 4 + trifad(4,2) = trifad(4,0) + 2 + cotrvo(4,2) = 6 + areqtr(4,1) = aretri(trifad(4,0),1) + areqtr(4,2) = aretri(trifad(4,0),3) + else + cotrvo(4,0) = 2 + trifad(4,1) = trifad(4,0) + 2 + cotrvo(4,1) = 1 + trifad(4,2) = trifad(4,0) + 1 + cotrvo(4,2) = 2 + areqtr(4,1) = aretri(trifad(4,0),3) + areqtr(4,2) = aretri(trifad(4,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 4' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(4,0) = ', trifad(4,0), + > 'trifad(4,1) = ', trifad(4,1), + > 'trifad(4,2) = ', trifad(4,2) + write(ulsort,1789) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1), + > 'cotrvo(4,2) = ', cotrvo(4,2) + write(ulsort,1789) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) + write(ulsort,1789) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c 2.5. ==> Face 5 +c trifad(5,0) = triangle central de la face 5 : FFi +c trifad(5,1) = triangle de la face 5 du cote du sommet 5 : FFi + 1/2 +c trifad(5,2) = triangle de la face 5 de l'autre cote : FFi + 2/1 +c areqtr(5,1) +c areqtr(5,2) + iaux = quahex(lehexa,nulofa(5)) + jaux = coquhe(lehexa,nulofa(5)) + trifad(5,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(5,0) = 4 + trifad(5,1) = trifad(5,0) + 2 + cotrvo(5,1) = 6 + trifad(5,2) = trifad(5,0) + 1 + cotrvo(5,2) = 4 + areqtr(5,1) = aretri(trifad(5,0),3) + areqtr(5,2) = aretri(trifad(5,0),1) + else + cotrvo(5,0) = 2 + trifad(5,1) = trifad(5,0) + 1 + cotrvo(5,1) = 2 + trifad(5,2) = trifad(5,0) + 2 + cotrvo(5,2) = 1 + areqtr(5,1) = aretri(trifad(5,0),1) + areqtr(5,2) = aretri(trifad(5,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 5' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(5,0) = ', trifad(5,0), + > 'trifad(5,1) = ', trifad(5,1), + > 'trifad(5,2) = ', trifad(5,2) + write(ulsort,1789) 'cotrvo(5,0) = ', cotrvo(5,0), + > 'cotrvo(5,1) = ', cotrvo(5,1), + > 'cotrvo(5,2) = ', cotrvo(5,2) + write(ulsort,1789) 'areqtr(5,1) = ', areqtr(5,1), + > ' de ',somare(1,areqtr(5,1)), + > ' a ',somare(2,areqtr(5,1)) + write(ulsort,1789) 'areqtr(5,2) = ', areqtr(5,2), + > ' de ',somare(1,areqtr(5,2)), + > ' a ',somare(2,areqtr(5,2)) +#endif +c +c 2.6. ==> Face 6 +c trifad(6,0) = triangle central de la face 6 : FFi +c trifad(6,1) = triangle de la face 6 du cote du sommet 5 : FFi + 1/2 +c trifad(6,2) = triangle de la face 6 de l'autre cote : FFi + 2/1 +c areqtr(6,1) +c areqtr(6,2) + iaux = quahex(lehexa,nulofa(6)) + jaux = coquhe(lehexa,nulofa(6)) + trifad(6,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(6,0) = 4 + trifad(6,1) = trifad(6,0) + 1 + cotrvo(6,1) = 4 + trifad(6,2) = trifad(6,0) + 2 + cotrvo(6,2) = 6 + areqtr(6,1) = aretri(trifad(6,0),1) + areqtr(6,2) = aretri(trifad(6,0),3) + else + cotrvo(6,0) = 2 + trifad(6,1) = trifad(6,0) + 2 + cotrvo(6,1) = 1 + trifad(6,2) = trifad(6,0) + 1 + cotrvo(6,2) = 2 + areqtr(6,1) = aretri(trifad(6,0),3) + areqtr(6,2) = aretri(trifad(6,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Face 6' + write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux + write(ulsort,1789) 'trifad(6,0) = ', trifad(6,0), + > 'trifad(6,1) = ', trifad(6,1), + > 'trifad(6,2) = ', trifad(6,2) + write(ulsort,1789) 'cotrvo(6,0) = ', cotrvo(6,0), + > 'cotrvo(6,1) = ', cotrvo(6,1), + > 'cotrvo(6,2) = ', cotrvo(6,2) + write(ulsort,1789) 'areqtr(6,1) = ', areqtr(6,1), + > ' de ',somare(1,areqtr(6,1)), + > ' a ',somare(2,areqtr(6,1)) + write(ulsort,1789) 'areqtr(6,2) = ', areqtr(6,2), + > ' de ',somare(1,areqtr(6,2)), + > ' a ',somare(2,areqtr(6,2)) +#endif +c +c==== +c 3. grandeurs independantes du cas traite (phase 2) +c==== +c niveau = niveau des triangles des conformites des faces + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,3000) niveau + 3000 format('niveau =',i3) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcham.F b/src/tool/Creation_Maillage/cmcham.F new file mode 100644 index 00000000..2eb7bafb --- /dev/null +++ b/src/tool/Creation_Maillage/cmcham.F @@ -0,0 +1,401 @@ + subroutine cmcham ( lehexa, etahex, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase M +c - - +c Remarque : cmchae, cmchag, cmchai, cmchan et cmcham sont des clones +c cmchan et cmcham sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . e . 1 . etat de l'hexaedre . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(6,0:2) . code des triangles dans les volumes . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAM' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex, indtet, indptp + integer trifad(6,0:2), cotrvo(6,0:2) + integer triint(27) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer code +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHxx', nompro + write (ulsort,1200) indtet+1, indtet+18 + 1200 format( '.. tetraedres de',i10,' a',i10) +#endif +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(1), triint(11), triint(10), + > cotrvo(1,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.82 .or. etahex.eq.86 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(3), triint(10), triint(22), + > cotrvo(1,1), code, 3, 5, + > nupere, nufami, indtet ) +c +c 2.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(8), triint(23), triint(11), + > cotrvo(1,2), code, 3, 5, + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(2), triint(12), triint(13), + > cotrvo(2,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 3.2. ==> tetraedre du cote du sommet 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(9), triint(22), triint(12), + > cotrvo(2,1), 3, 5, 5, + > nupere, nufami, indtet ) +c +c 3.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(6), triint(13), triint(23), + > cotrvo(2,2), 3, 3, 3, + > nupere, nufami, indtet ) +c +c==== +c 4. Face 3 +c==== +c 4.1. ==> tetraedre central +c + if ( etahex.eq.82 .or. etahex.eq.86 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(3), triint(15), triint(14), + > cotrvo(3,0), code, 5, 3, + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(5), triint(14), triint(24), + > cotrvo(3,1), 3, 3, code, + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,2), triint(9), triint(25), triint(15), + > cotrvo(3,2), 5, code, 5, + > nupere, nufami, indtet ) +c +c==== +c 5. Face 4 +c==== +c 5.1. ==> tetraedre central +c + if ( etahex.eq.82 .or. etahex.eq.86 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(4), triint(16), triint(17), + > cotrvo(4,0), code, 5, 3, + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(7), triint(24), triint(16), + > cotrvo(4,1), 3, code, 5, + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,2), triint(2), triint(17), triint(25), + > cotrvo(4,2), 5, 3, code, + > nupere, nufami, indtet ) +c +c==== +c 6. Face 5 +c==== +c 6.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,0), triint(5), triint(19), triint(18), + > cotrvo(5,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 6.2. ==> tetraedre du cote du sommet 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,1), triint(1), triint(18), triint(26), + > cotrvo(5,1), 5, 3, 5, + > nupere, nufami, indtet ) +c +c 6.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,2), triint(7), triint(27), triint(19), + > cotrvo(5,2), 5, 3, 5, + > nupere, nufami, indtet ) +c +c==== +c 7. Face 6 +c==== +c 7.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,0), triint(6), triint(20), triint(21), + > cotrvo(6,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 7.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.82 .or. etahex.eq.83 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,1), triint(8), triint(26), triint(20), + > cotrvo(6,1), code, 5, 5, + > nupere, nufami, indtet ) +c +c 7.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.82 .or. etahex.eq.86 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,2), triint(4), triint(21), triint(27), + > cotrvo(6,2), code, 3, 3, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 2222 , iaux = indtet-17, indtet + write(ulsort,1789) iaux, (tritet(iaux,code),code=1,4), + > (cotrte(iaux,code),code=1,4) + 2222 continue + 1789 format('tetraedre ',i6,' : ',4i6,4i2) +#endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchan.F b/src/tool/Creation_Maillage/cmchan.F new file mode 100644 index 00000000..3f6faba7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchan.F @@ -0,0 +1,406 @@ + subroutine cmchan ( lehexa, etahex, indtet, indptp, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase N +c - - +c Remarque : cmchae, cmchag, cmchai, cmchan et cmcham sont des clones +c cmchan et cmcham sont symetriques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . e . 1 . etat de l'hexaedre . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(6,0:2) . code des triangles dans les volumes . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex, indtet, indptp + integer trifad(6,0:2), cotrvo(6,0:2) + integer triint(27) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer code +c +#ifdef _DEBUG_HOMARD_ + character*2 saux02 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write(saux02,'(I2)') etahex + write (ulsort,texte(langue,3)) nompro, 'CMCH'//saux02 + write (ulsort,1200) indtet+1, indtet+18 + 1200 format( '.. tetraedres de',i10,' a',i10) +#endif +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(1), triint(10), triint(11), + > cotrvo(1,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.81 .or. etahex.eq.84 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(3), triint(22), triint(10), + > cotrvo(1,1), code, 3, 5, + > nupere, nufami, indtet ) +c +c 2.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(8), triint(11), triint(23), + > cotrvo(1,2), code, 3, 5, + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(2), triint(13), triint(12), + > cotrvo(2,0), 3, 5, 3, + > nupere, nufami, indtet ) +c +c 3.2. ==> tetraedre du cote du sommet 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(9), triint(12), triint(22), + > cotrvo(2,1), 3, 3, 3, + > nupere, nufami, indtet ) +c +c 3.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(6), triint(23), triint(13), + > cotrvo(2,2), 3, 5, 5, + > nupere, nufami, indtet ) +c +c==== +c 4. Face 3 +c==== +c 4.1. ==> tetraedre central +c + if ( etahex.eq.81 .or. etahex.eq.84 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(3), triint(14), triint(15), + > cotrvo(3,0), code, 5, 3, + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(5), triint(24), triint(14), + > cotrvo(3,1), 3, code, 5, + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,2), triint(9), triint(15), triint(25), + > cotrvo(3,2), 5, 3, code, + > nupere, nufami, indtet ) +c +c==== +c 5. Face 4 +c==== +c 5.1. ==> tetraedre central +c + if ( etahex.eq.81 .or. etahex.eq.84 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(4), triint(17), triint(16), + > cotrvo(4,0), code, 5, 3, + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(7), triint(16), triint(24), + > cotrvo(4,1), 3, 3, code, + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,2), triint(2), triint(25), triint(17), + > cotrvo(4,2), 5, code, 5, + > nupere, nufami, indtet ) +c +c==== +c 6. Face 5 +c==== +c 6.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,0), triint(5), triint(18), triint(19), + > cotrvo(5,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 6.2. ==> tetraedre du cote du sommet 1 +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,1), triint(1), triint(26), triint(18), + > cotrvo(5,1), 5, 3, 5, + > nupere, nufami, indtet ) +c +c 6.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(5,2), triint(7), triint(19), triint(27), + > cotrvo(5,2), 5, 3, 5, + > nupere, nufami, indtet ) +c +c==== +c 7. Face 6 +c==== +c 7.1. ==> tetraedre central +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,0), triint(6), triint(21), triint(20), + > cotrvo(6,0), 5, 5, 3, + > nupere, nufami, indtet ) +c +c 7.2. ==> tetraedre du cote du sommet 1 +c + if ( etahex.eq.81 .or. etahex.eq.85 ) then + code = 5 + else + code = 3 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,1), triint(8), triint(20), triint(26), + > cotrvo(6,1), code, 3, 3, + > nupere, nufami, indtet ) +c +c 7.3. ==> tetraedre de l'autre cote +c + if ( etahex.eq.81 .or. etahex.eq.84 ) then + code = 3 + else + code = 5 + endif + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(6,2), triint(4), triint(27), triint(21), + > cotrvo(6,2), code, 5, 5, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 2222 , iaux = indtet-17, indtet + write(ulsort,1789) iaux, (tritet(iaux,code),code=1,4), + > (cotrte(iaux,code),code=1,4) + 2222 continue + 1789 format('tetraedre ',i6,' : ',4i6,4i2) +#endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchap.F b/src/tool/Creation_Maillage/cmchap.F new file mode 100644 index 00000000..7db92777 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchap.F @@ -0,0 +1,439 @@ + subroutine cmchap ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase P +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAP' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(2), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(4), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(9), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(5), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(4), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(9), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(10), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(1), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(6), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(10), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(11), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(3), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(2), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(11), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(9), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(2), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(3), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(10), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(11), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(6), areint(10), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchaq.F b/src/tool/Creation_Maillage/cmchaq.F new file mode 100644 index 00000000..c1a68366 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchaq.F @@ -0,0 +1,439 @@ + subroutine cmchaq ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase Q +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAQ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(2), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(4), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(9), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(5), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(4), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(9), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(10), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(1), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(6), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(10), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(11), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(3), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(2), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(11), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(9), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(2), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(10), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(4), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(11), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(6), areint(11), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchar.F b/src/tool/Creation_Maillage/cmchar.F new file mode 100644 index 00000000..d0f5bce7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchar.F @@ -0,0 +1,439 @@ + subroutine cmchar ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase R +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(2), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(4), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(9), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(5), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(4), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(9), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(10), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(1), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(6), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(10), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(11), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(3), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(2), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(11), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(9), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(2), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(3), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(10), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(11), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(6), areint(11), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchas.F b/src/tool/Creation_Maillage/cmchas.F new file mode 100644 index 00000000..1bb690a2 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchas.F @@ -0,0 +1,439 @@ + subroutine cmchas ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase S +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAS' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(2), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(4), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(9), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(5), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(4), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(9), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(10), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(1), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(6), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(10), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(7), + > areint(11), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(3), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(2), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(8), + > areint(11), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(9), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(2), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(10), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(4), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(11), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(6), areint(11), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchat.F b/src/tool/Creation_Maillage/cmchat.F new file mode 100644 index 00000000..a9a570ed --- /dev/null +++ b/src/tool/Creation_Maillage/cmchat.F @@ -0,0 +1,439 @@ + subroutine cmchat ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase T +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(8), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(1), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(7), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(5), + > areint(9), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(4), + > areint(9), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(8), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(7), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(1), + > areint(10), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(6), + > areint(10), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(8), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(7), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(3), + > areint(11), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(2), + > areint(11), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(8), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(1), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(9), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(10), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(4), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(5), areint(11), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(11), areint(6), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchau.F b/src/tool/Creation_Maillage/cmchau.F new file mode 100644 index 00000000..269e4ff6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchau.F @@ -0,0 +1,439 @@ + subroutine cmchau ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase U +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(8), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(5), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(1), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(7), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(5), + > areint(9), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(4), + > areint(9), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(8), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(7), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(1), + > areint(10), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(6), + > areint(10), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(8), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(7), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(3), + > areint(11), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(2), + > areint(11), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(8), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(1), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(9), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(10), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(4), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(5), areint(11), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(11), areint(6), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchav.F b/src/tool/Creation_Maillage/cmchav.F new file mode 100644 index 00000000..1b1b0b34 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchav.F @@ -0,0 +1,439 @@ + subroutine cmchav ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase V +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAV' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(1), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(8), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(8), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(1), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(7), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(5), + > areint(9), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(4), + > areint(9), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(8), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(7), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(1), + > areint(10), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(6), + > areint(10), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(8), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(7), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(3), + > areint(11), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(2), + > areint(11), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(8), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(1), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(9), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(3), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(10), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(5), areint(11), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(11), areint(6), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchaw.F b/src/tool/Creation_Maillage/cmchaw.F new file mode 100644 index 00000000..4ab9faea --- /dev/null +++ b/src/tool/Creation_Maillage/cmchaw.F @@ -0,0 +1,439 @@ + subroutine cmchaw ( indtri, triint, + > lesare, + > trifad, areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 3 Aretes - phase W +c - - +c Remarque : cmchap, cmchaq, cmchar et cmchas sont des clones +c cmchat, cmchau, cmchav et cmchaw sont des clones +c tous sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 27 . triangles internes a l'hexaedre . +c . . . . 1-6 = appuyes sur une arete non decoupee . +c . . . . base de face centrale . +c . . . . 7-9 = appuyes sur une arete non decoupee . +c . . . . non base de face centrale . +c . . . . 10-21 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . . . . 22-27 = appuyes sur les filles des aretes . +c . . . . coupees . +c . lesare . e . 9 . liste des aretes non coupees . +c . . . . 1-6 = base de la face i . +c . . . . 6+i = opposee a la ieme arete decoupee . +c . trifad . e .(6,0:2) . triangles traces sur les faces decoupees . +c . areint . e . 11 . aretes internes a l'hexaedre . +c . areqtr . e . (6,2) . aretes sur les faces coupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 10 . aretes internes creees . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHAW' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(27) + integer lesare(9) + integer trifad(6,0:2) + integer areint(11) + integer areqtr(6,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. 1-6 : les triangles base de face centrale +c le i-eme triangle est sur la face i de l'hexaedre +c==== +c + iaux = 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(7), areint(1), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(8), areint(6), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(3), areint(7), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(8), + > codetr, niveau ) +c +c==== +c 3. 7-9 : les 3 autres triangles sur des aretes non decoupees +c la base du i-eme triangle est // a la i-eme arete coupee +c==== +c + indtri = indtri + 1 + iaux = iaux + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(6), areint(3), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(2), areint(5), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, lesare(iaux), areint(4), areint(1), + > codetr, niveau ) +c +c==== +c 4. 10-21 : les triangles s'appuyant sur les aretes tracees +c sur les faces coupees +c on les range face par face, et dans une face, sommet par sommet +c==== +c + jaux = 1 +c face 1, cote du sommet 1 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(9), + > areint(7), + > codetr, niveau ) +c face 1, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(5), + > areint(9), + > codetr, niveau ) +c +c face 2, cote du sommet 1 + jaux = 2 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(4), + > areint(9), + > codetr, niveau ) +c face 2, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(9), + > areint(8), + > codetr, niveau ) +c +c face 3, cote du sommet 3 + jaux = 3 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(10), + > areint(7), + > codetr, niveau ) +c face 3, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(1), + > areint(10), + > codetr, niveau ) +c +c face 4, cote du sommet 3 + jaux = 4 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(6), + > areint(10), + > codetr, niveau ) +c face 4, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(10), + > areint(8), + > codetr, niveau ) +c +c face 5, cote du sommet 5 + jaux = 5 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(11), + > areint(7), + > codetr, niveau ) +c face 5, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(3), + > areint(11), + > codetr, niveau ) +c +c face 6, cote du sommet 5 + jaux = 6 + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,1), areint(2), + > areint(11), + > codetr, niveau ) +c face 6, autre cote + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(jaux,2), areint(11), + > areint(8), + > codetr, niveau ) +c +c==== +c 5. 22-27 : les triangles s'appuyant sur les filles des aretes coupees +c . jaux represente la boucle sur les aretes coupees +c . aretri(trifad(2*jaux,1),i) : la i-eme fille de l'arete coupee +c . areint(8+jaux) : l'arete entre le noeud de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux-1) : l'arete entre le sommet 1 de l'arete coupee et +c le centre de l'hexaedre +c . areint(2*jaux ) : l'arete entre le sommet 2 de l'arete coupee et +c le centre de l'hexaedre +c==== +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,1),1), + > areint(1), areint(9), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(2,2),1), + > areint(9), areint(2), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,1),1), + > areint(3), areint(10), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(4,2),1), + > areint(10), areint(4), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,1),1), + > areint(5), areint(11), + > codetr, niveau ) +c + iaux = iaux + 1 + indtri = indtri + 1 + triint(iaux) = indtri + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, aretri(trifad(6,2),1), + > areint(11), areint(6), + > codetr, niveau ) +c +#ifdef _DEBUG_HOMARD_ + do 5555 , iaux = 1, 27 + write(ulsort,1789) iaux, triint(iaux), + > ' a1 ',aretri(triint(iaux),1), + > ' a2 ',aretri(triint(iaux),2), + > ' a3 ',aretri(triint(iaux),3) + if ( iaux.eq.6 .or. iaux.eq.9 .or. iaux.eq.21 ) then + write(ulsort,*)' ' + endif + 5555 continue + 1789 format('triint(',i2,') = ',i6,' : ',5(a,'=',i6,',')) +#endif +c +c=== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchea.F b/src/tool/Creation_Maillage/cmchea.F new file mode 100644 index 00000000..e4b47ec0 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchea.F @@ -0,0 +1,103 @@ + subroutine cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > nare01, nare02, nare03, nare04, + > nare05, nare06, nare07, nare08, + > nare09, nare10, nare11, nare12, + > nupere, famill, nuhexa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un HExaedre par ses Aretes +c - - - -- - +c ______________________________________________________________________ +c +c but : creation effective d'un hexaedre etant donne : +c - le numero de l'hexaedre +c - les numeros globaux des faces locales 1,2,3,4,5 et 6 +c - les codes des faces +c - le numero du pere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . narei . e . 1 . arete de numero local i dans l'hexaedre . +c . nupere . e . 1 . numero du pere du hexaedre . +c . famill . e . 1 . famille a attribuer a l'hexaedre . +c . nuhexa . e . 1 . numero du hexaedre a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer arehex(nouvha,12), famhex(nouvhe) + integer hethex(nouvhe), filhex(nouvhe), perhex(nouvhe) + integer nare01, nare02, nare03, nare04 + integer nare05, nare06, nare07, nare08 + integer nare09, nare10, nare11, nare12 + integer nupere, famill, nuhexa +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un hexaedre +c==== +c +cgn write (*,*) 'nuhexa',nuhexa + iaux = nuhexa - nouvhf + arehex(iaux,1) = nare01 + arehex(iaux,2) = nare02 + arehex(iaux,3) = nare03 + arehex(iaux,4) = nare04 + arehex(iaux,5) = nare05 + arehex(iaux,6) = nare06 + arehex(iaux,7) = nare07 + arehex(iaux,8) = nare08 + arehex(iaux,9) = nare09 + arehex(iaux,10) = nare10 + arehex(iaux,11) = nare11 + arehex(iaux,12) = nare12 +c + famhex(nuhexa) = famill +c + hethex(nuhexa) = 5000 + filhex(nuhexa) = 0 + perhex(nuhexa) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmchex.F b/src/tool/Creation_Maillage/cmchex.F new file mode 100644 index 00000000..36bba8c5 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchex.F @@ -0,0 +1,112 @@ + subroutine cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > nquad1, nquad2, nquad3, + > nquad4, nquad5, nquad6, + > codef1, codef2, codef3, + > codef4, codef5, codef6, + > nupere, famill, nuhexa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un HEXaedre +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'un hexaedre etant donne : +c - le numero du hexaedre +c - les numeros globaux des faces locales 1,2,3,4,5 et 6 +c - les codes des faces +c - le numero du pere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . quahex . es .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nouvhf*6. code des 6 quadrangles des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . nquad1 . e . 1 . face de numero local 1 dans le hexaedre . +c . nquad2 . e . 1 . face de numero local 2 dans le hexaedre . +c . nquad3 . e . 1 . face de numero local 3 dans le hexaedre . +c . nquad4 . e . 1 . face de numero local 4 dans le hexaedre . +c . nquad5 . e . 1 . face de numero local 5 dans le hexaedre . +c . nquad6 . e . 1 . face de numero local 6 dans le hexaedre . +c . codef1 . e . 1 . code de la face 1 . +c . codef2 . e . 1 . code de la face 2 . +c . codef3 . e . 1 . code de la face 3 . +c . codef4 . e . 1 . code de la face 4 . +c . codef5 . e . 1 . code de la face 5 . +c . codef6 . e . 1 . code de la face 6 . +c . nupere . e . 1 . numero du pere du hexaedre . +c . famill . e . 1 . famille a attribuer a l'hexaedre . +c . nuhexa . e . 1 . numero du hexaedre a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer quahex(nouvhf,6), coquhe(nouvhf,6), famhex(nouvhe) + integer hethex(nouvhe), filhex(nouvhe), perhex(nouvhe) + integer nquad1, nquad2, nquad3, nquad4, nquad5, nquad6 + integer codef1, codef2, codef3, codef4, codef5, codef6 + integer nupere, famill, nuhexa +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un hexaedre +c==== +c + quahex(nuhexa,1) = nquad1 + quahex(nuhexa,2) = nquad2 + quahex(nuhexa,3) = nquad3 + quahex(nuhexa,4) = nquad4 + quahex(nuhexa,5) = nquad5 + quahex(nuhexa,6) = nquad6 +c + coquhe(nuhexa,1) = codef1 + coquhe(nuhexa,2) = codef2 + coquhe(nuhexa,3) = codef3 + coquhe(nuhexa,4) = codef4 + coquhe(nuhexa,5) = codef5 + coquhe(nuhexa,6) = codef6 +c + famhex(nuhexa) = famill +c + hethex(nuhexa) = 5000 + filhex(nuhexa) = 0 + perhex(nuhexa) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmchf0.F b/src/tool/Creation_Maillage/cmchf0.F new file mode 100644 index 00000000..9f119698 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchf0.F @@ -0,0 +1,391 @@ + subroutine cmchf0 ( lehexa, etahex, etatfa, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - pilotage +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . etahex . s . 1 . etat final de l'hexaedre . +c . etatfa . e . 6 . etat des faces de l'hexaedre . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . facpyr . e .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nouvyf*5. codes des faces des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . e . nouvpy . famille des pyramides . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHF0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lehexa, etahex, etatfa(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12), listso(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + write (ulsort,1000) 'indtri', indtri + write (ulsort,1000) 'indtet', indtet + write (ulsort,1000) 'indpyr', indpyr + 1000 format (a6,' =',i10) +#endif +c + texte(1,4) = '(''Aucune face ne correspond.'')' + texte(1,5) = '(''Liste des '',a,'' :'',6i10)' + texte(1,6) = '(''avec les etats :'',6i10)' +c + texte(2,4) = '(''No face is good'')' + texte(2,5) = '(''List of '',a,'' :'',6i10)' + texte(2,6) = '(''with status :'',6i10)' +c + codret = 0 +c +c==== +c 2. Recherche des faces, des aretes et des sommets +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( lehexa, + > nouvqu, nouvhe, + > arequa, quahex, coquhe, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOHE', nompro +#endif + call utsohe ( somare, listar, listso ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'listar = ', listar + write(ulsort,*) 'listso = ', listso +#endif +c +c==== +c 3. decoupage +c==== +#ifdef _DEBUG_HOMARD_ + iaux = 212 + write(ulsort,*) 'arequa(iaux,1) = ', arequa(iaux,1), + > ' de ',somare(1,arequa(iaux,1)), + > ' a ',somare(2,arequa(iaux,1)) + write(ulsort,*) 'arequa(iaux,2) = ', arequa(iaux,2), + > ' de ',somare(1,arequa(iaux,2)), + > ' a ',somare(2,arequa(iaux,2)) + write(ulsort,*) 'arequa(iaux,3) = ', arequa(iaux,3), + > ' de ',somare(1,arequa(iaux,3)), + > ' a ',somare(2,arequa(iaux,3)) + write(ulsort,*) 'arequa(iaux,4) = ', arequa(iaux,4), + > ' de ',somare(1,arequa(iaux,4)), + > ' a ',somare(2,arequa(iaux,4)) +#endif +c +c 3.1. ==> C'est la face 1 qui est coupee +c + if ( etatfa(1).eq.4 ) then + etahex = 285 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH41', nompro +#endif + call cmch41 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.2. ==> C'est la face 2 qui est coupee +c + elseif ( etatfa(2).eq.4 ) then + etahex = 286 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH42', nompro +#endif + call cmch42 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.3. ==> C'est la face 3 qui est coupee +c + elseif ( etatfa(3).eq.4 ) then + etahex = 287 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH43', nompro + write (ulsort,*) 'indtri = ', indtri +#endif + call cmch43 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.4. ==> C'est la face 4 qui est coupee +c + elseif ( etatfa(4).eq.4 ) then + etahex = 288 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH44', nompro +#endif + call cmch44 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.5. ==> C'est la face 5 qui est coupee +c + elseif ( etatfa(5).eq.4 ) then + etahex = 289 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH45', nompro +#endif + call cmch45 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.6. ==> C'est la face 6 qui est coupee +c + elseif ( etatfa(6).eq.4 ) then + etahex = 290 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCH46', nompro +#endif + call cmch46 ( lehexa, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > quahex, coquhe, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 3.7. ==> Laquelle ? +c + else + codret = 1 + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) mess14(langue,3,4), + > ( quahex(lehexa,iaux), iaux=1,6 ) + write (ulsort,texte(langue,6)) (etatfa(iaux),iaux=1,6 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchfa.F b/src/tool/Creation_Maillage/cmchfa.F new file mode 100644 index 00000000..2f3adb16 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchfa.F @@ -0,0 +1,336 @@ + subroutine cmchfa ( facdec, cofdec, facnde, cofnde, + > niveau, noefac, + > quabas, arefad, + > trifad, cotrvo, areqtr, + > lehexa, nulofa, + > somare, aretri, nivtri, + > arequa, filqua, + > quahex, coquhe, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - utilitaire A +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . facnde . s . 1 . numero global de la face non decoupee . +c . cofnde . s . 1 . code de la face non decoupee dans l'hexa. . +c . facdec . s . 1 . numero global de la face decoupee . +c . cofdec . s . 1 . code de la face decoupee dans l'hexaedre . +c . niveau . s . 1 . niveau des triangle de conformite des faces. +c . noefac . s . 1 . noeud central de la face decoupee en 4 . +c . quabas . s . 4 . quadrangles fils de la face coupee en 4 . +c . . . . quabas(p) = base de la pyramide fille p . +c . arefad . s . 4 . aretes tracees sur la face coupee en 4 . +c . . . . arefad(p) est l'arete commune aux pyramides. +c . . . . filles numero p et p+1 . +c . trifad . s .(4,0:2) . triangles sur les faces de conformite . +c . . . . trifad(p,0) : triangle central du decoupage. +c . . . . trifad(p,1) : tria. bordant la pyramide p . +c . . . . trifad(p,2) : tria. bordant la pyramide p+1. +c . cotrvo . s .(4,0:2) . futur codes des triangles trifad dans la . +c . . . . description des tetraedres . +c . areqtr . s . (4,2) . arete interne au quadrangle de bord et . +c . . . . bordant le triangle trifad(p,i) . +c . lehexa . e . 1 . numero global d'hexaedre . +c . nulofa . e . 1 . numero local de la face couppe en 4 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . +c . tabaux . e . 4 . numeros locaux des faces coupees en 3, . +c . . . . dans l'ordre des pyramides p/p1+1 . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "comp07.h" +#include "defiqu.h" +c +c 0.3. ==> arguments +c + integer facdec, cofdec, facnde, cofnde + integer niveau, noefac + integer quabas(4) + integer arefad(4), areqtr(4,2) + integer trifad(4,0:2), cotrvo(4,0:2) + integer lehexa, nulofa + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr) + integer arequa(nouvqu,4), filqua(nouvqu) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer tabaux(4) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + 1789 format(5(a,i5,', ')) + 1792 format(2(a,i1,a,i5,', ')) +#endif +c + codret = 0 +c +c==== +c 2. La face coupee en 4 et son code dans l'hexaedre +c La face non coupee et son code dans l'hexaedre +c==== +c + facdec = quahex(lehexa,nulofa) + cofdec = coquhe(lehexa,nulofa) + facnde = quahex(lehexa,coen07(nulofa)) + cofnde = coquhe(lehexa,coen07(nulofa)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'facdec = ', facdec, 'cofdec = ', cofdec + write(ulsort,1789) 'facnde = ', facnde, 'cofnde = ', cofnde +#endif +c +c==== +c 3. Noeud central de la face coupee en 4 +c==== +c + iaux = filqua(facdec) + noefac = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'noefac = ', noefac +#endif +c +c==== +c 4. Quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c filqua(facdec) + defiqJ(cofdec) : J-eme fils du quadrangle +c Attention : la regle de numerotation locale des quadrangles quabas +c est celle des pyramides ; on part du sommet de plus +c petit numero local et on tourne en entrant dans +c l'hexaedre. Pour les fils du quadrangle, on part de la +c plus petite arete locale et on tourne dans le meme sens +c D'ou l'eventuel decalage selon les faces +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'defiq1 = ', defiq1(cofdec) + write(ulsort,1789) 'defiq2 = ', defiq2(cofdec) + write(ulsort,1789) 'defiq3 = ', defiq3(cofdec) + write(ulsort,1789) 'defiq4 = ', defiq4(cofdec) +#endif + if ( nulofa.eq.1 .or. nulofa.eq.3 .or. nulofa.eq.6 ) then + quabas(1) = filqua(facdec) + defiq2(cofdec) + quabas(2) = filqua(facdec) + defiq3(cofdec) + quabas(3) = filqua(facdec) + defiq4(cofdec) + quabas(4) = filqua(facdec) + defiq1(cofdec) + else + quabas(1) = filqua(facdec) + defiq1(cofdec) + quabas(2) = filqua(facdec) + defiq2(cofdec) + quabas(3) = filqua(facdec) + defiq3(cofdec) + quabas(4) = filqua(facdec) + defiq4(cofdec) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'Fils aine = ', filqua(facdec) + write(ulsort,1789) 'quabas(1) = ', quabas(1), + > 'arete 1 = ', arequa(quabas(1),1), + > ' de ',somare(1,arequa(quabas(1),1)), + > ' a ',somare(2,arequa(quabas(1),1)) + write(ulsort,1789) 'quabas(2) = ', quabas(2), + > 'arete 1 = ', arequa(quabas(2),1), + > ' de ',somare(1,arequa(quabas(2),1)), + > ' a ',somare(2,arequa(quabas(2),1)) + write(ulsort,1789) 'quabas(3) = ', quabas(3), + > 'arete 1 = ', arequa(quabas(3),1), + > ' de ',somare(1,arequa(quabas(3),1)), + > ' a ',somare(2,arequa(quabas(3),1)) + write(ulsort,1789) 'quabas(4) = ', quabas(4), + > 'arete 1 = ', arequa(quabas(4),1), + > ' de ',somare(1,arequa(quabas(4),1)), + > ' a ',somare(2,arequa(quabas(4),1)) +#endif +c +c==== +c 5. Aretes tracees sur la face coupee en 4 +c arefad(p) est l'arete commune aux pyramides filles numero p et p+1 +c==== +c + if ( cofdec.lt.5 ) then + arefad(1) = arequa(quabas(1),2) + arefad(2) = arequa(quabas(2),2) + arefad(3) = arequa(quabas(3),2) + arefad(4) = arequa(quabas(4),2) + else + arefad(1) = arequa(quabas(2),2) + arefad(2) = arequa(quabas(3),2) + arefad(3) = arequa(quabas(4),2) + arefad(4) = arequa(quabas(1),2) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'arefad(1) = ', arefad(1), + > ' de ',somare(1,arefad(1)), + > ' a ',somare(2,arefad(1)) + write(ulsort,1789) + > 'arefad(2) = ', arefad(2), + > ' de ',somare(1,arefad(2)), + > ' a ',somare(2,arefad(2)) + write(ulsort,1789) + > 'arefad(3) = ', arefad(3), + > ' de ',somare(1,arefad(3)), + > ' a ',somare(2,arefad(3)) + write(ulsort,1789) + > 'arefad(4) = ', arefad(4), + > ' de ',somare(1,arefad(4)), + > ' a ',somare(2,arefad(4)) +#endif +c +c==== +c 6. Triangles et aretes tracees sur les faces coupees en 3 +c Chaque quadrangle de bord qui est decoupe en 3 triangles +c borde deux pyramides consecutives : p et p+1 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant la pyramide p +c trifad(p,2) : triangle bordant la pyramide p+1 +c cotrvo(p,0) : futur code du triangle trifad(p,0) dans la +c description du tetraedre p +c cotrvo(p,1) : futur code du triangle trifad(p,1) dans la +c description de la pyramide p +c cotrvo(p,2) : futur code du triangle trifad(p,2) dans la +c description de la pyramide p+1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c + do 61 , iaux = 1 , 4 + jaux = quahex(lehexa,tabaux(iaux)) + kaux = coquhe(lehexa,tabaux(iaux)) + trifad(iaux,0) = -filqua(jaux) + if ( kaux.lt.5 ) then + cotrvo(iaux,0) = 4 + trifad(iaux,1) = trifad(iaux,0) + 1 + cotrvo(iaux,1) = 3 + trifad(iaux,2) = trifad(iaux,0) + 2 + cotrvo(iaux,2) = 2 + areqtr(iaux,1) = aretri(trifad(iaux,0),1) + areqtr(iaux,2) = aretri(trifad(iaux,0),3) + else + cotrvo(iaux,0) = 2 + trifad(iaux,1) = trifad(iaux,0) + 2 + cotrvo(iaux,1) = 5 + trifad(iaux,2) = trifad(iaux,0) + 1 + cotrvo(iaux,2) = 6 + areqtr(iaux,1) = aretri(trifad(iaux,0),3) + areqtr(iaux,2) = aretri(trifad(iaux,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) ' ' + write(ulsort,1789) 'face = ', jaux,', code = ', kaux + write(ulsort,1792) 'trifad(',iaux,',0) = ', trifad(iaux,0) + write(ulsort,1792) 'trifad(',iaux,',1) = ', trifad(iaux,1), + > 'trifad(',iaux,',2) = ', trifad(iaux,2) + write(ulsort,1792) 'cotrvo(',iaux,',0) = ', cotrvo(iaux,0), + > 'cotrvo(',iaux,',1) = ', cotrvo(iaux,1), + > 'cotrvo(',iaux,',2) = ', cotrvo(iaux,2) + write(ulsort,1789) 'areqtr(',iaux,'1) = ', areqtr(iaux,1), + > ' de ',somare(1,areqtr(iaux,1)), + > ' a ',somare(2,areqtr(iaux,1)) + write(ulsort,1789) 'areqtr(',iaux,'2) = ', areqtr(iaux,2), + > ' de ',somare(1,areqtr(iaux,2)), + > ' a ',somare(2,areqtr(iaux,2)) +#endif + 61 continue +c +c==== +c 7. niveau = niveau des quadrangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,1789) 'niveau = ', niveau +#endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchfb.F b/src/tool/Creation_Maillage/cmchfb.F new file mode 100644 index 00000000..d890c0bb --- /dev/null +++ b/src/tool/Creation_Maillage/cmchfb.F @@ -0,0 +1,183 @@ + subroutine cmchfb ( indtri, triint, + > hettri, aretri, nivtri, + > filtri, pertri, famtri, + > areint, arefad, areqtr, niveau, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - utilitaire B +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . (4,2) . triangles appuyes sur la face coupee . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer au triangle . +c . areint . e . 4 . numeros des aretes internes a l'hexaedre . +c . arefad . e . 4 . aretes internes a la face oupee en 4 . +c . areqtr . e . (4,2) . aretes internes au quadrangles coupes en 3 . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHFB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri, triint(4,2) + integer hettri(nouvtr), aretri(nouvtr,3), nivtri(nouvtr) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer areint(4), arefad(4), areqtr(4,2) + integer niveau +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. triangles interieurs s'appuyant sur les aretes interieures +c a la face coupee +c==== +c + iaux = 1 +c + triint(1,1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1,1), arefad(1), areqtr(1,1), areint(1), + > iaux, niveau ) +c + triint(1,2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(1,2), arefad(1), areint(2), areqtr(1,2), + > iaux, niveau ) +c + triint(2,1) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2,1), arefad(2), areqtr(2,1), areint(2), + > iaux, niveau ) +c + triint(2,2) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(2,2), arefad(2), areint(3), areqtr(2,2), + > iaux, niveau ) +c + triint(3,1) = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3,1), arefad(3), areqtr(3,1), areint(3), + > iaux, niveau ) +c + triint(3,2) = indtri + 6 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(3,2), arefad(3), areint(4), areqtr(3,2), + > iaux, niveau ) +c + triint(4,1) = indtri + 7 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4,1), arefad(4), areqtr(4,1), areint(4), + > iaux, niveau ) +c + triint(4,2) = indtri + 8 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > triint(4,2), arefad(4), areint(1), areqtr(4,2), + > iaux, niveau ) +c + indtri = triint(4,2) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchfc.F b/src/tool/Creation_Maillage/cmchfc.F new file mode 100644 index 00000000..22893689 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchfc.F @@ -0,0 +1,159 @@ + subroutine cmchfc ( indtri, trigpy, + > hettri, aretri, nivtri, + > filtri, pertri, famtri, + > areint, arext1, arext2, arext3, arext4, + > niveau, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - utilitaire C +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . trigpy . s . 4 . triangles bordant la grande pyramide . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . areint . e . 4 . numeros des aretes internes a l'hexaedre . +c . arextk . e . 1 . numeros des aretes externes a l'hexaedre . +c . niveau . e . 1 . niveau a attribuer au triangle . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHFC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri, trigpy(4) + integer hettri(nouvtr), aretri(nouvtr,3), nivtri(nouvtr) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer areint(4) + integer arext1, arext2, arext3, arext4 + integer niveau +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. triangles s'appuyant sur la face non decoupee +c==== +c + iaux = 1 +c + trigpy(1) = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > trigpy(1), arext1, areint(2), areint(1), + > iaux, niveau ) +c + trigpy(2) = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > trigpy(2), arext2, areint(3), areint(2), + > iaux, niveau ) +c + trigpy(3) = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > trigpy(3), arext3, areint(4), areint(3), + > iaux, niveau ) +c + trigpy(4) = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > trigpy(4), arext4, areint(1), areint(4), + > iaux, niveau ) +c + indtri = trigpy(4) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchfd.F b/src/tool/Creation_Maillage/cmchfd.F new file mode 100644 index 00000000..2fec951c --- /dev/null +++ b/src/tool/Creation_Maillage/cmchfd.F @@ -0,0 +1,134 @@ + subroutine cmchfd ( indpyr, + > facpyr, cofapy, fampyr, + > hetpyr, filpyr, perpyr, + > trifad, cotrvo, triint, quabas, cofdec, + > nupere, famill ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - utilitaire D +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . fampyr . es . nouvpy . famille des pyramides . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . trifad . e . (4,0:2). triangles sur les faces coupees en 3 . +c . cotrvo . e . (4,0:2). code de ces triangles dans les pyramides . +c . triint . e . (4,2) . triangles internes a l'hexaedre . +c . quabas . e . 4 . faces de base des pyramides . +c . cofdec . e . 1 . code de la face decoupee dans l'hexaedre . +c . famill . e . 1 . famille a attribuer a la pyramide . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMCHFD' ) +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indpyr + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(4,2) + integer quabas(4), cofdec + integer facpyr(nouvyf,5), cofapy(nouvyf,5), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) + integer nupere, famill +c +c 0.4. ==> variables locales +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#ifdef _DEBUG_HOMARD_ + call dmflsh (iaux) +#endif +c +c==== +c 1. creation des pyramides +c==== +c + iaux = -nupere +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,1), cotrvo(1,1), + > triint(1,1), 3, + > triint(4,2), 3, + > trifad(4,2), cotrvo(4,2), + > quabas(1), cofdec, + > iaux, famill, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(2,1), cotrvo(2,1), + > triint(2,1), 3, + > triint(1,2), 3, + > trifad(1,2), cotrvo(1,2), + > quabas(2), cofdec, + > iaux, famill, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(3,1), cotrvo(3,1), + > triint(3,1), 3, + > triint(2,2), 3, + > trifad(2,2), cotrvo(2,2), + > quabas(3), cofdec, + > iaux, famill, indpyr ) +c + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(4,1), cotrvo(4,1), + > triint(4,1), 3, + > triint(3,2), 3, + > trifad(3,2), cotrvo(3,2), + > quabas(4), cofdec, + > iaux, famill, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchfe.F b/src/tool/Creation_Maillage/cmchfe.F new file mode 100644 index 00000000..d4e00905 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchfe.F @@ -0,0 +1,127 @@ + subroutine cmchfe ( indtet, indptp, + > tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad, cotrvo, triint, trigpy, + > nufami ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Hexaedres +c - - - - +c - par 1 Face - utilitaire E +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . famtet . es . nouvte . famille des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . trifad . e . (4,0:2). triangles sur les faces coupees en 3 . +c . cotrvo . e . (4,0:2). code de ces triangles dans les pyramides . +c . triint . e . (4,2) . triangles internes a l'hexaedre . +c . trigpy . e . 4 . triangle de la grande pyramide . +c . nufami . e . 1 . famille a attribuer au tetraedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMCHFE' ) +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer tritet(nouvtf,4), cotrte(nouvtf,4), famtet(nouvte) + integer hettet(nouvte), filtet(nouvte), pertet(nouvte) + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(4,2) + integer trigpy(4) + integer nufami +c +c 0.4. ==> variables locales +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#ifdef _DEBUG_HOMARD_ + call dmflsh (iaux) +#endif +c +c==== +c 2. les 4 tetraedres internes au decoupage selon une face d'hexaedre +c le tetraedre p est entre les pyramides p et p+1 +c==== +c + iaux = -indptp +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), trigpy(1), triint(1,2), triint(1,1), + > cotrvo(1,0), 5, 1, 4, + > iaux, nufami, indtet ) +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), trigpy(2), triint(2,2), triint(2,1), + > cotrvo(2,0), 5, 1, 4, + > iaux, nufami, indtet ) +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), trigpy(3), triint(3,2), triint(3,1), + > cotrvo(3,0), 5, 1, 4, + > iaux, nufami, indtet ) +c + indtet = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), trigpy(4), triint(4,2), triint(4,1), + > cotrvo(4,0), 5, 1, 4, + > iaux, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchpa.F b/src/tool/Creation_Maillage/cmchpa.F new file mode 100644 index 00000000..079d59df --- /dev/null +++ b/src/tool/Creation_Maillage/cmchpa.F @@ -0,0 +1,161 @@ + subroutine cmchpa ( indare, nbaret, + > noefix, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des +c - - - +c Hexaedres ou Pentaedres - phase A +c - - - +c Construction des aretes internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . nbaret . e . 1 . nombre d'aretes a creer . +c . lesnoe . e . nbaret . liste des noeuds pour les extremites des . +c . . . . aretes a creer . +c . areint . s . nbaret . aretes internes creees . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHPA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "fractf.h" +c +c 0.3. ==> arguments +c + integer indare + integer nbaret + integer noefix, lesnoe(nbaret), areint(nbaret) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Creation des aretes internes +c L'arete i part du sommet i vers le noeud central +c==== +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nbaret +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( noefix , lesnoe(iaux) ) + somare(2,areint(iaux)) = max ( noefix , lesnoe(iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,91002) iaux, areint(iaux), + > somare(1,areint(iaux)), + > somare(2,areint(iaux)), 0 +#endif +c + 21 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmchpb.F b/src/tool/Creation_Maillage/cmchpb.F new file mode 100644 index 00000000..61236603 --- /dev/null +++ b/src/tool/Creation_Maillage/cmchpb.F @@ -0,0 +1,201 @@ + subroutine cmchpb ( indnoe, indare, nbaret, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des +c - - - +c Hexaedres ou Pentaedres - phase B +c - - - +c +c Construction du noeud central et des aretes internes reliees a lui +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . nbaret . e . 1 . nombre d'aretes a creer . +c . nbsomm . e . 1 . nombre de sommets de la maille volumique . +c . lesnoe . e . nbaret . liste des noeuds pour les extremites des . +c . . . . aretes . +c . . . . nbsomm premiers = les sommets du volume . +c . . . . puis milieu des aretes coupees . +c . areint . s . nbaret . aretes internes creees . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCHPB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nouvnb.h" +#include "fractf.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare + integer nbaret, nbsomm + integer lesnoe(nbaret), areint(nbaret) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer noecen +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Creation du noeud interne +c noecen : N0 +c==== +c + noecen = indnoe + 1 + arenoe(noecen) = 0 +c + do 21 , iaux = 1 , 3 +c + coonoe(noecen,iaux) = coonoe(lesnoe(1),iaux) + do 211 , jaux = 2 , nbsomm + coonoe(noecen,iaux) = coonoe(noecen,iaux) + > + coonoe(lesnoe(jaux),iaux) + 211 continue + coonoe(noecen,iaux) = coonoe(noecen,iaux)/dble(nbsomm) +c + 21 continue +c + famnoe(noecen) = 1 + hetnoe(noecen) = 51 +c + indnoe = noecen +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Noeud', noecen, + > coonoe(noecen,1), coonoe(noecen,2), coonoe(noecen,3) +#endif +c +c==== +c 3. Creation des aretes internes +c L'arete i part du sommet i vers le noeud central +c==== +c + do 31 , iaux = 1 , nbaret +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = lesnoe(iaux) + somare(2,areint(iaux)) = noecen +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,91002) iaux, areint(iaux), + > somare(1,areint(iaux)), + > somare(2,areint(iaux)), 0 +#endif +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmconf.F b/src/tool/Creation_Maillage/cmconf.F new file mode 100644 index 00000000..f95d4a6a --- /dev/null +++ b/src/tool/Creation_Maillage/cmconf.F @@ -0,0 +1,745 @@ + subroutine cmconf ( nomail, + > indnoe, indare, + > indtri, indqua, + > indtet, indpyr, indhex, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - mise en CONFormite +c - - ---- +c ______________________________________________________________________ +c +c but : mise en conformite du maillage : +c - decoupage des triangles en 2 +c - decoupage des quadrangles en 3 triangles, +c en 2 ou 3 quadrangles +c - decoupage des tetraedres en 2 ou en 4 +c - decoupage des hexaedres en hexaedres, pyramides et tetraedres +c - decoupage des pentaedres en pyramides et tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCONF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nouvnb.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, indare, indtri, indqua + integer indtet, indpyr, indhex +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer codre0 + integer pdecfa + integer phetno, pcoono, pareno + integer phetar, psomar, pfilar, pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu + integer phette, ptrite, pcotrt, pfilte, pperte, adtes2, parete + integer phetpe, pfacpe, pcofap, pfilpe, pperpe, adpes2, parepe + integer phetpy, pfacpy, pcofay, pfilpy, pperpy, adpys2, parepy + integer pquahe, pcoquh, phethe, pfilhe, pperhe, adhes2, parehe + integer pfamno, pcfano + integer pfamar + integer pfamtr, pcfatr + integer pfamte + integer pfamqu, pcfaqu + integer pfamhe, pcfahe + integer pfampe, pcfape + integer pfampy +c + integer indtea, indpya, indhea +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' MISE EN CONFORMITE DU MAILLAGE'')' + texte(1,5) = '(37(''=''),/)' + texte(1,6) = + >'(5x,''Nombre de '',a,'' crees :'',i10)' + texte(1,7) = + > '(5x,''Ce nombre est incorrect. On en attendait'',i10)' +c + texte(2,4) = + > '(/,a6,'' MESH CONFORMITY'')' + texte(2,5) = '(22(''=''),/)' + texte(2,6) = '(5x,''Number of new '',a,'':'',i10)' + texte(2,7) = + > '(5x,''Wrong number.'',i10,'' were expected.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write ( ulsort,texte(langue,4)) saux + write ( ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90006) 'nouvar =', nouvar, 'provar =', provar + write (ulsort,90006) 'nouvtr =', nouvtr, 'provtr =', provtr + write (ulsort,90006) 'nouvqu =', nouvqu, 'provqu =', provqu + write (ulsort,90006) 'nouvte =', nouvte, 'provte =', provte, + > 'provtf =', provtf, 'provta =', provta + write (ulsort,90006) 'nouvhe =', nouvhe, 'provhe =', provhe, + > 'provhf =', provhf, 'provha =', provha, + > 'nbheco =', nbheco + write (ulsort,90006) 'nouvpe =', nouvpe, 'provpe =', provpe, + > 'nbpeco =', nbpeco + write (ulsort,90006) 'nouvpy =', nouvpy, 'provpy =', provpy, + > 'provyf =', provyf, 'provya =', provya +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + if ( nouvno.eq.nbnoto ) then + iaux = 5 + else + iaux = 210 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, jaux, jaux, + > ulsort, langue, codret ) +c + iaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nouvtr.ne.0 ) then +c + iaux = 85470 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 85470 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, pcfaqu, jaux, + > pnivqu, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( provte.ne.0 ) then +c + iaux = 2730 + if ( nbheco.ne.0 .or. nbpeco.ne.0 ) then + iaux = iaux*17 + endif + if ( taopti(30).ge.0 .and. nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, pperte, + > pfamte, jaux, jaux, + > jaux, pcotrt, adtes2, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 101010 + if ( nbheco.ne.0 ) then + iaux = iaux*17 + endif + if ( taopti(30).ge.0 .and. nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, pcfahe, jaux, + > jaux, pcoquh, adhes2, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 101010 + if ( nbpeco.ne.0 ) then + iaux = iaux*17 + endif + if ( taopti(30).ge.0 .and. nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, pcfape, jaux, + > jaux, pcofap, adpes2, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + if ( provpy.ne.0 ) then +c + iaux = 101010 + if ( nbheco.ne.0 .or. nbpeco.ne.0 ) then + iaux = iaux*17 + endif + if ( taopti(30).ge.0 .and. nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, pfilpy, pperpy, + > pfampy, jaux, jaux, + > jaux, pcofay, adpys2, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + ntrav1 = taopts(12) + call gmadoj ( ntrav1, pdecfa, iaux, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.3. ==> indice de depart des volumes decrits par aretes +c + if ( codret.eq.0 ) then +c + indtea = nouvtf + indhea = nouvhf + indpya = nouvyf +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indtet, indtea', indtet, indtea +#endif +c + endif +c +c==== +c 3. decoupage des triangles en 2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 .and. provtr.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDTR', nompro +#endif +c + call cmcdtr ( indare, indtri, imem(pdecfa), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pfamtr), + > imem(pnivtr), + > imem(pcfatr), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. decoupage des quadrangles en 3 triangles, en 2 ou 3 quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 .and. ( provtr.gt.0 .or. provqu.gt.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDQU', nompro +#endif +c + call cmcdqu ( indnoe, indare, indtri, indqua, imem(pdecfa), + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(pfamno), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pfamtr), + > imem(pnivtr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), imem(pfamqu), + > imem(pnivqu), imem(adnmqu), + > imem(pcfaqu), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. decoupage des tetraedres en 2 ou 4 tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 .and. provte.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDTE', nompro +#endif +c + call cmcdte ( indare, indtri, indtet, + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pfamtr), + > imem(pnivtr), + > imem(phette), imem(ptrite), imem(pcotrt), + > imem(pfilte), imem(pperte), imem(pfamte), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. decoupage des hexaedres en pyramides, tetraedres, hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 .and. + > ( provte.gt.0 .or. provpy.gt.0 .or. provhe.gt.0 ) ) then +c +c 6.1. ==> conforme, avec des boites pour les hexaedres +c + if ( taopti(30).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'conforme, avec des boites pour les hexaedres' +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDHB', nompro +#endif +c + call cmcdhb ( indnoe, indare, indtri, indtet, indpyr, + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(pfamno), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pfamtr), + > imem(pnivtr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), + > imem(phette), imem(ptrite), imem(pcotrt), + > imem(pfilte), imem(pperte), imem(pfamte), + > imem(adtes2), + > imem(phetpy), imem(pfacpy), imem(pcofay), + > imem(pfilpy), imem(pperpy), imem(pfampy), + > imem(adpys2), + > imem(pquahe), imem(pcoquh), imem(phethe), + > imem(pfilhe), imem(adhes2), + > imem(pfamhe), imem(pcfahe), + > ulsort, langue, codret ) +c +c 6.2. ==> conforme general +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro, ' - conforme' +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDHE', nompro +#endif +c + call cmcdhe ( indnoe, indare, indtea, indpya, indhea, + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(pfamno), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(paretr), + > imem(parequ), + > imem(pfilqu), + > imem(phette), imem(parete), + > imem(pfilte), imem(pperte), imem(pfamte), + > imem(adtes2), + > imem(phetpy), imem(parepy), + > imem(pfilpy), imem(pperpy), imem(pfampy), + > imem(adpys2), + > imem(phethe), imem(parehe), + > imem(pfilhe), imem(adhes2), imem(pperhe), + > imem(pfamhe), imem(pcfahe), + > imem(pquahe), imem(pcoquh), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +cgn call gmprsx (nompro,nhhexa//'.ConnDesc') +cgn call gmprsx (nompro,nhhexa//'.ConnAret') +cgn call gmprsx (nompro,nhhexa//'.InfoSupp') +cgn call gmprsx (nompro,nhpyra//'.ConnAret') +cgn call gmprsx (nompro,nhpyra//'.ConnDesc') +cgn call gmprsx (nompro,nhpyra//'.InfoSup2') +cgn call gmprsx (nompro,nhhexa//'.InfoSup2') +cgn call gmprsx (nompro,nhvois) +cgn call gmprsx (nompro,nhvois//'.Vol/Tri') +cgn call gmprsx (nompro,nhvois//'.Vol/Qua') +cgn call gmprsx (nompro,nhvois//'.PyPe/Tri') +cgn call gmprsx (nompro,nhvois//'.PyPe/Qua') +c +c==== +c 7. decoupage des pentaedres en pyramides et tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 .and. ( provte.gt.0 .or. provpy.gt.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCDPE', nompro +#endif +c + call cmcdpe ( indnoe, indare, indtri, indtet, indpyr, + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(pfamno), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), imem(pfamar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pfamtr), + > imem(pnivtr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), + > imem(phette), imem(ptrite), imem(pcotrt), + > imem(pfilte), imem(pperte), imem(pfamte), + > imem(adtes2), + > imem(phetpy), imem(pfacpy), imem(pcofay), + > imem(pfilpy), imem(pperpy), imem(pfampy), + > imem(adpys2), + > imem(pfacpe), imem(pcofap), imem(phetpe), + > imem(pfilpe), imem(adpes2), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +c + endif +cgn call gmprsx (nompro,nhpyra//'.ConnDesc') +cgn call gmprsx (nompro,nhhexa//'.InfoSup2') +cgn call gmprsx (nompro,nhvois) +cgn call gmprsx (nompro,nhvois//'.Vol/Tri') +cgn call gmprsx (nompro,nhvois//'.Vol/Qua') +cgn call gmprsx (nompro,nhvois//'.PyPe/Tri') +cgn call gmprsx (nompro,nhvois//'.PyPe/Qua') +c +c==== +c 8. verifications des nombres d'entites crees et impressions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. verifications ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + indtet = indtea + indhex = indhea + indpyr = indpya +c + iaux = 0 +c +c attention : on ne sait pas verifier avec des noeuds P2 +c + if ( degre.eq.1 ) then + if ( provp1.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,-1), + > indnoe-permno + if ( indnoe.ne.nouvno ) then + write (ulsort,texte(langue,7)) provp1 + iaux = iaux + 1 + endif + endif + endif +c + if ( provar.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,1), + > indare-permar + if ( indare.ne.nouvar ) then + write (ulsort,texte(langue,7)) provar + iaux = iaux + 1 + endif + endif +c + if ( provtr.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,2), + > indtri-permtr + if ( indtri.ne.nouvtr ) then + write (ulsort,texte(langue,7)) provtr + iaux = iaux + 1 + endif + endif +c + if ( provqu.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,4), + > indqua-permqu + if ( indqua.ne.nouvqu ) then + write (ulsort,texte(langue,7)) provqu + iaux = iaux + 1 + endif + endif +c + if ( provte.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,3), + > indtet-permte + if ( indtet.ne.nouvte ) then + write (ulsort,texte(langue,7)) provte + iaux = iaux + 1 + endif + endif +c + if ( provpy.ne.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,5), + > indpyr-permpy + if ( indpyr.ne.nouvpy ) then + write (ulsort,texte(langue,7)) provpy + iaux = iaux + 1 + endif + endif +c + if ( iaux.gt.0 ) then + codret = 4 + endif +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmcp01.F b/src/tool/Creation_Maillage/cmcp01.F new file mode 100644 index 00000000..f1ed6099 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp01.F @@ -0,0 +1,431 @@ + subroutine cmcp01 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 01 - par l'arete de triangle 1 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f2, cf2 + integer f4, cf4 + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f3, cf3 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + f4 = facpen(lepent,4) + f5 = facpen(lepent,5) + cf2 = cofape(lepent,2) + cf4 = cofape(lepent,4) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + f3 = facpen(lepent,3) + cf1 = cofape(lepent,1) + cf3 = cofape(lepent,3) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 1 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(5) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S1,S2,S3) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF3 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle 1 de la face 2 : FF1 + 0/1 (FF1D2) +c trifad(2,1) = triangle 2 de la face 2 : FF1 + 1/0 (FF1D3) +c areqtr(2,2) : AS2N1 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 1 +c + ind001(1) = 2 + ind001(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i1, i2, i3, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N1 +c lesnoe(1) : S5 +c areint(1) : AS5N1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA5N1 +c triint(2) : FA8N1 +c triint(3) : FA6N1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(5) + lesare(2) = listar(8) + lesare(3) = listar(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f4 + coface(1) = cf4 +c + laface(2) = f5 + coface(2) = cf5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(5,cf2) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f2, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp02.F b/src/tool/Creation_Maillage/cmcp02.F new file mode 100644 index 00000000..a4ae0e9a --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp02.F @@ -0,0 +1,431 @@ + subroutine cmcp02 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 02 - par l'arete de triangle 2 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f2, cf2 + integer f3, cf3 + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f4, cf4 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 2 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(6) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S1,S2,S3) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF4 + 2/1 +c areqtr(1,1) : AS5N2 +c areqtr(1,2) : AS4N2 +c +c trifad(2,0) = triangle 1 de la face 2 : FF1 + 0/1 (FF1D3) +c trifad(2,1) = triangle 2 de la face 2 : FF1 + 1/0 (FF1D1) +c areqtr(2,2) : AS3N2 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 1 +c + ind001(1) = 1 + ind001(2) = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i2, i3, i1, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N2 +c lesnoe(1) : S6 +c areint(1) : AS6N2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA6N2 +c triint(2) : FA9N2 +c triint(3) : FA4N2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(6) + lesare(2) = listar(9) + lesare(3) = listar(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f5 + coface(1) = cf5 +c + laface(2) = f3 + coface(2) = cf3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(6,cf2) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f2, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp03.F b/src/tool/Creation_Maillage/cmcp03.F new file mode 100644 index 00000000..7703109d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp03.F @@ -0,0 +1,431 @@ + subroutine cmcp03 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 03 - par l'arete de triangle 3 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f5, cf5 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + cf5 = cofape(lepent,5) + f5 = facpen(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 3 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(4) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S1,S2,S3) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de S3 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S2 : FF5 + 2/1 +c areqtr(1,1) : AS6N3 +c areqtr(1,2) : AS5N3 +c +c trifad(2,0) = triangle 1 de la face 2 : FF1 + 0/1 (FF1D1) +c trifad(2,1) = triangle 2 de la face 2 : FF1 + 1/0 (FF1D2) +c areqtr(2,2) : AS1N3 +c + nulofa(1) = 5 + nulofa(2) = 1 +c + if ( codret.eq.0 ) then +c + ind001(1) = 3 + ind001(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i3, i1, i2, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N3 +c lesnoe(1) : S4 +c areint(1) : AS4N1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA4N3 +c triint(2) : FA7N3 +c triint(3) : FA5N3 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(4) + lesare(2) = listar(7) + lesare(3) = listar(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f3 + coface(1) = cf3 +c + laface(2) = f4 + coface(2) = cf4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(4,cf2) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f2, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp04.F b/src/tool/Creation_Maillage/cmcp04.F new file mode 100644 index 00000000..5c986d94 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp04.F @@ -0,0 +1,434 @@ + subroutine cmcp04 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 04 - par l'arete de triangle 4 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "ope002.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f1, cf1 + integer f4, cf4 + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f3, cf3 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 + write (ulsort,90015) 'Triangle', f1, + > ', aretes', (aretri(f1,jaux),jaux=1,3) +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 4 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(2) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S4,S6,S5) +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S6 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S4 : FF3 + 2/1 +c areqtr(1,1) : AS3N4 +c areqtr(1,2) : AS1N4 +c +c trifad(2,0) = triangle 1 de la face 2 : FF2 + 0/1 (FF2D5) +c trifad(2,1) = triangle 2 de la face 2 : FF2 + 1/0 (FF2D4) +c areqtr(2,2) : AS5N4 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 2 +c + ind001(1) = 2 + ind001(2) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i1, i2, i3, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N4 +c lesnoe(1) : S2 +c areint(1) : AS2N4 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA3N6 +c triint(2) : FA8N6 +c triint(3) : FA2N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(8) + lesare(3) = listar(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f5 + coface(1) = per002(3,cf5) +c + laface(2) = f4 + coface(2) = per002(3,cf4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(5,cf1) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp05.F b/src/tool/Creation_Maillage/cmcp05.F new file mode 100644 index 00000000..55720dfe --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp05.F @@ -0,0 +1,434 @@ + subroutine cmcp05 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 05 - par l'arete de triangle 5 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "ope002.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f1, cf1 + integer f3, cf3 + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f4, cf4 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 + write (ulsort,90015) 'Triangle', f1, + > ', aretes', (aretri(f1,jaux),jaux=1,3) +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 5 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(3) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S4,S6,S5) +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S4 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S5 : FF4 + 2/1 +c areqtr(1,1) : AS1N5 +c areqtr(1,2) : AS2N5 +c +c trifad(2,0) = triangle 1 de la face 2 : FF2 + 0/1 (FF2D4) +c trifad(2,1) = triangle 2 de la face 2 : FF2 + 1/0 (FF2D6) +c areqtr(2,2) : AS6N5 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 2 +c + ind001(1) = 3 + ind001(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i3, i1, i2, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N5 +c lesnoe(1) : S3 +c areint(1) : AS3N5 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA1N6 +c triint(2) : FA9N6 +c triint(3) : FA3N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(9) + lesare(3) = listar(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f3 + coface(1) = per002(3,cf3) +c + laface(2) = f5 + coface(2) = per002(3,cf5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(4,cf1) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp06.F b/src/tool/Creation_Maillage/cmcp06.F new file mode 100644 index 00000000..6b69d5d4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp06.F @@ -0,0 +1,434 @@ + subroutine cmcp06 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 06 - par l'arete de triangle 6 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "ope002.h" +#include "i1i2i3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami + integer f1, cf1 + integer f3, cf3 + integer f4, cf4 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f5, cf5 +#endif + integer noemil, lesnoe(2), lesare(3) + integer areint(1) + integer triint(3) + integer laface(2), coface(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer ind001(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'listso', listso +#endif +c +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 + write (ulsort,90015) 'Triangle', f1, + > ', aretes', (aretri(f1,jaux),jaux=1,3) +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 6 + jaux = listar(iaux) + noemil = somare(2,filare(jaux)) +c +c lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour +c definir l'arete interne + lesnoe(1) = listso(1) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil + write(ulsort,90002) 'lesnoe(1)', lesnoe(1) +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c Sens positif : (S1,S2,S3) +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de S5 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S6 : FF5 + 2/1 +c areqtr(1,1) : AS2N6 +c areqtr(1,2) : AS3N6 +c +c trifad(2,0) = triangle 1 de la face 2 : FF2 + 0/1 (FF2D5) +c trifad(2,1) = triangle 2 de la face 2 : FF2 + 1/0 (FF2D4) +c areqtr(2,2) : AS4N6 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 2 +c + ind001(1) = 1 + ind001(2) = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0B', nompro +#endif + call cmcp0b ( nulofa, lepent, + > i2, i3, i1, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil : N6 +c lesnoe(1) : S1 +c areint(1) : AS1N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 1 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c +c==== +c 5. Creation des trois triangles internes +c triint(1) : FA2N6 +c triint(2) : FA7N6 +c triint(3) : FA1N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+3 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) + lesare(2) = listar(7) + lesare(3) = listar(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0C', nompro +#endif + call cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-2 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation des deux pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+2 +#endif +c + if ( codret.eq.0 ) then +c + laface(1) = f4 + coface(1) = per002(3,cf4) +c + laface(2) = f3 + coface(2) = per002(3,cf3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP0D', nompro +#endif + call cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-1 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation du tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+1 +#endif +c + if ( codret.eq.0 ) then +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c + coface(1) = per001(6,cf1) + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f1, trifad(1,0), triint(3), triint(1), + > coface(1), cotrvo(1,0), 1, 6, + > nupere, nufami, indtet ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp0a.F b/src/tool/Creation_Maillage/cmcp0a.F new file mode 100644 index 00000000..65ef7e56 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp0a.F @@ -0,0 +1,382 @@ + subroutine cmcp0a ( lepent, etapen, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 0, phase A, pilotage +c - - +c - par 1 arete de triangle +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP0A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9), listso(6) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOPE', nompro +#endif + call utsope ( somare, listar, listso ) +c +c==== +c 3. Recherche de l'arete decoupee +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91002) iaux, listar(iaux), + > somare(1,listar(iaux)), somare(2,listar(iaux)), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> L'arete 1 est coupee +c + if ( mod(hetare(listar(1)),10).eq.2 ) then + etapen = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP01', nompro +#endif + call cmcp01 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> L'arete 2 est coupee +c + elseif ( mod(hetare(listar(2)),10).eq.2 ) then + etapen = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP02', nompro +#endif + call cmcp02 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.3. ==> L'arete 3 est coupee +c + elseif ( mod(hetare(listar(3)),10).eq.2 ) then + etapen = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP03', nompro +#endif + call cmcp03 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.4. ==> L'arete 4 est coupee +c + elseif ( mod(hetare(listar(4)),10).eq.2 ) then + etapen = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP04', nompro +#endif + call cmcp04 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.5. ==> L'arete 5 est coupee +c + elseif ( mod(hetare(listar(5)),10).eq.2 ) then + etapen = 5 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP05', nompro +#endif + call cmcp05 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.6. ==> L'arete 6 est coupee +c + elseif ( mod(hetare(listar(6)),10).eq.2 ) then + etapen = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP06', nompro +#endif + call cmcp06 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.9. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp0b.F b/src/tool/Creation_Maillage/cmcp0b.F new file mode 100644 index 00000000..380c92b7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp0b.F @@ -0,0 +1,244 @@ + subroutine cmcp0b ( nulofa, lepent, + > ind11, ind12, ind13, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 0, phase B +c - - +c Reperage des aretes et des triangles sur les faces externes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . ind11 . e . 1 . i1i2i3 associe a l'arete coupee . +c . ind12 . e . 1 . i1i2i3 associe a l'arete suivant ind11 . +c . ind13 . e . 1 . i1i2i3 associe a l'arete precedant ind11 . +c . ind001 . e . 2 . redirection dans per001 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(2,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(2,0:2) . code des triangles dans les volumes . +c . areqtr . s . (2,2) . aretes tri tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP0B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +#include "demitr.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(2) + integer ind11(6), ind12(6), ind13(6) + integer ind001(2) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer areqtr(2,2) + integer trifad(2,0:2), cotrvo(2,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer laface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c REMARQUE : +c On raisonne avec un sens de rotation qui est le sens entrant quand +c on regarde la face triangulaire coupee : (S1,S2,S3) ou (S4,S6,S5) +c +c==== +c 2. Triangles et aretes tracees sur le quadrangle coupe en 3 +c trifad(1,0) : triangle central de ce decoupage +c trifad(1,1) : triangle suivant le central selon le sens defini +c trifad(1,2) : triangle precedant le central selon le sens defini +c cotrvo(1,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description des fils +c areqtr(1,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(1,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c + laface = facpen(lepent,nulofa(1)) + iaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(laface) + if ( iaux.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', laface,', code =', iaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c==== +c 3. Triangles et aretes tracees sur le triangle coupe en 2 +c trifad(2,0) : triangle suivant le milieu de l'arete coupee +c trifad(2,1) : triangle precedant le milieu de l'arete coupee +c cotrvo(2,0/1) : futur code du triangle trifad(p,0/1) dans la +c description des fils +c areqtr(2,2) : arete commune aux deux triangles fils +c==== +c + laface = facpen(lepent,nulofa(2)) + iaux = cofape(lepent,nulofa(2)) + trifad(2,0) = filtri(laface) + nutrde(ind11(iaux),ind12(iaux)) + trifad(2,1) = filtri(laface) + nutrde(ind11(iaux),ind13(iaux)) + areqtr(2,2) = aretri(trifad(2,0),ind13(iaux)) + cotrvo(2,0) = per001(ind001(1),iaux) + cotrvo(2,1) = per001(ind001(2),iaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', laface,', code = ', iaux + do 3333 , iaux = 0, 1 + write (ulsort,90015) 'trifad(2,0/1) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 3333 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1) + write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c==== +c 4. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp0c.F b/src/tool/Creation_Maillage/cmcp0c.F new file mode 100644 index 00000000..49d50ab6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp0c.F @@ -0,0 +1,182 @@ + subroutine cmcp0c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 0, phase C +c - - +c Construction des triangles internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 3 . triangles internes au pentaedre . +c . . . . 1 = bordant la pyramide 1 uniquement . +c . . . . 2 = bordant la pyramide 2 uniquement . +c . . . . 3 = bordant les deux pyramides . +c . lesare . e . 3 . liste des aretes du pentaedre utiles . +c . . . . 1 = pyramide 1 et opposee a la face coupee. +c . . . . 2 = pyramide 2 et opposee a la face coupee. +c . . . . 3 = pyramide 1 et 2 . +c . areint . e . 1 . arete interne au pentaedre . +c . areqtr . e . (2,2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP0C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(3) + integer lesare(3) + integer areint(1) + integer areqtr(2,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles s'appuient sur les 3 aretes non decoupees +c triint(1) = dans la pyramide 1, l'arete non decoupee opposee +c a la face triangulaire coupee +c triint(2) = dans la pyramide 2, l'arete non decoupee opposee +c a la face triangulaire coupee +c triint(3) = triangle commun aux deux pyramides +c==== +c + indtri = indtri + 1 + triint(1) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(1,1), areint(1), lesare(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(2) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_2', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(2,2), lesare(2), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(3) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_3', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(1,2), lesare(3), + > codetr, niveau ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp0d.F b/src/tool/Creation_Maillage/cmcp0d.F new file mode 100644 index 00000000..b783c809 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp0d.F @@ -0,0 +1,190 @@ + subroutine cmcp0d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 0, phase D +c - - +c Construction des pyramides +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(2,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(2,0:2) . code des triangles dans les volumes . +c . triint . e . 3 .triangles internes au pentaedre . +c . . . . 1 = bordant la pyramide 1 uniquement . +c . . . . 2 = bordant la pyramide 2 uniquement . +c . . . . 3 = bordant les deux pyramides . +c . laface . e . 2 . numero des faces non coupees . +c . coface . e . 2 . futur code des faces dans le tetraedre . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP0D' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer indpyr, indptp + integer lepent + integer trifad(2,0:2), cotrvo(2,0:2) + integer triint(3) + integer laface(2), coface(2) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des pyramides et leur famille +c + nupere = -indptp + nufami = cfapen(cofpfp,fampen(lepent)) +c +c==== +c 2. Pyramide dont la base suit le quadrangle +c coupe, vu depuis le triangle coupe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_1', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(2,0), cotrvo(2,0), + > trifad(1,1), cotrvo(1,1), + > triint(1), 1, + > triint(2), 1, + > laface(1), coface(1), + > nupere, nufami, indpyr ) +c +c==== +c 3. Pyramide suivante +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_2', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(2,1), cotrvo(2,1), + > triint(2), 4, + > triint(3), 1, + > trifad(1,2), cotrvo(1,2), + > laface(2), coface(2), + > nupere, nufami, indpyr ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp17.F b/src/tool/Creation_Maillage/cmcp17.F new file mode 100644 index 00000000..00001fa2 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp17.F @@ -0,0 +1,353 @@ + subroutine cmcp17 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 17 - par l'arete de quadrangle 7 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP17' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indtri, indtet, indpyr + integer indptp + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 + integer f2, cf2 + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f3, cf3 + integer f4, cf4 +#endif + integer lesare(2) + integer tab1(4), tab2(4) + integer triint(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + cf5 = cofape(lepent,5) + f5 = facpen(lepent,5) +#ifdef _DEBUG_HOMARD_ + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + cf4 = cofape(lepent,4) + f4 = facpen(lepent,4) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> Triangles et aretes tracees sur les quadrangles coupes +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de F1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de F2 : FF4 + 2/1 +c areqtr(1,1) : AS2N7 +c areqtr(1,2) : AS5N7 +c +c trifad(2,0) = triangle central de la face 1 : FF3 +c trifad(2,1) = triangle de la face 1 du cote de F1 : FF3 + 1/2 +c trifad(2,2) = triangle de la face 1 du cote de F2 : FF3 + 2/1 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS6N7 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1B', nompro +#endif + call cmcp1b ( nulofa, lepent, + > aretri, nivtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c==== +c==== +c 5. Creation des deux triangles internes +c triint(1) : le triangle interne du cote de F1 +c triint(2) : le triangle interne du cote de F2 +c triint(1) : FA3N7 +c triint(2) : FA6N7 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+2 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1C', nompro +#endif + call cmcp1c ( indtri, triint, + > lesare, + > areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 1, + > trifad(1,0), cotrvo(1,0), + > triint(2), 1, + > trifad(2,0), cotrvo(2,0), + > f5, cf5, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write (ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c +c==== +c 7. Creation des 2 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c + tab1(1) = f1 + tab2(1) = per001(6,cf1) +c + tab1(2) = f2 + tab2(2) = per001(4,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1E', nompro +#endif + call cmcp1e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > tab1, tab2, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp18.F b/src/tool/Creation_Maillage/cmcp18.F new file mode 100644 index 00000000..7462045b --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp18.F @@ -0,0 +1,353 @@ + subroutine cmcp18 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 18 - par l'arete de quadrangle 8 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP18' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indtri, indtet, indpyr + integer indptp + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 +#ifdef _DEBUG_HOMARD_ + integer f4, cf4 + integer f5, cf5 +#endif + integer lesare(2) + integer tab1(4), tab2(4) + integer triint(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) +#ifdef _DEBUG_HOMARD_ + cf4 = cofape(lepent,4) + f4 = facpen(lepent,4) + cf5 = cofape(lepent,5) + f5 = facpen(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> Triangles et aretes tracees sur les quadrangles coupes +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de F1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de F2 : FF5 + 2/1 +c areqtr(1,1) : AS3N8 +c areqtr(1,2) : AS6N8 +c +c trifad(2,0) = triangle central de la face 1 : FF4 +c trifad(2,1) = triangle de la face 1 du cote de F1 : FF4 + 1/2 +c trifad(2,2) = triangle de la face 1 du cote de F2 : FF4 + 2/1 +c areqtr(2,1) : AS1N8 +c areqtr(2,2) : AS1N8 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1B', nompro +#endif + call cmcp1b ( nulofa, lepent, + > aretri, nivtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c==== +c==== +c 5. Creation des deux triangles internes +c triint(1) : le triangle interne du cote de F1 +c triint(2) : le triangle interne du cote de F2 +c triint(1) : FA1N8 +c triint(2) : FA4N8 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+2 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1C', nompro +#endif + call cmcp1c ( indtri, triint, + > lesare, + > areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 1, + > trifad(1,0), cotrvo(1,0), + > triint(2), 1, + > trifad(2,0), cotrvo(2,0), + > f3, cf3, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write (ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c +c==== +c 7. Creation des 2 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c + tab1(1) = f1 + tab2(1) = per001(5,cf1) +c + tab1(2) = f2 + tab2(2) = per001(5,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1E', nompro +#endif + call cmcp1e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > tab1, tab2, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp19.F b/src/tool/Creation_Maillage/cmcp19.F new file mode 100644 index 00000000..d1b779e9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp19.F @@ -0,0 +1,353 @@ + subroutine cmcp19 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 19 - par l'arete de quadrangle 9 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP19' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indtri, indtet, indpyr + integer indptp + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 + integer f2, cf2 + integer f4, cf4 +#ifdef _DEBUG_HOMARD_ + integer f3, cf3 + integer f5, cf5 +#endif + integer lesare(2) + integer tab1(4), tab2(4) + integer triint(2) + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) + integer nulofa(2) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + cf4 = cofape(lepent,4) + f4 = facpen(lepent,4) +#ifdef _DEBUG_HOMARD_ + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + cf5 = cofape(lepent,5) + f5 = facpen(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> Triangles et aretes tracees sur les quadrangles coupes +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de F1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de F2 : FF4 + 2/1 +c areqtr(1,1) : AS1N9 +c areqtr(1,2) : AS4N9 +c +c trifad(2,0) = triangle central de la face 1 : FF5 +c trifad(2,1) = triangle de la face 1 du cote de F1 : FF3 + 1/2 +c trifad(2,2) = triangle de la face 1 du cote de F2 : FF3 + 2/1 +c areqtr(2,1) : AS2N9 +c areqtr(2,2) : AS5N9 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1B', nompro +#endif + call cmcp1b ( nulofa, lepent, + > aretri, nivtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c==== +c==== +c 5. Creation des deux triangles internes +c triint(1) : le triangle interne du cote de F1 +c triint(2) : le triangle interne du cote de F2 +c triint(1) : FA2N9 +c triint(2) : FA5N9 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+2 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) + lesare(2) = listar(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1C', nompro +#endif + call cmcp1c ( indtri, triint, + > lesare, + > areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 1, + > trifad(1,0), cotrvo(1,0), + > triint(2), 1, + > trifad(2,0), cotrvo(2,0), + > f4, cf4, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write (ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c +c==== +c 7. Creation des 2 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c + tab1(1) = f1 + tab2(1) = per001(4,cf1) +c + tab1(2) = f2 + tab2(2) = per001(6,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP1E', nompro +#endif + call cmcp1e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > tab1, tab2, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write (ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp1a.F b/src/tool/Creation_Maillage/cmcp1a.F new file mode 100644 index 00000000..dde70a6d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp1a.F @@ -0,0 +1,290 @@ + subroutine cmcp1a ( lepent, etapen, + > indtri, indtet, indpyr, + > indptp, + > hetare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 1, phase A, pilotage +c - - +c - par 1 arete de quadrangle +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP1A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indtri, indtet, indpyr + integer indptp + integer hetare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +c==== +c 3. Recherche de l'arete decoupee +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91001) iaux, listar(iaux), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> L'arete 7 est coupee +c + if ( mod(hetare(listar(7)),10).eq.2 ) then + etapen = 17 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP17', nompro +#endif + call cmcp17 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> L'arete 8 est coupee +c + elseif ( mod(hetare(listar(8)),10).eq.2 ) then + etapen = 18 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP18', nompro +#endif + call cmcp18 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.3. ==> L'arete 9 est coupee +c + elseif ( mod(hetare(listar(9)),10).eq.2 ) then + etapen = 19 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP19', nompro +#endif + call cmcp19 ( lepent, listar, + > indtri, indtet, indpyr, + > indptp, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.4. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp1b.F b/src/tool/Creation_Maillage/cmcp1b.F new file mode 100644 index 00000000..0e6c876e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp1b.F @@ -0,0 +1,236 @@ + subroutine cmcp1b ( nulofa, lepent, + > aretri, nivtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 1, phase B +c - - +c Reperage des aretes et des triangles sur les faces externes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(2,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(2,0:2) . code des triangles dans les volumes . +c . areqtr . s . (2,2) . aretes tri tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP1B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(2) + integer aretri(nouvtr,3), nivtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur le quadrangle dont le +c triangle central sera la face 2 de la pyramide +c trifad(1,0) : triangle central de ce decoupage +c trifad(1,1) : triangle du cote de la face F1 du pentaedre +c trifad(1,2) : triangle du cote de la face F2 du pentaedre +c cotrvo(1,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description des fils +c areqtr(1,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(1,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90002) 'areqtr(1,1) = ', areqtr(1,1) + write(ulsort,90002) 'areqtr(1,2) = ', areqtr(1,2) +#endif +c +c==== +c 3. Triangles et aretes tracees sur le quadrangle dont le +c triangle central sera la face 4 de la pyramide +c trifad(2,0) : triangle central de ce decoupage +c trifad(2,1) : triangle du cote de la face F1 du pentaedre +c trifad(2,2) : triangle du cote de la face F2 du pentaedre +c cotrvo(2,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la +c description des fils +c areqtr(2,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(2,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 1 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 5 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 3333 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 3333 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90002) 'areqtr(2,1) = ', areqtr(1,1) + write(ulsort,90002) 'areqtr(2,2) = ', areqtr(1,2) +#endif +c +c==== +c 4. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp1c.F b/src/tool/Creation_Maillage/cmcp1c.F new file mode 100644 index 00000000..8c62f543 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp1c.F @@ -0,0 +1,163 @@ + subroutine cmcp1c ( indtri, triint, + > lesare, + > areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 1, phase C +c - - +c Construction des triangles internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 2 . triangles internes au pentaedre . +c . . . . 1 = bordant la face f1 . +c . . . . 2 = bordant la face f2 . +c . lesare . e . 2 . liste des aretes du pentaedre utiles . +c . . . . 1 = arete non decoupee face 1 et pyramide . +c . . . . 2 = arete non decoupee face 2 et pyramide . +c . areqtr . e . (2,2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP1C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(2) + integer lesare(2) + integer areqtr(2,2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles s'appuient sur les 2 aretes non decoupees +c triint(1) = borde la face triangulaire F1 +c triint(2) = borde la face triangulaire F2 +c==== +c + indtri = indtri + 1 + triint(1) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(2,1), areqtr(1,1), lesare(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(2) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_2', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(1,2), areqtr(2,2), lesare(2), + > codetr, niveau ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp1e.F b/src/tool/Creation_Maillage/cmcp1e.F new file mode 100644 index 00000000..25c1865c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp1e.F @@ -0,0 +1,184 @@ + subroutine cmcp1e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 1, phase E +c - - +c Construction des tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(2,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(2,0:2) . code des triangles dans les volumes . +c . triint . e . 2 .triangles internes au pentaedre . +c . . . . 1 = bordant la face f1 . +c . . . . 2 = bordant la face f2 . +c . laface . e . 2 . numero des faces non coupees . +c . coface . e . 2 . futur code des faces dans le tetraedre . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP1E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(2,0:2), cotrvo(2,0:2) + integer triint(2) + integer laface(2), coface(2) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c +c==== +c 2. Tetraedre +c==== +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_1', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > laface(1), triint(1), trifad(2,1), trifad(1,1), + > coface(1), 6, cotrvo(2,1), cotrvo(1,1), + > nupere, nufami, indtet ) +c +c==== +c 3. Tetraedre +c==== +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_2', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > laface(2), triint(2), trifad(1,2), trifad(2,2), + > coface(2), 6, cotrvo(1,2), cotrvo(2,2), + > nupere, nufami, indtet ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp21.F b/src/tool/Creation_Maillage/cmcp21.F new file mode 100644 index 00000000..b1ddd7b4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp21.F @@ -0,0 +1,389 @@ + subroutine cmcp21 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 21 - par les aretes 1 et 8 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP21' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f2, cf2 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 1 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 8 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S3 : FF3 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de F1 : FF4 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F2 : FF4 + 2/1 +c areqtr(2,1) : AS1N8 +c areqtr(2,2) : AS4N8 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de F1 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F2 : FF5 + 2/1 +c areqtr(3,1) : AS3N8 +c areqtr(3,2) : AS6N8 +c +c trifad(4,0) = triangle 1 de la face 4 : FF1 + 0/1 (FF1D2) +c trifad(4,1) = triangle 2 de la face 4 : FF1 + 1/0 (FF1D3) +c areqtr(4,1) : AS2N1 +c +c areqtr(1,0) : AS1N1 +c areqtr(2,0) : AS3N1 +c areqtr(3,0) : AS2N8 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + nulofa(3) = 5 + nulofa(4) = 1 +c + iaux = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i1, i2, i3, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N1 +c noemil(2) : N8 +c areint(1) : AN1N8 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA4 +c triint(2) : FS4 +c triint(3) : FS6 +c triint(4) : FS1 +c triint(5) : FS3 +c triint(6) : FS2 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-5 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(5,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f2, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp22.F b/src/tool/Creation_Maillage/cmcp22.F new file mode 100644 index 00000000..f80a586f --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp22.F @@ -0,0 +1,394 @@ + subroutine cmcp22 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 22 - par les aretes 2 et 9 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP22' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f2, cf2 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Triangle', f2, + > ', aretes', (aretri(f2,jaux),jaux=1,3) +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 2 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 9 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S2 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S1 : FF4 + 2/1 +c areqtr(1,1) : AS5N2 +c areqtr(1,2) : AS4N2 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de F1 : FF5 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F2 : FF5 + 2/1 +c areqtr(2,1) : AS2N9 +c areqtr(2,2) : AS5N9 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de F1 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F2 : FF3 + 2/1 +c areqtr(3,1) : AS1N9 +c areqtr(3,2) : AS4N9 +c +c trifad(4,0) = triangle 1 de la face 4 : FF1 + 0/1 (FF1D3) +c trifad(4,1) = triangle 2 de la face 4 : FF1 + 1/0 (FF1D1) +c areqtr(4,1) : AS3N2 +c +c areqtr(1,0) : AS2N2 +c areqtr(2,0) : AS1N2 +c areqtr(3,0) : AS3N9 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 5 + nulofa(3) = 3 + nulofa(4) = 1 +c + iaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i2, i3, i1, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N2 +c noemil(2) : N9 +c areint(1) : AN2N9 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA5 +c triint(2) : FS5 +c triint(3) : FS4 +c triint(4) : FS2 +c triint(5) : FS1 +c triint(6) : FS3 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-5 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(6,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f2, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp23.F b/src/tool/Creation_Maillage/cmcp23.F new file mode 100644 index 00000000..11a48e1b --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp23.F @@ -0,0 +1,389 @@ + subroutine cmcp23 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 23 - par les aretes 3 et 7 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP23' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f2, cf2 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 3 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 7 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de S3 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S2 : FF5 + 2/1 +c areqtr(1,1) : AS6N3 +c areqtr(1,2) : AS5N3 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de F1 : FF3 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F2 : FF3 + 2/1 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS6N7 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de F1 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F2 : FF4 + 2/1 +c areqtr(3,1) : AS2N7 +c areqtr(3,2) : AS5N7 +c +c trifad(4,0) = triangle 1 de la face 2 : FF1 + 0/1 (FF1D1) +c trifad(4,1) = triangle 2 de la face 2 : FF1 + 1/0 (FF1D2) +c areqtr(4,1) : AS1N3 +c +c areqtr(1,0) : AS3N3 +c areqtr(2,0) : AS2N3 +c areqtr(3,0) : AS1N7 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 3 + nulofa(3) = 4 + nulofa(4) = 1 +c + iaux = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i3, i1, i2, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N3 +c noemil(2) : N7 +c areint(1) : AN3N7 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA6 +c triint(2) : FS6 +c triint(3) : FS5 +c triint(4) : FS3 +c triint(5) : FS2 +c triint(6) : FS1 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-5 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(4,cf2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f2, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp24.F b/src/tool/Creation_Maillage/cmcp24.F new file mode 100644 index 00000000..faeaec83 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp24.F @@ -0,0 +1,380 @@ + subroutine cmcp24 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 24 - par les aretes 4 et 8 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP24' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 4 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 8 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 du cote de S6 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S4 : FF3 + 2/1 +c areqtr(1,1) : AS3N4 +c areqtr(1,2) : AS1N4 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 du cote de F2 : FF5 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F1 : FF5 + 2/1 +c areqtr(2,1) : AS6N8 +c areqtr(2,2) : AS3N8 +c +c trifad(3,0) = triangle central de la face 3 : FF4 +c trifad(3,1) = triangle de la face 3 du cote de F2 : FF4 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F1 : FF4 + 2/1 +c areqtr(3,1) : AS4N8 +c areqtr(3,2) : AS1N8 +c +c trifad(4,0) = triangle 1 de la face 4 : FF2 + 0/1 (FF2D6) +c trifad(4,1) = triangle 2 de la face 4 : FF2 + 1/0 (FF2D5) +c areqtr(4,1) : AS5N4 +c +c areqtr(1,0) : AS6N4 +c areqtr(2,0) : AS4N4 +c areqtr(3,0) : AS5N8 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 5 + nulofa(3) = 4 + nulofa(4) = 2 +c + iaux = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i1, i2, i3, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N4 +c noemil(2) : N8 +c areint(1) : AN4N8 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA1 +c triint(2) : FS3 +c triint(3) : FS1 +c triint(4) : FS6 +c triint(5) : FS4 +c triint(6) : FS5 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(5,cf1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f1, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp25.F b/src/tool/Creation_Maillage/cmcp25.F new file mode 100644 index 00000000..374aa6ab --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp25.F @@ -0,0 +1,380 @@ + subroutine cmcp25 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 25 - par les aretes 5 et 9 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP25' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 5 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 9 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 du cote de S6 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S4 : FF4 + 2/1 +c areqtr(1,1) : AS1N5 +c areqtr(1,2) : AS2N5 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 du cote de F2 : FF3 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F1 : FF3 + 2/1 +c areqtr(2,1) : AS4N9 +c areqtr(2,2) : AS1N9 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 du cote de F2 : FF5 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F1 : FF5 + 2/1 +c areqtr(3,1) : AS5N9 +c areqtr(3,2) : AS2N9 +c +c trifad(4,0) = triangle 1 de la face 4 : FF2 + 0/1 (FF2D4) +c trifad(4,1) = triangle 2 de la face 4 : FF2 + 1/0 (FF2D6) +c areqtr(4,1) : AS6N5 +c +c areqtr(1,0) : AS4N5 +c areqtr(2,0) : AS5N5 +c areqtr(3,0) : AS6N9 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 3 + nulofa(3) = 5 + nulofa(4) = 2 +c + iaux = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i3, i1, i2, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N5 +c noemil(2) : N9 +c areint(1) : AN5N9 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA2 +c triint(2) : FS1 +c triint(3) : FS2 +c triint(4) : FS4 +c triint(5) : FS5 +c triint(6) : FS6 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(4,cf1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f1, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp26.F b/src/tool/Creation_Maillage/cmcp26.F new file mode 100644 index 00000000..3fd1d27a --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp26.F @@ -0,0 +1,389 @@ + subroutine cmcp26 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 26 - par les aretes 6 et 7 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP26' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope001.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9) + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, cf1 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil(2), lesare(1) + integer areint(1) + integer triint(6) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer niveau + integer coface +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 6 + jaux = listar(iaux) + noemil(1) = somare(2,filare(jaux)) +c + iaux = 7 + jaux = listar(iaux) + noemil(2) = somare(2,filare(jaux)) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'noemil', noemil +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 du cote de S5 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 du cote de S6 : FF5 + 2/1 +c areqtr(1,1) : AS2N6 +c areqtr(1,2) : AS3N6 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 du cote de F2 : FF4 + 1/2 +c trifad(2,2) = triangle de la face 2 du cote de F1 : FF4 + 2/1 +c areqtr(2,1) : AS5N7 +c areqtr(2,2) : AS2N7 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 du cote de F2 : FF3 + 1/2 +c trifad(3,2) = triangle de la face 3 du cote de F1 : FF3 + 2/1 +c areqtr(3,1) : AS6N7 +c areqtr(3,2) : AS3N7 +c +c trifad(4,0) = triangle 1 de la face 4 : FF2 + 0/1 (FF2D5) +c trifad(4,1) = triangle 2 de la face 4 : FF2 + 1/0 (FF2D4) +c areqtr(4,1) : AS4N6 +c +c areqtr(1,0) : AS5N6 +c areqtr(2,0) : AS6N6 +c areqtr(3,0) : AS4N7 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 4 + nulofa(3) = 3 + nulofa(4) = 2 +c + iaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2B', nompro +#endif + call cmcp2b ( nulofa, lepent, + > i3, i2, i1, iaux, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation de l'arete interne +c noemil(1) : N6 +c noemil(2) : N7 +c areint(1) : AN6N7 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+1 +#endif +c + if ( codret.eq.0 ) then +c + indare = indare + 1 + areint(1) = indare +c + somare(1,areint(1)) = min ( noemil(1) , noemil(2) ) + somare(2,areint(1)) = max ( noemil(1) , noemil(2) ) +c + famare(areint(1)) = 1 + hetare(areint(1)) = 50 + merare(areint(1)) = 0 + filare(areint(1)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(1) = ', areint(1), + > ' de ',somare(1,areint(1)), + > ' a ',somare(2,areint(1)) +#endif +c + endif +c==== +c 5. Creation des six triangles internes +c triint(1) : FA3 +c triint(2) : FS1 +c triint(3) : FS2 +c triint(4) : FS5 +c triint(5) : FS6 +c triint(6) : FS4 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+6 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2C', nompro +#endif + call cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-5 , indtri + write (ulsort,90015) 'Triangle', iaux, + > ', aretes', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des 6 tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+6 +#endif +c + if ( codret.eq.0 ) then +c + coface = per001(6,cf1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP2E', nompro +#endif + call cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > f1, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-5 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp2a.F b/src/tool/Creation_Maillage/cmcp2a.F new file mode 100644 index 00000000..aa737afe --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp2a.F @@ -0,0 +1,357 @@ + subroutine cmcp2a( lepent, etapen, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 2, phase A, pilotage +c - - +c - par 2 aretes de tri/quadrangle +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP2A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indare, indtri, indtet + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +c==== +c 3. Recherche de l'arete decoupee +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91002) iaux, listar(iaux), + > somare(1,listar(iaux)), somare(2,listar(iaux)), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Les aretes 1 et 8 sont coupees +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etapen = 21 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP21', nompro +#endif + call cmcp21 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> Les aretes 2 et 9 sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etapen = 22 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP22', nompro +#endif + call cmcp22 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.3. ==> Les aretes 3 et 7 sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 ) then + etapen = 23 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP23', nompro +#endif + call cmcp23 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.4. ==> Les aretes 4 et 8 sont coupees +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etapen = 24 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP24', nompro +#endif + call cmcp24 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.5. ==> Les aretes 5 et 9 sont coupees +c + elseif ( mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etapen = 25 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP25', nompro +#endif + call cmcp25 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.6. ==> Les aretes 6 et 7 sont coupees +c + elseif ( mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 ) then + etapen = 26 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP26', nompro +#endif + call cmcp26 ( lepent, listar, + > indare, indtri, indtet, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.7. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp2b.F b/src/tool/Creation_Maillage/cmcp2b.F new file mode 100644 index 00000000..ebbbac25 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp2b.F @@ -0,0 +1,338 @@ + subroutine cmcp2b ( nulofa, lepent, + > ind11, ind12, ind13, ind001, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 2, phase B +c - - +c Reperage des aretes et des triangles sur les faces externes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . ind11 . e . 1 . i1i2i3 associe a l'arete coupee . +c . ind12 . e . 1 . i1i2i3 associe a l'arete suivant ind11 . +c . ind13 . e . 1 . i1i2i3 associe a l'arete precedant ind11 . +c . ind001 . e . 1 . indice associe a la permutation per001 . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:2) . code des triangles dans les volumes . +c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP2B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +#include "demitr.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(4) + integer ind11(6), ind12(6), ind13(6) + integer ind001 + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c REMARQUE : +c On raisonne avec un sens de rotation qui est le sens entrant quand +c on regarde la face triangulaire coupee : (S1,S2,S3) ou (S4,S6,S5) +c +c==== +c 2. Triangles et aretes tracees sur le quadrangle qui +c borde l'arete triangulaire coupee +c trifad(1,0) : triangle central de ce decoupage +c trifad(1,1) : triangle suivant le central selon le sens defini +c trifad(1,2) : triangle precedant le central selon le sens defini +c cotrvo(1,0/1/2) : futur code du triangle trifad(1,0/1/2) dans la +c description des fils +c areqtr(1,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(1,1) +c areqtr(1,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(1,2) +c==== +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90002) 'areqtr(1,1) = ', areqtr(1,1) + write(ulsort,90002) 'areqtr(1,2) = ', areqtr(1,2) +#endif +c +c==== +c 3. Triangles et aretes tracees sur le quadrangle suivant le premier +c trifad(2,0) : triangle central de ce decoupage +c trifad(2,1) : triangle du cote de la face triangulaire coupee +c trifad(2,2) : triangle du cote de l'autre face triangulaire +c cotrvo(2,0/1/2) : futur code du triangle trifad(2,0/1/2) dans la +c description des fils +c areqtr(2,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(2,1) +c areqtr(2,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(2,2) +c==== +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 3333 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 3333 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,90002) 'areqtr(2,1) = ', areqtr(2,1) + write(ulsort,90002) 'areqtr(2,2) = ', areqtr(2,2) +#endif +c +c==== +c 4. Triangles et aretes tracees sur le quadrangle suivant le deuxieme +c trifad(3,0) : triangle central de ce decoupage +c trifad(3,1) : triangle du cote de la face triangulaire coupee +c trifad(3,2) : triangle du cote de l'autre face triangulaire +c cotrvo(3,0/1/2) : futur code du triangle trifad(3,0/1/2) dans la +c description des fils +c areqtr(3,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(3,1) +c areqtr(3,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(3,2) +c==== +c + iaux = facpen(lepent,nulofa(3)) + jaux = cofape(lepent,nulofa(3)) + trifad(3,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(3,0) = 2 + trifad(3,1) = trifad(3,0) + 2 + cotrvo(3,1) = 1 + trifad(3,2) = trifad(3,0) + 1 + cotrvo(3,2) = 4 + areqtr(3,1) = aretri(trifad(3,0),3) + areqtr(3,2) = aretri(trifad(3,0),1) + else + cotrvo(3,0) = 4 + trifad(3,1) = trifad(3,0) + 1 + cotrvo(3,1) = 4 + trifad(3,2) = trifad(3,0) + 2 + cotrvo(3,2) = 1 + areqtr(3,1) = aretri(trifad(3,0),1) + areqtr(3,2) = aretri(trifad(3,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 4444 , iaux = 0, 2 + write (ulsort,90015) 'trifad(3,0/1/2) =', trifad(3,iaux), + > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3) + 4444 continue + write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1), + > 'cotrvo(3,2) = ', cotrvo(3,2) + write(ulsort,90002) 'areqtr(3,1) = ', areqtr(3,1) + write(ulsort,90002) 'areqtr(3,2) = ', areqtr(3,2) +#endif +c +c==== +c 5. Triangles et aretes tracees sur le triangle coupe en 2 +c trifad(4,0) : triangle suivant le milieu de l'arete coupee +c trifad(4,1) : triangle precedant le milieu de l'arete coupee +c cotrvo(4,0/1) : futur code du triangle trifad(p,0/1) dans la +c description des fils +c areqtr(4,2) : arete commune aux deux triangles fils +c==== +c + iaux = facpen(lepent,nulofa(4)) + jaux = cofape(lepent,nulofa(4)) + trifad(4,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux)) + trifad(4,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux)) + areqtr(4,2) = aretri(trifad(4,0),ind13(jaux)) + cotrvo(4,0) = per001(ind001,jaux) + cotrvo(4,1) = per001(ind001,jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code = ', jaux + do 5555 , iaux = 0, 1 + write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux), + > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3) + 5555 continue + write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1) + write(ulsort,90002) 'areqtr(4,2) = ', areqtr(4,2) +#endif +c +c==== +c 6. Demi-aretes +c areqtr(1,0) : demi-arete tri, du cote 'suivant' +c areqtr(2,0) : demi-arete tri, du cote 'precedant' +c areqtr(3,0) : demi-arete qua, du cote de la face tria coupee +c==== +c + areqtr(1,0) = aretri(trifad(1,1),1) + areqtr(2,0) = aretri(trifad(1,2),1) + areqtr(3,0) = aretri(trifad(2,1),1) +#ifdef _DEBUG_HOMARD_ + do 6666 , iaux = 1,3 + write(ulsort,90002) 'areqtr(1/2/3,0) = ', areqtr(iaux,0) + 6666 continue +#endif +c +c==== +c 7. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp2c.F b/src/tool/Creation_Maillage/cmcp2c.F new file mode 100644 index 00000000..38f4be54 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp2c.F @@ -0,0 +1,229 @@ + subroutine cmcp2c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 2, phase C +c - - +c Construction des triangles internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 6 . triangles internes au pentaedre . +c . . . . 1 = avec arete du tria non coupe . +c . . . . 2-3 = arete interne et so tria non coupe . +c . . . . 4-6 = arete interne et so tria coupe . +c . lesare . e . 1 . liste des aretes du pentaedre utiles . +c . . . . 1 = arete sur le triangle non coupe . +c . areint . e . 1 . arete interne au pentaedre . +c . areqtr . e .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP2C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(6) + integer lesare(1) + integer areint(1) + integer areqtr(4,0:2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c REMARQUE : +c On raisonne avec un sens de rotation qui est le sens entrant quand +c on regarde la face triangulaire coupee : (S1,S2,S3) ou (S4,S6,S5) +c +c==== +c 2. Le triangle base sur une arete non decoupee +c triint(1) = entre le milieu de l'arete de quadrangle coupee et +c l'arete non decoupee +c==== +c + indtri = indtri + 1 + triint(1) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(3,2), lesare(1), areqtr(2,2), + > codetr, niveau ) +c +c==== +c 3. Les triangles s'appuyant sur le milieu de l'arete de quadrangle +c coupee et une autre arete non decoupee sur la face non decoupee +c triint(2) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f1 +c triint(3) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f2 +c==== +c + indtri = indtri + 1 + triint(2) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_2', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(1,1), areqtr(2,2), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(3) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_3', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(3,2), areqtr(1,2), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur le milieu de l'arete de quadrangle +c coupee et une arete tracee sur la face triangulaire decoupee +c triint(4) : 1/2 arete de l'arete tria coupee, suivant le milieu +c triint(5) : 1/2 arete de l'arete tria coupee, precedant le milieu +c triint(6) : arete tracee sur la face triangulaire coupee +c==== +c + indtri = indtri + 1 + triint(4) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_4', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(2,1), areqtr(1,0), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(5) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_5', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(2,0),areqtr(3,1), + > codetr, niveau ) + +c + indtri = indtri + 1 + triint(6) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_6', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), areqtr(3,0), areqtr(4,2), + > codetr, niveau ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp2e.F b/src/tool/Creation_Maillage/cmcp2e.F new file mode 100644 index 00000000..fcc79922 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp2e.F @@ -0,0 +1,221 @@ + subroutine cmcp2e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > laface, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 2, phase E +c - - +c Construction des tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 6 . triangles internes au pentaedre . +c . . . . 1 = avec arete du tria non coupe . +c . . . . 2-3 = arete interne et so tria non coupe . +c . . . . 4-6 = arete interne et so tria coupe . +c . laface . e . 1 . numero des faces non coupees . +c . coface . e . 1 . futur code des faces dans le tetraedre . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP2E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(6) + integer laface, coface + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c +c==== +c 2. Tetraedres +c==== +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_1', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > laface, triint(1), trifad(3,2), trifad(2,2), + > coface, 2, cotrvo(3,2), cotrvo(2,2), + > nupere, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_2', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(5), triint(6), trifad(3,1), + > cotrvo(4,1), 2 , 6, cotrvo(3,1), + > nupere, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_3', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(4), trifad(2,1), triint(6), + > cotrvo(4,0), 1 , cotrvo(2,1), 6, + > nupere, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_4', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(1), triint(2), triint(3), + > cotrvo(1,0), 4 , 4, 1, + > nupere, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_5', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), trifad(3,0), triint(3),triint(5), + > cotrvo(1,2), cotrvo(3,0), 1 , 4, + > nupere, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_6', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), trifad(2,0), triint(4),triint(2), + > cotrvo(1,1), cotrvo(2,0), 1 , 4, + > nupere, nufami, indtet ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp31.F b/src/tool/Creation_Maillage/cmcp31.F new file mode 100644 index 00000000..835fc722 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp31.F @@ -0,0 +1,477 @@ + subroutine cmcp31 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 31 - par les aretes 1 et 5 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP31' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 1 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 5 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(3) + lesnoe(2) = listso(2) + lesnoe(3) = listso(5) + lesnoe(4) = listso(6) + lesnoe(5) = listso(1) + lesnoe(6) = listso(4) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF3 + 2/1 +c areqtr(1,1) : AS6N1 +c areqtr(1,2) : AS4N1 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF4 + 1/2 +c areqtr(2,1) : AS2N5 +c areqtr(2,2) : AS1N5 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS3N1 +c areqtr(3,1) : arete de trifad(3,1) : AS1N1 +c areqtr(3,2) : arete commune : AS2N1 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS5N5 +c areqtr(4,1) : arete de trifad(4,1) : AS4N5 +c areqtr(4,2) : arete commune : AS6N5 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 6 + ind001(2) = 4 + ind001(3) = 4 + ind001(4) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3B', nompro +#endif + call cmcp3b ( nulofa, lepent, + > i1, i3, i2, + > i3, i2, i1, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS3N0 +c areint(2) : AS2N0 +c areint(3) : AS5N0 +c areint(4) : AS6N0 +c areint(5) : AS1N0 +c areint(6) : AS4N0 +c areint(7) : AN1N0 +c areint(8) : AN5N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA3 +c triint( 2) = FA8 +c triint( 3) = FA6 +c triint( 4) = FA9 +c triint( 5) = FA2 +c triint( 6) = FA4 +c triint( 7) = FA7 +c triint( 8) = FS3N1 +c triint( 9) = FS1N1 +c triint(10) = FS5N5 +c triint(11) = FS4N5 +c triint(12) = FS6N1 +c triint(13) = FS4N1 +c triint(14) = FS2N5 +c triint(15) = FS1N5 +c triint(16) = FS2N1 +c triint(17) = FS6N5 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(8) + lesare(3) = listar(6) + lesare(4) = listar(9) + lesare(5) = listar(2) + lesare(6) = listar(4) + lesare(7) = listar(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3C', nompro +#endif + call cmcp3c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f5, cf5, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write(ulsort,90002) 'facpyr', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90002) 'cofapy', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3E', nompro +#endif + call cmcp3e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp32.F b/src/tool/Creation_Maillage/cmcp32.F new file mode 100644 index 00000000..1528dda6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp32.F @@ -0,0 +1,477 @@ + subroutine cmcp32 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 32 - par les aretes 2 et 6 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP32' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f3, cf3 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f4, cf4 + integer f5, cf5 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 2 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 6 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(1) + lesnoe(2) = listso(3) + lesnoe(3) = listso(6) + lesnoe(4) = listso(4) + lesnoe(5) = listso(2) + lesnoe(6) = listso(5) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF4 + 2/1 +c areqtr(1,1) : AS4N2 +c areqtr(1,2) : AS5N2 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF5 + 1/2 +c areqtr(2,1) : AS3N6 +c areqtr(2,2) : AS2N6 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS1N2 +c areqtr(3,1) : arete de trifad(3,1) : AS2N2 +c areqtr(3,2) : arete commune : AS3N2 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS6N6 +c areqtr(4,1) : arete de trifad(4,1) : AS5N6 +c areqtr(4,2) : arete commune : AS4N6 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 5 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 5 + ind001(2) = 6 + ind001(3) = 5 + ind001(4) = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3B', nompro +#endif + call cmcp3b ( nulofa, lepent, + > i2, i1, i3, + > i2, i1, i3, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS1N0 +c areint(2) : AS3N0 +c areint(3) : AS6N0 +c areint(4) : AS4N0 +c areint(5) : AS2N0 +c areint(6) : AS5N0 +c areint(7) : AN2N0 +c areint(8) : AN6N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA1 +c triint( 2) = FA9 +c triint( 3) = FA4 +c triint( 4) = FA7 +c triint( 5) = FA3 +c triint( 6) = FA5 +c triint( 7) = FA8 +c triint( 8) = FS1N2 +c triint( 9) = FS2N2 +c triint(10) = FS6N6 +c triint(11) = FS5N6 +c triint(12) = FS4N2 +c triint(13) = FS5N2 +c triint(14) = FS3N6 +c triint(15) = FS2N6 +c triint(16) = FS3N2 +c triint(17) = FS4N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(9) + lesare(3) = listar(4) + lesare(4) = listar(7) + lesare(5) = listar(3) + lesare(6) = listar(5) + lesare(7) = listar(8) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3C', nompro +#endif + call cmcp3c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f3, cf3, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write(ulsort,90002) 'facpyr', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90002) 'cofapy', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3E', nompro +#endif + call cmcp3e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp33.F b/src/tool/Creation_Maillage/cmcp33.F new file mode 100644 index 00000000..8c8f4c1b --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp33.F @@ -0,0 +1,477 @@ + subroutine cmcp33 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 33 - par les aretes 3 et 4 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP33' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f4, cf4 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f5, cf5 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 3 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 4 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(4) + lesnoe(4) = listso(5) + lesnoe(5) = listso(3) + lesnoe(6) = listso(6) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF5 + 2/1 +c areqtr(1,1) : AS5N3 +c areqtr(1,2) : AS6N3 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF3 + 1/2 +c areqtr(2,1) : AS1N4 +c areqtr(2,2) : AS3N4 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS2N3 +c areqtr(3,1) : arete de trifad(3,1) : AS3N3 +c areqtr(3,2) : arete commune : AS1N3 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS4N4 +c areqtr(4,1) : arete de trifad(4,1) : AS6N4 +c areqtr(4,2) : arete commune : AS5N4 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 3 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 4 + ind001(2) = 5 + ind001(3) = 6 + ind001(4) = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3B', nompro +#endif + call cmcp3b ( nulofa, lepent, + > i3, i2, i1, + > i1, i3, i2, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS2N0 +c areint(2) : AS1N0 +c areint(3) : AS4N0 +c areint(4) : AS5N0 +c areint(5) : AS3N0 +c areint(6) : AS6N0 +c areint(7) : AN3N0 +c areint(8) : AN4N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA2 +c triint( 2) = FA7 +c triint( 3) = FA5 +c triint( 4) = FA8 +c triint( 5) = FA1 +c triint( 6) = FA6 +c triint( 7) = FA9 +c triint( 8) = FS2N3 +c triint( 9) = FS3N3 +c triint(10) = FS4N4 +c triint(11) = FS6N4 +c triint(12) = FS5N3 +c triint(13) = FS6N3 +c triint(14) = FS1N4 +c triint(15) = FS3N4 +c triint(16) = FS1N3 +c triint(17) = FS5N4 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) + lesare(2) = listar(7) + lesare(3) = listar(5) + lesare(4) = listar(8) + lesare(5) = listar(1) + lesare(6) = listar(6) + lesare(7) = listar(9) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3C', nompro +#endif + call cmcp3c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f4, cf4, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write(ulsort,90002) 'facpyr', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90002) 'cofapy', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3E', nompro +#endif + call cmcp3e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp34.F b/src/tool/Creation_Maillage/cmcp34.F new file mode 100644 index 00000000..97294112 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp34.F @@ -0,0 +1,488 @@ + subroutine cmcp34 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 34 - par les aretes 1 et 6 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP34' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f4, cf4 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f5, cf5 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 1 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 6 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(4) + lesnoe(4) = listso(5) + lesnoe(5) = listso(3) + lesnoe(6) = listso(6) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF3 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS6N1 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF5 + 1/2 +c areqtr(2,1) : AS2N6 +c areqtr(2,2) : AS3N6 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS1N1 +c areqtr(3,1) : arete de trifad(3,1) : AS3N1 +c areqtr(3,2) : arete commune : AS2N1 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS5N6 +c areqtr(4,1) : arete de trifad(4,1) : AS6N6 +c areqtr(4,2) : arete commune : AS4N6 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 5 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 4 + ind001(2) = 6 + ind001(3) = 6 + ind001(4) = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3F', nompro +#endif + call cmcp3f ( nulofa, lepent, + > i1, i2, i3, + > i2, i3, i1, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS2N0 +c areint(2) : AS1N0 +c areint(3) : AS4N0 +c areint(4) : AS5N0 +c areint(5) : AS3N0 +c areint(6) : AS6N0 +c areint(7) : AN1N0 +c areint(8) : AN6N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 400 , iaux = indare-7 , indare + write (ulsort,90015) 'Arete', iaux, + > ', sommets', somare(1,iaux),somare(2,iaux) + 400 continue +#endif +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA2 +c triint( 2) = FA7 +c triint( 3) = FA5 +c triint( 4) = FA8 +c triint( 5) = FA3 +c triint( 6) = FA4 +c triint( 7) = FA9 +c triint( 8) = FS1N1 +c triint( 9) = FS3N1 +c triint(10) = FS5N6 +c triint(11) = FS6N6 +c triint(12) = FS4N1 +c triint(13) = FS6N1 +c triint(14) = FS2N6 +c triint(15) = FS3N6 +c triint(16) = FS2N1 +c triint(17) = FS4N6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(2) + lesare(2) = listar(7) + lesare(3) = listar(5) + lesare(4) = listar(8) + lesare(5) = listar(3) + lesare(6) = listar(4) + lesare(7) = listar(9) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3G', nompro +#endif + call cmcp3g ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f4, cf4, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3H', nompro +#endif + call cmcp3h ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp35.F b/src/tool/Creation_Maillage/cmcp35.F new file mode 100644 index 00000000..bff7cb1c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp35.F @@ -0,0 +1,488 @@ + subroutine cmcp35 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 35 - par les aretes 2 et 4 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP35' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f5, cf5 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 2 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 4 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(3) + lesnoe(2) = listso(2) + lesnoe(3) = listso(5) + lesnoe(4) = listso(6) + lesnoe(5) = listso(1) + lesnoe(6) = listso(4) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF4 + 2/1 +c areqtr(1,1) : AS5N2 +c areqtr(1,2) : AS4N2 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF3 + 1/2 +c areqtr(2,1) : AS3N4 +c areqtr(2,2) : AS1N4 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS2N2 +c areqtr(3,1) : arete de trifad(3,1) : AS1N2 +c areqtr(3,2) : arete commune : AS3N2 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS6N4 +c areqtr(4,1) : arete de trifad(4,1) : AS4N4 +c areqtr(4,2) : arete commune : AS5N4 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 3 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 6 + ind001(2) = 5 + ind001(3) = 4 + ind001(4) = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3F', nompro +#endif + call cmcp3f ( nulofa, lepent, + > i2, i3, i1, + > i1, i2, i3, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS3N0 +c areint(2) : AS2N0 +c areint(3) : AS5N0 +c areint(4) : AS6N0 +c areint(5) : AS1N0 +c areint(6) : AS4N0 +c areint(7) : AN2N0 +c areint(8) : AN4N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 400 , iaux = indare-7 , indare + write (ulsort,90015) 'Arete', iaux, + > ', sommets', somare(1,iaux),somare(2,iaux) + 400 continue +#endif +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA3 +c triint( 2) = FA8 +c triint( 3) = FA6 +c triint( 4) = FA9 +c triint( 5) = FA1 +c triint( 6) = FA5 +c triint( 7) = FA7 +c triint( 8) = FS2N2 +c triint( 9) = FS1N2 +c triint(10) = FS6N4 +c triint(11) = FS4N4 +c triint(12) = FS5N2 +c triint(13) = FS4N2 +c triint(14) = FS3N4 +c triint(15) = FS1N4 +c triint(16) = FS3N2 +c triint(17) = FS5N4 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(8) + lesare(3) = listar(6) + lesare(4) = listar(9) + lesare(5) = listar(1) + lesare(6) = listar(5) + lesare(7) = listar(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3G', nompro +#endif + call cmcp3g ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f5, cf5, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3H', nompro +#endif + call cmcp3h ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp36.F b/src/tool/Creation_Maillage/cmcp36.F new file mode 100644 index 00000000..3fb063b4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp36.F @@ -0,0 +1,488 @@ + subroutine cmcp36 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 36 - par les aretes 3 et 5 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP36' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f3, cf3 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f4, cf4 + integer f5, cf5 +#endif + integer lesnoe(8), lesare(7) + integer areint(8) + integer triint(17) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer nulofa(4) + integer ind001(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 3 + jaux = listar(iaux) + lesnoe(7) = somare(2,filare(jaux)) +c + iaux = 5 + jaux = listar(iaux) + lesnoe(8) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c Les 4 premiers sont les sommets Si de la pyramide +c lesnoe(5) : le dernier sommet de la face 1 +c lesnoe(6) : le dernier sommet de la face 2 +c + lesnoe(1) = listso(1) + lesnoe(2) = listso(3) + lesnoe(3) = listso(6) + lesnoe(4) = listso(4) + lesnoe(5) = listso(2) + lesnoe(6) = listso(5) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 bordant la pyr : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 autre : FF5 + 2/1 +c areqtr(1,1) : AS6N3 +c areqtr(1,2) : AS5N3 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 bordant la pyr : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 autre : FF4 + 1/2 +c areqtr(2,1) : AS1N5 +c areqtr(2,2) : AS2N5 +c +c trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,0) : arete de trifad(3,0) : AS3N3 +c areqtr(3,1) : arete de trifad(3,1) : AS2N3 +c areqtr(3,2) : arete commune : AS1N3 +c +c trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,0) : arete de trifad(4,0) : AS4N5 +c areqtr(4,1) : arete de trifad(4,1) : AS5N5 +c areqtr(4,2) : arete commune : AS6N5 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 4 + nulofa(3) = 1 + nulofa(4) = 2 +c + ind001(1) = 5 + ind001(2) = 4 + ind001(3) = 5 + ind001(4) = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3F', nompro +#endif + call cmcp3f ( nulofa, lepent, + > i3, i1, i2, + > i3, i1, i2, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS1N0 +c areint(2) : AS3N0 +c areint(3) : AS6N0 +c areint(4) : AS4N0 +c areint(5) : AS2N0 +c areint(6) : AS5N0 +c areint(7) : AN3N0 +c areint(8) : AN5N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+8 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 8 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 400 , iaux = indare-7 , indare + write (ulsort,90015) 'Arete', iaux, + > ', sommets', somare(1,iaux),somare(2,iaux) + 400 continue +#endif +c + endif +c +c==== +c 5. Creation des 17 triangles internes +c triint( 1) = FA1 +c triint( 2) = FA9 +c triint( 3) = FA4 +c triint( 4) = FA7 +c triint( 5) = FA2 +c triint( 6) = FA6 +c triint( 7) = FA8 +c triint( 8) = FS3N3 +c triint( 9) = FS2N3 +c triint(10) = FS4N5 +c triint(11) = FS5N5 +c triint(12) = FS6N3 +c triint(13) = FS5N3 +c triint(14) = FS1N5 +c triint(15) = FS2N5 +c triint(16) = FS1N3 +c triint(17) = FS6N5 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+17 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(1) + lesare(2) = listar(9) + lesare(3) = listar(4) + lesare(4) = listar(7) + lesare(5) = listar(2) + lesare(6) = listar(6) + lesare(7) = listar(8) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3G', nompro +#endif + call cmcp3g ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-16 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+1 +#endif +c + if ( codret.eq.0 ) then +c + iaux = -indptp + jaux = cfapen(cofpfp,fampen(lepent)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > triint(1), 2, + > triint(2), 2, + > triint(3), 2, + > triint(4), 1, + > f3, cf3, + > iaux, jaux, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP3H', nompro +#endif + call cmcp3h ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-9 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3a.F b/src/tool/Creation_Maillage/cmcp3a.F new file mode 100644 index 00000000..9a2b2f02 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3a.F @@ -0,0 +1,413 @@ + subroutine cmcp3a ( lepent, etapen, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase A, pilotage +c - - +c - par 2 aretes de tri/tri +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indnoe, indare, indtri, indtet, indpyr + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9), listso(6) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOPE', nompro +#endif + call utsope ( somare, listar, listso ) +c +c==== +c 3. Recherche des aretes decoupees +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91002) iaux, listar(iaux), + > somare(1,listar(iaux)), somare(2,listar(iaux)), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Les aretes 1 et 5 sont coupees +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 ) then + etapen = 31 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP31', nompro +#endif + call cmcp31 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> Les aretes 2 et 6 sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 ) then + etapen = 32 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP32', nompro +#endif + call cmcp32 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.3. ==> Les aretes 3 et 4 sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(4)),10).eq.2 ) then + etapen = 33 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP33', nompro +#endif + call cmcp33 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.4. ==> Les aretes 1 et 6 sont coupees +c + elseif ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 ) then + etapen = 34 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP34', nompro +#endif + call cmcp34 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.5. ==>> Les aretes 2 et 4 sont coupees +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(4)),10).eq.2 ) then + etapen = 35 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP35', nompro +#endif + call cmcp35 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.6. ==> Les aretes 3 et 5 sont coupees +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 ) then + etapen = 36 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP36', nompro +#endif + call cmcp36 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, indpyr, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.9. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3b.F b/src/tool/Creation_Maillage/cmcp3b.F new file mode 100644 index 00000000..a8a14b38 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3b.F @@ -0,0 +1,325 @@ + subroutine cmcp3b ( nulofa, lepent, + > ind11, ind12, ind13, + > ind21, ind22, ind23, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase B +c - - +c Reperage des aretes et des triangles sur les faces externes +c Remarque : cmcp3b et cmcp3f sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . indi1 . e . 1 . i1i2i3 associe a l'arete coupee face i . +c . indi2 . e . 1 . i1i2i3 associe a l'arete du cote de pyra . +c . indi3 . e . 1 . i1i2i3 associe a l'arete oppose a la pyra . +c . ind001 . e . 4 . redirection dans per001 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:2) . code des triangles dans les volumes . +c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +#include "demitr.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(4) + integer ind11(6), ind12(6), ind13(6) + integer ind21(6), ind22(6), ind23(6) + integer ind001(4) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer areqtr(4,0:2) + integer trifad(4,0:2), cotrvo(4,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les quadrangles coupees en 3 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est celle qui contient l'arete de F1 coupee. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee qui +c appartient a la pyramide +c trifad(p,2) : triangle bordant l'arete non decoupee qui +c n'appartient pas a la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c areqtr(3/4,0) = fille de l'arete coupee, du cote de la pyramide +c areqtr(3/4,1) = autre fille +c==== +c +c 2.1. ==> Face 1 +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 4 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 1 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + endif + areqtr(3,0) = aretri(trifad(1,1),1) + areqtr(3,1) = aretri(trifad(1,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2221 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2221 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) + write(ulsort,90006) 'areqtr(3,0) = ', areqtr(3,0), + > ' de ',somare(1,areqtr(3,0)), + > ' a ',somare(2,areqtr(3,0)) + write(ulsort,90006) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) +#endif +c +c 2.2. ==> Face 2 +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 4 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 1 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif + areqtr(4,0) = aretri(trifad(2,1),1) + areqtr(4,1) = aretri(trifad(2,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) + write(ulsort,90006) 'areqtr(4,0) = ', areqtr(4,0), + > ' de ',somare(1,areqtr(4,0)), + > ' a ',somare(2,areqtr(4,0)) + write(ulsort,90006) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) +#endif +c +c==== +c 3. Triangles et aretes tracees sur les triangles coupes en 2 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est F1. +c trifad(p,0) : triangle bordant la pyramide +c trifad(p,1) : triangle autre +c areqtr(p,2) : arete commune aux deux triangles fils +c==== +c 3.1. ==> Face 3 +c + iaux = facpen(lepent,nulofa(3)) + jaux = cofape(lepent,nulofa(3)) + trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux)) + trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux)) + areqtr(3,2) = aretri(trifad(3,0),ind13(jaux)) +c + cotrvo(3,0) = per001(ind001(1),jaux) + cotrvo(3,1) = per001(ind001(2),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3331 , iaux = 0, 1 + write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux), + > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3) + 3331 continue + write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1) + write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 3.2. ==> Face 4 +c + iaux = facpen(lepent,nulofa(4)) + jaux = cofape(lepent,nulofa(4)) + trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux)) + trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux)) + areqtr(4,2) = aretri(trifad(4,0),ind23(jaux)) + + cotrvo(4,0) = per001(ind001(3),jaux) + cotrvo(4,1) = per001(ind001(4),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3332 , iaux = 0, 1 + write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux), + > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3) + 3332 continue + write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1) + write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c==== +c 4. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3c.F b/src/tool/Creation_Maillage/cmcp3c.F new file mode 100644 index 00000000..be5e00a1 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3c.F @@ -0,0 +1,330 @@ + subroutine cmcp3c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase C +c - - +c Construction des triangles internes +c Remarque : cmcp3c et cmcp3g sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 17 . triangles internes au pentaedre . +c . . . . 1-4 = bordant la pyramide . +c . . . . 5 = bordant la face f1 . +c . . . . 6 = bordant la face f2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . . . . 8-11 = appuyes sur les filles des aretes . +c . . . . coupees . +c . . . . 12-17 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . lesare . e . 7 . liste des aretes du pentaedre utiles . +c . . . . 1-4 = les aretes de la pyramide . +c . . . . 5 = autre arete non decoupee face 1 . +c . . . . 6 = autre arete non decoupee face 2 . +c . . . . 7 = derniere arete non decoupee . +c . areint . e . 8 . aretes internes au pentaedre . +c . areqtr . e .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(17) + integer lesare(7) + integer areint(8) + integer areqtr(4,0:2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles de la pyramide +c triint(i) = triangle bordant la pyramide selon l'arete areint(i) +c==== +c + do 21 , iaux = 1 , 4 +c + jaux = per1a4(1,iaux) +c + indtri = indtri + 1 + triint(iaux) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1234', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(jaux), lesare(iaux), areint(iaux), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. Les triangles s'appuyant sur les 3 aretes non decoupees +c triint(5) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f1 +c triint(6) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f2 +c triint(7) = triangle s'appuyant sur la derniere arete non decoupee +c==== +c + indtri = indtri + 1 + triint(5) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_5', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(2),lesare(5), areint(5), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(6) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_6', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(4), lesare(6), areint(6), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(7) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_7', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(5),lesare(7),areint(6), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur les filles des aretes coupees +c triint(8) : 1/2 arete de la face F1, du cote pyramide +c triint(9) : 1/2 arete de la face F1, de l'autre cote +c triint(10) : 1/2 arete de la face F2, du cote pyramide +c triint(11) : 1/2 arete de la face F2, de l'autre cote +c==== +c + indtri = indtri + 1 + triint(8) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_8', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(7), areqtr(3,0), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(9) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_9', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(5), areqtr(3,1), areint(7), + > codetr, niveau ) + +c + indtri = indtri + 1 + triint(10) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_10', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(8), areqtr(4,0), areint(3), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(11) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_11', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(6), areqtr(4,1), areint(8), + > codetr, niveau ) +c +c==== +c 5. Les triangles s'appuyant sur une arete interne a une face coupee +c triint(12) : arete de la 1ere face quad , du cote pyramide +c triint(13) : arete de la 1ere face quad , de l'autre cote +c triint(14) : arete de la 2eme face quad , du cote pyramide +c triint(15) : arete de la 2eme face quad , de l'autre cote +c triint(16) : arete de la face F1 +c triint(17) : arete de la face F2 +c==== +c + indtri = indtri + 1 + triint(12) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_12', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(4), areqtr(1,1), areint(7), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(13) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_13', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(7), areqtr(1,2), areint(6), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(14) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_14', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(2), areqtr(2,1), areint(8), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(15) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_15', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(8), areqtr(2,2), areint(5), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(16) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_16', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(2), areqtr(3,2), areint(7), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(17) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_17', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(4), areqtr(4,2), areint(8), + > codetr, niveau ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3e.F b/src/tool/Creation_Maillage/cmcp3e.F new file mode 100644 index 00000000..2e8a8c9e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3e.F @@ -0,0 +1,291 @@ + subroutine cmcp3e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase E +c - - +c Construction des tetraedres +c Remarque : cmcp3e et cmcp3h sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 17 . triangles internes au pentaedre . +c . . . . 1-4 = bordant la pyramide . +c . . . . 5 = bordant la face f1 . +c . . . . 6 = bordant la face f2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . . . . 8-11 = appuyes sur les filles des aretes . +c . . . . coupees . +c . . . . 12-17 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(17) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_1', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(1), triint(8), triint(16), + > cotrvo(3,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 2.1. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_2', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(5), triint(16), triint(9), + > cotrvo(3,1), 2, 2, 2, + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_3', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(3), triint(10), triint(17), + > cotrvo(4,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 3.1. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_4', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(6), triint(17), triint(11), + > cotrvo(4,1), 2, 2, 2, + > nupere, nufami, indtet ) +c +c==== +c 4. Face quadrangulaire dont l'arete coupee est sur la face 1 +c==== +c 4.1. ==> tetraedre central +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_5', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(6), triint(13), triint(12), + > cotrvo(1,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_6', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(4), triint(12), triint(8), + > cotrvo(1,1), 4, 2, 4, + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_7', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(7), triint(9), triint(13), + > cotrvo(1,2), 2, 2, 4, + > nupere, nufami, indtet ) +c +c==== +c 5. Face quadrangulaire dont l'arete coupee est sur la face 2 +c==== +c 5.1. ==> tetraedre central +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_8', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(5), triint(15), triint(14), + > cotrvo(2,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_9', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(2), triint(14), triint(10), + > cotrvo(2,1), 4, 2, 4, + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_10', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(7), triint(11), triint(15), + > cotrvo(2,2), 4, 2, 4, + > nupere, nufami, indtet ) +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3f.F b/src/tool/Creation_Maillage/cmcp3f.F new file mode 100644 index 00000000..e0c373ab --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3f.F @@ -0,0 +1,325 @@ + subroutine cmcp3f ( nulofa, lepent, + > ind11, ind12, ind13, + > ind21, ind22, ind23, + > ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase F +c - - +c Reperage des aretes et des triangles sur les faces externes +c Remarque : cmcp3b et cmcp3f sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . indi1 . e . 1 . i1i2i3 associe a l'arete coupee face i . +c . indi2 . e . 1 . i1i2i3 associe a l'arete du cote de pyra . +c . indi3 . e . 1 . i1i2i3 associe a l'arete oppose a la pyra . +c . ind001 . e . 4 . redirection dans per001 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:2) . code des triangles dans les volumes . +c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3F' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +#include "demitr.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(4) + integer ind11(6), ind12(6), ind13(6) + integer ind21(6), ind22(6), ind23(6) + integer ind001(4) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer areqtr(4,0:2) + integer trifad(4,0:2), cotrvo(4,0:2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les quadrangles coupees en 3 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est celle qui contient l'arete de F1 coupee. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee qui +c appartient a la pyramide +c trifad(p,2) : triangle bordant l'arete non decoupee qui +c n'appartient pas a la pyramide +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c areqtr(3/4,0) = fille de l'arete coupee, du cote de la pyramide +c areqtr(3/4,1) = autre fille +c==== +c +c 2.1. ==> Face 1 +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 4 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 1 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif + areqtr(3,0) = aretri(trifad(1,1),1) + areqtr(3,1) = aretri(trifad(1,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2221 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2221 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) + write(ulsort,90006) 'areqtr(3,0) = ', areqtr(3,0), + > ' de ',somare(1,areqtr(3,0)), + > ' a ',somare(2,areqtr(3,0)) + write(ulsort,90006) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) +#endif +c +c 2.2. ==> Face 2 +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 4 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 1 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif + areqtr(4,0) = aretri(trifad(2,1),1) + areqtr(4,1) = aretri(trifad(2,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) + write(ulsort,90006) 'areqtr(4,0) = ', areqtr(4,0), + > ' de ',somare(1,areqtr(4,0)), + > ' a ',somare(2,areqtr(4,0)) + write(ulsort,90006) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) +#endif +c +c==== +c 3. Triangles et aretes tracees sur les triangles coupes en 2 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est F1. +c trifad(p,0) : triangle bordant la pyramide +c trifad(p,1) : triangle autre +c areqtr(p,2) : arete commune aux deux triangles fils +c==== +c 3.1. ==> Face 3 +c + iaux = facpen(lepent,nulofa(3)) + jaux = cofape(lepent,nulofa(3)) + trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux)) + trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux)) + areqtr(3,2) = aretri(trifad(3,0),ind13(jaux)) +c + cotrvo(3,0) = per001(ind001(1),jaux) + cotrvo(3,1) = per001(ind001(2),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3331 , iaux = 0, 1 + write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux), + > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3) + 3331 continue + write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1) + write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 3.2. ==> Face 4 +c + iaux = facpen(lepent,nulofa(4)) + jaux = cofape(lepent,nulofa(4)) + trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux)) + trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux)) + areqtr(4,2) = aretri(trifad(4,0),ind23(jaux)) + + cotrvo(4,0) = per001(ind001(3),jaux) + cotrvo(4,1) = per001(ind001(4),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3332 , iaux = 0, 1 + write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux), + > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3) + 3332 continue + write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1) + write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c==== +c 4. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3g.F b/src/tool/Creation_Maillage/cmcp3g.F new file mode 100644 index 00000000..b399a52c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3g.F @@ -0,0 +1,330 @@ + subroutine cmcp3g ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase G +c - - +c Construction des triangles internes +c Remarque : cmcp3c et cmcp3g sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 17 . triangles internes au pentaedre . +c . . . . 1-4 = bordant la pyramide . +c . . . . 5 = bordant la face f1 . +c . . . . 6 = bordant la face f2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . . . . 8-11 = appuyes sur les filles des aretes . +c . . . . coupees . +c . . . . 12-17 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . lesare . e . 7 . liste des aretes du pentaedre utiles . +c . . . . 1-4 = les aretes de la pyramide . +c . . . . 5 = autre arete non decoupee face 1 . +c . . . . 6 = autre arete non decoupee face 2 . +c . . . . 7 = derniere arete non decoupee . +c . areint . e . 8 . aretes internes au pentaedre . +c . areqtr . e .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3G' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(17) + integer lesare(7) + integer areint(8) + integer areqtr(4,0:2) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles de la pyramide +c triint(i) = triangle bordant la pyramide selon l'arete areint(i) +c==== +c + do 21 , iaux = 1 , 4 +c + jaux = per1a4(1,iaux) +c + indtri = indtri + 1 + triint(iaux) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1234', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(jaux), lesare(iaux), areint(iaux), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. Les triangles s'appuyant sur les 3 aretes non decoupees +c triint(5) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f1 +c triint(6) = triangle s'appuyant sur l'arete non decoupee, situee +c sur la face f2 +c triint(7) = triangle s'appuyant sur la derniere arete non decoupee +c==== +c + indtri = indtri + 1 + triint(5) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_5', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(5), lesare(5), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(6) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_6', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(6), lesare(6), areint(3), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(7) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_7', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(6),lesare(7),areint(5), + > codetr, niveau ) +c +c==== +c 4. Les triangles s'appuyant sur les filles des aretes coupees +c triint(8) : 1/2 arete de la face F1, du cote pyramide +c triint(9) : 1/2 arete de la face F1, de l'autre cote +c triint(10) : 1/2 arete de la face F2, du cote pyramide +c triint(11) : 1/2 arete de la face F2, de l'autre cote +c==== +c + indtri = indtri + 1 + triint(8) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_8', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(2), areqtr(3,0), areint(7), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(9) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_9', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(7), areqtr(3,1), areint(5), + > codetr, niveau ) + +c + indtri = indtri + 1 + triint(10) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_10', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(4), areqtr(4,0), areint(8), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(11) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_11', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(8), areqtr(4,1), areint(6), + > codetr, niveau ) +c +c==== +c 5. Les triangles s'appuyant sur une arete interne a une face coupee +c triint(12) : arete de la 1ere face quad , du cote pyramide +c triint(13) : arete de la 1ere face quad , de l'autre cote +c triint(14) : arete de la 2eme face quad , du cote pyramide +c triint(15) : arete de la 2eme face quad , de l'autre cote +c triint(16) : arete de la face F1 +c triint(17) : arete de la face F2 +c==== +c + indtri = indtri + 1 + triint(12) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_12', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(7), areqtr(1,1), areint(3), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(13) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_13', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(6), areqtr(1,2), areint(7), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(14) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_14', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(8), areqtr(2,1), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(15) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_15', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(5), areqtr(2,2), areint(8), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(16) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_16', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(7), areqtr(3,2), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(17) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_17', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(8), areqtr(4,2), areint(3), + > codetr, niveau ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp3h.F b/src/tool/Creation_Maillage/cmcp3h.F new file mode 100644 index 00000000..75b440d4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp3h.F @@ -0,0 +1,291 @@ + subroutine cmcp3h ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 3, phase H +c - - +c Construction des tetraedres +c Remarque : cmcp3e et cmcp3h sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 17 . triangles internes au pentaedre . +c . . . . 1-4 = bordant la pyramide . +c . . . . 5 = bordant la face f1 . +c . . . . 6 = bordant la face f2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . . . . 8-11 = appuyes sur les filles des aretes . +c . . . . coupees . +c . . . . 12-17 = appuyes sur une arete interne a . +c . . . . une face coupee . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP3H' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(17) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_1', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,0), triint(1), triint(16), triint(8), + > cotrvo(3,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 2.1. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_2', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(3,1), triint(5), triint(9), triint(16), + > cotrvo(3,1), 2, 4, 4, + > nupere, nufami, indtet ) +c +c==== +c 3. Face 2 +c==== +c 3.1. ==> tetraedre du cote de la pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_3', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(3), triint(17), triint(10), + > cotrvo(4,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 3.1. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_4', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,1), triint(6), triint(11), triint(17), + > cotrvo(4,1), 2, 4, 4, + > nupere, nufami, indtet ) +c +c==== +c 4. Face quadrangulaire dont l'arete coupee est sur la face 1 +c==== +c 4.1. ==> tetraedre central +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_5', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(6), triint(12), triint(13), + > cotrvo(1,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 4.2. ==> tetraedre du cote pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_6', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,1), triint(2), triint(8), triint(12), + > cotrvo(1,1), 4, 2, 4, + > nupere, nufami, indtet ) +c +c 4.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_7', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,2), triint(7), triint(13), triint(9), + > cotrvo(1,2), 2, 2, 4, + > nupere, nufami, indtet ) +c +c==== +c 5. Face quadrangulaire dont l'arete coupee est sur la face 2 +c==== +c 5.1. ==> tetraedre central +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_8', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(5), triint(14), triint(15), + > cotrvo(2,0), 4, 4, 2, + > nupere, nufami, indtet ) +c +c 5.2. ==> tetraedre du cote pyramide +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_9', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,1), triint(4), triint(10), triint(14), + > cotrvo(2,1), 4, 2, 4, + > nupere, nufami, indtet ) +c +c 5.3. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_10', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,2), triint(7), triint(15), triint(11), + > cotrvo(2,2), 4, 2, 4, + > nupere, nufami, indtet ) +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp43.F b/src/tool/Creation_Maillage/cmcp43.F new file mode 100644 index 00000000..059db771 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp43.F @@ -0,0 +1,433 @@ + subroutine cmcp43 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 43 - par la face F3 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP43' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer cf3 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3 + integer f4, cf4 + integer f5, cf5 +#endif + integer noemil, lesnoe(2), lesare(7) + integer areint(8) + integer triint(7) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer quafad(4), areqqu(4) + integer nulofa(5) + integer tabind(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + cf3 = cofape(lepent,3) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c +c lesnoe(i) = sommet a joindre au centre de la face quadrangulaire +c coupee pour creer l'arete interne i +c + lesnoe(1) = listso(2) + lesnoe(2) = listso(5) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF4 +c trifad(1,1) = triangle de la face 1 bordant F1 : FF4 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant F2 : FF4 + 2/1 +c areqtr(1,1) : AS2N7 +c areqtr(1,2) : AS5N7 +c +c trifad(2,0) = triangle central de la face 2 : FF5 +c trifad(2,1) = triangle de la face 2 bordant F1 : FF5 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant F2 : FF5 + 1/2 +c areqtr(2,1) : AS2N9 +c areqtr(2,2) : AS5N9 +c +c trifad(3,0) = triangle de la face 3 : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,2) : arete commune : AS2N1 +c +c trifad(4,0) = triangle de la face 4 : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,2) : arete commune : AS5N4 +c +c quafad(1) = quadrangle de la face 5 : FF3 + 0/1/2/3 +c quafad(2) = quadrangle de la face 5 autre : FF3 + 1/2/3/0 +c quafad(3) = quadrangle de la face 5 autre : FF3 + 2/3/0/1 +c quafad(4) = quadrangle de la face 5 autre : FF3 + 3/0/1/2 +c areqqu(p) : arete commune a quafad(p) et quafad(p+1) +c areqqu(1) : AN1N0 +c areqqu(2) : AN9N0 +c areqqu(3) : AN4N0 +c areqqu(4) : AN7N0 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 4 + nulofa(2) = 5 + nulofa(3) = 1 + nulofa(4) = 2 + nulofa(5) = 3 +c + tabind(1) = 3 + tabind(2) = 2 + tabind(3) = 3 + tabind(4) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4B', nompro +#endif + call cmcp4b ( nulofa, lepent, + > i1, i2, i3, + > i1, i3, i2, + > tabind, + > somare, + > aretri, nivtri, filtri, + > arequa, filqua, + > facpen, cofape, + > noemil, + > niveau, + > trifad, cotrvo, areqtr, + > quafad, areqqu, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation des aretes internes +c areint(1) : AS2N0 +c areint(2) : AS5N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 2 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 7 triangles internes +c triint( 1) = FS2N7 +c triint( 2) = FS2N9 +c triint( 3) = FS5N7 +c triint( 4) = FS5N9 +c triint( 5) = FS2N1 +c triint( 6) = FS5N4 +c triint( 7) = FA8 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+7 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(8) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4C', nompro +#endif + call cmcp4c ( indtri, triint, + > lesare, + > areint, areqtr, areqqu, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) + endif +c +c==== +c 6. Creation des pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+4 +#endif +c + if ( codret.eq.0 ) then +c + iaux = cf3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4D', nompro +#endif + call cmcp4d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > quafad, iaux, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-3 , indpyr + write(ulsort,90002) 'facpyr', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90002) 'cofapy', (cofapy(iaux,jaux),jaux=1,5) + 600 continue + do 601 , iaux = 1 , 4 + write(ulsort,90002) 'pyr 1', + > (aretri(facpyr(1,iaux),jaux),jaux=1,3) + 601 continue + write(ulsort,90002) 'pyr 1', + > (arequa(facpyr(1,5),jaux),jaux=1,4) +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4E', nompro +#endif + call cmcp4e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write(ulsort,90002) 'tritet', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90002) 'cotrte', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp44.F b/src/tool/Creation_Maillage/cmcp44.F new file mode 100644 index 00000000..cf1b088d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp44.F @@ -0,0 +1,431 @@ + subroutine cmcp44 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 44 - par la face F4 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP44' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer cf4 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f4 + integer f5, cf5 +#endif + integer noemil, lesnoe(2), lesare(7) + integer areint(8) + integer triint(7) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer quafad(4), areqqu(4) + integer nulofa(5) + integer tabind(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + cf4 = cofape(lepent,4) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c +c lesnoe(i) = sommet a joindre au centre de la face quadrangulaire +c coupee pour creer l'arete interne i +c + lesnoe(1) = listso(3) + lesnoe(2) = listso(6) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 bordant F1 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant F2 : FF5 + 2/1 +c areqtr(1,1) : AS3N8 +c areqtr(1,2) : AS6N8 +c +c trifad(2,0) = triangle central de la face 2 : FF3 +c trifad(2,1) = triangle de la face 2 bordant F1 : FF3 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant F2 : FF3 + 1/2 +c areqtr(2,1) : AS3N7 +c areqtr(2,2) : AS6N7 +c +c trifad(3,0) = triangle de la face 3 : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,2) : arete commune : AS3N2 +c +c trifad(4,0) = triangle de la face 4 : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,2) : arete commune : AS6N5 +c +c quafad(1) = quadrangle de la face 5 : FF4 + 0/1/2/3 +c quafad(2) = quadrangle de la face 5 autre : FF4 + 1/2/3/0 +c quafad(3) = quadrangle de la face 5 autre : FF4 + 2/3/0/1 +c quafad(4) = quadrangle de la face 5 autre : FF4 + 3/0/1/2 +c areqqu(p) : arete commune a quafad(p) et quafad(p+1) +c areqqu(1) : AN2N0 +c areqqu(2) : AN7N0 +c areqqu(3) : AN5N0 +c areqqu(4) : AN8N0 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 3 + nulofa(3) = 1 + nulofa(4) = 2 + nulofa(5) = 4 +c + tabind(1) = 2 + tabind(2) = 1 + tabind(3) = 1 + tabind(4) = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4B', nompro +#endif + call cmcp4b ( nulofa, lepent, + > i2, i3, i1, + > i3, i2, i1, + > tabind, + > somare, + > aretri, nivtri, filtri, + > arequa, filqua, + > facpen, cofape, + > noemil, + > niveau, + > trifad, cotrvo, areqtr, + > quafad, areqqu, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation des aretes internes +c areint(1) : AS3N0 +c areint(2) : AS6N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 2 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 7 triangles internes +c triint( 1) = FS3N8 +c triint( 2) = FS3N7 +c triint( 3) = FS6N8 +c triint( 4) = FS6N7 +c triint( 5) = FS3N2 +c triint( 6) = FS6N5 +c triint( 7) = FA9 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+7 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(9) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4C', nompro +#endif + call cmcp4c ( indtri, triint, + > lesare, + > areint, areqtr, areqqu, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) + endif +c +c==== +c 6. Creation des pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+4 +#endif +c + if ( codret.eq.0 ) then +c + iaux = cf4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4D', nompro +#endif + call cmcp4d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > quafad, iaux, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-3 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4E', nompro +#endif + call cmcp4e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp45.F b/src/tool/Creation_Maillage/cmcp45.F new file mode 100644 index 00000000..315c3b90 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp45.F @@ -0,0 +1,430 @@ + subroutine cmcp45 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 45 - par la face F5 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP45' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer cf5 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 + integer f5 +#endif + integer noemil, lesnoe(2), lesare(7) + integer areint(8) + integer triint(7) + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer quafad(4), areqqu(4) + integer nulofa(5) + integer tabind(4) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + cf5 = cofape(lepent,5) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c +c lesnoe(i) = sommet a joindre au centre de la face quadrangulaire +c coupee pour creer l'arete interne i +c + lesnoe(1) = listso(1) + lesnoe(2) = listso(4) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 bordant F1 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 bordant F2 : FF3 + 2/1 +c areqtr(1,1) : AS1N9 +c areqtr(1,2) : AS4N9 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 bordant F1 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 bordant F2 : FF4 + 1/2 +c areqtr(2,1) : AS1N8 +c areqtr(2,2) : AS4N8 +c +c trifad(3,0) = triangle de la face 3 : FF1 + 0/1 +c trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0 +c areqtr(3,2) : arete commune : AS1N3 +c +c trifad(4,0) = triangle de la face 4 : FF2 + 0/1 +c trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0 +c areqtr(4,2) : arete commune : AS4N6 +c +c quafad(1) = quadrangle de la face 5 : FF5 + 0/1/2/3 +c quafad(2) = quadrangle de la face 5 autre : FF5 + 1/2/3/0 +c quafad(3) = quadrangle de la face 5 autre : FF5 + 2/3/0/1 +c quafad(4) = quadrangle de la face 5 autre : FF5 + 3/0/1/2 +c areqqu(p) : arete commune a quafad(p) et quafad(p+1) +c areqqu(1) : AN3N0 +c areqqu(2) : AN8N0 +c areqqu(3) : AN6N0 +c areqqu(4) : AN9N0 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + nulofa(3) = 1 + nulofa(4) = 2 + nulofa(5) = 5 +c + tabind(1) = 1 + tabind(2) = 3 + tabind(3) = 2 + tabind(4) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4B', nompro +#endif + call cmcp4b ( nulofa, lepent, + > i3, i1, i2, + > i2, i1, i3, + > tabind, + > somare, + > aretri, nivtri, filtri, + > arequa, filqua, + > facpen, cofape, + > noemil, + > niveau, + > trifad, cotrvo, areqtr, + > quafad, areqqu, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c==== +c==== +c 4. Creation des aretes internes +c areint(1) : AS1N0 +c areint(2) : AS4N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,91000) indare+1, indare+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPA', nompro +#endif + iaux = 2 + call cmchpa ( indare, iaux, + > noemil, lesnoe, areint, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 7 triangles internes +c triint( 1) = FS1N9 +c triint( 2) = FS1N8 +c triint( 3) = FS4N9 +c triint( 4) = FS4N8 +c triint( 5) = FS1N3 +c triint( 6) = FS4N6 +c triint( 7) = FA7 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+7 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4C', nompro +#endif + call cmcp4c ( indtri, triint, + > lesare, + > areint, areqtr, areqqu, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) + endif +c +c==== +c 6. Creation des pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,95000) indpyr+1, indpyr+4 +#endif +c + if ( codret.eq.0 ) then +c + iaux = cf5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4D', nompro +#endif + call cmcp4d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > quafad, iaux, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + do 600 , iaux = indpyr-3 , indpyr + write (ulsort,90015) 'Pyra', iaux, + > ', faces', (facpyr(iaux,jaux),jaux=1,5) + write(ulsort,90015) 'Pyra', iaux, + > ', codes', (cofapy(iaux,jaux),jaux=1,5) + 600 continue +#endif +c + endif +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP4E', nompro +#endif + call cmcp4e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-1 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp4a.F b/src/tool/Creation_Maillage/cmcp4a.F new file mode 100644 index 00000000..532b0145 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp4a.F @@ -0,0 +1,319 @@ + subroutine cmcp4a ( lepent, etapen, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase A, pilotage +c - - +c - par 1 face quadrangulaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP4A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indare, indtri, indtet, indpyr + integer indptp + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9), listso(6) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOPE', nompro +#endif + call utsope ( somare, listar, listso ) +c +c==== +c 3. Recherche de l'arete decoupee +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91002) iaux, listar(iaux), + > somare(1,listar(iaux)), somare(2,listar(iaux)), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> La face F3 est coupee : aretes 1, 7, 4 ,9 +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etapen = 43 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP43', nompro +#endif + call cmcp43 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> La face F4 est coupee : aretes 2, 8, 5 ,7 +c + elseif ( mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(7)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 ) then + etapen = 44 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP44', nompro +#endif + call cmcp44 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.3. ==> La face F5 est coupee : aretes 3, 9, 6, 8 +c + elseif ( mod(hetare(listar(3)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 .and. + > mod(hetare(listar(8)),10).eq.2 .and. + > mod(hetare(listar(9)),10).eq.2 ) then + etapen = 45 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP45', nompro +#endif + call cmcp45 ( lepent, listar, listso, + > indare, indtri, indtet, indpyr, + > indptp, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.9. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp4b.F b/src/tool/Creation_Maillage/cmcp4b.F new file mode 100644 index 00000000..ed2aec16 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp4b.F @@ -0,0 +1,355 @@ + subroutine cmcp4b ( nulofa, lepent, + > ind11, ind12, ind13, + > ind21, ind22, ind23, + > tabind, + > somare, + > aretri, nivtri, filtri, + > arequa, filqua, + > facpen, cofape, + > noemil, + > niveau, + > trifad, cotrvo, areqtr, + > quafad, areqqu, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase B +c - - +c Reperage des aretes, triangles, quadrangles sur les faces externes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 5 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . indi1 . e . 1 . i1i2i3 associe a l'arete coupee face i . +c . indi2 . e . 1 . i1i2i3 associe a l'arete suivante . +c . indi3 . e . 1 . i1i2i3 associe a l'arete precedente . +c . tabind . e . 4 . redirection dans per001 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . noemil . s . 1 . noeud milieu de la face quad coupee en 4 . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:2) . code des triangles dans les volumes . +c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . quafad . s . 4 . quadrangles traces sur les faces decoupees . +c . areqqu . s . 4 . aretes qua tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP4B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +#include "demitr.h" +#include "defiqu.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(5) + integer ind11(6), ind12(6), ind13(6) + integer ind21(6), ind22(6), ind23(6) + integer tabind(4) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer noemil + integer niveau + integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2) + integer quafad(4), areqqu(4) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les quadrangles coupes en 3 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est celle qui contient l'arete de F1 coupee. +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant cette arete non decoupee +c trifad(p,2) : l'autre triangle +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c==== +c +c 2.1. ==> Face 1 +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 3 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 5 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2221 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2221 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) +#endif +c +c 2.2. ==> Face 2 +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 3 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 5 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) +#endif +c +c==== +c 3. Triangles et aretes tracees sur les triangles coupes en 2 +c On traite les faces du pentaedre coupees en 3 comme suit : +c La 1ere face est F1. +c trifad(p,0) : triangle bordant la pyramide +c trifad(p,1) : triangle autre +c areqtr(p,2) : arete commune aux deux triangles fils +c==== +c 3.1. ==> Face 3 +c + iaux = facpen(lepent,nulofa(3)) + jaux = cofape(lepent,nulofa(3)) + trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux)) + trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux)) + areqtr(3,2) = aretri(trifad(3,0),ind13(jaux)) +c + cotrvo(3,0) = per001(tabind(1),jaux) + cotrvo(3,1) = per001(tabind(2),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3331 , iaux = 0, 1 + write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux), + > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3) + 3331 continue + write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1) + write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) +#endif +c +c 3.2. ==> Face 4 +c + iaux = facpen(lepent,nulofa(4)) + jaux = cofape(lepent,nulofa(4)) + trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux)) + trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux)) + areqtr(4,2) = aretri(trifad(4,0),ind23(jaux)) + + cotrvo(4,0) = per001(tabind(4),jaux) + cotrvo(4,1) = per001(tabind(3),jaux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3332 , iaux = 0, 1 + write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux), + > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3) + 3332 continue + write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1) + write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) +#endif +c +c==== +c 4. Quadrangles et aretes tracees sur la face coupee en 4 +c quafad(0) : quadrangle bordant la face 2 et la face 3 +c quafad(i) : quadrangle suivant dans le sens entrant +c dans le pentadere +c areqqu(p) : arete commune a quafad(p) et quafad(p+1) +c==== +c + iaux = facpen(lepent,nulofa(5)) + jaux = cofape(lepent,nulofa(5)) + quafad(1) = filqua(iaux) + defiq1(jaux) + quafad(2) = filqua(iaux) + defiq2(jaux) + quafad(3) = filqua(iaux) + defiq3(jaux) + quafad(4) = filqua(iaux) + defiq4(jaux) +c + if ( jaux.lt.5 ) then + areqqu(1) = arequa(quafad(1),2) + areqqu(2) = arequa(quafad(2),2) + areqqu(3) = arequa(quafad(3),2) + areqqu(4) = arequa(quafad(4),2) + else + areqqu(1) = arequa(quafad(2),2) + areqqu(2) = arequa(quafad(3),2) + areqqu(3) = arequa(quafad(4),2) + areqqu(4) = arequa(quafad(1),2) + endif +c + noemil = somare(2,areqqu(1)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 4441 , iaux = 1 , 4 + write (ulsort,90015) 'quafad(1/2/3/4) =', quafad(iaux), + > ', aretes', (arequa(quafad(iaux),jaux),jaux=1,4) + 4441 continue + do 4442 , iaux = 1 , 4 + write (ulsort,90006) 'areqqu(1/2/3/4) =', areqqu(iaux), + > ' de ',somare(1,areqqu(iaux)), + > ' a ',somare(2,areqqu(iaux)) + 4442 continue + write(ulsort,90002) 'Noeud milieu = ', noemil +#endif +c +c==== +c 5. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp4c.F b/src/tool/Creation_Maillage/cmcp4c.F new file mode 100644 index 00000000..3c14013f --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp4c.F @@ -0,0 +1,231 @@ + subroutine cmcp4c ( indtri, triint, + > lesare, + > areint, areqtr, areqqu, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase C +c - - +c Construction des triangles internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 7 . triangles internes au pentaedre . +c . . . . 1-4 = base parallele au triangle . +c . . . . 1 = cote F1, quad suivant quad coupe en 4 . +c . . . . 2 = cote F1, quad suivant . +c . . . . 3 = cote F2, quad suivant quad coupe en 4 . +c . . . . 4 = cote F2, quad suivant . +c . . . . 5-6 = base coupant le triangle . +c . . . . 5 = cote F1 . +c . . . . 6 = cote F2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . lesare . e . 1 . liste des aretes du pentaedre utiles . +c . . . . 1 = arete de quadrangle non decoupee . +c . areint . e . 2 . aretes internes au pentaedre . +c . areqtr . s .(4,0:2) . aretes tri tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . areqqu . s . 4 . aretes qua tracees sur les faces decoupees . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP4C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(7) + integer lesare(1) + integer areint(2) + integer areqtr(4,0:2) + integer areqqu(4) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles paralleles aux faces triangulaires +c==== +c + indtri = indtri + 1 + triint(1) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_1', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(1,1), areqqu(4), areint(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(2) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_2', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(2,1), areint(1), areqqu(2), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(3) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_3', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(1,2), areint(2), areqqu(4), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(4) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_4', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(2,2), areqqu(2), areint(2), + > codetr, niveau ) +c +c==== +c 3. Les triangles coupant les faces triangulaires +c==== +c + indtri = indtri + 1 + triint(5) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_5', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(3,2), areint(1), areqqu(1), + > codetr, niveau ) +c + indtri = indtri + 1 + triint(6) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_6', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areqtr(4,2), areint(2), areqqu(3), + > codetr, niveau ) +c +c==== +c 4. Le triangle sur l'arete non decoupee +c==== +c + indtri = indtri + 1 + triint(7) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_7', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, areint(1), lesare(1), areint(2), + > codetr, niveau ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp4d.F b/src/tool/Creation_Maillage/cmcp4d.F new file mode 100644 index 00000000..a72c80e6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp4d.F @@ -0,0 +1,215 @@ + subroutine cmcp4d ( indpyr, indptp, + > lepent, + > trifad, cotrvo, triint, + > quafad, coface, + > hetpyr, facpyr, cofapy, + > filpyr, perpyr, fampyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase D +c - - +c Construction des pyramides +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 7 . triangles internes au pentaedre . +c . . . . 1-4 = base parallele au triangle . +c . . . . 1 = cote F1, quad suivant quad coupe en 4 . +c . . . . 2 = cote F1, quad suivant . +c . . . . 3 = cote F2, quad suivant quad coupe en 4 . +c . . . . 4 = cote F2, quad suivant . +c . . . . 5-6 = base coupant le triangle . +c . . . . 5 = cote F1 . +c . . . . 6 = cote F2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . quafad . e . 4 . quadrangles traces sur les faces decoupees . +c . coface . e . 1 . code des faces quadrangulaires . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP4D' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfp.h" +c +c 0.3. ==> arguments +c + integer indpyr, indptp + integer lepent + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(7) + integer quafad(4), coface + integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des pyramides et leur famille +c + nupere = -indptp + nufami = cfapen(cofpfp,fampen(lepent)) +c +c==== +c 2. Pyramide +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_1', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(3,0), cotrvo(3,0), + > triint(5), 1, + > triint(1), 2, + > trifad(1,1), cotrvo(1,1), + > quafad(1), coface, + > nupere, nufami, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_2', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(2,1), cotrvo(2,1), + > triint(2), 1, + > triint(5), 6, + > trifad(3,1), cotrvo(3,1), + > quafad(2), coface, + > nupere, nufami, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_3', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(4,1), cotrvo(4,1), + > triint(6), 1, + > triint(4), 2, + > trifad(2,2), cotrvo(2,2), + > quafad(3), coface, + > nupere, nufami, indpyr ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYR_4', nompro +#endif + indpyr = indpyr + 1 + call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr, + > trifad(1,2), cotrvo(1,2), + > triint(3), 1, + > triint(6), 6, + > trifad(4,0), cotrvo(4,0), + > quafad(4), coface, + > nupere, nufami, indpyr ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp4e.F b/src/tool/Creation_Maillage/cmcp4e.F new file mode 100644 index 00000000..1ea2821d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp4e.F @@ -0,0 +1,186 @@ + subroutine cmcp4e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase E +c - - +c Construction des tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:2) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:2) . code des triangles dans les volumes . +c . triint . e . 7 . triangles internes au pentaedre . +c . . . . 1-4 = base parallele au triangle . +c . . . . 1 = cote F1, quad suivant quad coupe en 4 . +c . . . . 2 = cote F1, quad suivant . +c . . . . 3 = cote F2, quad suivant quad coupe en 4 . +c . . . . 4 = cote F2, quad suivant . +c . . . . 5-6 = base coupant le triangle . +c . . . . 5 = cote F1 . +c . . . . 6 = cote F2 . +c . . . . 7 = s'appuyant sur la derniere non coupee . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP4E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(4,0:2), cotrvo(4,0:2) + integer triint(7) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +c +c==== +c 2. Face 1 +c==== +c 2.1. ==> tetraedre du cote de la face suivante +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_1', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(1,0), triint(7), triint(1), triint(3), + > cotrvo(1,0), 2, 3, 5, + > nupere, nufami, indtet ) +c +c 2.2. ==> tetraedre de l'autre cote +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_2', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(2,0), triint(7), triint(4), triint(2), + > cotrvo(2,0), 4, 3, 5, + > nupere, nufami, indtet ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp51.F b/src/tool/Creation_Maillage/cmcp51.F new file mode 100644 index 00000000..fae2f246 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp51.F @@ -0,0 +1,436 @@ + subroutine cmcp51 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 51 - par la face F1 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP51' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "ope001.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f2, cf2 +#ifdef _DEBUG_HOMARD_ + integer f1, cf1 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer lesnoe(6), lesare(7) + integer areint(8) + integer triint(15) + integer trifad(4,0:3), cotrvo(4,0:3), areqtr(4,0:3) + integer nulofa(4) + integer ind001(0:3) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) +#ifdef _DEBUG_HOMARD_ + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 1 + jaux = listar(iaux) + lesnoe(4) = somare(2,filare(jaux)) +c + iaux = 2 + jaux = listar(iaux) + lesnoe(5) = somare(2,filare(jaux)) +c + iaux = 3 + jaux = listar(iaux) + lesnoe(6) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c + lesnoe(1) = listso(4) + lesnoe(2) = listso(5) + lesnoe(3) = listso(6) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF3 +c trifad(1,1) = triangle de la face 1 voisin de F4 : FF3 + 1/2 +c trifad(1,2) = triangle de la face 1 voisin de F5 : FF3 + 2/1 +c areqtr(1,1) : AS4N1 +c areqtr(1,2) : AS6N1 +c areqtr(1,0) : AS1N1 +c areqtr(1,3) : AS3N1 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 voisin de F5 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 voisin de F3 : FF4 + 1/2 +c areqtr(2,1) : AS5N2 +c areqtr(2,2) : AS4N2 +c areqtr(2,0) : AS2N2 +c areqtr(2,3) : AS1N2 +c +c trifad(3,0) = triangle central de la face 3 : FF5 +c trifad(3,1) = triangle de la face 3 voisin de F3 : FF5 + 2/1 +c trifad(3,2) = triangle de la face 3 voisin de F4 : FF5 + 1/2 +c areqtr(3,1) : AS6N3 +c areqtr(3,2) : AS5N3 +c areqtr(3,0) : AS3N3 +c areqtr(3,3) : AS2N3 +c +c trifad(4,0) = triangle central de la face decoupee : FF1 +c trifad(4,1) = triangle de la face voisin de F4 et F3 : FF1 + 1/2/3 +c trifad(4,2) = triangle de la face voisin de F5 et F4 : FF1 + 2/3/1 +c trifad(4,3) = triangle de la face voisin de F3 et F5 : FF1 + 3/1/2 +c areqtr(4,1) : arete de trifad(4,1) : AN1N2 +c areqtr(4,2) : arete de trifad(4,2) : AN2N3 +c areqtr(4,3) : arete de trifad(4,3) : AN1N3 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 3 + nulofa(2) = 4 + nulofa(3) = 5 + nulofa(4) = 1 +c + ind001(0) = 5 + ind001(1) = 1 + ind001(2) = 3 + ind001(3) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5B', nompro +#endif + call cmcp5b ( nulofa, lepent, + > i1, i2, i3, ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS4N0 +c areint(2) : AS5N0 +c areint(3) : AS6N0 +c areint(4) : AN1N0 +c areint(5) : AN2N0 +c areint(6) : AN3N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+6 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 6 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Creation des 15 triangles internes +c triint( 1) = FS4N12 +c triint( 2) = FS5N23 +c triint( 3) = FS6N13 +c triint( 4) = FN1N2 +c triint( 5) = FN2N3 +c triint( 6) = FN1N3 +c triint( 7) = FA4 +c triint( 8) = FA5 +c triint( 9) = FA6 +c triint(10) = FS4N1 +c triint(11) = FS5N2 +c triint(12) = FS6N3 +c triint(13) = FS6N1 +c triint(14) = FS4N2 +c triint(15) = FS5N3 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+15 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(4) + lesare(2) = listar(5) + lesare(3) = listar(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5C', nompro +#endif + call cmcp5c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-14 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2 +c + jaux = per001(6,cf2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5E', nompro +#endif + call cmcp5e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > iaux, f2, jaux, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-10 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp52.F b/src/tool/Creation_Maillage/cmcp52.F new file mode 100644 index 00000000..a7153bc5 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp52.F @@ -0,0 +1,443 @@ + subroutine cmcp52 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - etat 52 - par la face F2 +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . listar . e . 9 . liste des aretes du pentaedre a decouper . +c . listso . e . 6 . liste des sommets du pentaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune face ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP52' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "i1i2i3.h" +#include "ope001.h" +c +c 0.3. ==> arguments +c + integer lepent + integer listar(9), listso(6) + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsomm + parameter ( nbsomm = 6 ) +c + integer iaux, jaux + integer f1, cf1 +#ifdef _DEBUG_HOMARD_ + integer f2, cf2 + integer f3, cf3 + integer f4, cf4 + integer f5, cf5 +#endif + integer lesnoe(6), lesare(7) + integer areint(8) + integer triint(15) + integer trifad(4,0:3), cotrvo(4,0:3), areqtr(4,0:3) + integer nulofa(4) + integer tabind(0:3) + integer niveau +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. initialisations +c==== +c 2.1. ==> grandeurs independantes du cas traite (phase 1) +c les faces du pentaedre et leurs codes +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) +#ifdef _DEBUG_HOMARD_ + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) + write(ulsort,90002) 'f1', f1, cf1 + write(ulsort,90002) 'f2', f2, cf2 + write(ulsort,90002) 'f3', f3, cf3 + write(ulsort,90002) 'f4', f4, cf4 + write(ulsort,90002) 'f5', f5, cf5 +#endif +c +c 2.2. ==> grandeurs dependant du cas traite +c iaux = numero local de l'arete coupee +c jaux = numero global de l'arete coupee +c noemil = noeud milieu de l'arete coupee +c + iaux = 6 + jaux = listar(iaux) + lesnoe(4) = somare(2,filare(jaux)) +c + iaux = 5 + jaux = listar(iaux) + lesnoe(5) = somare(2,filare(jaux)) +c + iaux = 4 + jaux = listar(iaux) + lesnoe(6) = somare(2,filare(jaux)) +c +c lesnoe(i) = sommet a joindre au centre du pentaedre pour creer +c l'arete interne i +c + lesnoe(1) = listso(2) + lesnoe(2) = listso(1) + lesnoe(3) = listso(3) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lesnoe', lesnoe +#endif +c +c 2.3. ==> Triangles et aretes tracees sur les faces coupees +c +c trifad(1,0) = triangle central de la face 1 : FF5 +c trifad(1,1) = triangle de la face 1 voisin de F4 : FF5 + 1/2 +c trifad(1,2) = triangle de la face 1 voisin de F3 : FF5 + 2/1 +c areqtr(1,1) : AS2N6 +c areqtr(1,2) : AS3N6 +c areqtr(1,0) : AS5N6 +c areqtr(1,3) : AS6N6 +c +c trifad(2,0) = triangle central de la face 2 : FF4 +c trifad(2,1) = triangle de la face 2 voisin de F3 : FF4 + 2/1 +c trifad(2,2) = triangle de la face 2 voisin de F5 : FF4 + 1/2 +c areqtr(2,1) : AS1N5 +c areqtr(2,2) : AS2N5 +c areqtr(2,0) : AS4N5 +c areqtr(2,3) : AS5N5 +c +c trifad(3,0) = triangle central de la face 3 : FF3 +c trifad(3,1) = triangle de la face 3 voisin de F5 : FF3 + 2/1 +c trifad(3,2) = triangle de la face 3 voisin de F4 : FF3 + 1/2 +c areqtr(3,1) : AS3N4 +c areqtr(3,2) : AS1N4 +c areqtr(3,0) : AS6N4 +c areqtr(3,3) : AS4N4 +c +c trifad(4,0) = triangle central de la face decoupee : FF2 +c trifad(4,1) = triangle de la face voisin de F4 et F5 : FF2 + 1/2/3 +c trifad(4,2) = triangle de la face voisin de F3 et F4 : FF2 + 2/3/1 +c trifad(4,3) = triangle de la face voisin de F5 et F3 : FF2 + 3/1/2 +c areqtr(4,1) : arete de trifad(4,1) : AN5N6 +c areqtr(4,2) : arete de trifad(4,2) : AN4N5 +c areqtr(4,3) : arete de trifad(4,3) : AN4N6 +c + if ( codret.eq.0 ) then +c + nulofa(1) = 5 + nulofa(2) = 4 + nulofa(3) = 3 + nulofa(4) = 2 +c + tabind(0) = 4 + tabind(1) = 3 + tabind(2) = 2 + tabind(3) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5B', nompro +#endif + call cmcp5b ( nulofa, lepent, + > i2, i3, i1, tabind, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation du noeud interne +c 4. Creation des aretes internes +c areint(1) : AS2N0 +c areint(2) : AS1N0 +c areint(3) : AS3N0 +c areint(4) : AN6N0 +c areint(5) : AN5N0 +c areint(6) : AN4N0 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,98000) indnoe+1, indnoe+1 + write (ulsort,91000) indare+1, indare+6 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + iaux = 6 + call cmchpb ( indnoe, indare, iaux, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 400 , iaux = indare-5 , indare + write (ulsort,90015) 'Arete', iaux, + > ', sommets', (somare(jaux,iaux),jaux=1,2) + 400 continue +#endif +c + endif +c +c==== +c 5. Creation des 15 triangles internes +c triint( 1) = FS2N56 +c triint( 2) = FS1N45 +c triint( 3) = FS3N46 +c triint( 4) = FN5N6 +c triint( 5) = FN4N5 +c triint( 6) = FN4N6 +c triint( 7) = FA3 +c triint( 8) = FA2 +c triint( 9) = FA1 +c triint(10) = FS3N6 +c triint(11) = FS2N5 +c triint(12) = FS1N4 +c triint(13) = FS2N6 +c triint(14) = FS1N5 +c triint(15) = FS3N4 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,92000) indtri+1, indtri+15 +#endif +c + if ( codret.eq.0 ) then +c + lesare(1) = listar(3) + lesare(2) = listar(2) + lesare(3) = listar(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5C', nompro +#endif + call cmcp5c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 500 , iaux = indtri-14 , indtri + write(ulsort,90015) 'tria', iaux, + > ' : aretes =', (aretri(iaux,jaux),jaux=1,3) + 500 continue +#endif +c + endif +c +c==== +c 6. Creation de la pyramide +c==== +c +c==== +c 7. Creation des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93000) indtet+1, indtet+10 +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +c + jaux = per001(6,cf1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP5E', nompro +#endif + call cmcp5e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > iaux, f1, jaux, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 700 , iaux = indtet-10 , indtet + write (ulsort,90015) 'Tetra', iaux, + > ', faces', (tritet(iaux,jaux),jaux=1,4) + write(ulsort,90015) 'Tetra', iaux, + > ', codes', (cotrte(iaux,jaux),jaux=1,4) + 700 continue +#endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp5a.F b/src/tool/Creation_Maillage/cmcp5a.F new file mode 100644 index 00000000..f2f1623d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp5a.F @@ -0,0 +1,289 @@ + subroutine cmcp5a ( lepent, etapen, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > arequa, filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 4, phase 5, pilotage +c - - +c - par 1 face triangulaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a decouper . +c . etapen . s . 1 . etat final du pentaedre . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . . nouvar . famille des aretes . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . fampen . e . nouvpe . famille des penaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP5A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lepent, etapen + integer indnoe, indare, indtri, indtet + integer indptp + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer hettri(nouvtr), aretri(nouvtr,3) + integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(9), listso(6) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucune arete ne correspond.'')' +c + texte(2,4) = '(''No edge is correct.'')' +c +#include "impr03.h" +#include "impr04.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indare', indare + write (ulsort,90002) 'indtri', indtri + write (ulsort,90002) 'indtet', indtet +#endif +c + codret = 0 +c +c==== +c 2. Recherche des aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( lepent, + > nouvqu, nouvpe, + > arequa, facpen, cofape, + > listar ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOPE', nompro +#endif + call utsope ( somare, listar, listso ) +c +c==== +c 3. Recherche des aretes decoupees +c==== +#ifdef _DEBUG_HOMARD_ + do 3999 , iaux = 1 , 9 + write(ulsort,91002) iaux, listar(iaux), + > somare(1,listar(iaux)), somare(2,listar(iaux)), + > hetare(listar(iaux)) + 3999 continue +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> La face F1 est coupee : aretes 1, 2 et 3 +c + if ( mod(hetare(listar(1)),10).eq.2 .and. + > mod(hetare(listar(2)),10).eq.2 .and. + > mod(hetare(listar(3)),10).eq.2 ) then + etapen = 51 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP51', nompro +#endif + call cmcp51 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.2. ==> La face F2 est coupee : aretes 4, 5 et 6 +c + elseif ( mod(hetare(listar(4)),10).eq.2 .and. + > mod(hetare(listar(5)),10).eq.2 .and. + > mod(hetare(listar(6)),10).eq.2 ) then + etapen = 52 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCP52', nompro +#endif + call cmcp52 ( lepent, listar, listso, + > indnoe, indare, indtri, indtet, + > indptp, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > hettri, aretri, + > filtri, pertri, famtri, + > nivtri, + > filqua, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > facpen, cofape, + > fampen, cfapen, + > ulsort, langue, codret ) +c +c 3.9. ==> Laquelle ? +c + else + codret = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp5b.F b/src/tool/Creation_Maillage/cmcp5b.F new file mode 100644 index 00000000..d1d73c89 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp5b.F @@ -0,0 +1,353 @@ + subroutine cmcp5b ( nulofa, lepent, + > ind1, ind2, ind3, ind001, + > somare, + > aretri, nivtri, filtri, + > filqua, + > facpen, cofape, + > niveau, + > trifad, cotrvo, areqtr, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 5, phase B +c - - +c Reperage des aretes et des triangles sur les faces externes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nulofa . e . 4 . numero local des faces a traiter . +c . lepent . e . 1 . pentaedre a decouper . +c . ind123 . e . 1 . i1i2i3 associe a la face coupee . +c . ind001 . e . 0:3 . redirection dans per001 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. codes des faces des pentaedres . +c . niveau . s . 1 . niveau des faces issus du decoupage . +c . trifad . s .(4,0:3) . triangles traces sur les faces decoupees . +c . cotrvo . s .(4,0:3) . code des triangles dans les volumes . +c . areqtr . s .(4,0:3) . aretes tracees sur les faces decoupees . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP5B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope001.h" +c +c 0.3. ==> arguments +c + integer lepent, nulofa(4) + integer ind1(6), ind2(6), ind3(6) + integer ind001(0:3) + integer somare(2,nouvar) + integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr) + integer filqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer niveau + integer trifad(4,0:3), cotrvo(4,0:3), areqtr(4,0:3) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "impr04.h" +c + codret = 0 +c +c==== +c 2. Triangles et aretes tracees sur les quadrangles coupes en 3 +c trifad(p,0) : triangle central de ce decoupage +c trifad(p,1) : triangle bordant l'arete non decoupee qui +c est voisin de la face p+1 +c trifad(p,2) : triangle bordant l'arete non decoupee qui +c est voisin de la face p-1 +c areqtr(p,1) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,1) +c areqtr(p,2) : arete interne au quadrangle de bord et bordant le +c triangle trifad(p,2) +c areqtr(p,0) = fille de l'arete coupee, du cote de la face p+1 +c areqtr(p,3) = autre fille +c==== +c +c 2.1. ==> Face 1 +c + iaux = facpen(lepent,nulofa(1)) + jaux = cofape(lepent,nulofa(1)) + trifad(1,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(1,0) = 4 + trifad(1,1) = trifad(1,0) + 2 + cotrvo(1,1) = 2 + trifad(1,2) = trifad(1,0) + 1 + cotrvo(1,2) = 6 + areqtr(1,1) = aretri(trifad(1,0),3) + areqtr(1,2) = aretri(trifad(1,0),1) + else + cotrvo(1,0) = 2 + trifad(1,1) = trifad(1,0) + 1 + cotrvo(1,1) = 6 + trifad(1,2) = trifad(1,0) + 2 + cotrvo(1,2) = 2 + areqtr(1,1) = aretri(trifad(1,0),1) + areqtr(1,2) = aretri(trifad(1,0),3) + endif + areqtr(1,0) = aretri(trifad(1,1),1) + areqtr(1,3) = aretri(trifad(1,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2221 , iaux = 0, 2 + write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux), + > ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3) + 2221 continue + write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0), + > 'cotrvo(1,1) = ', cotrvo(1,1), + > 'cotrvo(1,2) = ', cotrvo(1,2) + write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1), + > ' de ',somare(1,areqtr(1,1)), + > ' a ',somare(2,areqtr(1,1)) + write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2), + > ' de ',somare(1,areqtr(1,2)), + > ' a ',somare(2,areqtr(1,2)) + write(ulsort,90006) 'areqtr(1,0) = ', areqtr(1,0), + > ' de ',somare(1,areqtr(1,0)), + > ' a ',somare(2,areqtr(1,0)) + write(ulsort,90006) 'areqtr(1,3) = ', areqtr(1,3), + > ' de ',somare(1,areqtr(1,3)), + > ' a ',somare(2,areqtr(1,3)) +#endif +c +c 2.2. ==> Face 2 +c + iaux = facpen(lepent,nulofa(2)) + jaux = cofape(lepent,nulofa(2)) + trifad(2,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(2,0) = 4 + trifad(2,1) = trifad(2,0) + 2 + cotrvo(2,1) = 2 + trifad(2,2) = trifad(2,0) + 1 + cotrvo(2,2) = 6 + areqtr(2,1) = aretri(trifad(2,0),3) + areqtr(2,2) = aretri(trifad(2,0),1) + else + cotrvo(2,0) = 2 + trifad(2,1) = trifad(2,0) + 1 + cotrvo(2,1) = 6 + trifad(2,2) = trifad(2,0) + 2 + cotrvo(2,2) = 2 + areqtr(2,1) = aretri(trifad(2,0),1) + areqtr(2,2) = aretri(trifad(2,0),3) + endif + areqtr(2,0) = aretri(trifad(2,1),1) + areqtr(2,3) = aretri(trifad(2,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2222 , iaux = 0, 2 + write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux), + > ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3) + 2222 continue + write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0), + > 'cotrvo(2,1) = ', cotrvo(2,1), + > 'cotrvo(2,2) = ', cotrvo(2,2) + write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1), + > ' de ',somare(1,areqtr(2,1)), + > ' a ',somare(2,areqtr(2,1)) + write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2), + > ' de ',somare(1,areqtr(2,2)), + > ' a ',somare(2,areqtr(2,2)) + write(ulsort,90006) 'areqtr(2,0) = ', areqtr(2,0), + > ' de ',somare(1,areqtr(2,0)), + > ' a ',somare(2,areqtr(2,0)) + write(ulsort,90006) 'areqtr(2,3) = ', areqtr(2,3), + > ' de ',somare(1,areqtr(2,3)), + > ' a ',somare(2,areqtr(2,3)) +#endif +c +c 2.3. ==> Face 3 +c + iaux = facpen(lepent,nulofa(3)) + jaux = cofape(lepent,nulofa(3)) + trifad(3,0) = -filqua(iaux) + if ( jaux.lt.5 ) then + cotrvo(3,0) = 4 + trifad(3,1) = trifad(3,0) + 2 + cotrvo(3,1) = 2 + trifad(3,2) = trifad(3,0) + 1 + cotrvo(3,2) = 6 + areqtr(3,1) = aretri(trifad(3,0),3) + areqtr(3,2) = aretri(trifad(3,0),1) + else + cotrvo(3,0) = 2 + trifad(3,1) = trifad(3,0) + 1 + cotrvo(3,1) = 6 + trifad(3,2) = trifad(3,0) + 2 + cotrvo(3,2) = 2 + areqtr(3,1) = aretri(trifad(3,0),1) + areqtr(3,2) = aretri(trifad(3,0),3) + endif + areqtr(3,0) = aretri(trifad(3,1),1) + areqtr(3,3) = aretri(trifad(3,2),1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux + do 2223 , iaux = 0, 2 + write (ulsort,90015) 'trifad(3,0/1/2) =', trifad(3,iaux), + > ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3) + 2223 continue + write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0), + > 'cotrvo(3,1) = ', cotrvo(3,1), + > 'cotrvo(3,2) = ', cotrvo(3,2) + write(ulsort,90006) 'areqtr(3,1) = ', areqtr(3,1), + > ' de ',somare(1,areqtr(3,1)), + > ' a ',somare(2,areqtr(3,1)) + write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2), + > ' de ',somare(1,areqtr(3,2)), + > ' a ',somare(2,areqtr(3,2)) + write(ulsort,90006) 'areqtr(3,0) = ', areqtr(3,0), + > ' de ',somare(1,areqtr(3,0)), + > ' a ',somare(2,areqtr(3,0)) + write(ulsort,90006) 'areqtr(3,3) = ', areqtr(3,3), + > ' de ',somare(1,areqtr(3,3)), + > ' a ',somare(2,areqtr(3,3)) +#endif +c +c==== +c 3. Triangles et aretes tracees sur le triangle coupe en 4 +c trifad(4,0) : triangle central +c trifad(4,1) : triangle voisin des faces 1 et 2 precedentes +c trifad(4,2) : triangle voisin des faces 2 et 3 precedentes +c trifad(4,3) : triangle voisin des faces 3 et 1 precedentes +c areqtr(4,i) : arete commune aux triangle central et a trifad(4,i) +c==== +c + iaux = facpen(lepent,nulofa(4)) + jaux = cofape(lepent,nulofa(4)) + trifad(4,0) = filtri(iaux) + trifad(4,1) = filtri(iaux) + ind3(jaux) + trifad(4,2) = filtri(iaux) + ind1(jaux) + trifad(4,3) = filtri(iaux) + ind2(jaux) + cotrvo(4,0) = per001(ind001(0),jaux) + cotrvo(4,1) = per001(ind001(1),jaux) + cotrvo(4,2) = per001(ind001(2),jaux) + cotrvo(4,3) = per001(ind001(3),jaux) + areqtr(4,1) = aretri(trifad(4,0),ind3(jaux)) + areqtr(4,2) = aretri(trifad(4,0),ind1(jaux)) + areqtr(4,3) = aretri(trifad(4,0),ind2(jaux)) +c +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux + do 3333 , iaux = 0, 3 + write (ulsort,90015) 'trifad(4,0/1/2/3) =', trifad(4,iaux), + > ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3) + 3333 continue + write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0), + > 'cotrvo(4,1) = ', cotrvo(4,1), + > 'cotrvo(4,2) = ', cotrvo(4,2), + > 'cotrvo(4,3) = ', cotrvo(4,3) + write(ulsort,90006) 'areqtr(4,1) = ', areqtr(4,1), + > ' de ',somare(1,areqtr(4,1)), + > ' a ',somare(2,areqtr(4,1)) + write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2), + > ' de ',somare(1,areqtr(4,2)), + > ' a ',somare(2,areqtr(4,2)) + write(ulsort,90006) 'areqtr(4,3) = ', areqtr(4,3), + > ' de ',somare(1,areqtr(4,3)), + > ' a ',somare(2,areqtr(4,3)) +#endif +c +c==== +c 4. niveau des triangles des conformites des faces +c==== +c + niveau = nivtri(trifad(1,0)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'niveau', niveau +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp5c.F b/src/tool/Creation_Maillage/cmcp5c.F new file mode 100644 index 00000000..ddfb847e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp5c.F @@ -0,0 +1,246 @@ + subroutine cmcp5c ( indtri, triint, + > lesare, + > areint, areqtr, niveau, + > aretri, famtri, hettri, + > filtri, pertri, nivtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 5, phase C +c - - +c Construction des triangles internes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . triint . s . 15 . triangles internes au pentaedre . +c . . . . 1-3 = milieu/milieu et sommet face opposee. +c . . . . 4-6 = milieu/milieu et noeud central . +c . . . . 7-9 = arete face oppose et noeud central . +c . . . . 10-15 = appuyes sur une arete interne a . +c . . . . une face quadrangulaire coupee . +c . lesare . e . 3 . liste des aretes du pentaedre utiles . +c . . . . 1-3 = arete face oppose . +c . areint . e . 6 . aretes internes au pentaedre . +c . areqtr . e .(4,0:3) . aretes tracees sur les faces decoupees . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . niveau . e . 1 . niveau a attribuer aux triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP5C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nouvnb.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer indtri + integer niveau + integer triint(15) + integer lesare(3) + integer areint(6) + integer areqtr(4,0:3) + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + codetr = 1 +c +c==== +c 2. Les triangles entre les aretes tracees sur la face coupee et +c les sommets de la face opposee +c==== +c + do 21 , iaux = 1 , 3 +c + jaux = per1a3(1,iaux) +c + indtri = indtri + 1 + triint(iaux) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_123', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, + > areqtr(iaux,1), areqtr(4,iaux), areqtr(jaux,2), + > codetr, niveau ) +c + 21 continue +c +c==== +c 3. Les triangles entre les aretes tracees sur la face coupee et +c le noeud central +c==== +c + do 31 , iaux = 1 , 3 +c + jaux = per1a3(1,iaux) +c + indtri = indtri + 1 + triint(iaux+3) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_456', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, + > areint(iaux+3), areqtr(4,iaux), areint(jaux+3), + > codetr, niveau ) +c + 31 continue +c +c==== +c 4. Les triangles s'appuyant sur les 3 aretes de la face non decoupee +c==== +c + do 41 , iaux = 1 , 3 +c + jaux = per1a3(-1,iaux) +c + indtri = indtri + 1 + triint(iaux+6) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_789', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, + > areint(iaux), lesare(iaux), areint(jaux), + > codetr, niveau ) +c + 41 continue +c +c==== +c 5. Les triangles s'appuyant sur les aretes tracees sur +c les quadrangles coupes +c==== +c + do 511 , iaux = 1 , 3 +c + indtri = indtri + 1 + triint(iaux+9) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_10-11-12', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, + > areint(iaux), areqtr(iaux,1), areint(iaux+3), + > codetr, niveau ) +c + 511 continue +c + do 512 , iaux = 1 , 3 +c + jaux = per1a3(-1,iaux) +c + indtri = indtri + 1 + triint(iaux+12) = indtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTRI_13-14-15', nompro +#endif + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > indtri, + > areint(iaux+3), areqtr(iaux,2), areint(jaux), + > codetr, niveau ) +c + 512 continue +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcp5e.F b/src/tool/Creation_Maillage/cmcp5e.F new file mode 100644 index 00000000..54cfd5f8 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcp5e.F @@ -0,0 +1,266 @@ + subroutine cmcp5e ( indtet, indptp, + > lepent, + > trifad, cotrvo, triint, + > facdec, laface, coface, + > hettet, tritet, cotrte, + > filtet, pertet, famtet, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Conformite - decoupage des Pentaedres +c - - - - +c - cas 5, phase E +c - - +c Construction des tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . lepent . e . 1 . pentaedre a decouper . +c . trifad . e .(4,0:3) . triangles traces sur les faces decoupees . +c . cotrvo . e .(4,0:3) . code des triangles dans les volumes . +c . triint . e . 15 . triangles internes au pentaedre . +c . . . . 1-3 = milieu/milieu et sommet face opposee. +c . . . . 4-6 = milieu/milieu et noeud central . +c . . . . 7-9 = arete face oppose et noeud central . +c . . . . 10-15 = appuyes sur une arete interne a . +c . . . . une face quadrangulaire coupee . +c . facdec . e . 1 . numero local de la face non coupee . +c . laface . e . 1 . numero global de la face non coupee . +c . coface . e . 1 . futur code de la face dans le tetraedre . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . fampen . e . nouvpe . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : aucune arete ne correspond . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCP5E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "ope1a3.h" +#include "coftfp.h" +c +c 0.3. ==> arguments +c + integer indtet, indptp + integer lepent + integer trifad(4,0:3), cotrvo(4,0:3) + integer triint(15) + integer facdec, laface, coface + integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer fampen(nouvpe), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nupere, nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c 1.2. ==> Le pere des tetraedres et leur famille +c + nupere = -indptp + nufami = cfapen(coftfp,fampen(lepent)) +cgn write (ulsort,*) 'lepent', lepent +cgn write (ulsort,*) 'fampen(lepent)', fampen(lepent) +cgn write (ulsort,*) 'nufami', nufami +c +c==== +c 2. Tetraedres sur les triangles de la face coupee, sauf le central +c==== +c + do 21 , iaux = 1 , 3 +c + jaux = per1a3(1,iaux) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_123', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > triint(iaux), trifad(4,iaux), trifad(jaux,2), trifad(iaux,1), + > 4, cotrvo(4,iaux), cotrvo(jaux,2), cotrvo(iaux,1), + > nupere, nufami, indtet ) +c + 21 continue +c +c==== +c 3. Tetraedres avec une arete de la face coupee, le sommet oppose, +c le noeud central +c==== +c + do 31 , iaux = 1 , 3 +c + jaux = per1a3(1,iaux) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_456', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > triint(iaux), triint(iaux+3), triint(iaux+9), triint(jaux+12), + > 2, 2, 4, 2, + > nupere, nufami, indtet ) +c + 31 continue +c +c==== +c 4. Tetraedres bases sur le triangle central aux faces quadrangulaires +c==== +c + do 41 , iaux = 1 , 3 +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_789', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(iaux,0), triint(iaux+6), triint(iaux+9), triint(iaux+12), + > cotrvo(iaux,0), 2, 2, 4, + > nupere, nufami, indtet ) +c + 41 continue +c +c==== +c 5. Tetraedre sur le triangle central de la face coupee +c==== +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_10', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > trifad(4,0), triint(5), triint(6), triint(4), + > cotrvo(4,0), 4, 2, 4, + > nupere, nufami, indtet ) +c +c==== +c 8. Tetraedre sur la face non coupee +c==== +c + indtet = indtet + 1 + if ( facdec.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_11', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > laface, triint(7), triint(9), triint(8), + > coface, 4, 2, 4, + > nupere, nufami, indtet ) +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTET_11', nompro +#endif + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > laface, triint(8), triint(7), triint(9), + > coface, 4, 2, 4, + > nupere, nufami, indtet ) +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcpen.F b/src/tool/Creation_Maillage/cmcpen.F new file mode 100644 index 00000000..18818748 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpen.F @@ -0,0 +1,113 @@ + subroutine cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > nface1, nface2, nface3, + > nface4, nface5, + > codef1, codef2, codef3, + > codef4, codef5, + > nupere, famill, nupent ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un PENtaedre +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'un pentaedre etant donne : +c - le numero du pentaedre +c - les numeros globaux des faces locales 1,2,3,4 et 5 +c - les codes des faces +c - le numero du pere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . facpen . es .nouvpf*5. numeros des 5 faces des pentaedres . +c . cofape . es .nouvpf*5. code des 5 faces des pentaedres . +c . fampen . es . nouvpe . famille des pentaedres . +c . hetpen . es . nouvpe . historique de l'etat des pentaedres . +c . filpen . es . nouvpe . premier fils des pentaedres . +c . perpen . es . nouvpe . pere des pentaedres . +c . nface1 . e . 1 . face de numero local 1 dans le pentaedre . +c . nface2 . e . 1 . face de numero local 2 dans le pentaedre . +c . nface3 . e . 1 . face de numero local 3 dans le pentaedre . +c . nface4 . e . 1 . face de numero local 4 dans le pentaedre . +c . nface5 . e . 1 . face de numero local 5 dans le pentaedre . +c . codef1 . e . 1 . code de la face 1 . +c . codef2 . e . 1 . code de la face 2 . +c . codef3 . e . 1 . code de la face 3 . +c . codef4 . e . 1 . code de la face 4 . +c . codef5 . e . 1 . code de la face 5 . +c . nupere . e . 1 . numero du pere du pentaedre . +c . famill . e . 1 . famille a attribuer a l'pentaedre . +c . nupent . e . 1 . numero du pentaedre a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer facpen(nouvpe,5), cofape(nouvpf,5), fampen(nouvpe) + integer hetpen(nouvpe), filpen(nouvpe), perpen(nouvpe) + integer nface1, nface2, nface3, nface4, nface5 + integer codef1, codef2, codef3, codef4, codef5 + integer nupere, famill, nupent +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +cgn 1000 format('penta ',i8,' de faces :',5i8) +cgn 1001 format(' de codes :',5i8) +cgn write(*,1000) nupent, nface1, nface2, nface3, nface4, nface5 +cgn write(*,1001) codef1, codef2, codef3, codef4, codef5 +c +c==== +c 1. creation effective d'un pentaedre +c==== +c + facpen(nupent,1) = nface1 + facpen(nupent,2) = nface2 + facpen(nupent,3) = nface3 + facpen(nupent,4) = nface4 + facpen(nupent,5) = nface5 +c + cofape(nupent,1) = codef1 + cofape(nupent,2) = codef2 + cofape(nupent,3) = codef3 + cofape(nupent,4) = codef4 + cofape(nupent,5) = codef5 +c + fampen(nupent) = famill +c + hetpen(nupent) = 5500 + filpen(nupent) = 0 + perpen(nupent) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmcpy2.F b/src/tool/Creation_Maillage/cmcpy2.F new file mode 100644 index 00000000..f03c90c3 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpy2.F @@ -0,0 +1,242 @@ + subroutine cmcpy2 ( lehexa, indpyr, indptp, + > laface, + > somhex, areint, are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation de PYramidee par leurs aretes +c - - - -- +c - par paquets de 2 appuyes sur une face +c - +c ______________________________________________________________________ +c La description est faite comme pour le decoupage +c de la face 1 par les aretes 1 et 4 +c +c S2 N1 S1 +c |---------------|---------------| +c | | | +c | | | +c | | | +c A3 | | | A2 +c | | | +c | | | +c | | | +c |---------------|---------------| +c S3 N4 S4 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . laface . e . 1 . face coupee en 2 quadrangles . +c . somhex . e . 4 . Les sommets de la face dans . +c . . . . l'ordre S1, S4, S3, S2 . +c . areint . e . 6 . Les aretes internes utiles . +c . . . . . Les 4 premiers sur les sommets . +c . . . . . 5 sur le milieu de S1-S2 . +c . . . . . 6 sur le milieu de S3-S4 . +c . are1 . e . 1 . arete S1-S2 . +c . are2 . e . 1 . arete S1-S4 . +c . are3 . e . 1 . arete S3-S4 . +c . are4 . e . 1 . arete S2-S3 . +c . filare . e . nouvar . fille ainee de chaque arete . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . arepyr . e .nouvya*8. numeros des 8 aretes des pyramides . +c . fampyr . e . nouvpy . famille des pyramides . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCPY2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indpyr, indptp + integer laface + integer somhex(4), areint(6) + integer are1, are2, are3, are4 + integer filare(nouvar) + integer arequa(nouvqu,4), filqua(nouvqu) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) + integer arepyr(nouvya,8), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer as1n1, as2n1, as3n4, as4n4, an1n4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'laface', laface + write (ulsort,90002) 'somhex', somhex + write (ulsort,90002) 'areint', areint + write (ulsort,90002) 'are1, are2, are3, are4', + > are1, are2, are3, are4 +#endif +c +c==== +c 2. Recuperation des demi-aretes +c==== +c + if ( somhex(1).le.somhex(4) ) then + as1n1 = filare(are1) + as2n1 = filare(are1) + 1 + else + as1n1 = filare(are1) + 1 + as2n1 = filare(are1) + endif +c + if ( somhex(2).le.somhex(3) ) then + as3n4 = filare(are3) + 1 + as4n4 = filare(are3) + else + as3n4 = filare(are3) + as4n4 = filare(are3) + 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as2n1, as3n4, as4n4', + > as1n1, as2n1, as3n4, as4n4 +#endif +c +c==== +c 3. Recuperation de l'arete entre les milieux des aretes coupees +c C'est toujours la 4eme dans la description des fils (cf. cmcdq2) +c==== +c + an1n4 = arequa(filqua(laface),4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an1n4', an1n4 +#endif +c +c==== +c 4. Creation des pyramides +c==== +c + nupere = -indptp + nufami = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Pyramide numero 1 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(1), areint(2), areint(6), areint(5), + > are2, as4n4, an1n4, as1n1, + > nupere, nufami, indpyr ) +c +c 4.2. ==> Pyramide numero 2 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 2', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(3), areint(4), areint(5), areint(6), + > are4, as2n1, an1n4, as3n4, + > nupere, nufami, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcpy3.F b/src/tool/Creation_Maillage/cmcpy3.F new file mode 100644 index 00000000..2da7398d --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpy3.F @@ -0,0 +1,259 @@ + subroutine cmcpy3 ( lehexa, indpyr, indptp, + > laface, codfac, + > areint, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation de PYramidee par leurs aretes +c - - - -- +c - par paquets de 3 appuyes sur une face +c - +c ______________________________________________________________________ +c La description est faite comme pour le decoupage +c de la face 1 par les aretes 1 et 2 et code<5 +c +c S2 N1 S1 +c |-----------|-----------| +c | | | +c | | FFI | +c | | | +c | FFI+2 |NF1 | +c A3 | |-----------| N2 +c | / | +c | / | +c | / FFI+1 | +c | / | +c | / | +c |-----------------------| +c S3 A4 S4 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . laface . e . 1 . face coupee en 2 quadrangles . +c . codfac . e . 1 . code de la face coupee en 3 quad dans l'hex. +c . areint . e . 7 . Les aretes internes utiles . +c . . . . . 1 : le sommet de FFI . +c . . . . . 2 : le sommet du cote de FFI+1 . +c . . . . . 3 : le sommet commun a FFI+1 et FFI+2 . +c . . . . . 4 : le sommet du cote de FFI+2 . +c . . . . . 5 : noeud commun a FFI et FFI+1 . +c . . . . . 6 : noeud commun a FFI et FFI+2 . +c . . . . . 7 : sur NF1, milieu de la face . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . arepyr . e .nouvya*8. numeros des 8 aretes des pyramides . +c . fampyr . e . nouvpy . famille des pyramides . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCPY3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indpyr, indptp + integer laface, codfac + integer areint(7) + integer arequa(nouvqu,4), filqua(nouvqu) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) + integer arepyr(nouvya,8), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer as1n1, as1n2, an1nf1, an2nf1, as3nf1 + integer as4n2, as2n1, as2s3, as3s4 + integer as1s0, as2s0, as3s0, as4s0, an1s0, an2s0, anf1s0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'laface, codfac', laface, codfac + write (ulsort,90002) 'areint', areint +#endif +c +c==== +c 2. Recuperation des aretes tracees sur la face et des aretes internes +c==== +c + iaux = filqua(laface) +c + if ( codfac.lt.5 ) then + as1n1 = arequa(iaux,1) + as1n2 = arequa(iaux,2) + an2nf1 = arequa(iaux,3) + an1nf1 = arequa(iaux,4) + as4n2 = arequa(iaux+1,1) + as3s4 = arequa(iaux+1,2) + as2n1 = arequa(iaux+2,1) + as2s3 = arequa(iaux+2,4) + else + as1n1 = arequa(iaux,2) + as1n2 = arequa(iaux,1) + an2nf1 = arequa(iaux,4) + an1nf1 = arequa(iaux,3) + as4n2 = arequa(iaux+2,1) + as3s4 = arequa(iaux+2,4) + as2n1 = arequa(iaux+1,1) + as2s3 = arequa(iaux+1,2) + endif + as3nf1 = arequa(iaux+1,3) + as1s0 = areint(1) + as4s0 = areint(2) + as3s0 = areint(3) + as2s0 = areint(4) + an2s0 = areint(5) + an1s0 = areint(6) + anf1s0 = areint(7) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as1n2, an1nf1, an2nf1, as3nf1', + > as1n1, as1n2, an1nf1, an2nf1, as3nf1 + write (ulsort,90002) 'as4n2, as2n1, as2s3, as3s4', + > as4n2, as2n1, as2s3, as3s4 + write (ulsort,90002) + > 'as1s0, as2s0, as3s0, as4s0, an1s0, an2s0, anf1s0', + > as1s0, as2s0, as3s0, as4s0, an1s0, an2s0, anf1s0 +#endif +c +c==== +c 3. Creation des pyramides +c==== +c + nupere = -indptp + nufami = cfahex(cofpfh,famhex(lehexa)) +c +c 3.1. ==> Pyramide numero 1 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as1s0, an2s0, anf1s0, an1s0, + > as1n2, an2nf1, an1nf1, as1n1, + > nupere, nufami, indpyr ) +c +c 3.2. ==> Pyramide du cote de ffi+1 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA cote de ffi+1', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as4s0, as3s0, anf1s0, an2s0, + > as3s4, as3nf1, an2nf1, as4n2, + > nupere, nufami, indpyr ) +c +c 3.3. ==> Pyramide du cote de ffi+2 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA cote de ffi+2', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as2s0, an1s0, anf1s0, as3s0, + > as2n1, an1nf1, as3nf1, as2s3, + > nupere, nufami, indpyr ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcpy4.F b/src/tool/Creation_Maillage/cmcpy4.F new file mode 100644 index 00000000..10236d6c --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpy4.F @@ -0,0 +1,320 @@ + subroutine cmcpy4 ( lehexa, indpyr, indptp, + > laface, + > somhex, areint, as1s2, as1s4, as3s4, as2s3, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation de PYramidee par leurs aretes +c - - - -- +c - par paquets de 4 appuyes sur une face +c - +c ______________________________________________________________________ +c La description est faite comme pour le decoupage de la face 1 +c +c S2 N1 S1 +c |---------------|---------------| +c | | | +c | | | +c | | | +c | |N0 | +c N3 |---------------|---------------| N2 +c | | | +c | | | +c | | | +c | | | +c |---------------|---------------| +c S3 N4 S4 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . laface . e . 1 . face coupee en 2 quadrangles . +c . somhex . e . 8 . Les sommets de la face dans . +c . . . . l'ordre S2, S1, S4, S3 . +c . . . . puis les noeuds milieux N1, N2, N4, N3 . +c . areint . e . 9 . Les aretes internes utiles . +c . . . . . Les 4 1ers sur S2, S1, S4, S3 . +c . . . . . Les 4 suivants sur N1, N2, N4, N3 . +c . . . . . 9 sur le milieu de la face . +c . as1s2 . e . 1 . arete S1-S2 . +c . as1s4 . e . 1 . arete S1-S4 . +c . as3s4 . e . 1 . arete S3-S4 . +c . as2s3 . e . 1 . arete S2-S3 . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . filare . e . nouvar . fille ainee de chaque arete . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . arepyr . e .nouvya*8. numeros des 8 aretes des pyramides . +c . fampyr . e . nouvpy . famille des pyramides . +c . hetpyr . e . nouvpy . historique de l'etat des pyramides . +c . filpyr . e . nouvpy . premier fils des pyramides . +c . perpyr . e . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCPY4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "cofpfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indpyr, indptp + integer laface + integer somhex(8), areint(9) + integer as1s2, as1s4, as3s4, as2s3 + integer somare(2,nouvar), filare(nouvar) + integer arequa(nouvqu,4), filqua(nouvqu) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) + integer arepyr(nouvya,8), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer listar(4) + integer nupere, nufami + integer as1n1, as2n1, as1n2, as4n2 + integer as3n4, as4n4, as2n3, as3n3 + integer an1nf1, an2nf1, an4nf1, an3nf1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'laface', laface + write (ulsort,90002) 'somhex', somhex + write (ulsort,90002) 'areint', areint + write (ulsort,90002) 'as1s2, as1s4, as3s4, as2s3', + > as1s2, as1s4, as3s4, as2s3 +#endif +c +c==== +c 2. Recuperation des demi-aretes +c==== +c 2.1. == filles de as1s2 +c + if ( somhex(1).le.somhex(2) ) then + as1n1 = filare(as1s2) + 1 + as2n1 = filare(as1s2) + else + as1n1 = filare(as1s2) + as2n1 = filare(as1s2) + 1 + endif +c +c 2.2. == filles de as1s4 +c + if ( somhex(2).le.somhex(3) ) then + as1n2 = filare(as1s4) + as4n2 = filare(as1s4) + 1 + else + as1n2 = filare(as1s4) + 1 + as4n2 = filare(as1s4) + endif +c +c 2.4. == filles de as3s4 +c + if ( somhex(3).le.somhex(4) ) then + as3n4 = filare(as3s4) + 1 + as4n4 = filare(as3s4) + else + as3n4 = filare(as3s4) + as4n4 = filare(as3s4) + 1 + endif +c +c 2.4. == filles de as2s3 +c + if ( somhex(4).le.somhex(1) ) then + as2n3 = filare(as2s3) + 1 + as3n3 = filare(as2s3) + else + as2n3 = filare(as2s3) + as3n3 = filare(as2s3) + 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as2n1, as1n2, as4n2', + > as1n1, as2n1, as1n2, as4n2 + write (ulsort,90002) 'as3n4, as4n4, as2n3, as3n3', + > as3n4, as4n4, as2n3, as3n3 +#endif +c +c==== +c 3. Recuperation des aretes entre les milieux des aretes coupees +c==== +c 3.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans +c la description des fils (cf. cmcdq2) +c + listar(1) = arequa(filqua(laface) ,2) + listar(2) = arequa(filqua(laface) ,3) + listar(3) = arequa(filqua(laface)+2,2) + listar(4) = arequa(filqua(laface)+2,3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar', listar +#endif +c +c 3.2. ==> Positionnement +c + do 32 , iaux = 1 , 4 +c + jaux = somare(1,listar(iaux)) + if ( jaux.eq.somhex(5) ) then + an1nf1 = listar(iaux) + elseif ( jaux.eq.somhex(6) ) then + an2nf1 = listar(iaux) + elseif ( jaux.eq.somhex(7) ) then + an4nf1 = listar(iaux) + elseif ( jaux.eq.somhex(8) ) then + an3nf1 = listar(iaux) + endif +c + 32 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an1nf1, an2nf1, an4nf1, an3nf1', + > an1nf1, an2nf1, an4nf1, an3nf1 +#endif +c +c==== +c 4. Creation des pyramides +c==== +c + nupere = -indptp + nufami = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Pyramide numero 1 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(2), areint(6), areint(9), areint(5), + > as1n2, an2nf1, an1nf1, as1n1, + > nupere, nufami, indpyr ) +c +c 4.2. ==> Pyramide numero 2 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 2', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(3), areint(7), areint(9), areint(6), + > as4n4, an4nf1, an2nf1, as4n2, + > nupere, nufami, indpyr ) +c +c 4.3. ==> Pyramide numero 3 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(4), areint(8), areint(9), areint(7), + > as3n3, an3nf1, an4nf1, as3n4, + > nupere, nufami, indpyr ) +c +c 4.4. ==> Pyramide numero 4 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(1), areint(5), areint(9), areint(8), + > as2n1, an1nf1, an3nf1, as2n3, + > nupere, nufami, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmcpya.F b/src/tool/Creation_Maillage/cmcpya.F new file mode 100644 index 00000000..29cc7c39 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpya.F @@ -0,0 +1,108 @@ + subroutine cmcpya ( arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > naret1, naret2, naret3, naret4, + > naret5, naret6, naret7, naret8, + > nupere, famill, nupyra ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'une PYramide par ses Aretes +c - - - -- - +c ______________________________________________________________________ +c +c but : creation effective d'une pyramide etant donne : +c - le numero de la pyramide +c - les numeros globaux des aretes +c - le numero du pere +c - la famille a attribuer +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arepyr . es .provya*8. numeros des aretes des pyramides . +c . fampyr . es . nouvpy . famille des pyramides . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . nareti . e . 1 . arete de numero local i dans la pyramide . +c . nupere . e . 1 . numero du pere de la pyramide . +c . famill . e . 1 . famille a attribuer a la pyramide . +c . nupyra . e . 1 . numero de la pyramide a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer arepyr(provya,8), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) + integer naret1, naret2, naret3, naret4 + integer naret5, naret6, naret7, naret8 + integer nupere, famill, nupyra +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. creation effective d'une pyramide +c==== +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'nupyra', nupyra + write (*,90002) 'nouvya', nouvya + write (*,90002) 'nouvyf', nouvyf + write (*,90015) 'Pyramide', nupyra, + > ', aretes', naret1, naret2, naret3, naret4, + > naret5, naret6, naret7, naret8 +#endif +c + iaux = nupyra - nouvyf + arepyr(iaux,1) = naret1 + arepyr(iaux,2) = naret2 + arepyr(iaux,3) = naret3 + arepyr(iaux,4) = naret4 + arepyr(iaux,5) = naret5 + arepyr(iaux,6) = naret6 + arepyr(iaux,7) = naret7 + arepyr(iaux,8) = naret8 +c + fampyr(nupyra) = famill +c + hetpyr(nupyra) = 5500 + filpyr(nupyra) = 0 + perpyr(nupyra) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmcpyr.F b/src/tool/Creation_Maillage/cmcpyr.F new file mode 100644 index 00000000..5925fe6e --- /dev/null +++ b/src/tool/Creation_Maillage/cmcpyr.F @@ -0,0 +1,119 @@ + subroutine cmcpyr ( facpyr, cofapy, fampyr, + > hetpyr, filpyr, perpyr, + > nface1, codef1, + > nface2, codef2, + > nface3, codef3, + > nface4, codef4, + > nface5, codef5, + > nupere, famill, nupyra ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'une PYRamide +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'une pyramide etant donne : +c - le numero de la pyramide +c - les numero globaux des faces locales 1,2,3 et 4 +c - les codes des faces +c - le numero du pere +c - la famille a attribuer +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . +c . cofapy . es .nouvyf*5. codes des faces des pyramides . +c . fampyr . es . nouvpy . famille des pyramides . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . nface1 . e . 1 . face de numero local 1 dans la pyramide . +c . nface2 . e . 1 . face de numero local 2 dans la pyramide . +c . nface3 . e . 1 . face de numero local 3 dans la pyramide . +c . nface4 . e . 1 . face de numero local 4 dans la pyramide . +c . nface5 . e . 1 . face de numero local 5 dans la pyramide . +c . codef1 . e . 1 . code de la face 1 . +c . codef2 . e . 1 . code de la face 2 . +c . codef3 . e . 1 . code de la face 3 . +c . codef4 . e . 1 . code de la face 4 . +c . codef5 . e . 1 . code de la face 5 . +c . nupere . e . 1 . numero du pere de la pyramide . +c . famill . e . 1 . famille a attribuer a la pyramide . +c . nupyra . e . 1 . numero de la pyramide a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer facpyr(nouvyf,5), cofapy(nouvyf,5), fampyr(nouvpy) + integer hetpyr(nouvpy), filpyr(nouvpy), perpyr(nouvpy) + integer nface1, nface2, nface3, nface4, nface5 + integer codef1, codef2, codef3, codef4, codef5 + integer nupere, famill, nupyra +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'une pyramide +c==== +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" + write (1,90015) 'Pyramide', nupyra, + > ', faces', nface1, nface2, nface3, nface4, nface5 + write (1,90015) 'Pyramide', nupyra, + > ', codes', codef1, codef2, codef3, codef4, codef5 +#endif +c + facpyr(nupyra,1) = nface1 + facpyr(nupyra,2) = nface2 + facpyr(nupyra,3) = nface3 + facpyr(nupyra,4) = nface4 + facpyr(nupyra,5) = nface5 +c + cofapy(nupyra,1) = codef1 + cofapy(nupyra,2) = codef2 + cofapy(nupyra,3) = codef3 + cofapy(nupyra,4) = codef4 + cofapy(nupyra,5) = codef5 +c + fampyr(nupyra) = famill +c + hetpyr(nupyra) = 5500 + filpyr(nupyra) = 0 + perpyr(nupyra) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmcqua.F b/src/tool/Creation_Maillage/cmcqua.F new file mode 100644 index 00000000..b27fa980 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcqua.F @@ -0,0 +1,102 @@ + subroutine cmcqua + > ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > nuquad, arete1, arete2, arete3, arete4, + > codequ, niveau ) +c +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un Quadrangle +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'un quadrangle etant donne : +c - le niveau du quadrangle +c - le numero du quadrangle +c - les numero globaux des aretes locales 1,2 et 3 +c - le code du quadrangle qui permet en appliquant les fonctions +c i1, i2, i3 de determiner le numero d'ordre des aretes dans le +c quadruplet de definition du quadrangle +c remarque : l'ordre local des aretes et le code du quadrangle sont +c fonction de l'element sur lequel on travail lors de l'appel de +c ce sous-programme +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arequa . es .nouvqu*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . nuquad . e . 1 . numero du quadrangle a creer . +c . arete1 . e . 1 . arete de numero local 1 dans le quadrangle . +c . arete2 . e . 1 . arete de numero local 2 dans le quadrangle . +c . arete3 . e . 1 . arete de numero local 3 dans le quadrangle . +c . arete4 . e . 1 . arete de numero local 4 dans le quadrangle . +c . codequ . e . 1 . code du quadrangle . +c . niveau . e . 1 . niveau du quadrangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "j1234j.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer arequa(nouvqu,4), famqua(nouvqu) + integer hetqua(nouvqu), filqua(nouvqu), perqua(nouvqu) + integer nivqua(nouvqu) + integer nuquad, arete1, arete2, arete3, arete4, codequ, niveau +c +c 0.4. ==> variables locales +c +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un quadrangle +c==== +c + arequa(nuquad,j1(codequ)) = arete1 + arequa(nuquad,j2(codequ)) = arete2 + arequa(nuquad,j3(codequ)) = arete3 + arequa(nuquad,j4(codequ)) = arete4 +c + famqua(nuquad) = 1 +c + hetqua(nuquad) = 5500 + filqua(nuquad) = 0 + perqua(nuquad) = 0 + nivqua(nuquad) = niveau +c + end diff --git a/src/tool/Creation_Maillage/cmcte3.F b/src/tool/Creation_Maillage/cmcte3.F new file mode 100644 index 00000000..8fd700b6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmcte3.F @@ -0,0 +1,253 @@ + subroutine cmcte3 ( lehexa, indtet, indptp, + > laface, codfac, areint, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation de TEtraedres par leurs aretes +c - - - -- +c - par paquets de 3 appuyes sur une face +c - +c ______________________________________________________________________ +c +c S1 si code<5 are1 si code<5 S4 si code<5 +c |-----------------------------------| +c | .-----------------------> . | +c | | . | +c | | FFI+1 . V | +c | | . | | +c | | . | | +c | | . | | +c | . | | +c | . | | +c n1 . FFI | | are2 +c | . | | +c | . | | +c | | . | | +c | | . | | +c | | . | | +c | | FFI+2 . V | +c | | . | +c | <-------------------- . | +c |-----------------------------------| +c S2 si code<5 are3 si code<5 S3 si code<5 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indptp . e . 1 . indice du dernier pere enregistre . +c . laface . e . 1 . face coupee en 3 triangles . +c . codfac . e . 1 . code de la face coupee en 3 tria dans l'hex. +c . areint . e . 5 . Les aretes internes utiles . +c . . . . S1 du cote ffi+1 S4 et S3 base ffi . +c . . . . S2 du cote de ffi+2 n1 arete coupee . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . famtet . es . nouvte . famille des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famhex . e . nouvhe . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMCTE3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +#include "coftfh.h" +c +c 0.3. ==> arguments +c + integer lehexa, indtet, indptp + integer laface, codfac + integer areint(5) + integer aretri(nouvtr,3) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer famhex(nouvhe), cfahex(nctfhe,nbfhex) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nupere, nufami + integer as1n1, as4n1, as3n1, as2n1 + integer as1s0, as4s0, as3s0, as2s0, an1s0 + integer as1s4, as2s3, as3s4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) + +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'laface, codfac', laface, codfac + write (ulsort,90002) 'areint', areint +#endif +c +c==== +c 2. Recuperation des aretes tracees sur la face et des aretes internes +c==== +c + iaux = -filqua(laface) +c + if ( codfac.lt.5 ) then + as4n1 = aretri(iaux,1) + as3n1 = aretri(iaux,3) + as1n1 = aretri(iaux+1,1) + as1s4 = aretri(iaux+1,2) + as2n1 = aretri(iaux+2,1) + as2s3 = aretri(iaux+2,3) + else + as4n1 = aretri(iaux,3) + as3n1 = aretri(iaux,1) + as1n1 = aretri(iaux+2,1) + as1s4 = aretri(iaux+2,3) + as2n1 = aretri(iaux+1,1) + as2s3 = aretri(iaux+1,2) + endif + as3s4 = aretri(iaux,2) + as1s0 = areint(1) + as4s0 = areint(2) + as3s0 = areint(3) + as2s0 = areint(4) + an1s0 = areint(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as4n1, as3n1, as2n1', + > as1n1, as4n1, as3n1, as2n1 + write (ulsort,90002) 'as1s0, as4s0, as3s0, as2s0, an1s0', + > as1s0, as4s0, as3s0, as2s0, an1s0 + write (ulsort,90002) 'as1s4, as2s3, as3s4', + > as1s4, as2s3, as3s4 +#endif +c +c==== +c 3. Creation des tetraedres +c==== +c + nupere = -indptp + nufami = cfahex(coftfh,famhex(lehexa)) +c +c 3.1. ==> Sur la face centrale, ffi +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA pour ffi', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an1s0, as4s0, as3s0, as4n1, + > as3n1, as3s4, + > nupere, nufami, indtet ) +c +c 3.2. ==> Sur la face ffi+1 (si code<5) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA pour ffi+1', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an1s0, as1s0, as4s0, as1n1, + > as4n1, as1s4, + > nupere, nufami, indtet ) +c +c 3.3. ==> Sur la face ffi+2 (si code<5) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA pour ffi+2', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an1s0, as3s0, as2s0, as3n1, + > as2n1, as2s3, + > nupere, nufami, indtet ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmctea.F b/src/tool/Creation_Maillage/cmctea.F new file mode 100644 index 00000000..0e535fea --- /dev/null +++ b/src/tool/Creation_Maillage/cmctea.F @@ -0,0 +1,102 @@ + subroutine cmctea ( aretet, famtet, + > hettet, filtet, pertet, + > naret1, naret2, naret3, naret4, + > naret5, naret6, + > nupere, famill, nutetr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un TEtraedre par ses Aretes +c - - - -- - +c ______________________________________________________________________ +c +c but : creation effective d'un tetraedre etant donne : +c - le numero du tetraedre +c - les numero globaux des aretes +c - le numero du pere +c - la famille a attribuer +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . famtet . es . nouvte . famille des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . nareti . e . 1 . arete de numero local i dans le tetraedre . +c . nupere . e . 1 . numero du pere du tetraedre . +c . famill . e . 1 . famille a attribuer au tetraedre . +c . nutetr . e . 1 . numero du tetraedre a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer aretet(nouvta,6), famtet(nouvte) + integer hettet(nouvte), filtet(nouvte), pertet(nouvte) + integer naret1, naret2, naret3, naret4 + integer naret5, naret6 + integer nupere, famill, nutetr +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" + write (1,90015) 'Tetraedre', nutetr, + > ', aretes', naret1, naret2, naret3, naret4, + > naret5, naret6 +#endif + iaux = nutetr - nouvtf + aretet(iaux,1) = naret1 + aretet(iaux,2) = naret2 + aretet(iaux,3) = naret3 + aretet(iaux,4) = naret4 + aretet(iaux,5) = naret5 + aretet(iaux,6) = naret6 +c + famtet(nutetr) = famill +c + hettet(nutetr) = 5500 + filtet(nutetr) = 0 + pertet(nutetr) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmctet.F b/src/tool/Creation_Maillage/cmctet.F new file mode 100644 index 00000000..2f3d2b02 --- /dev/null +++ b/src/tool/Creation_Maillage/cmctet.F @@ -0,0 +1,116 @@ + subroutine cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ntria1, ntria2, ntria3, ntria4, + > codef1, codef2, codef3, codef4, + > nupere, famill, nutetr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un TETraedre +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'un tetraedre etant donne : +c - le numero du tetraedre +c - les numero globaux des faces locales 1, 2, 3 et 4 +c - les codes des faces +c - le numero du pere +c - la famille a attribuer +c ce sous-programme est valable pour les tetraedres qui ne +c conservent aucune face de leur pere : tous sauf les tetraedres +c issus d'un decoupage en deux. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . famtet . es . nouvte . famille des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . ntria1 . e . 1 . face de numero local 1 dans le tetraedre . +c . ntria2 . e . 1 . face de numero local 2 dans le tetraedre . +c . ntria3 . e . 1 . face de numero local 3 dans le tetraedre . +c . ntria4 . e . 1 . face de numero local 4 dans le tetraedre . +c . codef1 . e . 1 . code de la face 1 . +c . codef2 . e . 1 . code de la face 2 . +c . codef3 . e . 1 . code de la face 3 . +c . codef4 . e . 1 . code de la face 4 . +c . nupere . e . 1 . numero du pere du tetraedre . +c . famill . e . 1 . famille a attribuer au tetraedre . +c . nutetr . e . 1 . numero du tetraedre a creer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer tritet(nouvtf,4), cotrte(nouvtf,4), famtet(nouvte) + integer hettet(nouvte), filtet(nouvte), pertet(nouvte) + integer ntria1, ntria2, ntria3, ntria4 + integer codef1, codef2, codef3, codef4 + integer nupere, famill, nutetr +c +c 0.4. ==> variables locales +c +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" + write (1,90015) 'Tetraedre', nutetr, + > ', faces', ntria1, ntria2, ntria3, ntria4 + write (1,90015) 'Tetraedre', nutetr, + > ', codes', codef1, codef2, codef3, codef4 +#endif + tritet(nutetr,1) = ntria1 + tritet(nutetr,2) = ntria2 + tritet(nutetr,3) = ntria3 + tritet(nutetr,4) = ntria4 +c + cotrte(nutetr,1) = codef1 + cotrte(nutetr,2) = codef2 + cotrte(nutetr,3) = codef3 + cotrte(nutetr,4) = codef4 +c + famtet(nutetr) = famill +c + hettet(nutetr) = 5500 + filtet(nutetr) = 0 + pertet(nutetr) = nupere +c + end diff --git a/src/tool/Creation_Maillage/cmctri.F b/src/tool/Creation_Maillage/cmctri.F new file mode 100644 index 00000000..e83ff5de --- /dev/null +++ b/src/tool/Creation_Maillage/cmctri.F @@ -0,0 +1,101 @@ + subroutine cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > nutria, arete1, arete2, arete3, + > codetr, niveau ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Creation d'un TRIangle +c - - - --- +c ______________________________________________________________________ +c +c but : creation effective d'un triangle etant donne : +c - le niveau du triangle +c - le numero du triangle +c - les numero globaux des aretes locales 1,2 et 3 +c - le code du triangle qui permet en appliquant les fonctions +c i1, i2, i3 de determiner le numero d'ordre des aretes dans le +c triplet de definition du triangle +c remarque : l'ordre local des aretes et le code du triangle sont +c fonction de l'element sur lequel on travail lors de l'appel de +c ce sous-programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . famtri . es . nouvtr . famille des triangles . +c . nutria . e . 1 . numero du triangle a creer . +c . arete1 . e . 1 . arete de numero local 1 dans le triangle . +c . arete2 . e . 1 . arete de numero local 2 dans le triangle . +c . arete3 . e . 1 . arete de numero local 3 dans le triangle . +c . codetr . e . 1 . code du triangle . +c . niveau . e . 1 . niveau a attribuer au triangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "i1i2i3.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer aretri(nouvtr,3), famtri(nouvtr) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) + integer nutria, arete1, arete2, arete3, codetr, niveau +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. creation effective d'un triangle +c==== +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" + write (1,90015) 'Triangle', nutria, + > ', aretes', arete1, arete2, arete3 +#endif + aretri(nutria,i1(codetr)) = arete1 + aretri(nutria,i2(codetr)) = arete2 + aretri(nutria,i3(codetr)) = arete3 +c + famtri(nutria) = 1 +c + hettri(nutria) = 50 + filtri(nutria) = 0 + pertri(nutria) = 0 + nivtri(nutria) = niveau +c + end diff --git a/src/tool/Creation_Maillage/cmdera.F b/src/tool/Creation_Maillage/cmdera.F new file mode 100644 index 00000000..9541ac3a --- /dev/null +++ b/src/tool/Creation_Maillage/cmdera.F @@ -0,0 +1,1158 @@ + subroutine cmdera ( nomail, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - DERAffinement +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . s . 1 . nombre de noeuds restants apres deraff. . +c . indnp2 . s . 1 . nombre de noeuds p2 restants apres deraff. . +c . indnim . s . 1 . nombre de noeuds internes restants ap deraf. +c . indare . s . 1 . nombre d'aretes restantes apres deraff. . +c . indtri . s . 1 . nombre de triangles restants apres deraff. . +c . indqua . s . 1 . nombre de quads restants apres deraff. . +c . indtet . s . 1 . nombre de tetraedres restants apres deraff.. +c . indhex . s . 1 . nombre de hexaedres restants apres deraff. . +c . indpen . s . 1 . indice du dernier pentaedre cree . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMDERA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava, nretap, nrsset + integer iaux, jaux, ideb, ifin + integer tbiaux(1) +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 + integer pdecar, pdecfa + integer phetno, pcoono, pareno + integer phetar, psomar, pfilar, pmerar, pnp2ar + integer phettr, paretr, pfiltr, ppertr, pnivtr, adnmtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu + integer phette, ptrite, pcotrt, pfilte, pperte + integer phethe, pquahe, pcoquh, pfilhe, pperhe, adnmhe + integer phetpe, pfacpe, pcofap, pfilpe, pperpe + integer pfamno, pcfano + integer pfamar + integer pfamtr + integer pfamqu + integer pfamte + integer pfamhe + integer pfampe + integer pfacar, pposif + integer nbpere, pdispe, pancpe, pnoupe + integer nbhere, pdishe, panche, pnouhe + integer nbtere, pdiste, pancte, pnoute +cgn integer nbpyre, pdispy, pancpy, pnoupy + integer pdispy, pancpy, pnoupy + integer nbqure, pdisqu, pancqu, pnouqu + integer nbtrre, pdistr, panctr, pnoutr + integer nbarre, pdisar, pancar, pnouar + integer nbnore, pdisno, pancno, pnouno + integer nbp2re, nbimre + integer adhono, adhoar, adhotr, adhoqu + integer ptrav3, ptrav4 + integer nbancn +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nnoupy, nnoupe, nnouhe, nnoute + character*8 nnouqu, nnoutr, nnouar, nnouno + character*8 ndispy, ndispe, ndishe, ndiste + character*8 ndisqu, ndistr, ndisar, ndisno + character*8 ntrav1, ntrav2, ntrav3, ntrav4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + nouvno = nbnoto + nouvar = nbarto + nouvtr = nbtrto + nouvqu = nbquto + nouvte = nbteto + nouvtf = nouvte + nouvhe = nbheto + nouvhf = nouvhe + nouvpe = nbpeto + nouvpf = nouvpe +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' DERAFFINEMENT STANDARD DU MAILLAGE'')' + texte(1,5) = '(41(''=''),/)' +c + texte(2,4) = '(/,a6,'' STANDARD UNREFINEMENT OF MESH'')' + texte(2,5) = '(36(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. ==> structure generale' +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. ==> tableaux' +#endif +c + iaux = 210 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, adhono, jaux, + > ulsort, langue, codret ) +c + call gmnomc ( nomail//'.InfoSupE', nhsupe, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + iaux = 210 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, jaux, jaux, + > jaux, pnp2ar, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 2310 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, jaux, jaux, + > pnivtr, jaux, jaux, + > adnmtr, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 2310 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, jaux, jaux, + > pnivqu, jaux, jaux, + > adnmqu, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 2730 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, pperte, + > pfamte, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 2730 + if ( mod(mailet,5).eq.0 ) then + iaux = iaux*19 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, jaux, jaux, + > jaux, pcoquh, jaux, + > adnmhe, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 2730 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +cgn call gmprsx (nompro//'- DECARE', ntrav1) +cgn call gmprot (nompro//'- DECARE', ntrav1, 1659, 1662) +cgn if ( nbquto.eq.0 ) then +cgn call gmprot (nompro//'- DECFAC', ntrav2, 2, nbtrto+1) +cgn else +cgn call gmprsx (nompro//'- DECFAC', ntrav2) +cgn endif +c + endif +c +c 2.3. ==> allocations supplementaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. alloc supplementaires ; codret', codret +#endif +c +c 2.3.1. ==> Renumerotation des noeuds +c + if ( codret.eq.0 ) then +c + call gmobal ( nhnoeu//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codret ) + nbancn = iaux + elseif ( codre0.eq.0 ) then + call gmaloj ( nhnoeu//'.Deraffin', ' ', nouvno, pancno, codret ) + nbancn = nouvno + if ( codret.eq.0 ) then + do 231 , iaux = 1, nouvno + imem(pancno+iaux-1) = iaux + 231 continue + endif + else + codret = codre0 + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nharet//'.Deraffin', ' ', nouvar, pancar, codre1 ) + call gmaloj ( nhtria//'.Deraffin', ' ', nouvtr, panctr, codre2 ) + call gmaloj ( nhquad//'.Deraffin', ' ', nouvqu, pancqu, codre3 ) + call gmaloj ( nhtetr//'.Deraffin', ' ', nouvte, pancte, codre4 ) + call gmaloj ( nhhexa//'.Deraffin', ' ', nouvhe, panche, codre5 ) + call gmaloj ( nhpent//'.Deraffin', ' ', nouvpe, pancpe, codre6 ) + call gmaloj ( nhpyra//'.Deraffin', ' ', nouvpy, pancpy, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + iaux = nbnoto + 1 + call gmalot ( nnouno, 'entier ', iaux, pnouno, codre1 ) + iaux = nbarto + 1 + call gmalot ( nnouar, 'entier ', iaux, pnouar, codre2 ) + iaux = nbtrto + 1 + call gmalot ( nnoutr, 'entier ', iaux, pnoutr, codre3 ) + iaux = nbquto + 1 + call gmalot ( nnouqu, 'entier ', iaux, pnouqu, codre4 ) + iaux = nbteto+1 + call gmalot ( nnoute, 'entier ', iaux, pnoute, codre5 ) + iaux = nbheto+1 + call gmalot ( nnouhe, 'entier ', iaux, pnouhe, codre6 ) + iaux = nbpeto+1 + call gmalot ( nnoupe, 'entier ', iaux, pnoupe, codre7 ) + iaux = nbpyto+1 + call gmalot ( nnoupy, 'entier ', iaux, pnoupy, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmalot ( ndisno, 'entier ', nouvno, pdisno, codre1 ) + call gmalot ( ndisar, 'entier ', nouvar, pdisar, codre2 ) + call gmalot ( ndistr, 'entier ', nouvtr, pdistr, codre3 ) + call gmalot ( ndisqu, 'entier ', nouvqu, pdisqu, codre4 ) + call gmalot ( ndiste, 'entier ', nouvte, pdiste, codre5 ) + call gmalot ( ndishe, 'entier ', nouvhe, pdishe, codre6 ) + call gmalot ( ndispe, 'entier ', nouvpe, pdispe, codre7 ) + call gmalot ( ndispy, 'entier ', nouvpy, pdispy, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + iaux = max ( nbarto, nbtrto, nbquto, nbteto, nbheto, nbpeto ) + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre1 ) + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. regroupement des entites +c==== +c +c 3.1. ==> initialisation des tableaux de "disparition" +c Par convention, une valeur 0 indique la conservation et +c une autre valeur la disparition de l'entite concernee par la liste +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. Init tableaux disp ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + ideb = pdisno + ifin = pdisno + nouvno - 1 + do 311 , iaux = ideb , ifin + imem(iaux) = 0 + 311 continue +c + ideb = pdisar + ifin = pdisar + nouvar - 1 + do 312 , iaux = ideb , ifin + imem(iaux) = 0 + 312 continue +c + ideb = pdistr + ifin = pdistr + nouvtr - 1 + do 313 , iaux = ideb , ifin + imem(iaux) = 0 + 313 continue +c + ideb = pdisqu + ifin = pdisqu + nouvqu - 1 + do 314 , iaux = ideb , ifin + imem(iaux) = 0 + 314 continue +c + ideb = pdiste + ifin = pdiste + nouvte - 1 + do 315 , iaux = ideb , ifin + imem(iaux) = 0 + 315 continue +c + ideb = pdishe + ifin = pdishe + nouvhe - 1 + do 316 , iaux = ideb , ifin + imem(iaux) = 0 + 316 continue +c + ideb = pdispe + ifin = pdispe + nouvpe - 1 + do 317 , iaux = ideb , ifin + imem(iaux) = 0 + 317 continue +c + ideb = pdispy + ifin = pdispy + nouvpy - 1 + do 318 , iaux = ideb , ifin + imem(iaux) = 0 + 318 continue +c + endif +c +c 3.2. ==> regroupement des tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2 regroupement tetr ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRTE', nompro +#endif +c + call cmdrte ( + > imem(paretr), imem(pdecfa), + > imem(ptrite), imem(phette), + > imem(pfilte), imem(pdisar), imem(pdistr), imem(pdiste), + > imem(pareno), imem(psomar), imem(pcotrt), imem(pdisno), + > imem(pnp2ar), imem(ppertr), codret ) +c + endif +c + endif +c +c 3.3. ==> regroupement des hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3 regroupement hexa ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRHE', nompro +#endif +c + call cmdrhe ( + > imem(parequ), imem(pdecfa), + > imem(pquahe), imem(phethe), + > imem(pfilhe), imem(pdisar), imem(pdisqu), imem(pdishe), + > imem(psomar), imem(pdisno), + > imem(pnp2ar), codret ) +c + endif +c + endif +c +c 3.4. ==> regroupement des pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4 regroupement pent ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRPE', nompro +#endif +c + call cmdrpe ( + > imem(paretr), imem(pdecfa), + > imem(pfacpe), imem(phetpe), + > imem(pfilpe), + > imem(pdisar), imem(pdistr), imem(pdisqu), imem(pdispe), + > imem(pdisno), + > imem(pnp2ar), codret ) +c + endif +c + endif +c +c 3.5. ==> regroupement des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5 regroupement tria ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRTR', nompro +#endif +c + call cmdrtr ( + > imem(paretr), imem(pdecfa), + > imem(phettr), imem(pfiltr), imem(adnmtr), + > imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu), + > imem(pdecar), imem(pfilar), + > imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar), + > imem(phetno), codret ) +c + endif +c + endif +c +c 3.6. ==> regroupement des quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6 regroupement quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRQU', nompro +#endif +c + call cmdrqu ( + > imem(parequ), imem(pdecfa), + > imem(phetqu), imem(pfilqu), imem(adnmqu), + > imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu), + > imem(pdecar), imem(pfilar), + > imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar), + > imem(phetno), codret ) +c + endif +c + endif +c +c 3.7. ==> regroupement des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7 regroupement aret ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDRAR', nompro +#endif +c + call cmdrar ( + > imem(phetar), imem(pfilar), imem(pnp2ar), imem(psomar), + > imem(pdecar), + > imem(pdisar), imem(pdisno), imem(pdistr), imem(pdisqu), + > imem(phetno), imem(pposif), imem(pfacar), codret ) +c + endif +c +c==== +c 4. suppression des entites +c==== +c +c 4.1. ==> suppression des tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. suppression tetr ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUTE', nompro +#endif +c + call utsute ( imem(pdiste), + > imem(phette), imem(pperte), imem(pfilte), + > imem(ptrite), imem(pcotrt), + > imem(pareno), imem(psomar), imem(paretr), + > imem(pancte), imem(pnoute), + > nbtere, + > codret ) +c + indtet = nbtere +c + else +c + indtet = 0 +c + endif +c + endif +c +c 4.2. ==> suppression des hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. suppression hexa ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUHE', nompro +#endif +c + call utsuhe ( imem(pdishe), + > imem(phethe), imem(pperhe), imem(pfilhe), + > imem(panche), imem(pnouhe), + > nbhere ) +c + indhex = nbhere +c + else +c + indhex = 0 +c + endif +c + endif +c +c 4.3. ==> suppression des pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. suppression pent ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUPE', nompro +#endif +c + call utsupe ( imem(pdispe), + > imem(phetpe), imem(pperpe), imem(pfilpe), + > imem(pancpe), imem(pnoupe), + > nbpere ) +c + indpen = nbpere +c + else +c + indpen = 0 +c + endif +c + endif +c +c 4.4. ==> suppression des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. suppression tria ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUTR', nompro +#endif +c + call utsutr ( imem(pdistr), + > imem(phettr), imem(ppertr), imem(pfiltr), + > imem(panctr), imem(pnoutr), + > nbtrre ) +c + indtri = nbtrre +c + else +c + indtri = 0 +c + endif +c + endif +c +c 4.5. ==> suppression des quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.5. suppression quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUQU', nompro +#endif +c + call utsuqu ( imem(pdisqu), + > imem(phetqu), imem(pperqu), imem(pfilqu), + > imem(pancqu), imem(pnouqu), + > nbqure ) +c + indqua = nbqure +c + else +c + indqua = 0 +c + endif +c + endif +c +c 4.6. ==> suppression des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.6. suppression aret ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUAR', nompro +#endif +c + call utsuar ( imem(pdisar), + > imem(phetar), imem(pmerar), imem(pfilar), + > imem(pancar), imem(pnouar), + > nbarre ) +c + indare = nbarre +c + endif +c +c 4.7. ==> suppression des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.7. suppression noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUNO', nompro +#endif +c + call utsuno ( nbnoto, nouvno, imem(pdisno), + > imem(phetno), imem(pancno), imem(pnouno), + > nbnore, nbp2re, nbimre ) +c + indnoe = nbnore + indnp2 = nbp2re + indnim = nbimre +c + endif +c +c==== +c 5. compactage des numerotations +c==== +c +c 5.1. ==> compactage des tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1. compactage tetr ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNTE', nompro +#endif +c + call utcnte ( + > imem(ptrite), imem(pcotrt), imem(phette), imem(pfamte), + > imem(pfilte), imem(pperte), imem(pancte), imem(pnoute), + > imem(pnoutr), nbtere, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c + endif + +c +c 5.2. ==> compactage des hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. compactage hexa ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNHE', nompro +#endif + call utcnhe ( + > imem(pquahe), imem(pcoquh), imem(phethe), imem(pfamhe), + > imem(pfilhe), imem(pperhe), imem(adnmqu), + > imem(panche), imem(pnouhe), + > imem(pnouqu), nbhere, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c + endif +c +c 5.3. ==> compactage des pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.3. compactage pent ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNPE', nompro +#endif + call utcnpe ( + > imem(pfacpe), imem(pcofap), imem(phetpe), imem(pfampe), + > imem(pfilpe), imem(pperpe), imem(pancpe), imem(pnoupe), + > imem(pnoutr), imem(pnouqu), nbpere, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c + endif +c +c 5.4. ==> compactage des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.4. compactage tria ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c + iaux = 1 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*2 + endif + if ( homolo.ge.3 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNTR', nompro +#endif + call utcntr ( iaux, + > imem(phettr), imem(pfamtr), imem(pdecfa), imem(pnivtr), + > imem(pfiltr), imem(ppertr), + > tbiaux, imem(adnmtr), imem(adhotr), + > tbiaux, tbiaux, + > imem(panctr), imem(pnoutr), imem(pnouar), imem(paretr), + > nbtrre, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c + endif +c +c 5.5. ==> compactage des quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.5. compactage quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c + iaux = 1 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*3 + endif + if ( homolo.ge.3 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNQU', nompro +#endif + call utcnqu ( iaux, + > imem(phetqu), imem(pfamqu), imem(pdecfa), imem(pnivqu), + > imem(pfilqu), imem(pperqu), + > tbiaux, imem(adnmqu), + > tbiaux, tbiaux, + > imem(pancqu), imem(pnouqu), imem(pnouar), imem(parequ), + > nbqure, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c + endif +c +c 5.6. ==> compactage des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.6. compactage aret ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNAR', nompro +#endif + call utcnar ( + > imem(psomar), imem(phetar), imem(pfamar), imem(pdecar), + > imem(pfilar), imem(pmerar), imem(adhoar), imem(pnp2ar), + > imem(paretr), imem(parequ), + > imem(pposif), imem(pfacar), + > imem(pancar), imem(pnouar), imem(pnouno), + > nbtrre, nbqure, nbarre, + > imem(ptrav3), imem(ptrav4) ) +c + endif +c +c 5.7. ==> compactage des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.7. compactage noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*2 + endif + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*3 + endif + if ( homolo.ge.1 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNNO', nompro +#endif + call utcnno ( iaux, + > rmem(pcoono), + > imem(phetno), imem(pfamno), imem(pareno), imem(adhono), + > tbiaux, tbiaux, + > imem(adnmtr), + > imem(adnmqu), + > imem(pnouar), imem(pnouno), nbnoto ) +c +c + endif +c +c==== +c 6. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( nnouno, codre1 ) + call gmlboj ( nnouar, codre2 ) + call gmlboj ( nnoutr, codre3 ) + call gmlboj ( nnouqu, codre4 ) + call gmlboj ( nnoute, codre5 ) + call gmlboj ( nnouhe, codre6 ) + call gmlboj ( nnoupe, codre7 ) + call gmlboj ( nnoupy, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmlboj ( ndisno, codre1 ) + call gmlboj ( ndisar, codre2 ) + call gmlboj ( ndistr, codre3 ) + call gmlboj ( ndisqu, codre4 ) + call gmlboj ( ndiste, codre5 ) + call gmlboj ( ndishe, codre6 ) + call gmlboj ( ndispe, codre7 ) + call gmlboj ( ndispy, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmlboj ( ntrav3, codre1 ) + call gmlboj ( ntrav4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmdrar.F b/src/tool/Creation_Maillage/cmdrar.F new file mode 100644 index 00000000..3e922e1c --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrar.F @@ -0,0 +1,209 @@ + subroutine cmdrar ( hetare, filare, np2are, somare, + > decare, + > disare, disnoe, distri, disqua, + > hetnoe, posifa, facare, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des ARetes +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nouvar . historique de l'etat des aretes . +c . filare . e . nouvar . premiere fille des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . decare . e .0:nbarto. table des decisions sur les aretes . +c . disare . e . nouvar . indicateurs de disparition des aretes . +c . disnoe . e . nouvno . indicateurs de disparition des noeuds . +c . distri . e . nouvtr . indicateurs de disparition des triangles . +c . disqua . e . nouvqu . indicateurs de disparition des quadrangles . +c . hetnoe . e/s . nouvno . historique de l'etat des noeuds . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . codret . s . 1 . code de retour, 0 si ok, (no arete) si pb . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMRDAR' ) +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombar.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "distet" et "distri" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer hetare(nouvar), filare(nouvar), np2are(nouvar) + integer somare(2,nouvar), decare(0:nbarto), disare(nouvar) + integer disnoe(nouvno), hetnoe(nouvno), codret + integer distri(nouvtr), disqua(nouvqu) + integer posifa(0:nbarto), facare(nbfaar) +c +c 0.4. ==> variables locales +c + integer larete, lafill, noemil, noefil + integer ideb, ifin, facvoi, nbdisp + integer iaux +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. traitement des aretes +c==== +c + do 100 , larete = 1 , nbarpe +c +c 1.1 dans le cas ou l'arete est mere d'active +c + if ( mod( hetare(larete) , 10 ) .eq. 2 ) then +c +c 1.1.1 dans le cas ou l'arete est marquee "a reactiver" +c + if ( decare(larete) .eq. -1 ) then +c +c on verifie que les faces voisines des aretes filles de +c l'arete consideree sont toutes marquees a disparaitre. +c pour cela, on comptabilise (en negatif) le nombre de faces +c voisines des aretes fille marquees a disparaitre. si le +c total est nul, c'est que toutes les faces doivent bien +c disparaitre. dans ce cas, et dans ce cas seulement, +c on pourra marquer les aretes filles comme etant a +c disparaitre. +c +c test des faces voisines de la premiere arete fille +c + lafill = filare(larete) + ideb = posifa(lafill - 1) + 1 + ifin = posifa(lafill) +c + nbdisp = ifin - ideb + 1 + do 210 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 210 continue +c +c test des faces voisines de la seconde arete fille +c + lafill = filare(larete) + 1 + ideb = posifa(lafill - 1) + 1 + ifin = posifa(lafill) +c + nbdisp = ifin - ideb + 1 + nbdisp + do 212 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 212 continue +c +c verification du nombre de faces marquees a disparaitre +c (il ne doit pas en rester, qui ne soit pas marquees a +c disparaitre, pour pouvoir eliminer les aretes filles) +c + if ( nbdisp .eq. 0 ) then +c +c 1.1.1.1 marquage de ses deux aretes filles "a disparaitre" +c + lafill = filare(larete) + disare( lafill ) = 1 + disare( lafill + 1 ) = 1 +c +c 1.1.1.2 marquage des noeuds milieux "a disparaitre" +c + noemil = 0 + noefil = somare(1,lafill) + if ( ( noefil .eq. somare(1,lafill+1) ).or. + > ( noefil .eq. somare(2,lafill+1) ) ) then + noemil = noefil + endif + noefil = somare(2,lafill) + if ( ( noefil .eq. somare(1,lafill+1) ).or. + > ( noefil .eq. somare(2,lafill+1) ) ) then + noemil = noefil + endif +c + if ( noemil .eq. 0 ) then + codret = larete + endif +c + if ( degre .eq. 2 ) then +c + disnoe(np2are(lafill)) = 1 + disnoe(np2are(lafill + 1)) = 1 +c +c modification de l'etat du noeud p1 milieu en p2 : +c . son etat anterieur, la dizaine, est conserve +c . son etat courant passe de 1, P1, a 2, P2 +c + iaux = hetnoe(noemil) - mod(hetnoe(noemil),10) + hetnoe(noemil) = iaux + 2 +c + if ( noemil .ne. np2are(larete) ) then + codret = larete + endif +c + else +c + disnoe(noemil) = 1 +c + endif +c + endif +c + endif +c + endif +c + 100 continue +c + end diff --git a/src/tool/Creation_Maillage/cmdrhe.F b/src/tool/Creation_Maillage/cmdrhe.F new file mode 100644 index 00000000..512730b2 --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrhe.F @@ -0,0 +1,231 @@ + subroutine cmdrhe ( arequa, decfac, quahex, hethex, + > filhex, disare, disqua, dishex, + > somare, disnoe, + > np2are, + > codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des Hexaedres +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nouvhe . historique de l'etat des hexaedres . +c . filhex . e . nouvhe . premier fils des hexaedres . +c . disare . s . nouvar . indicateurs de disparition des aretes . +c . disqua . s . nouvqu . indicateurs de disparition des quadrangles . +c . dishex . s . nouvhe . indicateurs de disparition des hexaedres . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . disnoe . s . nouvno . indicateurs de disparition des noeuds . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'CMDRHE' ) +#endif +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "dishex" et "disqua" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer decfac(-nbquto:nbtrto) + integer arequa(nouvqu,4) + integer quahex(nouvhf,6) + integer hethex(nouvhe), filhex(nouvhe), disare(nouvar) + integer disqua(nouvqu), dishex(nouvhe), disnoe(nouvno) + integer somare(2,nouvar) + integer np2are(nouvar) +c + integer codret +c +c 0.4. ==> variables locales +c + integer pf1n5, pf1n6, pf1n7, pf1n8 + integer pf2n2, pf2n3, pf2n10, pf2n11 + integer pf3n1, pf3n4, pf3n9, pf3n12 + integer nf1n0,nf2n0,nf3n0,nf4n0,nf5n0,nf6n0 +c + integer lehexa, lefils, leprem + integer etahex, dt, d1, d2, d3, d4, d5, d6 +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. traitement des hexaedres +c==== +c + do 100 , lehexa = 1 , nbhepe +c + etahex = mod(hethex(lehexa),1000) +c + if ( etahex.eq.8 ) then +c +c 1.1. ==> verification de l'etat des 6 faces de l'hexaedre +c attention, cette methode pour verifier l'etat n'est valable +c que si la seule solution pour obtenir "-6" a partir des +c decisions sur les faces est d'avoir 6 fois "-1", +c et idem pour "-5", "-4" ou "-3". +c + d1 = decfac(-quahex(lehexa,1)) + d2 = decfac(-quahex(lehexa,2)) + d3 = decfac(-quahex(lehexa,3)) + d4 = decfac(-quahex(lehexa,4)) + d5 = decfac(-quahex(lehexa,5)) + d6 = decfac(-quahex(lehexa,6)) + dt = d1 + d2 + d3 + d4 + d5 + d6 +c +c 1.2. ==> cas ou les 6 faces du hexaedre sont a reactiver +c + if ( dt.le.-3 ) then +c +c 1.2.1. ==> marquage de ses huit hexaedres fils "a disparaitre" +c + leprem = filhex(lehexa) +c + do 210 , lefils = leprem , leprem + 7 +c + dishex(lefils) = 1 +c + 210 continue +c +c 1.2.2. ==> marquage de ses douze faces internes "a disparaitre" +c + lefils = leprem + pf1n5=quahex(lefils,6) + disqua(pf1n5)=1 + pf2n2=quahex(lefils,5) + disqua(pf2n2)=1 + pf3n1=quahex(lefils,4) + disqua(pf3n1)=1 +c + lefils=lefils+1 + pf2n3=quahex(lefils,5) + disqua(pf2n3)=1 + pf1n6=quahex(lefils,6) + disqua(pf1n6)=1 +c + lefils=lefils+1 + pf3n4=quahex(lefils,3) + disqua(pf3n4)=1 + pf1n8=quahex(lefils,6) + disqua(pf1n8)=1 +c + lefils=lefils+1 + pf1n7=quahex(lefils,6) + disqua(pf1n7)=1 +c + lefils=lefils+1 + pf3n9=quahex(lefils,3) + disqua(pf3n9)=1 + pf2n11=quahex(lefils,5) + disqua(pf2n11)=1 +c + lefils=lefils+1 + pf2n10=quahex(lefils,5) + disqua(pf2n10)=1 +c + lefils=lefils+1 + pf3n12=quahex(lefils,4) + disqua(pf3n12)=1 +c +c 1.2.3. ==> recherche des aretes internes "a disparaitre" +c + nf1n0=arequa(pf2n2,2) + disare(nf1n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf1n0)) = 1 + endif +c + nf2n0=arequa(pf1n6,2) + disare(nf2n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf2n0)) = 1 + endif +c + nf3n0=arequa(pf1n5,2) + disare(nf3n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf3n0)) = 1 + endif +c + nf4n0=arequa(pf1n8,2) + disare(nf4n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf4n0)) = 1 + endif +c + nf5n0=arequa(pf1n7,2) + disare(nf5n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf5n0)) = 1 + endif +c + nf6n0=arequa(pf3n9,2) + disare(nf6n0)=1 + if ( degre.eq.2 ) then + disnoe(np2are(nf6n0)) = 1 + endif +c +c 1.2.4. ==> recherche du point central +c + disnoe(somare(2,nf1n0)) = 1 +c + endif +c + endif +c + 100 continue +c + end diff --git a/src/tool/Creation_Maillage/cmdrpe.F b/src/tool/Creation_Maillage/cmdrpe.F new file mode 100644 index 00000000..de71b4e9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrpe.F @@ -0,0 +1,201 @@ + subroutine cmdrpe ( aretri, decfac, + > facpen, hetpen, + > filpen, + > disare, distri, disqua, dispen, + > disnoe, + > np2are, + > codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des Pentaedres +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . hetpen . e . nouvpe . historique de l'etat des pentaedres . +c . filpen . e . nouvpe . premier fils des pentaedres . +c . disare . s . nouvar . indicateurs de disparition des aretes . +c . distri . s . nouvtr . indicateurs de disparition des triangles . +c . disqua . s . nouvqu . indicateurs de disparition des quadrangles . +c . dispen . s . nouvpe . indicateurs de disparition des pentaedres . +c . disnoe . s . nouvno . indicateurs de disparition des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMDRPE' ) +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "dispen" et "disqua" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer decfac(-nbquto:nbtrto) + integer aretri(nouvtr,3) + integer facpen(nouvpe,5) + integer hetpen(nouvpe), filpen(nouvpe), disare(nouvar) + integer distri(nouvtr), disqua(nouvqu) + integer dispen(nouvpe), disnoe(nouvno) + integer np2are(nouvar) +c + integer codret +c +c 0.4. ==> variables locales +c + integer nf3nf4, nf4nf5, nf5nf3 + integer pf3f1, pf3f2, pf4f1, pf4f2, pf5f1, pf5f2 + integer pf1, pf1n7, pf1n8, pf1n9 +c + integer lepent, lefils, leprem + integer etapen, dt, d1, d2, d3, d4, d5 +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. traitement des pentaedres +c==== +c + do 100 , lepent = 1 , nbpepe +c + etapen = mod(hetpen(lepent),100) +c + if ( etapen.eq.80 ) then +c +c Le pentaedre est coupe en 8. +c Il est a reactiver dans 2 cas : +c . ses 5 faces sont a reactiver : decision -1 pour chacune +c . 4 faces sont a reactiver : decision -1 pour chacune +c la derniere reste coupee : decision 0 +c donc des que la somme des decisions est <= -4 +c + d1 = decfac(facpen(lepent,1)) + d2 = decfac(facpen(lepent,2)) + d3 = decfac(-facpen(lepent,3)) + d4 = decfac(-facpen(lepent,4)) + d5 = decfac(-facpen(lepent,5)) + dt = d1 + d2 + d3 + d4 + d5 +cgn print *,'pour penta ',lepent,', dt = ',dt +c + if ( dt.le.-4 ) then +c +c 1.2.1. ==> marquage de ses huit pentaedres fils "a disparaitre" +c + leprem = filpen(lepent) +c + do 210 , lefils = leprem , leprem + 7 +c + dispen(lefils) = 1 +c + 210 continue +c +c 1.2.2. ==> marquage de ses six quadrangles internes "a disparaitre" +c + lefils = leprem + 6 + pf3f1 = facpen(lefils,3) + disqua(pf3f1) = 1 + pf4f1 = facpen(lefils,4) + disqua(pf4f1) = 1 + pf5f1 = facpen(lefils,5) + disqua(pf5f1) = 1 +c + lefils = lefils + 1 + pf3f2 = facpen(lefils,3) + disqua(pf3f2) = 1 + pf4f2 = facpen(lefils,4) + disqua(pf4f2) = 1 + pf5f2 = facpen(lefils,5) + disqua(pf5f2) = 1 +c +c 1.2.3. ==> marquage de ses quatre triangles internes "a disparaitre" +c + lefils = leprem + pf1n7 = facpen(lefils,2) + distri(pf1n7) = 1 +c + lefils = leprem + 1 + pf1n8 = facpen(lefils,2) + distri(pf1n8) = 1 +c + lefils = leprem + 2 + pf1n9 = facpen(lefils,2) + distri(pf1n9) = 1 +c + lefils = leprem + 6 + pf1 = facpen(lefils,2) + distri(pf1) = 1 +c +c 1.2.4. ==> marquage des trois des aretes internes "a disparaitre" +c + nf3nf4 = aretri(pf1,1) + disare(nf3nf4) = 1 + if ( degre.eq.2 ) then + disnoe(np2are(nf3nf4)) = 1 + endif +c + nf4nf5 = aretri(pf1,2) + disare(nf4nf5) = 1 + if ( degre.eq.2 ) then + disnoe(np2are(nf4nf5)) = 1 + endif +c + nf5nf3 = aretri(pf1,3) + disare(nf5nf3) = 1 + if ( degre.eq.2 ) then + disnoe(np2are(nf5nf3)) = 1 + endif +c + endif +c + endif +c + 100 continue +c + end diff --git a/src/tool/Creation_Maillage/cmdrqu.F b/src/tool/Creation_Maillage/cmdrqu.F new file mode 100644 index 00000000..1a5f364b --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrqu.F @@ -0,0 +1,311 @@ + subroutine cmdrqu ( arequa, decfac, hetqua, filqua, ninqua, + > disnoe, disare, distri, disqua, + > decare, filare, + > np2are, posifa, facare, somare, + > hetnoe, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des QUadrangles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . disnoe . s . nouvno . indicateurs de disparition des noeuds . +c . disare . s . nouvar . indicateurs de disparition des aretes . +c . distri . s . nouvtr . indicateurs de disparition des triangles . +c . disqua . s . nouvqu . indicateurs de disparition des quadrangles . +c . decare . e .0:nbarto. table des decisions sur les aretes . +c . filare . e . nouvar . premiere fille des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . hetnoe . e/s . nouvno . historique de l'etat des noeuds . +c . codret . s . 1 . code de retour, 0 si ok . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'CMDRQU' ) +#endif +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombar.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "distri" et "disqua" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer decfac(-nbquto:nbtrto) + integer arequa(nouvqu,4), hetqua(nouvqu) + integer filqua(nouvqu), ninqua(nbquto) + integer disnoe(nouvno), disare(nouvar) + integer distri(nouvtr), disqua(nouvqu) + integer decare(0:nbarto), filare(nouvar), np2are(nouvar) + integer posifa(0:nbarto), facare(nbfaar) + integer somare(2,nouvar), hetnoe(nouvno), codret +c +c 0.4. ==> variables locales +c + integer lequad, lefils, fafils, numare + integer larete, lenoeu, noemil, noefil + integer ideb, ifin, facvoi, nbdisp +c + logical noinma +c +c 0.5. ==> initialisations +c + codret = 0 +c +#include "impr03.h" +c ______________________________________________________________________ +c +#ifdef _DEBUG_HOMARD_ + write (1,*) 'entree de ',nompro + do 1105 , lequad = 1 , nouvqu + if ( lequad.eq.1094 .or. + >(lequad.ge.3341 .and. lequad.le.3344)) then + write (1,90001) 'quadrangle', lequad, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4) + write (1,90001) 'quadrangle', lequad, + > decare(arequa(lequad,1)), decare(arequa(lequad,2)), + > decare(arequa(lequad,3)), decare(arequa(lequad,4)) + write (1,90112) 'decfac', lequad,decfac(-lequad) + endif + 1105 continue +#endif +c +c==== +c 1. traitement des faces +c==== +c + if ( mod(mailet,3).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + do 100 , lequad = 1 , nbqupe +c +c 1.1. ==> dans le cas ou le quadrangle est pere d'actif +c + if ( mod( hetqua(lequad) , 100 ).eq.4 ) then +c +c 1.1.1. ==> dans le cas ou le quadrangle est marque "a reactiver" +c + if ( decfac(-lequad).eq.-1 ) then +c +c 1.1.1.1. ==> marquage de ses quatre quadrangles fils "a disparaitre" +c + lefils = filqua(lequad) +c + do 200 , fafils = lefils , lefils + 3 +c + disqua(fafils) = 1 +c + 200 continue +c +c 1.1.1.2. ==> marquage des filles de ses quatre aretes "a disparaitre" +c a condition que l'arete reapparaisse. +c + do 220 , numare = 1 , 4 +c + larete = arequa(lequad,numare) +c + if ( decare(larete).eq.-1 ) then +c +c on verifie que les faces voisines des aretes filles de +c l'arete consideree sont toutes marquees a disparaitre. +c pour cela, on comptabilise (en negatif) le nombre de faces +c voisines des aretes fille marquees a disparaitre. si le +c total est nul, c'est que toutes les faces doivent bien +c disparaitre. dans ce cas, et dans ce cas seulement, +c on pourra marquer les aretes filles comme etant a +c disparaitre. +c +c test des faces voisines de la premiere arete fille +c + lefils = filare(larete) + ideb = posifa(lefils - 1) + 1 + ifin = posifa(lefils) +c + nbdisp = ifin - ideb + 1 + do 210 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 210 continue +c +c test des faces voisines de la seconde arete fille +c + lefils = filare(larete) + 1 + ideb = posifa(lefils - 1) + 1 + ifin = posifa(lefils) +c + nbdisp = ifin - ideb + 1 + nbdisp + do 212 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 212 continue +c +c verification du nombre de quadrangles marques a +c disparaitre +c (il ne doit pas en rester, qui ne soit pas marques a +c disparaitre, pour pouvoir eliminer les aretes filles) +c + if ( nbdisp.eq.0 ) then +c + lefils = filare(larete) + disare( lefils ) = 1 + disare( lefils + 1 ) = 1 +c + noemil = 0 + noefil = somare(1,lefils) + if ( ( noefil.eq.somare(1,lefils+1) ).or. + > ( noefil.eq.somare(2,lefils+1) ) ) then + noemil = noefil + endif + noefil = somare(2,lefils) + if ( ( noefil.eq.somare(1,lefils+1) ).or. + > ( noefil.eq.somare(2,lefils+1) ) ) then + noemil = noefil + endif + if ( noemil.eq.0 ) then + codret = larete + endif +c + if ( degre.eq.2 ) then +c + if ( noemil.ne.np2are(larete) ) then + codret = larete + endif +c + disnoe(np2are(lefils)) = 1 + disnoe(np2are(lefils + 1)) = 1 +c +c modification de l'etat du noeud p1 milieu en p2 : +c . son etat anterieur, la dizaine, est conserve +c . son etat courant passe a 2, P2 + hetnoe(noemil) = hetnoe(noemil) + > - mod(hetnoe(noemil),10) + > + 2 +c + else +c + disnoe(noemil) = 1 +c + endif +c + endif +c + endif +c + 220 continue +c +c 1.1.1.3. ==> marquage des quatre aretes internes +c les quatre eventuels noeuds p2 sont aussi marques +c +c remarque : ses quatre aretes internes sont les deuxiemes +c dans la definition des faces filles +c + lefils = filqua(lequad) +c + do 240 , fafils = lefils , lefils + 3 +c + larete = arequa(fafils,2) +cgn print 1789,larete, somare(1,larete), somare(2,larete) +cgn 1789 format('Arete ',i10,' de',i10,' a',i10) +c + disare(larete) = 1 +c + if ( degre.eq.2 ) then + lenoeu = np2are(larete) + disnoe(lenoeu) = 1 + endif +c + 240 continue +c +c 1.1.1.4. ==> marquage des eventuels noeuds internes "a disparaitre" +c ce sont ceux des fils +c remarque : le noeud central est le second de chacune de ces +c aretes internes +c il ne disparait que si on n'est pas en quad9 +c + if ( noinma ) then +c + do 241 , fafils = lefils , lefils + 3 +c + lenoeu = ninqua(fafils) + disnoe(lenoeu) = 1 +c + 241 continue +c + else +c + disnoe(somare(2,arequa(lefils,2))) = 1 +c + endif +c + endif +c + endif +c + 100 continue +c + end diff --git a/src/tool/Creation_Maillage/cmdrte.F b/src/tool/Creation_Maillage/cmdrte.F new file mode 100644 index 00000000..b9843b44 --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrte.F @@ -0,0 +1,179 @@ + subroutine cmdrte ( aretri, decfac, tritet, hettet, + > filtet, disare, distri, distet, + > arenoe, somare, cotrte, disnoe, + > np2are, pertri, + > codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des TEtraedres +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . tritet . e .nouvtf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nouvte . historique de l'etat des tetraedres . +c . filtet . e . nouvte . premier fils des tetraedres . +c . disare . s . nouvar . indicateurs de disparition des aretes . +c . distri . s . nouvtr . indicateurs de disparition des triangles . +c . distet . s . nouvte . indicateurs de disparition des tetraedres . +c . arenoe . e . nouvno . arete liee a un nouveau noeud . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . disnoe . s . nouvno . indicateurs de disparition des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . pertri . e . nouvtr . pere des triangles . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMDRTE' ) +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "distet" et "distri" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer decfac(-nbquto:nbtrto) + integer aretri(nouvtr,3) + integer tritet(nouvtf,4) + integer hettet(nouvte), filtet(nouvte), disare(nouvar) + integer distri(nouvtr), distet(nouvte), disnoe(nouvno) + integer arenoe(nouvno), somare(2,nouvar), cotrte(nouvtf,4) + integer np2are(nouvar), pertri(nouvtr) +c + integer codret +c +c 0.4. ==> variables locales +c + integer letria, letetr, lefils, leprem + integer etatet, dt, ardiag, d1, d2, d3, d4, decoup + integer numfac +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. traitement des tetraedres +c==== +c + do 100 , letetr = 1 , nbtepe +c + etatet = mod(hettet(letetr),100) + etatet = ( etatet - mod(etatet,10) ) / 10 +c + if ( etatet.eq.8 ) then +c +c Le tetraedre est coupe en 8. +c Il est a reactiver dans 2 cas : +c . ses 4 faces sont a reactiver : decision -1 pour chacune +c . 3 faces sont a reactiver : decision -1 pour chacune +c la derniere reste coupee : decision 0 +c donc des que la somme des decisions est <= -3 +c + d1 = decfac(tritet(letetr,1)) + d2 = decfac(tritet(letetr,2)) + d3 = decfac(tritet(letetr,3)) + d4 = decfac(tritet(letetr,4)) + dt = d1 + d2 + d3 + d4 +c + if ( dt.le.-3 ) then +c +c 1.2.1 marquage de ses huit tetraedres fils "a disparaitre" +c + leprem = filtet(letetr) +c + do 210 , lefils = leprem , leprem + 7 +c + distet(lefils) = 1 +c + 210 continue +c +c 1.2.2 marquage de ses huit faces internes "a disparaitre" +c ce sont les faces sans mere des 4 tetraedres internes +c + leprem = filtet(letetr) + 4 +c + do 220 , lefils = leprem , leprem + 3 + do 222 , numfac = 1 , 4 +c + letria = tritet(lefils,numfac) + if ( pertri(letria).eq.0 ) then + distri(letria) = 1 + endif +c + 222 continue + 220 continue +c +c 1.2.3 recherche de l'arete diagonale interne +c + call utdiag (letetr, + > filtet, tritet, aretri, + > arenoe, somare, cotrte, + > ardiag, decoup, codret ) +c + if (codret .ne. 0) then + goto 120 + endif +c +c 1.2.3.3 marquage de l'arete diagonale commune "a disparaitre" +c + disare(ardiag) = 1 +c + if ( degre.eq.2 ) then + disnoe(np2are(ardiag)) = 1 + endif +c + endif +c + endif +c + 100 continue +c + 120 continue +c + end diff --git a/src/tool/Creation_Maillage/cmdrtr.F b/src/tool/Creation_Maillage/cmdrtr.F new file mode 100644 index 00000000..7b606aa9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmdrtr.F @@ -0,0 +1,283 @@ + subroutine cmdrtr ( aretri, decfac, hettri, filtri, nintri, + > disnoe, disare, distri, disqua, + > decare, filare, + > np2are, posifa, facare, somare, + > hetnoe, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Deraffinement - Regroupement des TRiangles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hettri . e . nouvtr . historique de l'etat des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . disnoe . s . nouvno . indicateurs de disparition des noeuds . +c . disare . s . nouvar . indicateurs de disparition des aretes . +c . distri . s . nouvtr . indicateurs de disparition des triangles . +c . disqua . s . nouvqu . indicateurs de disparition des quadrangles . +c . decare . e .0:nbarto. table des decisions sur les aretes . +c . filare . e . nouvar . premiere fille des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . hetnoe . e/s . nouvno . historique de l'etat des noeuds . +c . codret . s . 1 . code de retour, 0 si ok . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'CMDRTR' ) +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombar.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c +c remarque : "disnoe", "disare", "distri" et "disqua" sont des +c tableaux temporaires destines a la suppression ulterieure des +c entites. par convention, une valeur 0 indique la conservation et +c une valeur 1 la disparition de l'entite concernee par la liste. +c + integer decfac(-nbquto:nbtrto) + integer aretri(nouvtr,3), hettri(nouvtr) + integer filtri(nouvtr), nintri(nbtrto) + integer disnoe(nouvno), disare(nouvar) + integer distri(nouvtr), disqua(nouvqu) + integer decare(0:nbarto), filare(nouvar), np2are(nouvar) + integer posifa(0:nbarto), facare(nbfaar) + integer somare(2,nouvar), hetnoe(nouvno) + integer codret +c +c 0.4. ==> variables locales +c + integer letria, lefils, fafils + integer larete, lenoeu, noemil, noefil + integer ideb, ifin, facvoi, nbdisp + integer iaux +c + logical noinma +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. traitement des faces +c==== +c + if ( mod(mailet,2).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + do 100 , letria = 1 , nbtrpe +c +c 1.1. ==> dans le cas ou le triangle est pere d'actif +c + if ( mod( hettri(letria) , 10 ).eq.4 ) then +c +c 1.1.1. ==> dans le cas ou le triangle est marque "a reactiver" +c + if ( decfac(letria).eq.-1 ) then +c +c 1.1.1.1. ==> marquage de ses quatre triangles fils "a disparaitre" +c + lefils = filtri(letria) +c + do 200 , fafils = lefils , lefils + 3 +c + distri(fafils) = 1 +c + 200 continue +c +c 1.1.1.2. ==> marquage des filles de ses trois aretes "a disparaitre" +c a condition que l'arete reapparaisse. +c + do 220 , iaux = 1 , 3 +c + larete = aretri(letria,iaux) +c + if ( decare(larete).eq.-1 ) then +c +c on verifie que les faces voisines des aretes filles de +c l'arete consideree sont toutes marquees a disparaitre. +c pour cela, on comptabilise (en negatif) le nombre de faces +c voisines des aretes fille marquees a disparaitre. si le +c total est nul, c'est que toutes les faces doivent bien +c disparaitre. dans ce cas, et dans ce cas seulement, +c on pourra marquer les aretes filles comme etant a +c disparaitre. +c +c test des faces voisines de la premiere arete fille +c + lefils = filare(larete) + ideb = posifa(lefils - 1) + 1 + ifin = posifa(lefils) +c + nbdisp = ifin - ideb + 1 + do 210 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 210 continue +c +c test des faces voisines de la seconde arete fille +c + lefils = filare(larete) + 1 + ideb = posifa(lefils - 1) + 1 + ifin = posifa(lefils) +c + nbdisp = ifin - ideb + 1 + nbdisp + do 212 , facvoi = ideb , ifin + if ( facare(facvoi).gt.0 ) then + if (distri(facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + else + if (disqua(-facare(facvoi)).eq.1) then + nbdisp = nbdisp - 1 + endif + endif + 212 continue +c +c verification du nombre de triangles marques a disparaitre +c (il ne doit pas en rester, qui ne soit pas marques a +c disparaitre, pour pouvoir eliminer les aretes filles) +c + if ( nbdisp.eq.0 ) then +c + lefils = filare(larete) + disare( lefils ) = 1 + disare( lefils + 1 ) = 1 +c + noemil = 0 + noefil = somare(1,lefils) + if ( ( noefil.eq.somare(1,lefils+1) ).or. + > ( noefil.eq.somare(2,lefils+1) ) ) then + noemil = noefil + endif + noefil = somare(2,lefils) + if ( ( noefil.eq.somare(1,lefils+1) ).or. + > ( noefil.eq.somare(2,lefils+1) ) ) then + noemil = noefil + endif + if ( noemil.eq.0 ) then + codret = larete + endif +c + if ( degre.eq.2 ) then +c + if ( noemil .ne. np2are(larete) ) then + codret = larete + endif +c + disnoe(np2are(lefils)) = 1 + disnoe(np2are(lefils + 1)) = 1 +c +c modification de l'etat du noeud p1 milieu en p2 : +c . son etat anterieur, la dizaine, est conserve +c . son etat courant passe a 2, P2 + hetnoe(noemil) = hetnoe(noemil) + > - mod(hetnoe(noemil),10) + > + 2 +c + else +c + disnoe(noemil) = 1 +c + endif +c + endif +c + endif +c + 220 continue +c +c 1.1.1.3. ==> marquage de ses trois aretes internes "a disparaitre" +c et des trois eventuels noeuds p2 +c +c remarque : ses trois aretes internes sont celles du triangle +c fils central, range le premier +c + lefils = filtri(letria) +c + do 240 , iaux = 1 , 3 +c + larete = aretri(lefils,iaux) +c + disare(larete) = 1 +c + if ( degre.eq.2 ) then + lenoeu = np2are(larete) + disnoe(lenoeu) = 1 + endif +c + 240 continue +c +c 1.1.1.4. ==> marquage des eventuels noeuds internes "a disparaitre" +c ce sont ceux des trois fils peripheriques +c + if ( noinma ) then +c + do 241 , iaux = 1 , 3 +c + lenoeu = nintri(lefils+iaux) + disnoe(lenoeu) = 1 +c + 241 continue +c + endif +c + endif +c + endif +c + 100 continue +c + end diff --git a/src/tool/Creation_Maillage/cmh100.F b/src/tool/Creation_Maillage/cmh100.F new file mode 100644 index 00000000..bd3962f6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh100.F @@ -0,0 +1,346 @@ + subroutine cmh100 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro ='CMH100' ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(9), areint(9) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + + integer as1n1, as2n1 + integer as3n1, as4n1 + integer as5n1, as6n1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . du noeud milieu de l'arete coupee +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , 9 + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Recuperation des aretes tracees sur les faces coupees en 3 +c==== +c + fdnume = listfa(1) + jaux = -filqua(fdnume) + if ( listcf(1).lt.5 ) then + as4n1 = aretri(jaux,1) + as3n1 = aretri(jaux,3) + as1n1 = aretri(jaux+1,1) + as2n1 = aretri(jaux+2,1) + else + as4n1 = aretri(jaux,3) + as3n1 = aretri(jaux,1) + as1n1 = aretri(jaux+2,1) + as2n1 = aretri(jaux+1,1) + endif +c + fdnume = listfa(2) + jaux = -filqua(fdnume) + if ( listcf(2).lt.5 ) then + as6n1 = aretri(jaux,3) + as5n1 = aretri(jaux,1) + else + as6n1 = aretri(jaux,1) + as5n1 = aretri(jaux,3) + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'as1n1, as2n1', as1n1, as2n1 + write(ulsort,90002) 'as3n1, as4n1', as3n1, as4n1 + write(ulsort,90002) 'as5n1, as6n1', as5n1, as6n1 +#endif +c +c==== +c 4. Creation des deux aretes internes +c areint(1) : AS7N1 +c areint(2) : AS8N1 +c==== +c + do 41 , iaux = 1 , 2 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( lesnoe(9) , lesnoe(6+iaux) ) + somare(2,areint(iaux)) = max ( lesnoe(9) , lesnoe(6+iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 41 continue +c +c==== +c 5. Creation des 4 pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 5.1. ==> Sur la face 3 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as4n1, as1n1, as6n1, areint(1), + > listar(2), listar(5), listar(10), listar(7), + > iaux, jaux, indpyr ) +c +c 5.2. ==> Sur la face 4 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as2n1, as3n1, areint(2), as5n1, + > listar(3), listar(8), listar(11), listar(6), + > iaux, jaux, indpyr ) +c +c 5.3. ==> Sur la face 5 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as3n1, as4n1, areint(1), areint(2), + > listar(4), listar(7), listar(12), listar(8), + > iaux, jaux, indpyr ) +c +c 5.4. ==> Sur la face 6 +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > as6n1, as5n1, areint(2), areint(1), + > listar(9), listar(11), listar(12), listar(10), + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh200.F b/src/tool/Creation_Maillage/cmh200.F new file mode 100644 index 00000000..84b64679 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh200.F @@ -0,0 +1,380 @@ + subroutine cmh200 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH200' ) + parameter ( nbarin = 10 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 2 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(7))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des deux pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(9) + fdnume = listfa(1) + fdcode = listcf(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 1', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh201.F b/src/tool/Creation_Maillage/cmh201.F new file mode 100644 index 00000000..1d8667c7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh201.F @@ -0,0 +1,380 @@ + subroutine cmh201 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH201' ) + parameter ( nbarin = 10 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 2 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(8))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des deux pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(9) + fdnume = listfa(1) + fdcode = listcf(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 1', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + are1 = areint(4) + are2 = areint(1) + are3 = areint(6) + are4 = areint(7) + are5 = listar(2) + are6 = listar(5) + are7 = listar(10) + are8 = listar(7) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh202.F b/src/tool/Creation_Maillage/cmh202.F new file mode 100644 index 00000000..5b8bcb3b --- /dev/null +++ b/src/tool/Creation_Maillage/cmh202.F @@ -0,0 +1,380 @@ + subroutine cmh202 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH202' ) + parameter ( nbarin = 10 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 2 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(12))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des deux pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(9) + fdnume = listfa(1) + fdcode = listcf(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 1', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + are1 = areint(4) + are2 = areint(1) + are3 = areint(6) + are4 = areint(7) + are5 = listar(2) + are6 = listar(5) + are7 = listar(10) + are8 = listar(7) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(10) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh203.F b/src/tool/Creation_Maillage/cmh203.F new file mode 100644 index 00000000..92470b46 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh203.F @@ -0,0 +1,384 @@ + subroutine cmh203 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH203' ) + parameter ( nbarin = 11 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 2 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) +c + iaux = filqua(listfa(1)) + lesnoe(11) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(11) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh204.F b/src/tool/Creation_Maillage/cmh204.F new file mode 100644 index 00000000..ce2a9d43 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh204.F @@ -0,0 +1,388 @@ + subroutine cmh204 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH204' ) + parameter ( nbarin = 10 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 2 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(4))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des cinq pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(4) + liarin(2) = areint(4) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(9) + liarin(6) = areint(10) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 1', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + are1 = areint(4) + are2 = areint(1) + are3 = areint(6) + are4 = areint(7) + are5 = listar(2) + are6 = listar(5) + are7 = listar(10) + are8 = listar(7) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh300.F b/src/tool/Creation_Maillage/cmh300.F new file mode 100644 index 00000000..bf61a475 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh300.F @@ -0,0 +1,385 @@ + subroutine cmh300 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH300' ) + parameter ( nbarin = 11 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(7))) + lesnoe(11) = somare(2,filare(listar(11))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-huit tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(9) + fdnume = listfa(1) + fdcode = listcf(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 1', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh301.F b/src/tool/Creation_Maillage/cmh301.F new file mode 100644 index 00000000..13f9f3ae --- /dev/null +++ b/src/tool/Creation_Maillage/cmh301.F @@ -0,0 +1,385 @@ + subroutine cmh301 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH301' ) + parameter ( nbarin = 11 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(8))) + lesnoe(11) = somare(2,filare(listar(10))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-huit tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(9) + fdnume = listfa(1) + fdcode = listcf(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 1', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(7) + liarin(2) = areint(4) + liarin(3) = areint(1) + liarin(4) = areint(6) + liarin(5) = areint(11) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh302.F b/src/tool/Creation_Maillage/cmh302.F new file mode 100644 index 00000000..f80e7ccb --- /dev/null +++ b/src/tool/Creation_Maillage/cmh302.F @@ -0,0 +1,395 @@ + subroutine cmh302 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH302' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(5))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(11) + liarin(7) = areint(13) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(10) + liarin(7) = areint(14) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh303.F b/src/tool/Creation_Maillage/cmh303.F new file mode 100644 index 00000000..3826020c --- /dev/null +++ b/src/tool/Creation_Maillage/cmh303.F @@ -0,0 +1,397 @@ + subroutine cmh303 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH303' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(9))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des sept pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(11) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh304.F b/src/tool/Creation_Maillage/cmh304.F new file mode 100644 index 00000000..61650e01 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh304.F @@ -0,0 +1,397 @@ + subroutine cmh304 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH304' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des sept pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(11) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh305.F b/src/tool/Creation_Maillage/cmh305.F new file mode 100644 index 00000000..289ac4e0 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh305.F @@ -0,0 +1,389 @@ + subroutine cmh305 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH305' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatre pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh306.F b/src/tool/Creation_Maillage/cmh306.F new file mode 100644 index 00000000..ecbdd670 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh306.F @@ -0,0 +1,389 @@ + subroutine cmh306 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH306' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatre pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh307.F b/src/tool/Creation_Maillage/cmh307.F new file mode 100644 index 00000000..5bc95c58 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh307.F @@ -0,0 +1,392 @@ + subroutine cmh307 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH307' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des huit pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh308.F b/src/tool/Creation_Maillage/cmh308.F new file mode 100644 index 00000000..1269bdea --- /dev/null +++ b/src/tool/Creation_Maillage/cmh308.F @@ -0,0 +1,392 @@ + subroutine cmh308 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH308' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des huit pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(13) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh309.F b/src/tool/Creation_Maillage/cmh309.F new file mode 100644 index 00000000..3521aa11 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh309.F @@ -0,0 +1,389 @@ + subroutine cmh309 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH309' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(12) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatre pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(12) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh310.F b/src/tool/Creation_Maillage/cmh310.F new file mode 100644 index 00000000..7209b0bc --- /dev/null +++ b/src/tool/Creation_Maillage/cmh310.F @@ -0,0 +1,401 @@ + subroutine cmh310 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH310' ) + parameter ( nbarin = 11 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(4))) + lesnoe(11) = somare(2,filare(listar(9))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(4) + liarin(2) = areint(4) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(9) + liarin(6) = areint(10) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 1', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(11) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + are1 = areint(4) + are2 = areint(1) + are3 = areint(6) + are4 = areint(7) + are5 = listar(2) + are6 = listar(5) + are7 = listar(10) + are8 = listar(7) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh311.F b/src/tool/Creation_Maillage/cmh311.F new file mode 100644 index 00000000..528da298 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh311.F @@ -0,0 +1,393 @@ + subroutine cmh311 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH311' ) + parameter ( nbarin = 11 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 3 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(4))) + lesnoe(11) = somare(2,filare(listar(10))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des onze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des trois pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(4) + liarin(2) = areint(4) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(9) + liarin(6) = areint(10) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 1', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(7) + liarin(2) = areint(4) + liarin(3) = areint(1) + liarin(4) = areint(6) + liarin(5) = areint(11) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(11) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh400.F b/src/tool/Creation_Maillage/cmh400.F new file mode 100644 index 00000000..28d71139 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh400.F @@ -0,0 +1,521 @@ + subroutine cmh400 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH400' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +#include "coftfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +#include "defiqu.h" +c + integer laface, letria + integer niveau, nf1 + integer quabas(4) + integer an1nf1, an2nf1, an3nf1, an4nf1 + integer as5n1, as6n1, as1n1, as2n1 + integer as6n2, as7n2, as1n2, as4n2 + integer as5n3, as8n3, as2n3, as3n3 + integer as7n4, as8n4, as4n4, as3n4 + integer nufami +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c La face coupee en 4 et son code dans l'hexaedre +c + fdnume = listfa(1) + fdcode = listcf(1) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'fdnume, fdcode', fdnume, fdcode +#endif +c +c==== +c 3. Recuperation du noeud central de la face coupee en 4 +c==== +c + iaux = filqua(fdnume) + nf1 = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nf1', nf1 +#endif +c +c==== +c 4. Recuperation des aretes tracees sur la face coupee en 4 +c quabas stocke les quadrangles fils de la face coupee en 4 +c quabas(p) est la base de la pyramide fille numero p +c filqua(fdnume) + defiqJ(fdcode) : J-eme fils du quadrangle +c Attention : la regle de numerotation locale des quadrangles quabas +c est celle des pyramides ; on part du sommet de plus +c petit numero local et on tourne en entrant dans +c l'hexaedre. Pour les fils du quadrangle, on part de la +c plus petite arete locale et on tourne dans le meme sens +c D'ou l'eventuel decalage selon les faces +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'defiq1', defiq1(fdcode) + write(ulsort,90002) 'defiq2', defiq2(fdcode) + write(ulsort,90002) 'defiq3', defiq3(fdcode) + write(ulsort,90002) 'defiq4', defiq4(fdcode) +#endif + quabas(1) = filqua(fdnume) + defiq2(fdcode) + quabas(2) = filqua(fdnume) + defiq3(fdcode) + quabas(3) = filqua(fdnume) + defiq4(fdcode) + quabas(4) = filqua(fdnume) + defiq1(fdcode) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fils aine', filqua(fdnume) + write(ulsort,90006) 'quabas(1) :', quabas(1) + write(ulsort,90006) 'quabas(2) :', quabas(2) + write(ulsort,90006) 'quabas(3) :', quabas(3) + write(ulsort,90006) 'quabas(4) :', quabas(4) +#endif +c + if ( fdcode.lt.5 ) then + an2nf1 = arequa(quabas(1),2) + an4nf1 = arequa(quabas(2),2) + an3nf1 = arequa(quabas(3),2) + an1nf1 = arequa(quabas(4),2) + else + an2nf1 = arequa(quabas(2),2) + an4nf1 = arequa(quabas(3),2) + an3nf1 = arequa(quabas(4),2) + an1nf1 = arequa(quabas(1),2) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90015) 'an2nf1', an2nf1, ' entre les noeuds', + > somare(1,an2nf1), somare(2,an2nf1) + write(ulsort,90015) 'an4nf1', an4nf1, ' entre les noeuds', + > somare(1,an4nf1), somare(2,an4nf1) + write(ulsort,90015) 'an3nf1', an3nf1, ' entre les noeuds', + > somare(1,an3nf1), somare(2,an3nf1) + write(ulsort,90015) 'an1nf1', an1nf1, ' entre les noeuds', + > somare(1,an1nf1), somare(2,an1nf1) +#endif +c +c==== +c 5. Recuperation des aretes tracees sur les faces coupees en 3 +c==== +c + laface = listfa(2) + letria = -filqua(laface) + if ( listcf(2).lt.5 ) then + as5n1 = aretri(letria,1) + as6n1 = aretri(letria,3) + as1n1 = aretri(letria+2,1) + as2n1 = aretri(letria+1,1) + else + as5n1 = aretri(letria,3) + as6n1 = aretri(letria,1) + as1n1 = aretri(letria+1,1) + as2n1 = aretri(letria+2,1) + endif +c + laface = listfa(3) + letria = -filqua(laface) + if ( listcf(3).lt.5 ) then + as6n2 = aretri(letria,1) + as7n2 = aretri(letria,3) + as1n2 = aretri(letria+1,1) + as4n2 = aretri(letria+2,1) + else + as6n2 = aretri(letria,3) + as7n2 = aretri(letria,1) + as1n2 = aretri(letria+2,1) + as4n2 = aretri(letria+1,1) + endif +c + laface = listfa(4) + letria = -filqua(laface) + if ( listcf(4).lt.5 ) then + as5n3 = aretri(letria,3) + as8n3 = aretri(letria,1) + as2n3 = aretri(letria+2,1) + as3n3 = aretri(letria+1,1) + else + as5n3 = aretri(letria,1) + as8n3 = aretri(letria,3) + as2n3 = aretri(letria+1,1) + as3n3 = aretri(letria+2,1) + endif +c + laface = listfa(5) + letria = -filqua(laface) + if ( listcf(5).lt.5 ) then + as7n4 = aretri(letria,1) + as8n4 = aretri(letria,3) + as4n4 = aretri(letria+1,1) + as3n4 = aretri(letria+2,1) + else + as7n4 = aretri(letria,3) + as8n4 = aretri(letria,1) + as4n4 = aretri(letria+2,1) + as3n4 = aretri(letria+1,1) + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'as5n1, as6n1, as1n1, as2n1', + > as5n1, as6n1, as1n1, as2n1 + write(ulsort,90002) 'as6n2, as7n2, as1n2, as4n2', + > as6n2, as7n2, as1n2, as4n2 + write(ulsort,90002) 'as5n3, as8n3, as2n3, as3n3', + > as5n3, as8n3, as2n3, as3n3 + write(ulsort,90002) 'as7n4, as8n4, as4n4, as3n4', + > as7n4, as8n4, as4n4, as3n4 +#endif +c +c==== +c 6. Creation des quatre aretes internes +c areint(1) : AS5NF1 +c areint(2) : AS6NF1 +c areint(3) : AS7NF1 +c areint(4) : AS8NF1 +c==== +c + do 61 , iaux = 1 , 4 +c + indare = indare + 1 + areint(iaux) = indare +c + somare(1,areint(iaux)) = min ( nf1 , listso(4+iaux) ) + somare(2,areint(iaux)) = max ( nf1 , listso(4+iaux) ) +c + famare(areint(iaux)) = 1 + hetare(areint(iaux)) = 50 + merare(areint(iaux)) = 0 + filare(areint(iaux)) = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,90006) 'areint(iaux) = ', areint(iaux), + > ' de ',somare(1,areint(iaux)), + > ' a ',somare(2,areint(iaux)) +#endif +c + 61 continue +c +c==== +c 5. Creation des 5 pyramides +c==== +c + iaux = -indptp + nufami = cfahex(cofpfh,famhex(lehexa)) +c +c 5.1. ==> Pyramide s'appuyant sur la face non decoupee +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > areint(2), areint(1), areint(4), areint(3), + > listar(9), listar(11), listar(12), listar(10), + > iaux, nufami, indpyr ) +c +c 5.2. ==> Pyramides s'appuyant sur la face decoupee +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 2', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > listar(5), as6n2, areint(2), as6n1, + > as1n2, an2nf1, an1nf1, as1n1, + > iaux, nufami, indpyr ) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 3', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > listar(7), as7n4, areint(3), as7n2, + > as4n4, an4nf1, an2nf1, as4n2, + > iaux, nufami, indpyr ) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > listar(8), as8n3, areint(4), as8n4, + > as3n3, an3nf1, an4nf1, as3n4, + > iaux, nufami, indpyr ) +c + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA pyra 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > listar(6), as5n1, areint(1), as5n3, + > as2n1, an1nf1, an3nf1, as2n3, + > iaux, nufami, indpyr ) +c +c==== +c 6. Creation des 4 tetraedres +c==== +c + nufami = cfahex(coftfh,famhex(lehexa)) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA - tetra 1', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an1nf1, areint(1), areint(2), as5n1, + > as6n1, listar(9), + > iaux, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA - tetra 2', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an2nf1, areint(2), areint(3), as6n2, + > as7n2, listar(10), + > iaux, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA - tetra 3', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an4nf1, areint(3), areint(4), as7n4, + > as8n4, listar(12), + > iaux, nufami, indtet ) +c + indtet = indtet + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTEA - tetra 4', nompro +#endif + call cmctea ( aretet, famtet, hettet, filtet, pertet, + > an3nf1, areint(4), areint(1), as8n3, + > as5n3, listar(11), + > iaux, nufami, indtet ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh401.F b/src/tool/Creation_Maillage/cmh401.F new file mode 100644 index 00000000..a1bb7a21 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh401.F @@ -0,0 +1,413 @@ + subroutine cmh401 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH401' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(9))) + lesnoe(12) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(11) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(12) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(11) + liarin(6) = areint(12) + liarin(7) = areint(14) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh402.F b/src/tool/Creation_Maillage/cmh402.F new file mode 100644 index 00000000..d2c06c37 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh402.F @@ -0,0 +1,405 @@ + subroutine cmh402 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH402' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(9))) + lesnoe(12) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des neuf pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(11) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(12) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh403.F b/src/tool/Creation_Maillage/cmh403.F new file mode 100644 index 00000000..08e326c5 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh403.F @@ -0,0 +1,405 @@ + subroutine cmh403 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH403' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(10))) + lesnoe(12) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des neuf pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(11) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(11) + liarin(6) = areint(12) + liarin(7) = areint(14) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh404.F b/src/tool/Creation_Maillage/cmh404.F new file mode 100644 index 00000000..c3d44100 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh404.F @@ -0,0 +1,397 @@ + subroutine cmh404 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH404' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(11))) + lesnoe(12) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(12) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh405.F b/src/tool/Creation_Maillage/cmh405.F new file mode 100644 index 00000000..6919d01e --- /dev/null +++ b/src/tool/Creation_Maillage/cmh405.F @@ -0,0 +1,405 @@ + subroutine cmh405 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH405' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des neuf pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(2) + liarin(3) = areint(2) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(8) + are2 = listar(11) + are3 = listar(6) + are4 = listar(3) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh406.F b/src/tool/Creation_Maillage/cmh406.F new file mode 100644 index 00000000..9964f262 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh406.F @@ -0,0 +1,405 @@ + subroutine cmh406 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH406' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) + lesnoe(12) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des neuf pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(7) + liarin(1) = areint(7) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(12) + are1 = listar(7) + are2 = listar(12) + are3 = listar(8) + are4 = listar(4) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh407.F b/src/tool/Creation_Maillage/cmh407.F new file mode 100644 index 00000000..ba9a2706 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh407.F @@ -0,0 +1,402 @@ + subroutine cmh407 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH407' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(9))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des cinq pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(12) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh408.F b/src/tool/Creation_Maillage/cmh408.F new file mode 100644 index 00000000..63dba562 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh408.F @@ -0,0 +1,402 @@ + subroutine cmh408 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH408' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des cinq pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(12) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh409.F b/src/tool/Creation_Maillage/cmh409.F new file mode 100644 index 00000000..77b28bea --- /dev/null +++ b/src/tool/Creation_Maillage/cmh409.F @@ -0,0 +1,397 @@ + subroutine cmh409 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH409' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh410.F b/src/tool/Creation_Maillage/cmh410.F new file mode 100644 index 00000000..35f20adf --- /dev/null +++ b/src/tool/Creation_Maillage/cmh410.F @@ -0,0 +1,397 @@ + subroutine cmh410 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH410' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) + lesnoe(12) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh411.F b/src/tool/Creation_Maillage/cmh411.F new file mode 100644 index 00000000..108ea28e --- /dev/null +++ b/src/tool/Creation_Maillage/cmh411.F @@ -0,0 +1,400 @@ + subroutine cmh411 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH411' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(7))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(12) + liarin(7) = areint(15) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh412.F b/src/tool/Creation_Maillage/cmh412.F new file mode 100644 index 00000000..6d25ef40 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh412.F @@ -0,0 +1,410 @@ + subroutine cmh412 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH412' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(9))) + lesnoe(12) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des huit pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(11) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + are1 = areint(2) + are2 = areint(3) + are3 = areint(8) + are4 = areint(5) + are5 = listar(3) + are6 = listar(8) + are7 = listar(11) + are8 = listar(6) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 4', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(5) + liarin(1) = areint(5) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(11) + liarin(6) = areint(12) + are1 = listar(9) + are2 = listar(11) + are3 = listar(12) + are4 = listar(10) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh413.F b/src/tool/Creation_Maillage/cmh413.F new file mode 100644 index 00000000..4c3c1fa4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh413.F @@ -0,0 +1,410 @@ + subroutine cmh413 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH413' ) + parameter ( nbarin = 13 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(10))) + lesnoe(12) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des treize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des huit pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(11) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + are1 = areint(3) + are2 = areint(4) + are3 = areint(7) + are4 = areint(8) + are5 = listar(4) + are6 = listar(7) + are7 = listar(12) + are8 = listar(8) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(5) + liarin(4) = areint(5) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(11) + are2 = listar(12) + are3 = listar(10) + are4 = listar(9) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh414.F b/src/tool/Creation_Maillage/cmh414.F new file mode 100644 index 00000000..a91262c9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh414.F @@ -0,0 +1,397 @@ + subroutine cmh414 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH414' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh415.F b/src/tool/Creation_Maillage/cmh415.F new file mode 100644 index 00000000..c45f2a81 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh415.F @@ -0,0 +1,397 @@ + subroutine cmh415 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH415' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(14) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(11) + liarin(6) = areint(12) + liarin(7) = areint(14) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh416.F b/src/tool/Creation_Maillage/cmh416.F new file mode 100644 index 00000000..fb181b67 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh416.F @@ -0,0 +1,400 @@ + subroutine cmh416 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH416' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(5))) + lesnoe(12) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(13) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(13) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(11) + liarin(7) = areint(14) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(10) + liarin(7) = areint(15) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh417.F b/src/tool/Creation_Maillage/cmh417.F new file mode 100644 index 00000000..01adb25c --- /dev/null +++ b/src/tool/Creation_Maillage/cmh417.F @@ -0,0 +1,406 @@ + subroutine cmh417 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH417' ) + parameter ( nbarin = 12 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 4 aretes coupees +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(4))) + lesnoe(11) = somare(2,filare(listar(10))) + lesnoe(12) = somare(2,filare(listar(11))) +c +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des douze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatre pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(4) + liarin(2) = areint(4) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(9) + liarin(6) = areint(10) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 1', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(7) + liarin(2) = areint(4) + liarin(3) = areint(1) + liarin(4) = areint(6) + liarin(5) = areint(11) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(10) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(5) + liarin(4) = areint(5) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(11) + are2 = listar(12) + are3 = listar(10) + are4 = listar(9) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh418.F b/src/tool/Creation_Maillage/cmh418.F new file mode 100644 index 00000000..6050054c --- /dev/null +++ b/src/tool/Creation_Maillage/cmh418.F @@ -0,0 +1,300 @@ + subroutine cmh418 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro ='CMH418' ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer as1n1, as2n1, as3n4, as4n4 + integer as5n9, as6n9, as7n12, as8n12 + integer an1n4, an1n9, an4n12, an9n12 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation des demi-aretes +c==== +c 2.1. ==> Filles de l'arete 1 +c + if ( listso(1).le.listso(2) ) then + as1n1 = filare(listar(1)) + as2n1 = filare(listar(1)) + 1 + else + as1n1 = filare(listar(1)) + 1 + as2n1 = filare(listar(1)) + endif +c +c 2.2. ==> Filles de l'arete 4 +c + if ( listso(3).le.listso(4) ) then + as3n4 = filare(listar(4)) + as4n4 = filare(listar(4)) + 1 + else + as3n4 = filare(listar(4)) + 1 + as4n4 = filare(listar(4)) + endif +c +c 2.3. ==> Filles de l'arete 9 +c + if ( listso(5).le.listso(6) ) then + as5n9 = filare(listar(9)) + as6n9 = filare(listar(9)) + 1 + else + as5n9 = filare(listar(9)) + 1 + as6n9 = filare(listar(9)) + endif +c +c 2.4. ==> Filles de l'arete 12 +c + if ( listso(7).le.listso(8) ) then + as7n12 = filare(listar(12)) + as8n12 = filare(listar(12)) + 1 + else + as7n12 = filare(listar(12)) + 1 + as8n12 = filare(listar(12)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as2n1, as3n4, as4n4', + > as1n1, as2n1, as3n4, as4n4 + write (ulsort,90002) 'as5n9, as6n9, as7n12, as8n12', + > as5n9, as6n9, as7n12, as8n12 +#endif +c +c==== +c 3. Recuperation des aretes tracees sur les faces coupees +c C'est toujours la 4eme dans la description des fils (cf. cmcdq2) +c==== +c + an1n4 = arequa(filqua(listfa(1)),4) + an1n9 = arequa(filqua(listfa(2)),4) + an4n12 = arequa(filqua(listfa(5)),4) + an9n12 = arequa(filqua(listfa(6)),4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an1n4, an1n9, an4n12, an9n12', + > an1n4, an1n9, an4n12, an9n12 +#endif +c +c==== +c 4. Creation des hexaedres +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 3 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > as1n1, listar(2), an1n4, as4n4, + > listar(5), an1n9, listar(7), an4n12, + > as6n9, listar(10), an9n12, as7n12, + > lehexa, jaux, indhex ) +c +c 4.2. ==> Sur la face 4 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > as2n1, an1n4, listar(3), as3n4, + > an1n9, listar(6), an4n12, listar(8), + > as5n9, an9n12, listar(11), as8n12, + > lehexa, jaux, indhex ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh500.F b/src/tool/Creation_Maillage/cmh500.F new file mode 100644 index 00000000..8f68e7e4 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh500.F @@ -0,0 +1,413 @@ + subroutine cmh500 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH500' ) + parameter ( nbarin = 16 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(16) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des seize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des onze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(2) + liarin(3) = areint(2) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(8) + are2 = listar(11) + are3 = listar(6) + are4 = listar(3) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + liarin(6) = areint(13) + liarin(7) = areint(16) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh501.F b/src/tool/Creation_Maillage/cmh501.F new file mode 100644 index 00000000..cefd0a73 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh501.F @@ -0,0 +1,413 @@ + subroutine cmh501 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH501' ) + parameter ( nbarin = 16 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(16) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des seize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des onze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(15) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(13) + liarin(6) = areint(12) + liarin(7) = areint(16) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(7) + liarin(1) = areint(7) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(12) + are1 = listar(7) + are2 = listar(12) + are3 = listar(8) + are4 = listar(4) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh502.F b/src/tool/Creation_Maillage/cmh502.F new file mode 100644 index 00000000..d4ad86a8 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh502.F @@ -0,0 +1,418 @@ + subroutine cmh502 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH502' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(9))) + lesnoe(13) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(12) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(11) + liarin(6) = areint(13) + liarin(7) = areint(15) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(5) + liarin(1) = areint(5) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(12) + liarin(6) = areint(13) + are1 = listar(9) + are2 = listar(11) + are3 = listar(12) + are4 = listar(10) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh503.F b/src/tool/Creation_Maillage/cmh503.F new file mode 100644 index 00000000..64d1a2f6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh503.F @@ -0,0 +1,418 @@ + subroutine cmh503 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH503' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(10))) + lesnoe(13) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(9) + fdnume = listfa(2) + fdcode = listcf(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(12) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(13) + liarin(6) = areint(11) + liarin(7) = areint(15) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(5) + liarin(4) = areint(5) + liarin(5) = areint(13) + liarin(6) = areint(12) + are1 = listar(11) + are2 = listar(12) + are3 = listar(10) + are4 = listar(9) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh504.F b/src/tool/Creation_Maillage/cmh504.F new file mode 100644 index 00000000..fbb2c165 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh504.F @@ -0,0 +1,421 @@ + subroutine cmh504 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH504' ) + parameter ( nbarin = 16 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(7))) + lesnoe(13) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des seize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatorze pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(12) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(2) + liarin(3) = areint(2) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(13) + liarin(6) = areint(11) + are1 = listar(8) + are2 = listar(11) + are3 = listar(6) + are4 = listar(3) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(7) + liarin(1) = areint(7) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(12) + liarin(6) = areint(13) + are1 = listar(7) + are2 = listar(12) + are3 = listar(8) + are4 = listar(4) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh505.F b/src/tool/Creation_Maillage/cmh505.F new file mode 100644 index 00000000..588f08a1 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh505.F @@ -0,0 +1,418 @@ + subroutine cmh505 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH505' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(8))) + lesnoe(12) = somare(2,filare(listar(9))) + lesnoe(13) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(12) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(13) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(11) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(12) + liarin(6) = areint(13) + liarin(7) = areint(15) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh506.F b/src/tool/Creation_Maillage/cmh506.F new file mode 100644 index 00000000..69c6387d --- /dev/null +++ b/src/tool/Creation_Maillage/cmh506.F @@ -0,0 +1,418 @@ + subroutine cmh506 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH506' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(13) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(2) + liarin(3) = areint(2) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(8) + are2 = listar(11) + are3 = listar(6) + are4 = listar(3) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh507.F b/src/tool/Creation_Maillage/cmh507.F new file mode 100644 index 00000000..2adccd24 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh507.F @@ -0,0 +1,418 @@ + subroutine cmh507 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH507' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(9))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(15) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(15) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(7) + liarin(1) = areint(7) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(12) + are1 = listar(7) + are2 = listar(12) + are3 = listar(8) + are4 = listar(4) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh508.F b/src/tool/Creation_Maillage/cmh508.F new file mode 100644 index 00000000..699b36f7 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh508.F @@ -0,0 +1,408 @@ + subroutine cmh508 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH508' ) + parameter ( nbarin = 17 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(7))) + lesnoe(13) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(17) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-sept aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(12) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(11) + liarin(6) = areint(13) + liarin(7) = areint(17) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh509.F b/src/tool/Creation_Maillage/cmh509.F new file mode 100644 index 00000000..de54c86c --- /dev/null +++ b/src/tool/Creation_Maillage/cmh509.F @@ -0,0 +1,408 @@ + subroutine cmh509 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH509' ) + parameter ( nbarin = 17 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(7))) + lesnoe(13) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(17) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-sept aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(12) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(12) + liarin(7) = areint(17) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh510.F b/src/tool/Creation_Maillage/cmh510.F new file mode 100644 index 00000000..7f7f6c8e --- /dev/null +++ b/src/tool/Creation_Maillage/cmh510.F @@ -0,0 +1,408 @@ + subroutine cmh510 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH510' ) + parameter ( nbarin = 17 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(5))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(17) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-sept aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(14) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(11) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(10) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(13) + liarin(6) = areint(12) + liarin(7) = areint(17) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh511.F b/src/tool/Creation_Maillage/cmh511.F new file mode 100644 index 00000000..1da0b8f1 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh511.F @@ -0,0 +1,415 @@ + subroutine cmh511 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH511' ) + parameter ( nbarin = 16 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des seize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des onze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(14) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(13) + liarin(7) = areint(15) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh512.F b/src/tool/Creation_Maillage/cmh512.F new file mode 100644 index 00000000..bcdb01ca --- /dev/null +++ b/src/tool/Creation_Maillage/cmh512.F @@ -0,0 +1,416 @@ + subroutine cmh512 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH512' ) + parameter ( nbarin = 14 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 5 aretes coupees +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(9))) +c + iaux = filqua(listfa(1)) + lesnoe(14) = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quatorze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des six pyramides et des douze tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(14) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(13) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh600.F b/src/tool/Creation_Maillage/cmh600.F new file mode 100644 index 00000000..c5a1c182 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh600.F @@ -0,0 +1,419 @@ + subroutine cmh600 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH600' ) + parameter ( nbarin = 20 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 6 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(5))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(11))) + lesnoe(14) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(18) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(19) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(20) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des vingt aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-huit pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(11) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(10) + liarin(7) = areint(17) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(13) + liarin(6) = areint(12) + liarin(7) = areint(18) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + liarin(6) = areint(14) + liarin(7) = areint(19) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(14) + liarin(6) = areint(13) + liarin(7) = areint(20) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh601.F b/src/tool/Creation_Maillage/cmh601.F new file mode 100644 index 00000000..3151e05a --- /dev/null +++ b/src/tool/Creation_Maillage/cmh601.F @@ -0,0 +1,433 @@ + subroutine cmh601 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH601' ) + parameter ( nbarin = 16 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . du noeud milieu de la face coupee en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(9))) + lesnoe(14) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(6)) + lesnoe(16) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des seize aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des onze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(15) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(14) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(13) + liarin(6) = areint(14) + liarin(7) = areint(16) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh602.F b/src/tool/Creation_Maillage/cmh602.F new file mode 100644 index 00000000..ad6a54a9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh602.F @@ -0,0 +1,437 @@ + subroutine cmh602 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH602' ) + parameter ( nbarin = 15 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(9))) + lesnoe(14) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des quinze aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(15) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(10) + fdnume = listfa(3) + fdcode = listcf(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 3', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(4) + liarin(1) = areint(4) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(8) + liarin(3) = areint(8) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(14) + are1 = listar(4) + are2 = listar(7) + are3 = listar(12) + are4 = listar(8) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(5) + liarin(1) = areint(5) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(13) + liarin(6) = areint(14) + are1 = listar(9) + are2 = listar(11) + are3 = listar(12) + are4 = listar(10) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh603.F b/src/tool/Creation_Maillage/cmh603.F new file mode 100644 index 00000000..5303a47d --- /dev/null +++ b/src/tool/Creation_Maillage/cmh603.F @@ -0,0 +1,428 @@ + subroutine cmh603 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH603' ) + parameter ( nbarin = 17 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(17) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-sept aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(15) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(13) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(17) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(3) + liarin(1) = areint(3) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(5) + liarin(3) = areint(5) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(11) + liarin(6) = areint(14) + are1 = listar(3) + are2 = listar(8) + are3 = listar(11) + are4 = listar(6) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(14) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh604.F b/src/tool/Creation_Maillage/cmh604.F new file mode 100644 index 00000000..0a20a450 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh604.F @@ -0,0 +1,428 @@ + subroutine cmh604 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH604' ) + parameter ( nbarin = 17 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(17) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-sept aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des douze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(15) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(13) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(17) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(11) + fdnume = listfa(4) + fdcode = listcf(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(4) + liarin(1) = areint(4) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(8) + liarin(3) = areint(8) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(14) + are1 = listar(4) + are2 = listar(7) + are3 = listar(12) + are4 = listar(8) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(14) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh605.F b/src/tool/Creation_Maillage/cmh605.F new file mode 100644 index 00000000..6135846e --- /dev/null +++ b/src/tool/Creation_Maillage/cmh605.F @@ -0,0 +1,426 @@ + subroutine cmh605 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH605' ) + parameter ( nbarin = 19 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(8))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(18) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(19) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-neuf aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-sept pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(15) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(13) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(17) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(3) + liarin(2) = areint(8) + liarin(3) = areint(5) + liarin(4) = areint(2) + liarin(5) = areint(14) + liarin(6) = areint(11) + liarin(7) = areint(18) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(3) + liarin(2) = areint(4) + liarin(3) = areint(7) + liarin(4) = areint(8) + liarin(5) = areint(12) + liarin(6) = areint(14) + liarin(7) = areint(19) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + are1 = areint(6) + are2 = areint(5) + are3 = areint(8) + are4 = areint(7) + are5 = listar(9) + are6 = listar(11) + are7 = listar(12) + are8 = listar(10) + indpyr = indpyr + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPYA - face 6', nompro +#endif + call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr, + > are1, are2, are3, are4, + > are5, are6, are7, are8, + > iaux, jaux, indpyr ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh606.F b/src/tool/Creation_Maillage/cmh606.F new file mode 100644 index 00000000..8c74f2cc --- /dev/null +++ b/src/tool/Creation_Maillage/cmh606.F @@ -0,0 +1,419 @@ + subroutine cmh606 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH606' ) + parameter ( nbarin = 20 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 6 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(7))) + lesnoe(13) = somare(2,filare(listar(11))) + lesnoe(14) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(18) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(19) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(20) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des vingt aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-huit pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(12) + liarin(7) = areint(17) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(5) + liarin(2) = areint(2) + liarin(3) = areint(3) + liarin(4) = areint(8) + liarin(5) = areint(11) + liarin(6) = areint(13) + liarin(7) = areint(18) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(7) + liarin(2) = areint(8) + liarin(3) = areint(3) + liarin(4) = areint(4) + liarin(5) = areint(14) + liarin(6) = areint(12) + liarin(7) = areint(19) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(14) + liarin(6) = areint(13) + liarin(7) = areint(20) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh607.F b/src/tool/Creation_Maillage/cmh607.F new file mode 100644 index 00000000..a27bdd64 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh607.F @@ -0,0 +1,429 @@ + subroutine cmh607 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH607' ) + parameter ( nbarin = 18 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(6))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(10))) + lesnoe(14) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(2)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(18) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-huit aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des seize pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(2) + liarin(2) = areint(5) + liarin(3) = areint(6) + liarin(4) = areint(1) + liarin(5) = areint(11) + liarin(6) = areint(9) + liarin(7) = areint(16) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(10) + liarin(6) = areint(13) + are1 = listar(2) + are2 = listar(5) + are3 = listar(10) + are4 = listar(7) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(8) + liarin(1) = areint(8) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(2) + liarin(3) = areint(2) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(11) + are1 = listar(8) + are2 = listar(11) + are3 = listar(6) + are4 = listar(3) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(8) + liarin(2) = areint(3) + liarin(3) = areint(4) + liarin(4) = areint(7) + liarin(5) = areint(12) + liarin(6) = areint(14) + liarin(7) = areint(17) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(7) + liarin(2) = areint(6) + liarin(3) = areint(5) + liarin(4) = areint(8) + liarin(5) = areint(13) + liarin(6) = areint(14) + liarin(7) = areint(18) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh608.F b/src/tool/Creation_Maillage/cmh608.F new file mode 100644 index 00000000..4b8a0f8a --- /dev/null +++ b/src/tool/Creation_Maillage/cmh608.F @@ -0,0 +1,429 @@ + subroutine cmh608 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH608' ) + parameter ( nbarin = 18 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 6 aretes coupees +c . des noeuds milieux des 4 faces coupees en 3 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(7))) + lesnoe(12) = somare(2,filare(listar(8))) + lesnoe(13) = somare(2,filare(listar(9))) + lesnoe(14) = somare(2,filare(listar(11))) +c + iaux = filqua(listfa(1)) + lesnoe(15) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(16) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(18) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-huit aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des seize pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + liarin(1) = areint(1) + liarin(2) = areint(4) + liarin(3) = areint(3) + liarin(4) = areint(2) + liarin(5) = areint(10) + liarin(6) = areint(9) + liarin(7) = areint(15) + fdcode = listcf(1) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(5) + liarin(2) = areint(5) + lisomm(3) = lesnoe(6) + liarin(3) = areint(6) + lisomm(4) = lesnoe(1) + liarin(4) = areint(1) + liarin(5) = areint(9) + liarin(6) = areint(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 2', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(4) + liarin(2) = areint(1) + liarin(3) = areint(6) + liarin(4) = areint(7) + liarin(5) = areint(10) + liarin(6) = areint(11) + liarin(7) = areint(16) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(8) + liarin(2) = areint(5) + liarin(3) = areint(2) + liarin(4) = areint(3) + liarin(5) = areint(14) + liarin(6) = areint(12) + liarin(7) = areint(17) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(7) + liarin(1) = areint(7) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(3) + liarin(3) = areint(3) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(11) + liarin(6) = areint(12) + are1 = listar(7) + are2 = listar(12) + are3 = listar(8) + are4 = listar(4) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(14) + liarin(6) = areint(13) + liarin(7) = areint(18) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh700.F b/src/tool/Creation_Maillage/cmh700.F new file mode 100644 index 00000000..dc8242a2 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh700.F @@ -0,0 +1,437 @@ + subroutine cmh700 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH700' ) + parameter ( nbarin = 19 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 7 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c . des noeuds milieux des 2 faces coupees en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(6))) + lesnoe(15) = somare(2,filare(listar(9))) +c + iaux = filqua(listfa(1)) + lesnoe(16) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(17) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(3)) + lesnoe(18) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(19) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-neuf aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des quatorze pyramides et des six tetraedres +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(16) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(2) + liarin(2) = areint(2) + lisomm(3) = lesnoe(5) + liarin(3) = areint(5) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(14) + liarin(7) = areint(15) + liarin(8) = areint(13) + liarin(9) = areint(17) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(14) + lisomm(7) = lesnoe(15) + lisomm(8) = lesnoe(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 2', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(18) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + liarin(6) = areint(14) + liarin(7) = areint(19) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(12) + fdnume = listfa(5) + fdcode = listcf(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 5', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(5) + liarin(2) = areint(8) + liarin(3) = areint(7) + liarin(4) = areint(6) + liarin(5) = areint(15) + fdnume = listfa(6) + fdcode = listcf(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCTE3 - face 6', nompro +#endif + call cmcte3 ( lehexa, indtet, indptp, + > fdnume, fdcode, liarin, + > aretri, filqua, + > aretet, famtet, + > hettet, filtet, pertet, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh701.F b/src/tool/Creation_Maillage/cmh701.F new file mode 100644 index 00000000..df2212ff --- /dev/null +++ b/src/tool/Creation_Maillage/cmh701.F @@ -0,0 +1,444 @@ + subroutine cmh701 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH701' ) + parameter ( nbarin = 19 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 7 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c . du noeud milieu de la face coupee en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(11))) + lesnoe(15) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(16) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(17) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(3)) + lesnoe(18) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(19) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des dix-neuf aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-sept pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(16) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + liarin(1) = areint(1) + liarin(2) = areint(2) + liarin(3) = areint(5) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(13) + liarin(7) = areint(17) + fdcode = listcf(2) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 2', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(18) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + lisomm(1) = lesnoe(3) + liarin(1) = areint(3) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(5) + liarin(3) = areint(5) + lisomm(4) = lesnoe(2) + liarin(4) = areint(2) + liarin(5) = areint(11) + liarin(6) = areint(14) + are1 = listar(3) + are2 = listar(8) + are3 = listar(11) + are4 = listar(6) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 4', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(4) + liarin(1) = areint(4) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(8) + liarin(3) = areint(8) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(15) + are1 = listar(4) + are2 = listar(7) + are3 = listar(12) + are4 = listar(8) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(8) + liarin(2) = areint(7) + liarin(3) = areint(6) + liarin(4) = areint(5) + liarin(5) = areint(15) + liarin(6) = areint(14) + liarin(7) = areint(19) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh800.F b/src/tool/Creation_Maillage/cmh800.F new file mode 100644 index 00000000..df6f9a3e --- /dev/null +++ b/src/tool/Creation_Maillage/cmh800.F @@ -0,0 +1,508 @@ + subroutine cmh800 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH800' ) + parameter ( nbarin = 18 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + + integer listaf(4) + integer as1n1, as2n1, as1n2, as4n2 + integer as3n4, as4n4, as2n3, as3n3 + integer an1nf1, an2nf1, an4nf1, an3nf1 + integer as5n9, as6n9, as6n10, as7n10 + integer as7n12, as8n12, as8n11, as5n11 + integer an9f6, an10f6, an11f6, an12f6 + integer an1n9, an2n10, an3n11, an4n12 + integer af1f6 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 8 aretes coupees +c . des noeuds milieux des 2 faces coupees en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(9))) + lesnoe(14) = somare(2,filare(listar(10))) + lesnoe(15) = somare(2,filare(listar(11))) + lesnoe(16) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(17) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(6)) + lesnoe(18) = somare(2,arequa(iaux,2)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Recuperation des demi-aretes de la face f1 +c==== +c 3.1. ==> Filles des aretes de bord +c 3.1.1. == filles de listar(1) +c + if ( lesnoe(2).le.lesnoe(1) ) then + as1n1 = filare(listar(1)) + 1 + as2n1 = filare(listar(1)) + else + as1n1 = filare(listar(1)) + as2n1 = filare(listar(1)) + 1 + endif +c +c 3.1.2. == filles de listar(2) +c + if ( lesnoe(1).le.lesnoe(4) ) then + as1n2 = filare(listar(2)) + as4n2 = filare(listar(2)) + 1 + else + as1n2 = filare(listar(2)) + 1 + as4n2 = filare(listar(2)) + endif +c +c 3.1.3. == filles de listar(4) +c + if ( lesnoe(4).le.lesnoe(3) ) then + as3n4 = filare(listar(4)) + 1 + as4n4 = filare(listar(4)) + else + as3n4 = filare(listar(4)) + as4n4 = filare(listar(4)) + 1 + endif +c +c 3.1.4. == filles de listar(3) +c + if ( lesnoe(3).le.lesnoe(2) ) then + as2n3 = filare(listar(3)) + 1 + as3n3 = filare(listar(3)) + else + as2n3 = filare(listar(3)) + as3n3 = filare(listar(3)) + 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as1n1, as2n1, as1n2, as4n2', + > as1n1, as2n1, as1n2, as4n2 + write (ulsort,90002) 'as3n4, as4n4, as2n3, as3n3', + > as3n4, as4n4, as2n3, as3n3 +#endif +c +c 3.2. Recuperation des aretes entre les milieux des aretes coupees +c 3.2.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans +c la description des fils (cf. cmcdq2) +c + listaf(1) = arequa(filqua(listfa(1)) ,2) + listaf(2) = arequa(filqua(listfa(1)) ,3) + listaf(3) = arequa(filqua(listfa(1))+2,2) + listaf(4) = arequa(filqua(listfa(1))+2,3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listaf', listaf +#endif +c +c 3.2.2. ==> Positionnement +c + do 322 , iaux = 1 , 4 +c + jaux = somare(1,listaf(iaux)) + if ( jaux.eq.lesnoe(9) ) then + an1nf1 = listaf(iaux) + elseif ( jaux.eq.lesnoe(10) ) then + an2nf1 = listaf(iaux) + elseif ( jaux.eq.lesnoe(12) ) then + an4nf1 = listaf(iaux) + elseif ( jaux.eq.lesnoe(11) ) then + an3nf1 = listaf(iaux) + endif +c + 322 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an1nf1, an2nf1, an4nf1, an3nf1', + > an1nf1, an2nf1, an4nf1, an3nf1 +#endif +c +c==== +c 4. Recuperation des demi-aretes de la face f6 +c==== +c 4.1. ==> Filles des aretes de bord +c 4.1.1. == filles de listar(9) +c + if ( lesnoe(5).le.lesnoe(6) ) then + as5n9 = filare(listar(9)) + as6n9 = filare(listar(9)) + 1 + else + as5n9 = filare(listar(9)) + 1 + as6n9 = filare(listar(9)) + endif +c +c 4.1.2. == filles de listar(10) +c + if ( lesnoe(6).le.lesnoe(7) ) then + as6n10 = filare(listar(10)) + as7n10 = filare(listar(10)) + 1 + else + as6n10 = filare(listar(10)) + 1 + as7n10 = filare(listar(10)) + endif +c +c 4.1.3. == filles de listar(12) +c + if ( lesnoe(7).le.lesnoe(8) ) then + as7n12 = filare(listar(12)) + as8n12 = filare(listar(12))+ 1 + else + as7n12 = filare(listar(12))+ 1 + as8n12 = filare(listar(12)) + endif +c +c 4.1.4. == filles de listar(11) +c + if ( lesnoe(5).le.lesnoe(8) ) then + as5n11 = filare(listar(11)) + as8n11 = filare(listar(11))+ 1 + else + as5n11 = filare(listar(11))+ 1 + as8n11 = filare(listar(11)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'as5n9, as6n9, as6n10, as7n10', + > as5n9, as6n9, as6n10, as7n10 + write (ulsort,90002) 'as7n12, as8n12, as8n11, as5n11', + > as7n12, as8n12, as8n11, as5n11 +#endif +c +c 4.2. Recuperation des aretes entre les milieux des aretes coupees +c 4.2.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans +c la description des fils (cf. cmcdq2) +c + listaf(1) = arequa(filqua(listfa(6)) ,2) + listaf(2) = arequa(filqua(listfa(6)) ,3) + listaf(3) = arequa(filqua(listfa(6))+2,2) + listaf(4) = arequa(filqua(listfa(6))+2,3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listaf', listaf +#endif +c +c 4.2.2. ==> Positionnement +c + do 422 , iaux = 1 , 4 +c + jaux = somare(1,listaf(iaux)) + if ( jaux.eq.lesnoe(13) ) then + an9f6 = listaf(iaux) + elseif ( jaux.eq.lesnoe(14) ) then + an10f6 = listaf(iaux) + elseif ( jaux.eq.lesnoe(15) ) then + an11f6 = listaf(iaux) + elseif ( jaux.eq.lesnoe(16) ) then + an12f6 = listaf(iaux) + endif +c + 422 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an9f6, an10f6, an11f6, an12f6', + > an9f6, an10f6, an11f6, an12f6 +#endif +c +c==== +c 5. Aretes sur les faces coupees en 2 +c C'est toujours la 4eme dans la description des fils (cf. cmcdq2) +c==== +c + an1n9 = arequa(filqua(listfa(2)),4) + an2n10 = arequa(filqua(listfa(3)),4) + an3n11 = arequa(filqua(listfa(4)),4) + an4n12 = arequa(filqua(listfa(5)),4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'an1n9, an2n10, an3n11, an4n12', + > an1n9, an2n10, an3n11, an4n12 +#endif +c +c==== +c 6. Creation de l'arete interne +c==== +c + indare = indare + 1 +c + af1f6 = indare + somare(1,af1f6) = min ( lesnoe(17) , lesnoe(18) ) + somare(2,af1f6) = max ( lesnoe(17) , lesnoe(18) ) +c + famare(af1f6) = 1 + hetare(af1f6) = 50 + merare(af1f6) = 0 + filare(af1f6) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'af1f6', af1f6 +#endif +c +c==== +c 7. Creation des hexaedres +c==== +c + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 7.1. ==> Contenant l'arete A5 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > as1n1, as1n2, an1nf1, an2nf1, + > listar(5), an1n9, an2n10, af1f6, + > as6n9, as6n10, an9f6, an10f6, + > lehexa, jaux, indhex ) +c + filhex(lehexa) = indhex +c +c 7.2. ==> Contenant l'arete A7 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > an2nf1, as4n2, an4nf1, as4n4, + > an2n10, af1f6, listar(7), an4n12, + > an10f6, as7n10, an12f6, as7n12, + > lehexa, jaux, indhex ) +c +c 7.3. ==> Contenant l'arete A8 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > an3nf1, an4nf1, as3n3, as3n4, + > af1f6, an3n11, an4n12, listar(8), + > an11f6, an12f6, as8n11, as8n12, + > lehexa, jaux, indhex ) +c +c 7.4. ==> Contenant l'arete A6 +c + indhex = indhex + 1 + call cmchea ( arehex, famhex, + > hethex, filhex, perhex, + > as2n1, an1nf1, as2n3, an3nf1, + > an1n9, listar(6), af1f6, an3n11, + > as5n9, an9f6, as5n11, an11f6, + > lehexa, jaux, indhex ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh801.F b/src/tool/Creation_Maillage/cmh801.F new file mode 100644 index 00000000..6b3f8886 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh801.F @@ -0,0 +1,458 @@ + subroutine cmh801 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH801' ) + parameter ( nbarin = 20 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 8 aretes coupees +c . des noeuds milieux des 2 faces coupees en 3 quadrangles +c . des noeuds milieux des 2 faces coupees en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(6))) + lesnoe(15) = somare(2,filare(listar(9))) + lesnoe(16) = somare(2,filare(listar(12))) +c + iaux = filqua(listfa(1)) + lesnoe(17) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(18) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(3)) + lesnoe(19) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(4)) + lesnoe(20) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des vingt aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des dix-huit pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(17) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(2) + liarin(2) = areint(2) + lisomm(3) = lesnoe(5) + liarin(3) = areint(5) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(14) + liarin(7) = areint(15) + liarin(8) = areint(13) + liarin(9) = areint(18) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(14) + lisomm(7) = lesnoe(15) + lisomm(8) = lesnoe(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 2', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + liarin(1) = areint(1) + liarin(2) = areint(6) + liarin(3) = areint(7) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(10) + liarin(7) = areint(19) + fdcode = listcf(3) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 3', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + liarin(6) = areint(14) + liarin(7) = areint(20) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + lisomm(1) = lesnoe(4) + liarin(1) = areint(4) + lisomm(2) = lesnoe(7) + liarin(2) = areint(7) + lisomm(3) = lesnoe(8) + liarin(3) = areint(8) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(12) + liarin(6) = areint(16) + are1 = listar(4) + are2 = listar(7) + are3 = listar(12) + are4 = listar(8) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 5', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + lisomm(1) = lesnoe(5) + liarin(1) = areint(5) + lisomm(2) = lesnoe(8) + liarin(2) = areint(8) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(15) + liarin(6) = areint(16) + are1 = listar(9) + are2 = listar(11) + are3 = listar(12) + are4 = listar(10) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro +#endif + call cmcpy2 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, + > are1, are2, are3, are4, + > filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmh900.F b/src/tool/Creation_Maillage/cmh900.F new file mode 100644 index 00000000..f73f6792 --- /dev/null +++ b/src/tool/Creation_Maillage/cmh900.F @@ -0,0 +1,462 @@ + subroutine cmh900 ( lehexa, + > indnoe, indare, indtet, indpyr, indhex, + > indptp, + > listso, listar, listfa, listcf, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > aretri, + > arequa, filqua, + > hettet, aretet, + > filtet, pertet, famtet, + > hetpyr, arepyr, + > filpyr, perpyr, fampyr, + > hethex, arehex, + > filhex, perhex, famhex, + > cfahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - decoupage de conformite des Hexaedres +c - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . hexaedre a decouper . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indpyr . es . 1 . indice de la derniere pyramide creee . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indptp . es . 1 . indice du dernier pere enregistre . +c . listso . e . 8 . numeros globaux des sommets . +c . listar . e . 12 . numeros globaux des aretes . +c . listfa . e . 6 . numeros globaux des faces . +c . listcf . e . 6 . codes des faces . +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . famille des noeuds . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . famare . es . nouvar . famille des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . aretet . es .nouvta*6. numeros des 6 aretes des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nouvte . famille des tetraedres . +c . hetpyr . es . nouvpy . historique de l'etat des pyramides . +c . arepyr . es .nouvya*8. numeros des 8 aretes des pyramides . +c . filpyr . es . nouvpy . premier fils des pyramides . +c . perpyr . es . nouvpy . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . fampyr . es . nouvpy . famille des pyramides . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . arehex . es .nouvha12. numeros des 12 aretes des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . famhex . es . nouvhe . famille des hexaedres . +c . cfahex . e . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbarin + character*6 nompro + parameter ( nompro ='CMH900' ) + parameter ( nbarin = 23 ) +c + integer nbsomm + parameter ( nbsomm = 8 ) +c +#include "nblang.h" +#include "cofpfh.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer indnoe, indare, indtet, indpyr, indhex + integer indptp + integer listso(8), listar(12), listfa(6), listcf(6) + integer hetnoe(nouvno), arenoe(nouvno) + integer famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar) + integer filare(nouvar), merare(nouvar), famare(nouvar) + integer aretri(nouvtr,3) + integer arequa(nouvqu,4) + integer filqua(nouvqu) + integer hettet(nouvte), aretet(nouvta,6) + integer filtet(nouvte), pertet(nouvte), famtet(nouvte) + integer hetpyr(nouvpy), arepyr(nouvya,8) + integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) + integer arehex(nouvha,12) + integer hethex(nouvhe) + integer filhex(nouvhe), perhex(nouvhe) + integer cfahex(nctfhe,nbfhex), famhex(nouvhe) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer lesnoe(nbarin), areint(nbarin) + integer lisomm(10), liarin(10) + integer fdnume, fdcode + integer are1, are2, are3, are4 + integer are5, are6, are7, are8 + +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'indtet', indtet + write (ulsort,90002) 'indpyr', indpyr + write (ulsort,90002) 'indhex', indhex +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listar 1-8', (listar(iaux),iaux=1,8) + write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12) + write (ulsort,90002) 'listso', listso + write (ulsort,90002) 'listfa', listfa + write (ulsort,90002) 'listcf', listcf +#endif +c + codret = 0 +c +c==== +c 2. Recuperation +c . des sommets de l'hexaedre +c . des noeuds milieux des 9 aretes coupees +c . des noeuds milieux des 3 faces coupees en 3 quadrangles +c . des noeuds milieux des 3 faces coupees en 4 quadrangles +c==== +c + do 21 , iaux = 1 , 8 + lesnoe(iaux) = listso(iaux) + 21 continue +c + lesnoe(9) = somare(2,filare(listar(1))) + lesnoe(10) = somare(2,filare(listar(2))) + lesnoe(11) = somare(2,filare(listar(3))) + lesnoe(12) = somare(2,filare(listar(4))) + lesnoe(13) = somare(2,filare(listar(5))) + lesnoe(14) = somare(2,filare(listar(6))) + lesnoe(15) = somare(2,filare(listar(7))) + lesnoe(16) = somare(2,filare(listar(9))) + lesnoe(17) = somare(2,filare(listar(10))) +c + iaux = filqua(listfa(1)) + lesnoe(18) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(2)) + lesnoe(19) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(3)) + lesnoe(20) = somare(2,arequa(iaux,2)) + iaux = filqua(listfa(4)) + lesnoe(21) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(5)) + lesnoe(22) = somare(2,arequa(iaux,4)) + iaux = filqua(listfa(6)) + lesnoe(23) = somare(2,arequa(iaux,4)) +#ifdef _DEBUG_HOMARD_ + do 2000 , iaux = 1 , nbarin + write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux) + 2000 continue +#endif +c +c==== +c 3. Creation du noeud interne et des vingt-trois aretes internes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCHPB', nompro +#endif + call cmchpb ( indnoe, indare, nbarin, + > nbsomm, lesnoe, areint, + > coonoe, hetnoe, arenoe, + > famnoe, + > hetare, somare, + > filare, merare, famare, + > ulsort, langue, codret ) +c +c==== +c 4. Creation des vingt et une pyramides +c==== +c + iaux = -indptp + jaux = cfahex(cofpfh,famhex(lehexa)) +c +c 4.1. ==> Sur la face 1 +c + lisomm(1) = lesnoe(2) + liarin(1) = areint(2) + lisomm(2) = lesnoe(1) + liarin(2) = areint(1) + lisomm(3) = lesnoe(4) + liarin(3) = areint(4) + lisomm(4) = lesnoe(3) + liarin(4) = areint(3) + liarin(5) = areint(9) + liarin(6) = areint(10) + liarin(7) = areint(12) + liarin(8) = areint(11) + liarin(9) = areint(18) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(10) + lisomm(7) = lesnoe(12) + lisomm(8) = lesnoe(11) + are1 = listar(1) + are2 = listar(2) + are3 = listar(4) + are4 = listar(3) + fdnume = listfa(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.2. ==> Sur la face 2 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(2) + liarin(2) = areint(2) + lisomm(3) = lesnoe(5) + liarin(3) = areint(5) + lisomm(4) = lesnoe(6) + liarin(4) = areint(6) + liarin(5) = areint(9) + liarin(6) = areint(14) + liarin(7) = areint(16) + liarin(8) = areint(13) + liarin(9) = areint(19) + lisomm(5) = lesnoe(9) + lisomm(6) = lesnoe(14) + lisomm(7) = lesnoe(16) + lisomm(8) = lesnoe(13) + are1 = listar(1) + are2 = listar(6) + are3 = listar(9) + are4 = listar(5) + fdnume = listfa(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 2', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.3. ==> Sur la face 3 +c + lisomm(1) = lesnoe(1) + liarin(1) = areint(1) + lisomm(2) = lesnoe(6) + liarin(2) = areint(6) + lisomm(3) = lesnoe(7) + liarin(3) = areint(7) + lisomm(4) = lesnoe(4) + liarin(4) = areint(4) + liarin(5) = areint(13) + liarin(6) = areint(17) + liarin(7) = areint(15) + liarin(8) = areint(10) + liarin(9) = areint(20) + lisomm(5) = lesnoe(13) + lisomm(6) = lesnoe(17) + lisomm(7) = lesnoe(15) + lisomm(8) = lesnoe(10) + are1 = listar(5) + are2 = listar(10) + are3 = listar(7) + are4 = listar(2) + fdnume = listfa(3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY4 - face 3', nompro +#endif + call cmcpy4 ( lehexa, indpyr, indptp, + > fdnume, + > lisomm, liarin, are1, are2, are3, are4, + > somare, filare, arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.4. ==> Sur la face 4 +c + liarin(1) = areint(2) + liarin(2) = areint(3) + liarin(3) = areint(8) + liarin(4) = areint(5) + liarin(5) = areint(11) + liarin(6) = areint(14) + liarin(7) = areint(21) + fdcode = listcf(4) + fdnume = listfa(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.5. ==> Sur la face 5 +c + liarin(1) = areint(4) + liarin(2) = areint(7) + liarin(3) = areint(8) + liarin(4) = areint(3) + liarin(5) = areint(15) + liarin(6) = areint(12) + liarin(7) = areint(22) + fdcode = listcf(5) + fdnume = listfa(5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c 4.6. ==> Sur la face 6 +c + liarin(1) = areint(6) + liarin(2) = areint(5) + liarin(3) = areint(8) + liarin(4) = areint(7) + liarin(5) = areint(16) + liarin(6) = areint(17) + liarin(7) = areint(23) + fdcode = listcf(6) + fdnume = listfa(6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro +#endif + call cmcpy3 ( lehexa, indpyr, indptp, + > fdnume, fdcode, + > liarin, + > arequa, filqua, + > arepyr, fampyr, + > hetpyr, filpyr, perpyr, + > famhex, cfahex, + > ulsort, langue, codret ) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmhoma.F b/src/tool/Creation_Maillage/cmhoma.F new file mode 100644 index 00000000..17a9ef3c --- /dev/null +++ b/src/tool/Creation_Maillage/cmhoma.F @@ -0,0 +1,275 @@ + subroutine cmhoma ( noehom, arehom, + > somare, filare, hetare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - HOMologues - les Aretes +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noehom . es . nbnoto . ensemble des noeuds homologues . +c . arehom . es . nbarto . ensemble des aretes homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMHOMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto), arehom(nbarto) + integer somare(2,nbarto), filare(nbarto), hetare(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer a21, a22, a11, a12, s11, s12, s21, s22, s2m, s1m + integer larete + integer areh +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Le noeud'',i10,'' est homologue du noeud'',i10)' + texte(1,5) = + > '(''Le '',a,i10,'' devrait etre homologue du '',a,i10)' + texte(1,6) = '(''alors que les tables indiquent que :'')' + texte(1,7) = '(''Arete'',i10,'' de sommets'',2i10)' +c + texte(2,4) = '(''Node #'',i10,'' is homologous of node #'',i10)' + texte(2,5) = + >'(''The '',a,''#'',i10,'' should be homologous of '',a,''#'',i10)' + texte(2,6) = '(''but tables indicate that :'')' + texte(2,7) = '(''Edge #'',i10,'' with vertices #'',2i10)' +c +c==== +c 2. on boucle uniquement sur les aretes de la face periodique 2 +c qui viennent d'etre decoupees en 2 +c==== +c + do 21, larete = 1 , nbarpe +cgn print *,' ' +cgn print *,'larete = ',larete +c + if ( arehom(larete).gt.0 ) then +c +c larete est sur la face periodique 2 +c + if ( hetare(larete).eq.2 ) then +cgn print *,'.. larete est coupee en 2' +c +c 2.1. ==> les entites liees a l'arete courante, larete : +c . sommets de l'arete mere +c . les aretes filles +c . le nouveau noeud +c . l'arete homologue de la mere +c +c s21 larete s22 +c x-----------.-----------x +c a21 s2m a22 +c + s21 = somare(1,larete) + s22 = somare(2,larete) +c + a21 = filare(larete) + a22 = a21 + 1 +c + s2m = somare(2,a21) +c + areh = arehom(larete) +cgn if ( larete.eq.50)then +cgn print *,'.. sommets de larete : ',s21,s22 +cgn print *,'.. filles de larete : ',a21,a22 +cgn print *,'.. homologue de larete : ',arehom(larete) +cgn endif +c + if ( larete.eq.areh ) then +c +c 2.2. ==> si on est sur l'axe : les deux aretes filles et le nouveau +c noeud sont homologues d'eux memes +c par convention, ils sont notes positifs. +c + if ( noehom(s2m).ne.0 ) then + if ( abs(noehom(s2m)).ne.s2m ) then +c il y a un probleme : la table est deja remplie + write (ulsort,texte(langue,5)) mess14(langue,1,-1), + > s2m, mess14(langue,1,-1), s2m + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,4)) s2m, noehom(s2m) + codret = 2 + endif + endif +c + noehom(s2m) = s2m +c + arehom(a21) = a21 + arehom(a22) = a22 +c + else +c +c 2.3. ==> on n'est pas sur l'axe : il faut les entites liees a l'arete +c homologue, areh : +c . sommets de l'arete mere +c . les aretes filles +c . le nouveau noeud +c +c s11 areh s12 +c x-----------.-----------x +c a11 s1m a12 +c + s11 = somare(1,areh) + s12 = somare(2,areh) +c + a11 = filare(areh) + a12 = a11 + 1 +c + s1m = somare(2,a11) +c +c les 2 nouveaux noeuds sommets doivent etre homologues +c s2m est sur la meme face que "larete" c'est-a-dire la face 2 +c donc noehom(s2m) est positif. +c s1m est sur l'autre face, donc noehom(s1m) est negatif +c + if ( noehom(s2m).ne.0 ) then + if ( abs(noehom(s2m)).ne.s1m ) then +c il y a un probleme : la table est deja remplie + write (ulsort,texte(langue,5)) mess14(langue,1,-1), + > s1m, mess14(langue,1,-1), s2m + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,4)) s1m, noehom(s1m) + write (ulsort,texte(langue,4)) s2m, noehom(s2m) + codret = 2 + endif + endif +c + noehom(s2m) = s1m + noehom(s1m) = -s2m +c +c on repere les homologues des aretes +c on utilise le fait que noehom(s21) > 0 car s21 est +c sur la face 2 +c + if ( noehom(s21).eq.s11 ) then +c +c la premiere fille de larete est homologue a +c la premiere fille de areh +c + arehom(a21) = a11 + arehom(a11) = -a21 + arehom(a22) = a12 + arehom(a12) = -a22 +c + elseif ( noehom(s21).eq.s12 ) then +c +c la premiere fille de larete est homologue a +c la deuxieme fille de areh +c + arehom(a21) = a12 + arehom(a11) = -a22 + arehom(a22) = a11 + arehom(a12) = -a21 +c + else +c il y a un probleme : la correspondance sur les noeuds +c n'est pas coherente avec la correspondance sur les aretes + write (ulsort,texte(langue,5)) mess14(langue,1,1), + > larete, mess14(langue,1,1), areh + write (ulsort,texte(langue,7)) larete, s21, s22 + write (ulsort,texte(langue,7)) areh, s11, s12 + write (ulsort,texte(langue,4)) s21, noehom(s21) + write (ulsort,texte(langue,4)) s22, noehom(s22) + write (ulsort,texte(langue,4)) s11, noehom(s11) + write (ulsort,texte(langue,4)) s12, noehom(s12) + codret = 2 + endif +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmhomo.F b/src/tool/Creation_Maillage/cmhomo.F new file mode 100644 index 00000000..75ae5232 --- /dev/null +++ b/src/tool/Creation_Maillage/cmhomo.F @@ -0,0 +1,270 @@ + subroutine cmhomo ( noehom, arehom, trihom, quahom, + > somare, filare, hetare, np2are, + > aretri, filtri, hettri, + > arequa, filqua, hetqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - HOMOlogues +c - - ---- +c ______________________________________________________________________ +c +c but : mise a jour des tables d'homologues +c +c remarque importante : reperage des elements homologues +c on prend la convention de reperage suivante : lorsque +c l'on a deux faces periodiques 1 et 2, on attribue un signe a +c chacune des faces. pour un noeud "i", noehom(i) est alors egal +c a la valeur suivante : +c - "le numero du noeud correspondant par periodicite +c si i est sur la face 2" +c - "l'oppose du numero du noeud correspondant par periodicite +c si i est sur la face 1" +c +c Donc, on etend cette convention a toutes les entites noeuds, +c aretes, triangles et quadrangles : +c enthom(i) = abs(homologue(i)) ssi i est sur la face 2 +c enthom(i) = -abs(homologue(i)) ssi i est sur la face 1 +c pour une entite situee sur l'axe, on prend la convention positive. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noehom . es . nbnoto . ensemble des noeuds homologues . +c . arehom . es . nbarto . ensemble des aretes homologues . +c . trihom . es . nbtrto . ensemble des triangles homologues . +c . quahom . es . nbquto . ensemble des quadrangles homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMHOMO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto), arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer somare(2,nbarto), filare(nbarto), hetare(nbarto) + integer np2are(nbarto) + integer aretri(nbtrto,3), filtri(nbtrto), hettri(nbtrto) + integer arequa(nbquto,4), filqua(nbquto), hetqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer areh +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. les tables des aretes +c il faut commencer par les aretes pour pouvoir traiter les tables +c des faces ensuite +c==== +c +cgn print *,'debut de ', nompro +cgn print *,'trihom' +cgn print 1788,(trihom(iaux),iaux=1,16) +cgn print *,'quahom' +cgn print 1787,(quahom(iaux),iaux=1,8) +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,50) +cgn print *,'noehom' +cgn print 1789,(noehom(iaux),iaux=1,27) +cgn 1787 format(4I4) +cgn 1788 format(8I4) +cgn 1789 format(10I4) + if (codret.eq.0 ) then +c + if ( homolo.ge.2 ) then +c + call cmhoma ( noehom, arehom, + > somare, filare, hetare, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. les tables des triangles +c==== +c + if (codret.eq.0 ) then +c + if ( homolo.ge.3 .and. nbtrto.ne.0 ) then +c + call cmhomt ( arehom, trihom, + > somare, + > aretri, filtri, hettri, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. les tables des quadrangles et complements sur les triangles +c==== +c + if (codret.eq.0 ) then +c + if ( homolo.ge.3 .and. nbquto.ne.0 ) then +c + call cmhomq ( noehom, arehom, trihom, quahom, + > somare, aretri, + > arequa, filqua, hetqua, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. les noeuds milieux en degre 2 +c on n'examine que les aretes tracees sur la face periodique 2 +c comme d'habitude, attention a l'axe ... +c==== +c + if ( codret.eq.0 ) then +c + if ( homolo.ge.2 ) then +c + if ( degre.eq.2 ) then +c + do 51, iaux = 1, nbarto +c + if ( arehom(iaux).gt.0 ) then +c + areh = arehom(iaux) +c + noehom(np2are(iaux)) = np2are(areh) + if ( iaux.ne.areh ) then + noehom(np2are(areh)) = -np2are(iaux) + endif +c + endif +c + 51 continue +c + endif +c + endif +c + endif +c +c==== +c 6. decompte du nombre de paires d'entites homologues +c==== +c + if ( codret.eq.0 ) then +c + call uthonh ( noehom, arehom, + > trihom, quahom, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +cgn print *,'fin de ', nompro +cgn print *,'trihom' +cgn print 1789,(trihom(iaux),iaux=1,nbtrto) +cgn print *,'quahom' +cgn print 1789,(quahom(iaux),iaux=1,nbquto) +cgn print *,'arehom' +cgn print 1789,(arehom(iaux),iaux=1,nbarto) +cgn print *,'noehom' +cgn print 1789,(noehom(iaux),iaux=1,nbnoto) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmhomq.F b/src/tool/Creation_Maillage/cmhomq.F new file mode 100644 index 00000000..2db1eb05 --- /dev/null +++ b/src/tool/Creation_Maillage/cmhomq.F @@ -0,0 +1,411 @@ + subroutine cmhomq ( noehom, arehom, trihom, quahom, + > somare, aretri, + > arequa, filqua, hetqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - HOMologues - les Quadrangles +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noehom . es . nbnoto . ensemble des noeuds homologues . +c . arehom . es . nbarto . ensemble des aretes homologues . +c . trihom . es . nbtrto . ensemble des triangles homologues . +c . quahom . es . nbquto . ensemble des quadrangles homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMHOMQ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto), arehom(nbarto) + integer trihom(nbtrto), quahom(nbquto) + integer somare(2,nbarto), aretri(nbtrto,3) + integer arequa(nbquto,4), filqua(nbquto), hetqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad + integer fach + integer hist, etafac + integer a2(4), n2f1(4), a2nin0(4), n20 + integer a1(4), n1f1(4), a1nin0(4), n10 + integer perma1, perma2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Etat du '',a,i10,'' : '',i4)' + texte(1,5) = '(/,''Les deux '',a,'' homologues'',2i10)' + texte(1,6) = '(''devraient etre coupes en 3.'')' + texte(1,7) = '(''Il faudrait l''''arete'',i10,'' ou '',i10)' + texte(1,9) = '(''Arete'',i10,'' de sommets'',2i10)' + texte(1,10) = '(5x,''Erreur sur les '',a,'' homologues.'')' +c + texte(2,4) = '(''State of '',a,'' #'',i10,'' : '',i4)' + texte(2,5) = '(/,''The two homologous '',a,'' #'',i10)' + texte(2,6) = '(''should be cut into 3.'')' + texte(2,7) = '(''It should be edge #'',i10,'' or #'',i10)' + texte(2,9) = '(''Edge #'',i10,'' with vertices #'',2i10)' + texte(2,10) = '(5x,''Error for homologous '',a)' +c +cgn 1788 format(a,i6,' : ',10i6) +cgn 1789 format(10i6) +cgn write(ulsort,*)'hetqua' +cgn write(ulsort,1789)hetqua +cgn write(ulsort,*)'filqua' +cgn write(ulsort,1789)filqua +cgn write(ulsort,*)'noehom' +cgn write(ulsort,1789)noehom +cgn write(ulsort,*)'arehom' +cgn write(ulsort,1789)arehom +cgn write(ulsort,*)'trihom' +cgn write(ulsort,1789)trihom +cgn write(ulsort,*)'quahom' +cgn write(ulsort,1789)quahom +c==== +c 2. on boucle uniquement sur les quadrangles de la face periodique 2 +c qui viennent d'etre decoupes en 2 ou en 4 quadrangles ou en +c 3 triangles +c on se rapportera a cmrdqu pour les conventions +c==== +c + do 21, lequad = 1, nbqupe +c + if ( codret.eq.0 ) then +c + if ( quahom(lequad).gt.0 ) then +c + fach = abs(quahom(lequad)) +c + hist = hetqua(lequad) + etafac = mod ( hist, 100 ) +cgn write(ulsort,*)'lequad, hist, etafac = ',lequad, hist,etafac +c + if ( etafac.eq.4 ) then +c +c 2.1. ==> le quadrangle vient d'etre decoupe en 4 +c +c 2.1.1. ==> infos sur lequad et ses fils +c + a2(1) = arequa(lequad,1) + a2(2) = arequa(lequad,2) + a2(3) = arequa(lequad,3) + a2(4) = arequa(lequad,4) +c + n2f1(1) = filqua(lequad) + n2f1(2) = n2f1(1) + 1 + n2f1(3) = n2f1(2) + 1 + n2f1(4) = n2f1(3) + 1 + a2nin0(1) = arequa(n2f1(1),2) + a2nin0(2) = arequa(n2f1(2),2) + a2nin0(3) = arequa(n2f1(3),2) + a2nin0(4) = arequa(n2f1(4),2) + n20 = somare(2,a2nin0(1)) +c +c 2.1.2. ==> infos sur l'homologue de lequad et ses fils +c + a1(1) = arequa(fach,1) + a1(2) = arequa(fach,2) + a1(3) = arequa(fach,3) + a1(4) = arequa(fach,4) +c + n1f1(1) = filqua(fach) + n1f1(2) = n1f1(1) + 1 + n1f1(3) = n1f1(2) + 1 + n1f1(4) = n1f1(3) + 1 + a1nin0(1) = arequa(n1f1(1),2) + a1nin0(2) = arequa(n1f1(2),2) + a1nin0(3) = arequa(n1f1(3),2) + a1nin0(4) = arequa(n1f1(4),2) + n10 = somare(2,a1nin0(1)) +c +cgn write(ulsort,*) 'face 2' +cgn write(ulsort,1789) a2(1), a2(2), a2(3), a2(4) +cgn write(ulsort,1789) n2f1 +cgn write(ulsort,1789) a2nin0 +cgn write(ulsort,1789) n20 +cgn write(ulsort,*) 'face 1' +cgn write(ulsort,1789) a1(1), a1(2), a1(3), a1(4) +cgn write(ulsort,1789) n1f1 +cgn write(ulsort,1789) a1nin0 +cgn write(ulsort,1789) n10 +c +c 2.1.3. ==> reperage des homologues +c +c 2.1.3.1. ==> recherche du positionnement relatif des deux quadrangles +c peres homologues +c perma1 : numero de la permutation sur les aretes a1(1) et a1(3) +c perma2 : numero de la permutation sur les aretes a1(2) et a1(4) +c +c a1(4) a2(4) +c .________. .________. +c . . . . +c . . . . +c a1(1). .a1(3) a2(1). .a2(3) +c . . . . +c .________. .________. +c a1(2) a2(2) +c + perma1 = 100 + perma2 = 100 +c + if ( arehom(a2(1)).eq.a1(1) ) then + perma1 = 0 + if ( arehom(a2(2)).eq.a1(2) ) then + perma2 = 0 + elseif ( arehom(a2(2)).eq.a1(4) ) then + perma2 = 2 + endif +c + elseif ( arehom(a2(1)).eq.a1(2) ) then + perma1 = 1 + if ( arehom(a2(2)).eq.a1(3) ) then + perma2 = 1 + elseif ( arehom(a2(2)).eq.a1(1) ) then + perma2 = 3 + endif +c + elseif ( arehom(a2(1)).eq.a1(3) ) then + perma1 = 2 + if ( arehom(a2(2)).eq.a1(4) ) then + perma2 = 2 + elseif ( arehom(a2(2)).eq.a1(2) ) then + perma2 = 4 + endif +c + elseif ( arehom(a2(1)).eq.a1(4) ) then + perma1 = 3 + if ( arehom(a2(2)).eq.a1(1) ) then + perma2 = 3 + elseif ( arehom(a2(2)).eq.a1(3) ) then + perma2 = 1 + endif +c + endif +c + if ( perma1.eq.100 .or. perma2.eq.100 ) then +c + write (ulsort,texte(langue,5)) mess14(langue,3,4), + > lequad, fach + write (ulsort,texte(langue,9)) a2(1), + > somare(1,a2(1)), somare(2,a2(1)) + write (ulsort,texte(langue,9)) a2(1), arehom(a2(1)) + codret = 2 +c + endif +cgn write(ulsort,*)'perma1, perma2',perma1, perma2 +c +c 2.1.3.2. ==> remplissage des tables +c + if ( codret.eq.0 ) then +c + iaux = per1a4(perma1,1) + quahom(n2f1(1)) = n1f1(iaux) + quahom(n1f1(iaux)) = -n2f1(1) + arehom(a2nin0(1)) = a1nin0(iaux) + arehom(a1nin0(iaux)) = -a2nin0(1) +c + iaux = per1a4(perma2,2) + quahom(n2f1(2)) = n1f1(iaux) + quahom(n1f1(iaux)) = -n2f1(2) + arehom(a2nin0(2)) = a1nin0(iaux) + arehom(a1nin0(iaux)) = -a2nin0(2) +c + iaux = per1a4(perma1,3) + quahom(n2f1(3)) = n1f1(iaux) + quahom(n1f1(iaux)) = -n2f1(3) + arehom(a2nin0(3)) = a1nin0(iaux) + arehom(a1nin0(iaux)) = -a2nin0(3) +c + iaux = per1a4(perma2,4) + quahom(n2f1(4)) = n1f1(iaux) + quahom(n1f1(iaux)) = -n2f1(4) + arehom(a2nin0(4)) = a1nin0(iaux) + arehom(a1nin0(iaux)) = -a2nin0(4) +c + noehom(n20) = n10 + noehom(n10) = -n20 +c + endif +c + elseif ( etafac.eq.31 .or. etafac.eq.32 .or. + > etafac.eq.33 .or. etafac.eq.34 ) then +c +c 2.2. ==> le quadrangle vient d'etre decoupe en 3 triangles +c +c 2.2.1. ==> infos sur lequad et ses fils +c + n2f1(1) = -filqua(lequad) + n2f1(2) = n2f1(1) + 1 + n2f1(3) = n2f1(2) + 1 + a2nin0(1) = aretri(n2f1(1),1) + a2nin0(2) = aretri(n2f1(1),3) + a2nin0(3) = aretri(n2f1(2),1) +c +c 2.2.2. ==> infos sur l'homologue de lequad et ses fils +c + n1f1(1) = -filqua(fach) + n1f1(2) = n1f1(1) + 1 + n1f1(3) = n1f1(2) + 1 + a1nin0(1) = aretri(n1f1(1),1) + a1nin0(2) = aretri(n1f1(1),3) + a1nin0(3) = aretri(n1f1(2),1) + a1nin0(4) = aretri(n1f1(3),1) +c +cgn write(ulsort,*) 'face 2' +cgn write(ulsort,1788) 'fils de ',lequad,n2f1(1), n2f1(2), n2f1(3) +cgn write(ulsort,1788) 'aretes des fils de ',lequad, +cgn > a2nin0(1), a2nin0(2), a2nin0(3) +cgn write(ulsort,*) 'face 1' +cgn write(ulsort,1788) 'fils de ',fach,n1f1(1), n1f1(2), n1f1(3) +cgn write(ulsort,1788) 'aretes des fils de ',fach, +cgn > a1nin0 +cgn write(ulsort,1789) arehom(a2nin0(3)) +c +c 2.2.3. ==> reperage des homologues +c + trihom(n2f1(1)) = n1f1(1) + trihom(n1f1(1)) = -n2f1(1) +c + if ( arehom(a2nin0(3)).eq.a1nin0(3) ) then +c + arehom(a2nin0(1)) = a1nin0(1) + arehom(a1nin0(1)) = -a2nin0(1) + arehom(a2nin0(2)) = a1nin0(2) + arehom(a1nin0(2)) = -a2nin0(2) + trihom(n2f1(2)) = n1f1(2) + trihom(n1f1(2)) = -n2f1(2) + trihom(n2f1(3)) = n1f1(3) + trihom(n1f1(3)) = -n2f1(3) +c + elseif ( arehom(a2nin0(3)).eq.a1nin0(4) ) then +c + arehom(a2nin0(1)) = a1nin0(2) + arehom(a1nin0(2)) = -a2nin0(1) + arehom(a2nin0(2)) = a1nin0(1) + arehom(a1nin0(1)) = -a2nin0(2) + trihom(n2f1(2)) = n1f1(3) + trihom(n1f1(3)) = -n2f1(2) + trihom(n2f1(3)) = n1f1(2) + trihom(n1f1(2)) = -n2f1(3) +c + else +c + write (ulsort,texte(langue,5)) mess14(langue,3,4), + > lequad, fach + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,4)) mess14(langue,1,4), + > lequad, hetqua(lequad) + write (ulsort,texte(langue,4)) mess14(langue,1,4), + > fach, hetqua(fach) + codret = 2 +c + endif +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +cgn write(ulsort,*)'noehom' +cgn write(ulsort,1789)noehom +cgn write(ulsort,*)'arehom' +cgn write(ulsort,1789)arehom +cgn write(ulsort,*)'trihom' +cgn write(ulsort,1789)trihom +cgn write(ulsort,*)'quahom' +cgn write(ulsort,1789)quahom +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmhomt.F b/src/tool/Creation_Maillage/cmhomt.F new file mode 100644 index 00000000..4e45259f --- /dev/null +++ b/src/tool/Creation_Maillage/cmhomt.F @@ -0,0 +1,556 @@ + subroutine cmhomt ( arehom, trihom, + > somare, + > aretri, filtri, hettri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - HOMologues - les Triangles +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arehom . es . nbarto . ensemble des aretes homologues . +c . trihom . es . nbtrto . ensemble des triangles homologues . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMHOMT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "demitr.h" +#include "nombar.h" +#include "nombtr.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer arehom(nbarto), trihom(nbtrto) + integer somare(2,nbarto) + integer aretri(nbtrto,3), filtri(nbtrto), hettri(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letria + integer fach + integer hist, etafac, etafho, an2, an1, n2f, n1f + integer a2f1, a2f2, a2f3, a1f1, a1f2, a1f3 + integer f2k, f2j, f1k, f1j + integer na2k, na1k, na1j + integer a2s2s3, a2s1s3 + integer a1s1s2, a1s2s3, a1s1s3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Etat du '',a,i10,'' : '',i4)' + texte(1,5) = '(/,''Les deux '',a,'' homologues'',2i10)' + texte(1,6) = '(''devraient etre coupes en 2.'')' + texte(1,7) = '(''Elle a pour homologue '',i10)' + texte(1,8) = '(''Il faudrait l''''arete'',i10,'' ou '',i10)' + texte(1,9) = '(''Arete'',i10,'' de sommets'',2i10)' + texte(1,10) = '(5x,''Erreur sur les '',a,'' homologues.'')' +c + texte(2,4) = '(''State of '',a,'' #'',i10,'' : '',i4)' + texte(2,5) = '(/,''The two homologous '',a,'' #'',i10)' + texte(2,6) = '(''should be cut into 2.'')' + texte(2,7) = '(''Its homologous is ''i10)' + texte(2,8) = '(''It should be edge #'',i10,'' or #'',i10)' + texte(2,9) = '(''Edge #'',i10,'' with vertices #'',2i10)' + texte(2,10) = '(5x,''Error for homologous '',a)' +c +c==== +c 2. on boucle uniquement sur les triangles de la face periodique 2 +c qui viennent d'etre decoupes en 2 ou en 4 +c==== +c + do 21, letria = 1, nbtrpe +c + if ( trihom(letria).gt.0 ) then +c + hist = hettri(letria) + etafac = mod ( hist, 10 ) +c + if ( hist.eq. 4 .or. hist.eq.14 .or. + > hist.eq.24 .or. hist.eq.34 ) then +c + fach = abs(trihom(letria)) +c +c 2.1. ==> le triangle vient d'etre decoupe en 4 +c +c 2.1.1. ==> recuperation des infos sur les fils de letria +c + n2f = filtri(letria) +c +c recuperation des numeros d'aretes +c + a2s2s3 = aretri(letria,1) + a2s1s3 = aretri(letria,2) +c +c recuperation des aretes internes +c + a2f1 = aretri(n2f,1) + a2f2 = aretri(n2f,2) + a2f3 = aretri(n2f,3) +c +c 2.1.2. ==> recuperation des infos sur le triangle homologue +c + n1f = filtri(fach) +c +c recuperation des numeros d'aretes +c + a1s1s2 = aretri(fach,3) + a1s2s3 = aretri(fach,1) + a1s1s3 = aretri(fach,2) +c +c recuperation des aretes internes +c + a1f1 = aretri(n1f,1) + a1f2 = aretri(n1f,2) + a1f3 = aretri(n1f,3) +c +c 2.1.3. ==> reperage des homologues +c +c dans tous les cas on a correspondance entre +c les triangles n2f et n1f, fils aines. +c n2f est sur la meme face que "larete" c'est-a-dire la face 2 +c donc noehom(n2f) est positif. +c s1f est sur l'autre face, donc noehom(s1f) est negatif +c + trihom(n2f) = n1f + trihom(n1f) = -n2f +c + if ( abs(arehom(a2s2s3)).eq.a1s2s3 ) then +c +c les aretes 1 correspondent donc on a correspondance entre +c les triangles n2f+1 et n1f+1 +c les aretes a2f1 et a1f1 +c + arehom(a2f1) = a1f1 + arehom(a1f1) = -a2f1 +c + trihom(n2f+1) = (n1f+1) + trihom(n1f+1) = -(n2f+1) +c + if ( abs(arehom(a2s1s3)).eq.a1s1s3 ) then +c +c les aretes 2 correspondent donc +c on a correspondance entre +c les triangles n2f+2 et n1f+2 +c les triangles n2f+3 et n1f+3 +c les aretes a2f2 et a1f2 +c les aretes a2f3 et a1f3 +c + arehom(a2f2) = a1f2 + arehom(a1f2) = -a2f2 + arehom(a2f3) = a1f3 + arehom(a1f3) = -a2f3 +c + trihom(n2f+2) = (n1f+2) + trihom(n1f+2) = -(n2f+2) + trihom(n2f+3) = (n1f+3) + trihom(n1f+3) = -(n2f+3) +c + else +c +c les aretes 2 et 3 correspondent +c donc on a correspondance entre +c les triangles n2f+2 et n1f+3 +c les triangles n2f+3 et n1f+2 +c les aretes a2f2 et a1f3 +c les aretes a2f3 et a1f2 +c + arehom(a2f2) = a1f3 + arehom(a1f3) = -a2f2 + arehom(a2f3) = a1f2 + arehom(a1f2) = -a2f3 +c + trihom(n2f+2) = (n1f+3) + trihom(n1f+3) = -(n2f+2) + trihom(n2f+3) = (n1f+2) + trihom(n1f+2) = -(n2f+3) +c + endif +c + elseif ( abs(arehom(a2s2s3)).eq.a1s1s3 ) then +c +c les aretes 1 et 2 correspondent +c donc on a correspondance entre +c les triangles n2f+1 et n1f+2 +c les aretes a2f1 et a1f2 +c + arehom(a2f1) = a1f2 + arehom(a1f2) = -a2f1 +c + trihom(n2f+1) = (n1f+2) + trihom(n1f+2) = -(n2f+1) +c + if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then +c +c les aretes 2 et 1 correspondent +c donc on a correspondance entre +c les triangles n2f+2 et n1f+1 +c les triangles n2f+3 et n1f+3 +c les aretes a2f2 et a1f1 +c les aretes a2f3 et a1f3 +c + arehom(a2f2) = a1f1 + arehom(a1f1) = -a2f2 + arehom(a2f3) = a1f3 + arehom(a1f3) = -a2f3 +c + trihom(n2f+2) = (n1f+1) + trihom(n1f+1) = -(n2f+2) + trihom(n2f+3) = (n1f+3) + trihom(n1f+3) = -(n2f+3) +c + else +c +c les aretes 2 et 3 correspondent +c donc on a correspondance entre +c les triangles n2f+2 et n1f+3 +c les triangles n2f+3 et n1f+1 +c les aretes a2f2 et a1f3 +c les aretes a2f3 et a1f1 +c + arehom(a2f2) = a1f3 + arehom(a1f3) = -a2f2 + arehom(a2f3) = a1f1 + arehom(a1f1) = -a2f3 +c + trihom(n2f+2) = (n1f+3) + trihom(n1f+3) = -(n2f+2) + trihom(n2f+3) = (n1f+1) + trihom(n1f+1) = -(n2f+3) +c + endif +c + elseif ( abs(arehom(a2s2s3)).eq.a1s1s2 ) then +c +c les aretes 1 et 3 correspondent +c donc on a correspondance entre +c les triangles n2f+1 et n1f+3 +c les aretes a2f1 et a1f3 +c + arehom(a2f1) = a1f3 + arehom(a1f3) = -a2f1 +c + trihom(n2f+1) = (n1f+3) + trihom(n1f+3) = -(n2f+1) +c + if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then +c +c les aretes 2 et 1 correspondent +c donc on a correspondance entre +c les triangles n2f+2 et n1f+1 +c les triangles n2f+3 et n1f+2 +c les aretes a2f2 et a1f1 +c les aretes a2f3 et a1f2 +c + arehom(a2f2) = a1f1 + arehom(a1f1) = -a2f2 + arehom(a2f3) = a1f2 + arehom(a1f2) = -a2f3 +c + trihom(n2f+2) = (n1f+1) + trihom(n1f+1) = -(n2f+2) + trihom(n2f+3) = (n1f+2) + trihom(n1f+2) = -(n2f+3) +c + else +c +c les aretes 2 correspondent +c donc on a correspondance entre +c les triangles n2f+2 et n1f+2 +c les triangles n2f+3 et n1f+1 +c les aretes a2f2 et a1f3 +c les aretes a2f3 et a1f1 +c + arehom(a2f2) = a1f2 + arehom(a1f2) = -a2f2 + arehom(a2f3) = a1f1 + arehom(a1f1) = -a2f3 +c + trihom(n2f+2) = (n1f+2) + trihom(n1f+2) = -(n2f+2) + trihom(n2f+3) = (n1f+1) + trihom(n1f+1) = -(n2f+3) +c + endif +c + else + write (ulsort,texte(langue,10)) mess14(langue,3,2) + endif +c + elseif ( etafac.eq.1 .or. etafac.eq.2 .or. etafac.eq.3 ) then +c +c 2.2. ==> le triangle vient d'etre decoupe en 2 +c . il n'y a aucune regle d'ordre de creation des +c demi-triangles entre les deux meres homologues. +c . il n'y a pas de probleme d'axe a gerer, car letria est +c sur la face 2 par hypothese, et donc fach sur la face 1 +c . la seule information dont on est certain est la +c correspondance entre les filles des aretes decoupees : le +c tableau arehom a ete mis a jour precedemment +c +c letria fach +c +c s2i s1i +c x x +c ... ... +c . . . . . . +c are2j . . . are2k <--> are1j . . . are1k +c . a. . . a. . +c . n. . . n. . +c . 2. . . 1. . +c . f2k . f2j . . f1k . f1j . +c . . . . . . +c x-----------------x x-----------------x +c s2k na2k n2 na2j s2j s1k na1k n1 na1j s1j +c +c alternative : f2k est homologue de f1k +c ou : f2k est homologue de f1j +c +c 2.2.1. ==> recuperation des infos sur les fils de letria +c + if ( etafac.eq.1 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 1 +c +c recuperation des triangles fils +c + f2k = filtri(letria) + nutrde(1,2) + f2j = filtri(letria) + nutrde(1,3) +c +c recuperation des nouvelles aretes +c + na2k = aretri(f2k,1) +c + an2 = aretri(f2k,3) +c + elseif ( etafac.eq.2 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 2 +c +c recuperation des triangles fils +c + f2k = filtri(letria) + nutrde(2,3) + f2j = filtri(letria) + nutrde(2,1) +c +c recuperation des nouvelles aretes +c + na2k = aretri(f2k,2) +c + an2 = aretri(f2k,1) +c + elseif ( etafac.eq.3 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 3 +c +c recuperation des triangles fils +c + f2k = filtri(letria) + nutrde(3,1) + f2j = filtri(letria) + nutrde(3,2) +c +c recuperation des nouvelles aretes +c + na2k = aretri(f2k,3) +c + an2 = aretri(f2k,2) +c + endif +c +c 2.2.2. ==> recuperation des infos sur le triangle homologue +c + fach = abs(trihom(letria)) +c + etafho = mod ( hettri(fach), 10 ) +c + if ( etafho.eq.1 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 1 +c +c recuperation des triangles fils +c + f1k = filtri(fach) + nutrde(1,2) + f1j = filtri(fach) + nutrde(1,3) +c +c recuperation des nouvelles aretes +c + na1k = aretri(f1k,1) + na1j = aretri(f1j,1) +c + an1 = aretri(f1k,3) +c + elseif ( etafho.eq.2 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 2 +c +c recuperation des triangles fils +c + f1k = filtri(fach) + nutrde(2,3) + f1j = filtri(fach) + nutrde(2,1) +c +c recuperation des nouvelles aretes +c + na1k = aretri(f1k,2) + na1j = aretri(f1j,2) +c + an1 = aretri(f1k,1) +c + elseif ( etafho.eq.3 ) then +c +c le triangle a ete decoupe en 2 par l'arete numero 3 +c +c recuperation des triangles fils +c + f1k = filtri(fach) + nutrde(3,1) + f1j = filtri(fach) + nutrde(3,2) +c +c recuperation des nouvelles aretes +c + na1k = aretri(f1k,3) + na1j = aretri(f1j,3) +c + an1 = aretri(f1k,2) +c + else +c +c le triangle homologue n'est pas coupe en deux ??? +c + write (ulsort,texte(langue,5))mess14(langue,3,2), + > letria, fach + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,4)) mess14(langue,1,2), + > letria, etafac + write (ulsort,texte(langue,4)) mess14(langue,1,2), + > fach, etafho + codret = 2 +c + endif +c +c 2.2.3. ==> reperage des homologues +c + arehom(an2) = an1 + arehom(an1) = -an2 +c + if ( arehom(na2k).eq.na1k ) then +c + trihom(f2k) = f1k + trihom(f2j) = f1j + trihom(f1k) = -f2k + trihom(f1j) = -f2j +c + elseif ( arehom(na2k).eq.na1j ) then +c + trihom(f2k) = f1j + trihom(f2j) = f1k + trihom(f1k) = -f2j + trihom(f1j) = -f2k +c + else +c +c l'arete n'a pas d'homologue ? +c + write (ulsort,texte(langue,5)) mess14(langue,3,2), + > letria, fach + write (ulsort,texte(langue,9)) + > na2k, somare(1,na2k), somare(2,na2k) + write (ulsort,texte(langue,7)) arehom(na2k) + if ( arehom(na2k).ne.0 ) then + write (ulsort,texte(langue,9)) abs(arehom(na2k)), + > somare(1,abs(arehom(na2k))), somare(2,abs(arehom(na2k))) + endif + write (ulsort,texte(langue,8)) na1k, na1j + write (ulsort,texte(langue,9)) + > na1k, somare(1,na1k), somare(2,na1k) + write (ulsort,texte(langue,9)) + > na1j, somare(1,na1j), somare(2,na1j) + codret = 2 +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmin00.F b/src/tool/Creation_Maillage/cmin00.F new file mode 100644 index 00000000..0be1f1bc --- /dev/null +++ b/src/tool/Creation_Maillage/cmin00.F @@ -0,0 +1,306 @@ + subroutine cmin00 ( option, + > degre, homolo, + > eancno, nbnoan, nbnono, + > eancar, nbaran, nbarno, + > eanctr, nbtran, nbtrno, + > eancqu, nbquan, nbquno, + > eancte, nbtean, nbteno, + > eanche, nbhean, nbheno, + > eancpe, nbpean, nbpeno, + > eancpy, nbpyan, nbpyno, + > decfac, + > ancnoe, noehom, + > ancare, arehom, np2are, + > anctri, trihom, + > ancqua, quahom, + > anctet, anchex, + > ancpen, ancpyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - INitialisation - 00 +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . type de traitement . +c . . . . 0 : raffinement . +c . . . . 1 : deraffinement . +c . . . . 2 : conformite . +c . eancno . e . logique. vrai si ancnoe existe, faux sinon . +c . nbnoan . e . 1 . nombre de noeuds - ancien . +c . nbnono . e . 1 . nombre de noeuds - nouveau . +c . eancar . e . logique. vrai si ancare existe, faux sinon . +c . nbaran . e . 1 . nombre d'aretes - ancien . +c . nbarno . e . 1 . nombre d'aretes - nouveau . +c . eanctr . e . logique. vrai si anctri existe, faux sinon . +c . nbtran . e . 1 . nombre de triangles - ancien . +c . nbtrno . e . 1 . nombre de triangles - nouveau . +c . eancqu . e . logique. vrai si ancqua existe, faux sinon . +c . nbquan . e . 1 . nombre de quadrangles - ancien . +c . nbquno . e . 1 . nombre de quadrangles - nouveau . +c . eancte . e . logique. vrai si anctet existe, faux sinon . +c . nbtean . e . 1 . nombre de tetraedres - ancien . +c . nbteno . e . 1 . nombre de tetraedres - nouveau . +c . eanche . e . logique. vrai si anchex existe, faux sinon . +c . nbhean . e . 1 . nombre d'hexaedres - ancien . +c . nbheno . e . 1 . nombre d'hexaedres - nouveau . +c . eancpe . e . logique. vrai si ancpen existe, faux sinon . +c . nbpean . e . 1 . nombre de pentaedres - ancien . +c . nbpeno . e . 1 . nombre de pentaedres - nouveau . +c . eancpy . e . logique. vrai si ancpyr existe, faux sinon . +c . nbpyan . e . 1 . nombre de pyramides - ancien . +c . nbpyno . e . 1 . nombre de pyramides - nouveau . +c . decfac . es . -nbquno. decision sur les faces (quad. + tri.) . +c . . . :nbtrno. . +c . ancnoe . es . nouvno . ancien numero des noeuds . +c . noehom . es . nbnono . ensemble des noeuds homologues . +c . ancare . es . nouvar . ancien numero des aretes . +c . arehom . es . nbarno . ensemble des aretes homologues . +c . np2are . es . nbarno . numero des noeuds p2 milieux d'aretes . +c . . . . ou 0 lorsqu'on est en degre 1 . +c . anctri . es . nbtrno . ancien numero des triangles . +c . trihom . es . nbtrno . ensemble des triangles homologues . +c . ancqua . es . nbquno . ancien numero des quadrangles . +c . quahom . es . nbquno . ensemble des quadrangles homologues . +c . anctet . es . nbteno . ancien numero des tetraedres . +c . anchex . es . nbheno . ancien numero des hexaedres . +c . ancpen . es . nbpeno . ancien numero des pentaedres . +c . ancpyr . es . nbpyno . ancien numero des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer option + integer degre, homolo +c + logical eancno, eancar, eanctr, eancqu + logical eancte, eanche, eancpe, eancpy + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpean, nbpeno + integer nbpyan, nbpyno +c + integer decfac(-nbquno:nbtrno) + integer ancnoe(nbnono), noehom(nbnono) + integer ancare(nbarno), arehom(nbarno), np2are(nbarno) + integer anctri(nbtrno), trihom(nbtrno) + integer ancqua(nbquno), quahom(nbquno) + integer anctet(nbteno) + integer anchex(nbheno) + integer ancpen(nbpeno) + integer ancpyr(nbpyno) +c +c 0.4. ==> variables locales +c + integer ideb, ifin + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. pas d'ancien numeros pour les futures entites +c==== +c + if ( eancno ) then +c + ideb = nbnoan + 1 + ifin = nbnono +c + do 11 , iaux = ideb , ifin + ancnoe(iaux) = -1 + 11 continue +c + endif +c + if ( eancar ) then +c + ideb = nbaran + 1 + ifin = nbarno +c + do 12 , iaux = ideb , ifin + ancare(iaux) = -1 + 12 continue +c + endif +c + if ( eanctr ) then +c + ideb = nbtran + 1 + ifin = nbtrno +c + do 13 , iaux = ideb , ifin + anctri(iaux) = -1 + 13 continue +c + endif +c + if ( eancqu ) then +c + ideb = nbquan + 1 + ifin = nbquno +c + do 14 , iaux = ideb , ifin + ancqua(iaux) = -1 + 14 continue +c + endif +c + if ( eancte ) then +c + ideb = nbtean + 1 + ifin = nbteno +c + do 15 , iaux = ideb , ifin + anctet(iaux) = -1 + 15 continue +c + endif +c + if ( eanche ) then +c + ideb = nbhean + 1 + ifin = nbheno +c + do 16 , iaux = ideb , ifin + anchex(iaux) = -1 + 16 continue +c + endif +c + if ( eancpe ) then +c + ideb = nbpean + 1 + ifin = nbpeno +c + do 17 , iaux = ideb , ifin + ancpen(iaux) = -1 + 17 continue +c + endif +c + if ( eancpy ) then +c + ideb = nbpyan + 1 + ifin = nbpyno +c + do 18 , iaux = ideb , ifin + ancpyr(iaux) = -1 + 18 continue +c + endif +c +c==== +c 2. mise a zero eventuelle des tables pour le degre 2 +c==== +c + if ( degre.eq.2 ) then +c + ideb = nbaran + 1 + ifin = nbarno +c + do 21 , iaux = ideb , ifin + np2are(iaux) = 0 + 21 continue +c + endif +c +c==== +c 3. mise a zero eventuelle des tables pour les homologues +c==== +c + if ( homolo.ge.1 ) then +c + ideb = nbnoan + 1 + ifin = nbnono +c + do 31 , iaux = ideb , ifin + noehom(iaux) = 0 + 31 continue +c + endif +c + if ( homolo.ge.2 ) then +c + ideb = nbaran + 1 + ifin = nbarno +c + do 32 , iaux = ideb , ifin + arehom(iaux) = 0 + 32 continue +c + endif +c + if ( homolo.ge.3 ) then +c + ideb = nbtran + 1 + ifin = nbtrno +c + do 33 , iaux = ideb , ifin + trihom(iaux) = 0 + 33 continue +c + ideb = nbquan + 1 + ifin = nbquno +c + do 34 , iaux = ideb , ifin + quahom(iaux) = 0 + 34 continue +c + endif +c +c==== +c 4. mise a zero des decisions sur les futures faces +c==== +c + if ( option.eq.0 ) then +c + ideb = nbtran + 1 + ifin = nbtrno +c + do 41 , iaux = ideb , ifin + decfac(iaux) = 0 + 41 continue +c + ideb = -nbquno + ifin = -nbquan - 1 +c + do 42 , iaux = ideb , ifin + decfac(iaux) = 0 + 42 continue +c + endif +c + end diff --git a/src/tool/Creation_Maillage/cminma.F b/src/tool/Creation_Maillage/cminma.F new file mode 100644 index 00000000..65578f85 --- /dev/null +++ b/src/tool/Creation_Maillage/cminma.F @@ -0,0 +1,221 @@ + subroutine cminma ( indnoe, indare, indtri, indqua, + > indtet, indhex, indpyr, indpen, + > lgopti, taopti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - INitialisation du MAillage +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indnoe . s . 1 . indice du dernier noeud cree . +c . indare . s . 1 . indice de la derniere arete creee . +c . indtri . s . 1 . indice du dernier triangle cree . +c . indqua . s . 1 . indice du dernier quadrangle cree . +c . indtet . s . 1 . indice du dernier tetraedre cree . +c . indhex . s . 1 . indice du dernier hexaedre cree . +c . indpyr . s . 1 . indice de la derniere pyramide creee . +c . indpen . s . 1 . indice du dernier pentaedre cree . +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMINMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer indnoe, indare, indtri, indqua + integer indtet, indhex, indpyr, indpen +c + integer lgopti + integer taopti(lgopti) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. initialisation des pointeurs +c Quand le maillage ne change pas, il faut initialiser les pointeurs. +c Cela arrive dans deux cas : +c A l'iteration 0 : si pas de raffinement, quel que soit le type de +c deraffinement car il sera ete inhibe +c Aux iterations suivantes : si ni raffinement, ni deraffinement +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. initial. pointeurs ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbiter', nbiter + write (ulsort,90002) 'taopti(31)', taopti(31) + write (ulsort,90002) 'taopti(32)', taopti(32) +#endif +c + if ( codret.eq.0 ) then +c + if ( ( nbiter.eq.0 .and. taopti(31).eq.0 ) .or. + > ( nbiter.gt.0 .and. + > taopti(31).eq.0 .and. taopti(32).eq.0 ) ) then +c + permno = nbnoto + permp2 = nbnop2 + permim = nbnoim + permar = nbarpe + permtr = nbtrpe + permqu = nbqupe + permte = nbtepe + permhe = nbhepe + permpy = nbpype + permpe = nbpepe +c + nouvno = nbnoto + nouvp2 = nbnop2 + nouvim = nbnoim + nouvar = nbarto + nouvtr = nbtrto + nouvqu = nbquto + nouvte = nbteto + nouvtf = nouvte + nouvta = 0 + nouvhe = nbheto + nouvhf = nouvhe + nouvha = 0 + nouvpy = nbpyto + nouvyf = nouvpy + nouvya = 0 + nouvpe = nbpeto + nouvpf = nouvpe + nouvpa = 0 +c + indnoe = nbnoto + indare = nbarto + indtri = nbtrto + indqua = nbquto + indtet = nbteto + indhex = nbheto + indpyr = nbpyto + indpen = nbpeto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) + >'permar, permtr, permno, permp2, permim, permqu', + > permar, permtr, permno, permp2, permim, permqu + write (ulsort,90002) + >'nouvar, nouvtr, nouvno, nouvp2, nouvim, nouvqu', + > nouvar, nouvtr, nouvno, nouvp2, nouvim, nouvqu + write (ulsort,90002) + >'provar, provtr, provp1, provp2, provim, provqu', + > provar, provtr, provp1, provp2, provim, provqu + write (ulsort,90002) + >'permte, permhe, permpy, permpe', + > permte, permhe, permpy, permpe + write (ulsort,90002) + >'nouvte, nouvhe, nouvpy, nouvpe', + > nouvte, nouvhe, nouvpy, nouvpe + write (ulsort,90002) + >'provta, provha, provya, provpa', + > provta, provha, provya, provpa + write (ulsort,90002) + >'provtf, provhf, provyf, provpf', + > provtf, provhf, provyf, provpf +#endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmmisa.F b/src/tool/Creation_Maillage/cmmisa.F new file mode 100644 index 00000000..e67a0de6 --- /dev/null +++ b/src/tool/Creation_Maillage/cmmisa.F @@ -0,0 +1,723 @@ + subroutine cmmisa ( nomail, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - MISe A jour de la structure de donnees +c - - --- - +c ______________________________________________________________________ +c +c but : mise a jour de la structure de donnees pour le maillage adapte +c dont : +c - reconstruction des voisinages +c - traitement des homologues +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMMISA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "envada.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux, jaux +c + integer codre0, codre1, codre2, codre3, codre4 + integer codre5, codre6, codre7, codre8 + integer phetno, pcoono + integer psomar, phetar, pfilar, pnp2ar + integer pposif, pfacar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer ptrite, phette, pfilte + integer pquahe, phethe, pfilhe + integer pfacpy, phetpy, pfilpy + integer pfacpe, phetpe, pfilpe + integer adhono, adhoar, adhotr, adhoqu + integer numead +c + integer nvacar, nvactr, nvacqu, nvacte, nvache, nvacpy, nvacpe + integer vofaar, vovofa +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*14 saux14 +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' MISE A JOUR DES DONNEES DU MAILLAGE ADAPTE'')' + texte(1,5) = '(49(''=''),/)' +c + texte(1,6) = '(5x,''Nombre de noeuds :'',i10)' + texte(1,7) = '(5x,''Nombre de '',a,'' actifs :'',i10)' + texte(1,8) = '(5x,''Niveau minimum des '',a,'':'',i10)' + texte(1,9) = '(5x,''Niveau minimum des '',a,'':'',i10,''.5'')' + texte(1,10) = '(5x,''Niveau maximum des '',a,'':'',i10)' + texte(1,11) = '(5x,''Niveau maximum des '',a,'':'',i10,''.5'')' +c + texte(2,4) = '(/,a6,'' UPDATING OF DATA ON ADAPTED MESH'')' + texte(2,5) = '(39(''=''),/)' + texte(2,6) = '(5x,''Number of nodes :'',i10)' + texte(2,7) = '(5x,''Number of active '',a,'':'',i10)' + texte(2,8) = '(5x,''Minimum level of '',a,'':'',i10)' + texte(2,9) = '(5x,''Minimum level of '',a,'':'',i10,''.5'')' + texte(2,10) = '(5x,''Maximum level of '',a,'':'',i10)' + texte(2,11) = '(5x,''Maximum level of '',a,'':'',i10,''.5'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write ( ulsort,texte(langue,4)) saux + write ( ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. tableaux ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 6 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > jaux, jaux, jaux, + > pcoono, jaux, adhono, jaux, + > ulsort, langue, codret ) +c + iaux = 6 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, jaux, + > jaux, jaux, jaux, + > jaux, pnp2ar, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nouvtr.ne.0 ) then +c + iaux = 330 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nouvqu.ne.0 ) then +c + iaux = 330 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nouvte.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nouvhe.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nouvpy.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, pfilpy, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nouvpe.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. comptage des entites actives du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. comptage entites active ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCACT', nompro +#endif + call cmcact ( imem(phetno), + > imem(pfilar), + > imem(pfiltr), imem(pnivtr), + > imem(pfilqu), imem(pnivqu), + > imem(pfilte), imem(pfilhe), + > imem(pfilpy), imem(pfilpe), + > nvacar, nvactr, nvacqu, + > nvacte, nvache, nvacpy, nvacpe, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. mise a jour des nombres d'entites du maillage adapte +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. mise a jour des nombres ; codret', codret + call dmflsh (iaux) +#endif +c + if ( codret.eq.0 ) then +c +c 4.1. commun "nombno" --> noeuds +c +c nbpnho = mis a jour en 5.1 +c nbnois = non modifie +c nbnoei = non modifie +c nbnoma = non modifie +c nbnomp = non modifie +cgn write (ulsort,90002) 'nouvno,provp1',nouvno,provp1 +cgn write (ulsort,90002) 'nouvp2,nouvim',nouvp2,nouvim +cgn write (ulsort,90002) 'nbnoei,nbnois',nbnoei,nbnois + nbnop1 = nouvno - nouvp2 - nouvim - nbnomp - nbnoei - nbnois + nbnop2 = nouvp2 + nbnoim = nouvim + nbnoto = nouvno + nbnoin = provp1 - nbquq5/3 +cgn write (ulsort,90002) 'p1,p2,im,to',nbnop1,nbnop2,nbnoim,nbnoto +c +c 4.2. commun "nombar" --> aretes +c + nbarac = nvacar + nbarde = permar - nbarma +c nbart2 = calcule dans utplco +c nbarq2 = calcule dans utplco +c nbarq3 = calcule dans utplco +c nbarq5 = calcule dans utplco +c nbpaho = mis a jour en 5.1 +c nbarin = calcule dans utplco +c nbarma = non modifie + nbarpe = permar + nbarto = nouvar +cgn write (ulsort,*) nbarac,nbarde,nbarpe,nbarto +c +c 4.3. commun "nombtr" --> triangles +c + nbtrac = nvactr + nbtrde = permtr - nbtrma +c nbtrt2 = calcule dans utplco +c nbtrq3 = calcule dans utplco +c nbptho = mis a jour en 5.1 +c nbtrhc = calcule dans utplco +c nbtrpc = calcule dans utplco +c nbtrtc = calcule dans utplco +c nbtrma = non modifie + nbtrpe = permtr + nbtrto = nouvtr +cgn write (ulsort,*) nbtrac,nbtrde,nbtrpe,nbtrto +c +c 4.4. commun "nombqu" --> quadrangles +c + nbquac = nvacqu + nbqude = permqu - nbquma +c nbquq2 = calcule dans utplco +c nbquq5 = calcule dans utplco + nbqupe = permqu + nbquto = nouvqu +cgn write (ulsort,*) nbquac,nbqude,nbqupe,nbquto +c +c 4.5. commun "nombte" --> tetraedres +c + nbteac = nvacte +c nbtea2 = calcule dans utplco +c nbtea4 = calcule dans utplco + nbtede = permte - nbtema +c nbtef4 = calcule dans utplco +c nbtema = non modifie + nbtepe = permte + nbteto = nouvte + nbteca = provta + nbtecf = nbteto - nbteca +cgn write (ulsort,90002) 'nbteac,nbtepe,nbteto,nbtecf,nbteca', +cgn > nbteac,nbtepe,nbteto,nbtecf,nbteca +c +c 4.6. commun "nombhe" --> hexaedres +c + nbheac = nvache + nbhede = permhe - nbhema +c nbhema = non modifie + nbhepe = permhe + nbheto = nouvhe + nbheca = provha + nbhecf = nbheto - nbheca +cgn write (ulsort,90002) 'nbheac,nbhepe,nbheto,nbhecf,nbheca', +cgn > nbheac,nbhepe,nbheto,nbhecf,nbheca +c +c 4.7. commun "nombpy" --> pyramides +c + nbpyac = nvacpy +c nbpyma = non modifie + nbpype = permpy + nbpyto = nouvpy + nbpyca = provya + nbpycf = nbpyto - nbpyca +cgn write (ulsort,90002) 'nbpyac,nbpype,nbpyto,nbpycf,nbpyca', +cgn > nbpyac,nbpype,nbpyto,nbpycf,nbpyca +c +c 4.8. commun "nombpe" --> pentaedres +c + nbpeac = nvacpe + nbpede = permpe - nbpema +c nbpema = non modifie + nbpepe = permpe + nbpeto = nouvpe + nbpeto = nouvpe + nbpeca = provpa + nbpecf = nbpeto - nbpeca +cgn write (ulsort,90002) 'nbpeac,nbpepe,nbpeto,nbpecf,nbpeca', +cgn > nbpeac,nbpepe,nbpeto,nbpecf,nbpeca +c +c 4.9. ==> stockage +c + call gmecat ( nhnoeu, 1 , nbnoto, codre1 ) + call gmecat ( nharet, 1 , nbarto, codre2 ) + call gmecat ( nhtria, 1 , nbtrto, codre3 ) + call gmecat ( nhquad, 1 , nbquto, codre4 ) + call gmecat ( nhtetr, 1 , nbteto, codre5 ) + call gmecat ( nhhexa, 1 , nbheto, codre6 ) + call gmecat ( nhpyra, 1 , nbpyto, codre7 ) + call gmecat ( nhpent, 1 , nbpeto, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmecat ( nhtetr, 2, nbteca, codre1 ) + call gmecat ( nhhexa, 2, nbheca, codre2 ) + call gmecat ( nhpyra, 2, nbpyca, codre3 ) + call gmecat ( nhpent, 2, nbpeca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 5. determination des voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. voisinages ; codret', codret +#endif +c +c 5.1. ==> determination des faces voisines des aretes +c + if ( codret.eq.0 ) then +c + vofaar = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGFA', nompro +#endif +c + call utvgfa ( nhvois, nharet, nhtria, nhquad, + > vofaar, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + iaux = 2 + write (ulsort,texte(langue,3)) 'UTVERI_UTVGFA_apres', nompro + call utveri ( 'adap ', nomail, 'UTVGFA', iaux, + > ulsort, langue, codret ) + endif +#endif +c +c 5.2. ==> determination des volumes voisins des faces +c + if ( codret.eq.0 ) then +c + vovofa = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVF', nompro +#endif +c + call utvgvf ( nhvois, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > vovofa, + > ulsort, langue, codret) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + iaux = 2 + write (ulsort,texte(langue,3)) 'UTVERI_UTVGVF_apres', nompro + call utveri ( 'adap ', nomail, 'UTVGVF', iaux, + > ulsort, langue, codret ) + endif +#endif +c +c==== +c 6. mise a jour eventuelle pour les homologues +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. homologues ; codret', codret +#endif +c + if ( homolo.ne.0 ) then +c + if ( codret.eq.0 ) then +c +c 6.1. ==> comptage des entites du maillage concernees par une +c condition homologue et mise a jour des tables +c provisoires de correspondance +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMHOMO', nompro +#endif + call cmhomo ( + > imem(adhono), imem(adhoar), imem(adhotr), imem(adhoqu), + > imem(psomar), imem(pfilar), imem(phetar), imem(pnp2ar), + > imem(paretr), imem(pfiltr), imem(phettr), + > imem(parequ), imem(pfilqu), imem(phetqu), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. mise a jour eventuelle pour les non conformites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. maj non-conformite ; codret', codret +#endif +c + if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC08', nompro +#endif + call utnc08 ( nharet, nhtria, nhquad, nhvois, + > numead, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,3)) 'UTVERI_UTNC08_apres', nompro + iaux = 2 + call utveri ( 'adap ', nomail, 'UTNC08', iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c +c==== +c 8. impressions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Impressions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,6)) nbnoto + write(ulsort,texte(langue,7)) mess14(langue,3,1), nbarac + if ( nbtrto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,2), nbtrac + endif + if ( nbquto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,4), nbquac + endif + if ( nbteto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,3), nbteac + endif + if ( nbheto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,6), nbheac + endif + if ( nbpyto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,5), nbpyac + endif + if ( nbpeto.ne.0 ) then + write(ulsort,texte(langue,7)) mess14(langue,3,7), nbpeac + endif + if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + if ( nbquto.eq.0 ) then + saux14 = mess14(langue,3,2) + elseif ( nbtrto.eq.0 ) then + saux14 = mess14(langue,3,4) + else + saux14 = mess14(langue,3,8) + endif + iaux = mod(niincf,10) + if ( iaux.ne.0 ) then + if ( nivinf.le.((niincf-5)/10) ) then + iaux = 0 + endif + endif + if ( iaux.eq.0 ) then + write (ulsort,texte(langue,8)) saux14, nivinf + else + write (ulsort,texte(langue,9)) saux14, (niincf-5)/10 + endif + iaux = mod(nisucf,10) + if ( iaux.eq.0 ) then + write (ulsort,texte(langue,10)) saux14, nivsup + else + write (ulsort,texte(langue,11)) saux14, (nisucf-5)/10 + endif + endif +c + endif +c +c==== +c 9. la fin +c==== +c +c 9.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 9.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +c======================================================================= + endif +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmnbco.F b/src/tool/Creation_Maillage/cmnbco.F new file mode 100644 index 00000000..c85e55c9 --- /dev/null +++ b/src/tool/Creation_Maillage/cmnbco.F @@ -0,0 +1,355 @@ + subroutine cmnbco ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - NomBre de mise en COnformite +c - - - - -- +c ______________________________________________________________________ +c +c but : decompte les entites a creer lors du decoupage de mise en +c conformite des faces et des volumes. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c Rappel des codes de pilotage du raffinement et deraffinement : +c 30 : mode de conformite +c 0 : conforme (defaut) +c 1 : non-conforme avec 1 seule arete decoupee (en 2) +c par face (triangle ou quadrangle) +c 2 : non-conforme avec 1 seul noeud pendant par arete +c 3 : non-conforme fidele a l'indicateur +c -1 : conforme, avec des boites pour les quadrangles, hexaedres +c et pentaedres +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMNBCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux, kaux +c + integer codre0 + integer codre1, codre2 +c + integer pdecar, pdecfa + integer phetar + integer paretr, phettr, pnivtr + integer parequ, phetqu, pnivqu + integer phette, ptrite + integer phethe, pquahe, pcoquh + integer phetpe, pfacpe +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' NOMBRE DE MISES EN CONFORMITE'')' + texte(1,5) = '(36(''=''),/)' + texte(1,6) = '(''Modification de taille des tableaux des '',a)' + texte(1,7) = '(5x,''==> code de retour :'',i8)' +c + texte(2,4) = + > '(/,a6,'' NUMBER OF REQUESTED CONFORMITY OPERATIONS'')' + texte(2,5) = '(48(''=''),/)' + texte(2,6) = '(''Size modification of arrays for '',a)' + texte(2,7) = '(5x,''==> error code :'',i8)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write ( ulsort,texte(langue,4)) saux + write ( ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav1 = taopts(12) + call gmadoj ( ntrav1, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 2 + call utad02 ( iaux, nharet, + > phetar, kaux , jaux , jaux , + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux , jaux , + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux , jaux , + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2 + if ( taopti(30).ge.0 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. decompte des nouvelles entites a creer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. decompte ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPLCO', nompro +#endif +c + call utplco ( taopti(30), + > imem(pdecar), imem(pdecfa), + > imem(phetar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(phette), imem(ptrite), + > imem(phethe), imem(pquahe), imem(pcoquh), + > imem(phetpe), imem(pfacpe), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmno22.F b/src/tool/Creation_Maillage/cmno22.F new file mode 100644 index 00000000..a1c870ce --- /dev/null +++ b/src/tool/Creation_Maillage/cmno22.F @@ -0,0 +1,236 @@ + subroutine cmno22 ( nomail, + > indnoe, nuarde, nuarfi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - les NOeuds P2 +c - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . nuarde . e . 1 . debut des numeros d'aretes a traiter . +c . nuarfi . e . 1 . fin des numeros d'aretes a traiter . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMNO22' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, nuarde, nuarfi +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer phetno, pareno, pcoono + integer phetar, psomar, pfilar, pnp2ar, pmerar + integer pfamar, pcfano, pfamno + integer nnoep2 +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(5x,''Nombre de noeuds p2 (milieux) crees : '',i10)' + texte(1,8) = + > '(5x,''Au depart, nombre de '',a,'' : '',i10)' + texte(1,9) = + > '(5x,''A la fin, nombre de '',a,'' : '',i10)' +c + texte(2,5) = '(5x,''Number of p2 nodes (center) created: '',i10)' + texte(2,8) = + > '(5x,''At the beginning, number of created '',a,'': '',i10)' + texte(2,9) = + > '(5x,''At the end, number of created '',a,'': '',i10)' +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 210 + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 2730 + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, jaux, jaux, + > jaux , pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. creation effective des noeuds p2 +c attention : a une epoque, on distinguait les bords droits et les +c bords courbes. En fait, le traitement applique a ces bords courbes +c etait mauvais. +c En atttente d'un autre algorithme mais qui semble plutot complique, +c on suppose qu'une nouvelle arete est toujours un segment de droite. +c Si on veut mieux approcher des bords courbes, il faut utiliser +c l'option de suivi de frontiere. +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), indnoe + write (ulsort,90002) 'nouvar', nouvar + write (ulsort,90002) 'nouvno', nouvno + write (ulsort,90002) 'permp2', permp2 + write (ulsort,90002) 'nouvp2', nouvp2 + write (ulsort,90002) 'permim', permim + write (ulsort,90002) 'nouvim', nouvim + write (ulsort,90002) 'nuarde', nuarde + write (ulsort,90002) 'nuarfi', nuarfi +#endif + nnoep2 = indnoe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOAD', nompro +#endif + call utnoad ( rmem(pcoono), + > imem(phetno), imem(pareno), imem(pfamno), + > imem(psomar), imem(pnp2ar), + > indnoe, nouvno, + > nuarde, nuarfi ) +c + endif +c + nnoep2 = indnoe - nnoep2 + write (ulsort,texte(langue,5)) nnoep2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,-1), indnoe +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmnoim.F b/src/tool/Creation_Maillage/cmnoim.F new file mode 100644 index 00000000..7bb4f8bc --- /dev/null +++ b/src/tool/Creation_Maillage/cmnoim.F @@ -0,0 +1,317 @@ + subroutine cmnoim ( nomail, + > indnoe, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - les NOeuds Internes aux Mailles +c - - -- - - +c ______________________________________________________________________ +c +c but : gestion de la creation des noeuds internes aux mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . option . e . 1 . 0 : decoupage standard . +c . . . . 1 : decoupage de conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMNOIM' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer phetno, pareno, pcoono + integer phetar, psomar, pfilar, pnp2ar + integer pcfano, pfamno + integer paretr, phettr, pfiltr, adnmtr + integer parequ, phetqu, pfilqu, adnmqu + integer nnoeim +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(5x,''Nombre de noeuds internes crees : '',i10)' + texte(1,8) = + > '(5x,''Au depart, nombre de '',a,'' : '',i10)' + texte(1,9) = + > '(5x,''A la fin, nombre de '',a,'' : '',i10)' +c + texte(2,5) = '(5x,''Number of internal nodes created: '',i10)' + texte(2,8) = + > '(5x,''At the beginning, number of created '',a,'': '',i10)' + texte(2,9) = + > '(5x,''At the end, number of created '',a,'': '',i10)' +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 210 + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 78 + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, jaux, + > jaux, jaux, jaux, + > jaux , pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nouvtr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 798 + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > adnmtr, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nouvqu.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 798 + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. creation effective des noeuds internes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. creation effective ; codret = ', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), indnoe + write (ulsort,90002) 'nouvtr', nouvtr + write (ulsort,90002) 'nouvqu', nouvqu + write (ulsort,90002) 'permim', permim + write (ulsort,90002) 'nouvim', nouvim +cgn call gmprsx(nompro//' tria', nhtria//'.NoeuInMa') +cgn call gmprsx(nompro//' quad', nhquad//'.NoeuInMa') +#endif + nnoeim = indnoe +c +c 3.1. ==> Pour le decoupage de triangles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNITR', nompro +#endif + call utnitr ( rmem(pcoono), + > imem(phetno), imem(pareno), imem(pfamno), + > imem(psomar), imem(pnp2ar), + > imem(paretr), imem(phettr), imem(pfiltr), + > imem(adnmtr), + > indnoe, nouvno, nouvar, nouvtr, + > option, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) indnoe - nnoeim +#endif +c + endif +c +c 3.2. ==> Pour le decoupage de quadrangles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNIQU', nompro +#endif + call utniqu ( rmem(pcoono), + > imem(phetno), imem(pareno), imem(pfamno), + > imem(phetar), imem(psomar), imem(pfilar), + > imem(pnp2ar), + > imem(adnmtr), + > imem(parequ), imem(phetqu), imem(pfilqu), + > imem(adnmqu), + > indnoe, nouvno, nouvar, nouvtr, nouvqu, + > option, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) indnoe - nnoeim +#endif +c + endif +c +c 3.3. ==> Bilan +c + if ( codret.eq.0 ) then +c + nnoeim = indnoe - nnoeim + write (ulsort,texte(langue,5)) nnoeim +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,-1), indnoe +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmnosu.F b/src/tool/Creation_Maillage/cmnosu.F new file mode 100644 index 00000000..d6ddfc75 --- /dev/null +++ b/src/tool/Creation_Maillage/cmnosu.F @@ -0,0 +1,319 @@ + subroutine cmnosu ( nohman, + > indnoe, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - les NOeuds SUpplementairs +c - - -- -- +c ______________________________________________________________________ +c +c but : gestion de la creation des noeuds p2 et internes aux mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohman . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMNOSU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombar.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nohman +c + integer indnoe + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux + integer nuard1, nuarf1, nuard2, nuarf2 +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c + texte(1,4) = '(/,a6,'' CREATION DES NOEUDS SUPPLEMENTAIRES'')' + texte(1,5) = '(42(''=''),/)' + texte(1,6) = + > '(5x,''On attendait un nombre total de noeuds de : '',i10)' + texte(1,7) = + > '(5x,''Mais on en a cree un nombre total de : '',i10)' +c + texte(2,4) = '(/,a6,'' CREATION OF ADDITIONAL NODES'')' + texte(2,5) = '(35(''=''),/)' + texte(2,6) = '(5x,i10,'' nodes were expected.'')' + texte(2,7) = '(5x,i10,'' nodes were created.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + write ( ulsort,texte(langue,4)) saux + write ( ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe + write (ulsort,90002) 'permar', permar + write (ulsort,90002) 'nouvtr', nouvtr +#endif +c +c==== +c 2. Prealables +c Il faut trier pour creer d'abord les noeuds supplementaires +c attaches aux entites permanentes, puis ceux attaches aux entites +c provisoires. Cela est indispensable pour traiter correctement +c la future suppression de la conformite. +c==== +c + if ( codret.eq.0 ) then +c + nuard1 = nbarma + 1 +c + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then + nuarf1 = permar + nuard2 = nuarf1 + 1 + nuarf2 = nouvar + else + nuarf1 = nouvar + nuard2 = nuarf1 + 1 + nuarf2 = -1 + endif +c + endif +c +c==== +c 2. Creation des noeuds P2 sur les aretes : +c . permanentes tout le temps +c . provisoires si pas de noeuds internes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. noeuds P2 permanents ; codret = ', codret + write (ulsort,90002) 'nuard1, nuarf1', nuard1, nuarf1 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNO22 permanent', nompro +#endif + call cmno22 ( nohman, + > indnoe, nuard1, nuarf1, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Creation des noeuds internes aux mailles permanentes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. internes permanents ; codret = ', codret +#endif +c + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNOIM permanent', nompro +#endif + call cmnoim ( nohman, + > indnoe, iaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Creation des noeuds P2 sur les aretes : +c . provisoires s'il existe des noeuds internes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. noeuds P2 provisoires ; codret = ', codret + write (ulsort,90002) 'nuard2, nuarf2', nuard2, nuarf2 +#endif +c + if ( nuarf2.ge.nuard2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNO22 provisoire', nompro +#endif + call cmno22 ( nohman, + > indnoe, nuard2, nuarf2, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. Creation des noeuds internes aux mailles provisoires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. internes provisoires ; codret = ', codret +#endif +c + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNOIM provisoire', nompro +#endif + call cmnoim ( nohman, + > indnoe, iaux, + > ulsort, langue, codret ) +c + endif +c + endif + +c==== +c 6. verifications et impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'indnoe', indnoe +#endif +c + if ( codret.eq.0 ) then +c + if ( indnoe.ne.nouvno ) then + write(ulsort,texte(langue,6)) nouvno + write(ulsort,texte(langue,7)) indnoe + codret = 4 + endif +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmraff.F b/src/tool/Creation_Maillage/cmraff.F new file mode 100644 index 00000000..a9437e3d --- /dev/null +++ b/src/tool/Creation_Maillage/cmraff.F @@ -0,0 +1,652 @@ + subroutine cmraff ( nomail, + > indnoe, indare, indtri, indqua, + > indtet, indhex, indpen, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - RAFFinement +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRAFF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe, indare, indtri, indqua + integer indtet, indhex, indpen +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer codre0, codre1, codre2 + integer pdecar, pdecfa + integer phetno, pcoono, pareno + integer phetar, psomar, pfilar, pmerar, pnp2ar + integer phettr, paretr, pfiltr, ppertr, pnivtr, adnmtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu + integer phette, ptrite, pcotrt, pfilte, pperte + integer phethe, pquahe, pcoquh, pfilhe, pperhe, adnmhe + integer phetpe, pfacpe, pcofap, pfilpe, pperpe + integer pfamno, pcfano + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte + integer pfamhe + integer pfampe +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' RAFFINEMENT STANDARD DU MAILLAGE'')' + texte(1,5) = '(39(''=''),/)' + texte(1,6) = + > '(5x,''Nombre de '',a,'' crees :'',i10,'' ; total : '',i10)' +c + texte(2,4) = '(/,a6,'' STANDARD REFINEMENT OF MESH'')' + texte(2,5) = '(34(''=''),/)' + texte(2,6) = + > '(5x,''Number of new '',a,'' :'',i10,'' ; total : '',i10)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +cgn call gmprot(nompro//' -0',nharet//'.Famille.EntiFamm',1,26) +cgn call gmprot(nompro//' -0', nharet//'.Famille.EntiFamm',27,118) +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 7770 + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 7770 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, pcfaar, jaux, + > jaux , pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 85470 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, jaux, jaux, + > adnmtr, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 85470 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, pcfaqu, jaux, + > pnivqu, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2730 + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, pperte, + > pfamte, jaux, jaux, + > jaux , pcotrt, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2730 + if ( mod(mailet,5).eq.0 ) then + iaux = iaux*19 + endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, jaux, jaux, + > jaux , pcoquh, jaux, + > adnmhe, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 2730 + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, jaux, jaux, + > jaux , pcofap, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +cgn call gmprsx (nompro,ntrav1) +cgn call gmprsx (nompro,ntrav2) +c + endif +c +c==== +c 3. decoupage des aretes en degre 1 et degre 2 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. aretes ; codret', codret + write (ulsort,90002) 'indare', indare +#endif +c +#ifdef _DEBUG_HOMARD_ + do 3011 , iaux = 1 , nbarto + if ( iaux.eq.-1661 ) then + write (ulsort,9001) 'arete', iaux, + > imem(psomar+2*iaux-2), imem(psomar+2*iaux-1), + > imem(pfilar+iaux-1),imem(phetar+iaux-1),imem(pdecar+iaux) + endif + 3011 continue + 9001 format(a,i8,', som :',2i8,', fille',i8,', e/d',i3,3i2) +#endif +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDA1', nompro +#endif + call cmrda1 + > ( rmem(pcoono), imem(phetno), imem(pareno), imem(psomar), + > imem(phetar), imem(pfilar), imem(pmerar), imem(pdecar), + > imem(pcfaar), imem(pfamar), imem(pfamno), + > indnoe, indare, + > ulsort, langue, codret ) +c + elseif ( degre.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDA2', nompro +#endif + call cmrda2 + > ( imem(phetno), imem(psomar), imem(phetar), imem(pfilar), + > imem(pmerar), imem(pdecar), imem(pnp2ar), + > imem(pcfaar), imem(pfamar), + > indare, + > ulsort, langue, codret ) +c + else + write(ulsort,90050) degre + codret = 5 + endif +c + endif +#ifdef _DEBUG_HOMARD_ +cgn do 30012 , iaux = 1 , nbarto +cgn if ( iaux.eq.478 ) then +cgn write (ulsort,9001) 'arete', iaux, +cgn > imem(psomar+2*iaux-2), imem(psomar+2*iaux-1), +cgn > imem(pfilar+iaux-1),imem(phetar+iaux-1),imem(pdecar+iaux) +cgn endif +cgn30012 continue +#endif +cgn write(ulsort,90002) 'indare', indare +cgn call gmprot(nompro//' -1',nharet//'.Famille.EntiFamm',1,26) +cgn call gmprot(nompro//' -1', nharet//'.Famille.EntiFamm',27,118) +c +c==== +c 4. decoupage des triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDTR', nompro +#endif + call cmrdtr + > ( imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(paretr), imem(phettr), imem(pfiltr), imem(ppertr), + > imem(pnivtr), imem(pdecfa), + > imem(pfamar), imem(pfamtr), + > indare, indtri, + > imem(pcfatr), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. decoupage des quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDQU', nompro +#endif + call cmrdqu + > ( rmem(pcoono), imem(phetno), imem(pareno), + > imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(parequ), imem(phetqu), imem(pfilqu), imem(pperqu), + > imem(pnivqu), imem(adnmqu), imem(pdecfa), + > imem(pfamno), imem(pfamar), imem(pfamqu), + > indnoe, indare, indqua, + > imem(pcfaqu), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. decoupage des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDTE', nompro +#endif + call cmrdte + > ( rmem(pcoono), + > imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(paretr), imem(phettr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(ptrite), imem(pcotrt), imem(phette), imem(pfilte), + > imem(pperte), + > imem(pfamar), imem(pfamtr), imem(pfamte), + > indare, indtri, indtet, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. decoupage des hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDHE', nompro +#endif + call cmrdhe + > ( rmem(pcoono), imem(phetno), imem(pareno), + > imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(parequ), imem(phetqu), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(pquahe), imem(pcoquh), imem(phethe), + > imem(pfilhe), imem(pperhe), imem(adnmhe), + > imem(pfamno), imem(pfamar), imem(pfamqu), imem(pfamhe), + > indnoe, indare, indqua, indhex, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8 decoupage des pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRDPE', nompro +#endif + call cmrdpe + > ( imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(paretr), imem(phettr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(parequ), imem(phetqu), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(pfacpe), imem(pcofap), imem(phetpe), + > imem(pfilpe), imem(pperpe), + > imem(pfamar), imem(pfamtr), imem(pfamqu), imem(pfampe), + > indare, indtri, indqua, indpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. verifications des nombres d'entites crees et impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. verifications ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,6)) mess14(langue,3,-1), + > indnoe-nbnoto, indnoe + write(ulsort,texte(langue,6)) mess14(langue,3,1), + > indare-nbarto, indare + if ( nbtrto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,2), + > indtri-nbtrto, indtri + endif + if ( nbquto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,4), + > indqua-nbquto, indqua + endif + if ( nbteto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,3), + > indtet-nbteto, indtet + endif + if ( nbheto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,6), + > indhex-nbheto, indhex + endif + if ( nbpeto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,7), + > indpen-nbpeto, indpen + endif +c + iaux = 0 + if ( degre.eq.1 ) then + if ( indnoe.ne.nouvno ) then + write(ulsort,90100) mess14(langue,3,-1), permno-nbnoto + iaux = iaux + 1 + endif + endif + if ( indare.ne.permar ) then + write(ulsort,90100) mess14(langue,3,1), permar-nbarto + iaux = iaux + 1 + endif + if ( nbtrto.ne.0 .and. indtri.ne.permtr ) then + write(ulsort,90100) mess14(langue,3,2), permtr-nbtrto + iaux = iaux + 1 + endif + if ( nbquto.ne.0 .and. indqua.ne.permqu ) then + write(ulsort,90100) mess14(langue,3,4), permqu-nbquto + iaux = iaux + 1 + endif + if ( nbteto.ne.0 .and. indtet.ne.permte ) then + write(ulsort,90100) mess14(langue,3,3), permte-nbteto + iaux = iaux + 1 + endif + if ( nbheto.ne.0 .and. indhex.ne.permhe ) then + write(ulsort,90100) mess14(langue,3,6), permhe-nbheto + iaux = iaux + 1 + endif + if ( nbpeto.ne.0 .and. indpen.ne.permpe ) then + write(ulsort,90100) mess14(langue,3,7), permpe-nbpeto + iaux = iaux + 1 + endif +c + if ( iaux.ne.0 ) then + codret = 4 + endif +c + endif +cgn call gmprsx(nompro,nhnoeu) +c +90050 format(/,5x,'Le degre d''interpolation est : ',i1, + > /,5x,'Seules les discretisations de degres 1 et 2 sont ', + > 'supportees',/) +90100 format(/,5x,'Nombre de ',a,' crees incorrect, ', + > /,5x,'On en attendait ',i10,' nouveaux.') +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Creation_Maillage/cmrda1.F b/src/tool/Creation_Maillage/cmrda1.F new file mode 100644 index 00000000..1fc71a59 --- /dev/null +++ b/src/tool/Creation_Maillage/cmrda1.F @@ -0,0 +1,223 @@ + subroutine cmrda1 ( coonoe, hetnoe, arenoe, somare, + > hetare, filare, merare, decare, + > cfaare, famare, famnoe, + > indnoe, indare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - DEcoupage des Aretes en degre 1 +c - - -- - - +c ______________________________________________________________________ +c +c but : decoupage des aretes en degre 1 +c creation de 2 aretes et de 1 noeud +c les coordonnees des nouveaux noeuds sont calculees par +c interpolation lineaire sur les deux noeuds voisins +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . decare . es .0:nbarto. decision des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nouvar . famille des aretes . +c . famnoe . es . nouvno . caracteristiques des noeuds . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDA1' ) +c +#include "nblang.h" +c +#include "fracta.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nbfami.h" +#include "nombar.h" +#include "nouvnb.h" +#include "dicfen.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer hetnoe(nouvno), arenoe(nouvno) + integer somare(2,nouvar), hetare(nouvar) + integer filare(nouvar), merare(nouvar), decare(0:nbarto) + integer famare(nouvar), cfaare(nctfar,nbfare), famnoe(nouvno) + integer indare, indnoe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat, larete, mere, na1, na2, s1, s2 + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage de l''''arete'',i10)' + texte(1,5) = '(''... Noeud milieu'',i10,'', aretes filles'',2i10)' +c + texte(2,4) = '(''Splitting of edge #'',i10)' + texte(2,5) = '(''... Node'',i10,'', edges'',2i10)' +c +c==== +c 2. decoupage en 2 des aretes de decision 2 +c==== +c + do 200 , larete = 1 , nbarpe +c + if ( decare(larete).eq.2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) larete +#endif +c +c 2.1. ==> creation du noeud milieu : nouveau sommet +c + indnoe = indnoe + 1 + arenoe(indnoe) = larete + s1 = somare(1,larete) + s2 = somare(2,larete) + coonoe(indnoe,1) = ( coonoe(s1,1) + coonoe(s2,1) ) * unsde + if ( sdim.ge.2 ) then + coonoe(indnoe,2) = ( coonoe(s1,2) + coonoe(s2,2) ) * unsde + if ( sdim.eq.3 ) then + coonoe(indnoe,3) = ( coonoe(s1,3) + coonoe(s2,3) ) * unsde + endif + endif + famnoe(indnoe) = 1 + hetnoe(indnoe) = 51 +c +c 2.2. ==> creation de la premiere arete +c + na1 = indare + 1 + somare(1,na1) = s1 + somare(2,na1) = indnoe +c +c 2.3. ==> creation de la seconde arete +c + na2 = na1 + 1 + somare(1,na2) = s2 + somare(2,na2) = indnoe +c +c 2.4. ==> mise a jour de la mere et de la grand-mere eventuelle +c + filare(larete) = na1 + hetare(larete) = hetare(larete) + 2 + mere = merare(larete) + if ( mere .ne. 0 ) then + etat = hetare(mere) + hetare(mere) = etat - mod(etat,10) + 9 + endif +c +c 2.5. ==> caracteristiques des deux filles +c + famare(na1) = famare(larete) +c correction pour l'orientation de la deuxieme fille + famare(na2) = cfaare(cofifa,famare(larete)) +c + hetare(na1) = 50 + hetare(na2) = 50 + filare(na1) = 0 + filare(na2) = 0 + merare(na1) = larete + merare(na2) = larete +c + indare = na2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) indnoe, na1, na2 +#endif +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrda2.F b/src/tool/Creation_Maillage/cmrda2.F new file mode 100644 index 00000000..749fe107 --- /dev/null +++ b/src/tool/Creation_Maillage/cmrda2.F @@ -0,0 +1,212 @@ + subroutine cmrda2 ( hetnoe, somare, hetare, filare, + > merare, decare, np2are, + > cfaare, famare, + > indare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - DEcoupage des Aretes en degre 2 +c - - -- - - +c ______________________________________________________________________ +c +c but : decoupage des aretes en degre 2 +c creation de 2 aretes et recuperation du noeud milieu +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . decare . es .0:nbarto. decision des aretes . +c . np2are . es . nouvar . numero des noeuds p2 milieux d'aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nouvar . famille des aretes . +c . indare . es . 1 . indice de la derniere arete creee . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDA2' ) +c +#include "nblang.h" +c +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nbfami.h" +#include "nombar.h" +#include "nouvnb.h" +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer hetnoe(nouvno), np2are(nouvar) + integer somare(2,nouvar), hetare(nouvar) + integer filare(nouvar), merare(nouvar), decare(0:nbarto) + integer famare(nouvar), cfaare(nctfar,nbfare) + integer indare +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat, larete, mere, na1, na2, noemil, s1, s2 + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage de l''''arete'',i10)' + texte(1,5) = '(''... Noeud milieu'',i10,'', aretes filles'',2i10)' +c + texte(2,4) = '(''Splitting of edge #'',i10)' + texte(2,5) = '(''... Node'',i10,'', edges'',2i10)' +c +c==== +c 2. decoupage en 2 des aretes de decision 2 +c==== +c + do 200 , larete = 1 , nbarpe +c + if ( decare(larete).eq.2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) larete +#endif +c +c 2.1. ==> recuperation du noeud milieu p2 : nouveau sommet p1 +c remarque : par defaut, son numero est superieur a ceux +c des 2 extremites. cela est fait soit au moment +c de l'interface pour le macro-maillage, soit lors +c de la creation des nouveaux noeuds p2. +c + noemil = np2are(larete) + hetnoe(noemil) = 21 +c + s1 = somare(1,larete) + s2 = somare(2,larete) +c +c 2.2. ==> creation de la premiere arete +c + na1 = indare + 1 + somare(1,na1) = s1 + somare(2,na1) = noemil +c +c 2.3. ==> creation de la seconde arete +c + na2 = na1 + 1 + somare(1,na2) = s2 + somare(2,na2) = noemil +c +c 2.4. ==> mise a jour de la mere et de la grand-mere eventuelle +c + filare(larete) = na1 + hetare(larete) = hetare(larete) + 2 + mere = merare(larete) + if ( mere .ne. 0 ) then + etat = hetare(mere) + hetare(mere) = etat - mod(etat,10) + 9 + endif +c +c 2.5. ==> caracteristiques des deux filles +c + famare(na1) = famare(larete) +c correction pour l'orientation de la deuxieme fille + famare(na2) = cfaare(cofifa,famare(larete)) +c + hetare(na1) = 50 + hetare(na2) = 50 + filare(na1) = 0 + filare(na2) = 0 + merare(na1) = larete + merare(na2) = larete +c + indare = na2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) noemil, na1, na2 +#endif +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrdhe.F b/src/tool/Creation_Maillage/cmrdhe.F new file mode 100644 index 00000000..c2d24b07 --- /dev/null +++ b/src/tool/Creation_Maillage/cmrdhe.F @@ -0,0 +1,757 @@ + subroutine cmrdhe ( coonoe, hetnoe, arenoe, + > somare, hetare, filare, merare, + > arequa, hetqua, + > filqua, perqua, nivqua, + > quahex, coquhe, hethex, + > filhex, perhex, ninhex, + > famnoe, famare, famqua, famhex, + > indnoe, indare, indqua, indhex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Raffinement - Decoupage des HExaedres +c - - - - -- +c ______________________________________________________________________ +c remarque : on est forcement en 3d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . perqua . e . nouvqu . pere des quadrangles . +c . nivqua . e . nouvqu . niveau des quadrangles . +c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nouvhf*6. code des 6 quadrangles des hexaedres . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . perhex . e . nouvhe . pere des hexaedres . +c . ninhex . es . nouvhe . noeud interne a l'hexaedre . +c . famnoe . . nouvno . famille des noeuds . +c . famare . es . nouvar . famille des aretes . +c . famqua . es . nouvqu . famille des quadrangles . +c . famhex . es . nouvhe . famille des hexaedres . +c . indnoe . es . 1 . indice du derniere noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDHE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "envca1.h" +#include "defiqu.h" +#include "nombhe.h" +#include "nouvnb.h" +#include "fracte.h" +#include "cofhex.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer hetnoe(nouvno), arenoe(nouvno) + integer somare(2,nouvar), hetare(nouvar), filare(nouvar) + integer merare(nouvar) + integer arequa(nouvqu,4), hetqua(nouvqu) + integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu) + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer hethex(nouvhe), filhex(nouvhe), perhex(nouvhe) + integer ninhex(nouvhe) + integer famnoe(nouvno), famare(nouvar), famqua(nouvqu) + integer famhex(nouvhe) + integer indnoe, indare, indqua, indhex +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nuhexa, dt, etat, lehexa, pere + integer niveau, cf1, cf2, cf3, cf4, cf5, cf6 + integer f1, f2, f3, f4, f5, f6 + integer codefa + +c le noeud nfi est le milieu de la face fi + integer nf1, nf2, nf3, nf4, nf5, nf6 +c le noeud central a l'hexaedre a pour nom ... + integer n0 +c +c la face fisj est la fille de la face fi et qui contient sj. +c + integer f1s1,f1s2, f1s3, f1s4 + integer f2s1,f2s2, f2s5, f2s6 + integer f3s1,f3s4, f3s6, f3s7 + integer f4s2,f4s3, f4s5, f4s8 + integer f5s3,f5s4, f5s7, f5s8 + integer f6s5,f6s6, f6s7, f6s8 +c +c Attention les noms des aretes internes aux faces de l'hexaedre +c decoupe sont ANINJ quand elle relie le noeud ni au noeud nj, +c dans la doc. +c Ici pour rester a 6 lettres, on les appelera ninj. + + integer n1nf1, n2nf1, n3nf1, n4nf1 + integer n1nf2, n5nf2, n6nf2, n9nf2 + integer n2nf3, n5nf3, n7nf3, n10nf3 + integer n3nf4, n6nf4, n8nf4, n11nf4 + integer n4nf5, n7nf5, n8nf5, n12nf5 + integer n9nf6, n10nf6, n11nf6, n12nf6 +c +c Les aretes internes a l'hexaedre : +c NfiN0 relie le noeud nfi(milieu de la face fi) au noeud central + integer nf1n0, nf2n0, nf3n0, nf4n0, nf5n0, nf6n0 +c +c Les faces creees +c La face pfinj est parallele a la face fi et contient le noeud nj + integer pf1n5, pf1n6, pf1n7, pf1n8 + integer pf2n2, pf2n3, pf2n10, pf2n11 + integer pf3n1, pf3n4, pf3n9, pf3n12 +c + integer iaux, jaux +c + logical noinma +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage de '',a,i10)' + texte(1,5) = + > '(''.. Face :'',i10,'', d''''aretes'',4i10,'', code'',i2)' + texte(1,6) = '(''.. Noeuds milieux des faces'',6i10)' + texte(1,7) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)' + texte(1,8) = '(''.. Creation des '',a,'' internes'')' + texte(1,9) = '(''.. Creation des 8 hexaedres'')' + texte(1,10) = '(''.. Hexaedre :'',i10,'', de faces'',6i10)' +c + texte(2,4) = '(''Splitting of '',a,'' #'',i10)' + texte(2,5) = + > '(''.. Face :'',i10,'', with edges'',4i10,'', code'',i2)' + texte(2,6) = '(''.. Center nodes for faces'',6i10)' + texte(2,7) = '(''.. Central node'',i10,'', coor :'',3g15.7)' + texte(2,8) = '(''.. Creation of internal '',a)' + texte(2,9) = '(''.. Creation of 8 hexahedrons'')' + texte(2,10) = '(''.. Hexahedron :'',i10,'', with faces'',6i10)' +c + if ( mod(mailet,5).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c +c==== +c 2. decoupage en 8 des hexaedres dont les 6 faces sont coupees en 4 +c==== +c + do 200 , lehexa = 1 , nbhepe +c + if ( mod(hethex(lehexa),1000) .eq. 0 ) then +c +c 2.1. decoupage ? +c + dt = 0 + do 21 , iaux = 1 , 6 + jaux = quahex(lehexa,iaux) + if ( mod(hetqua(jaux),100).eq.4 .or. + > mod(hetqua(jaux),100).eq.99 ) then + dt = dt + 1 + endif + 21 continue +c + if ( dt.eq.6 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,6), lehexa +#endif +c +c 2.2. ==> description des 6 faces de l'hexaedre +c quand le code cf vaut 1, on a defiqj(cf) = j-1 +c cela signifie que l'on presente ici les quadrangles dans +c l'ordre de la filiation enregistree +c +c 2.2.1. ==> description de la face 1 +c + f1 = quahex(lehexa,1) + cf1 = coquhe(lehexa,1) +c +c 2.2.1.1. ==> reperage des 4 quadrangles fils +c + f1s2 = filqua(f1) + defiq1(cf1) + f1s1 = filqua(f1) + defiq2(cf1) + f1s4 = filqua(f1) + defiq3(cf1) + f1s3 = filqua(f1) + defiq4(cf1) +#ifdef _DEBUG_HOMARD_ +9998 format(a,i6,a,5i6) +9999 format(a,4i6) + write (ulsort,9998) 'f1 = ', f1, ', cf1 = ', cf1 + write (ulsort,9999) 'defiq1(cf1) = ', defiq1(cf1) + write (ulsort,9999) 'defiq2(cf1) = ', defiq2(cf1) + write (ulsort,9999) 'defiq3(cf1) = ', defiq3(cf1) + write (ulsort,9999) 'defiq4(cf1) = ', defiq4(cf1) + write(ulsort,9999) 'f1s1, f1s2, f1s3, f1s4 ',f1s1,f1s2,f1s3,f1s4 +#endif +c +c 2.2.1.2. ==> reperage des 4 aretes internes + + if ( cf1.lt.5 ) then + n1nf1 = arequa(f1s2,2) + n2nf1 = arequa(f1s1,2) + n3nf1 = arequa(f1s3,2) + n4nf1 = arequa(f1s4,2) + else + n1nf1 = arequa(f1s1,2) + n2nf1 = arequa(f1s4,2) + n3nf1 = arequa(f1s2,2) + n4nf1 = arequa(f1s3,2) + endif +c +c 2.2.2. ==> description de la face 2 +c + f2 = quahex(lehexa,2) + cf2 = coquhe(lehexa,2) +c +c 2.2.2.1. ==> reperage des 4 quadrangles fils +c + f2s1 = filqua(f2) + defiq1(cf2) + f2s2 = filqua(f2) + defiq2(cf2) + f2s5 = filqua(f2) + defiq3(cf2) + f2s6 = filqua(f2) + defiq4(cf2) +#ifdef _DEBUG_HOMARD_ +cgn write(ulsort,*) 'f2s2, f2s1, f2s6, f2s5 ',f2s2,f2s1,f2s6,f2s5 + write(ulsort,9998) 'f2s2 : ',f2s2, ', aretes ', + > arequa(f2s2,1),arequa(f2s2,2),arequa(f2s2,3) ,arequa(f2s2,4) + write(ulsort,9998) 'f2s1 : ',f2s1, ', aretes ', + > arequa(f2s1,1),arequa(f2s1,2),arequa(f2s1,3) ,arequa(f2s1,4) + write(ulsort,9998) 'f2s6 : ',f2s6, ', aretes ', + > arequa(f2s6,1),arequa(f2s1,2),arequa(f2s6,3) ,arequa(f2s6,4) + write(ulsort,9998) 'f2s5 : ',f2s5, ', aretes ', + > arequa(f2s5,1),arequa(f2s5,2),arequa(f2s5,3) ,arequa(f2s5,4) +#endif +c +c 2.2.2.2. ==> reperage des 4 aretes internes +c + if ( cf2.lt.5 ) then + n1nf2 = arequa(f2s1,2) + n6nf2 = arequa(f2s2,2) + n9nf2 = arequa(f2s5,2) + n5nf2 = arequa(f2s6,2) + else + n1nf2 = arequa(f2s2,2) + n6nf2 = arequa(f2s5,2) + n9nf2 = arequa(f2s6,2) + n5nf2 = arequa(f2s1,2) + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,9999) 'n1nf2,n6nf2,n9nf2,n5nf2 ', + > n1nf2,n6nf2,n9nf2,n5nf2 +#endif +c +c 2.2.3. ==> description de la face 3 +c + f3 = quahex(lehexa,3) + cf3 = coquhe(lehexa,3) +c +c 2.2.3.1. ==> reperage des 4 quadrangles fils +c + f3s4 = filqua(f3) + defiq1(cf3) + f3s1 = filqua(f3) + defiq2(cf3) + f3s6 = filqua(f3) + defiq3(cf3) + f3s7 = filqua(f3) + defiq4(cf3) +c write(ulsort,*) 'f3s1, f3s4, f3s7, f3s6 ',f3s1,f3s4,f3s7,f3s6 +c +c 2.2.3.2. ==> reperage des 4 aretes internes +c + if ( cf3.lt.5 ) then + n2nf3 = arequa(f3s4,2) + n5nf3 = arequa(f3s1,2) + n10nf3= arequa(f3s6,2) + n7nf3 = arequa(f3s7,2) + else + n2nf3 = arequa(f3s1,2) + n5nf3 = arequa(f3s6,2) + n10nf3= arequa(f3s7,2) + n7nf3 = arequa(f3s4,2) + endif +c +c 2.2.4. ==> description de la face 4 +c + f4 = quahex(lehexa,4) + cf4 = coquhe(lehexa,4) +c +c 2.2.4.1. ==> reperage des 4 quadrangles fils +c + f4s2 = filqua(f4) + defiq1(cf4) + f4s3 = filqua(f4) + defiq2(cf4) + f4s8 = filqua(f4) + defiq3(cf4) + f4s5 = filqua(f4) + defiq4(cf4) +c +c 2.2.4.2. ==> reperage des 4 aretes internes +c + if ( cf4.lt.5 ) then + n3nf4 = arequa(f4s2,2) + n6nf4 = arequa(f4s5,2) + n8nf4 = arequa(f4s3,2) + n11nf4= arequa(f4s8,2) + else + n3nf4 = arequa(f4s3,2) + n6nf4 = arequa(f4s2,2) + n8nf4 = arequa(f4s8,2) + n11nf4= arequa(f4s5,2) + endif +c +c 2.2.5. ==> description de la face 5 +c + f5 = quahex(lehexa,5) + cf5 = coquhe(lehexa,5) +c +c 2.2.5.1. ==> reperage des 4 quadrangles fils +c + f5s3 = filqua(f5) + defiq1(cf5) + f5s4 = filqua(f5) + defiq2(cf5) + f5s7 = filqua(f5) + defiq3(cf5) + f5s8 = filqua(f5) + defiq4(cf5) +c +c 2.2.5.2. ==> reperage des 4 aretes internes +c + if ( cf5.lt.5 ) then + n4nf5 = arequa(f5s3,2) + n7nf5 = arequa(f5s4,2) + n8nf5 = arequa(f5s8,2) + n12nf5= arequa(f5s7,2) + else + n4nf5 = arequa(f5s4,2) + n7nf5 = arequa(f5s7,2) + n8nf5 = arequa(f5s3,2) + n12nf5= arequa(f5s8,2) + endif +c +c 2.2.6. ==> description de la face 6 +c + f6 = quahex(lehexa,6) + cf6 = coquhe(lehexa,6) +c +c 2.2.6.1. ==> reperage des 4 quadrangles fils +c + f6s6 = filqua(f6) + defiq1(cf6) + f6s5 = filqua(f6) + defiq2(cf6) + f6s8 = filqua(f6) + defiq3(cf6) + f6s7 = filqua(f6) + defiq4(cf6) +c +c 2.2.6.2. ==> reperage des 4 aretes internes +c + if ( cf6.lt.5 ) then + n9nf6 = arequa(f6s6,2) + n11nf6 = arequa(f6s5,2) + n12nf6 = arequa(f6s8,2) + n10nf6 = arequa(f6s7,2) + else + n9nf6 = arequa(f6s5,2) + n11nf6 = arequa(f6s8,2) + n12nf6 = arequa(f6s7,2) + n10nf6 = arequa(f6s6,2) + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) f1,arequa(f1,1),arequa(f1,2) + > ,arequa(f1,3),arequa(f1,4),cf1 + write(ulsort,texte(langue,5)) f2,arequa(f2,1),arequa(f2,2) + > ,arequa(f2,3),arequa(f2,4),cf2 + write(ulsort,texte(langue,5)) f3,arequa(f3,1),arequa(f3,2) + > ,arequa(f3,3),arequa(f3,4),cf3 + write(ulsort,texte(langue,5)) f4,arequa(f4,1),arequa(f4,2) + > ,arequa(f4,3),arequa(f4,4),cf4 + write(ulsort,texte(langue,5)) f5,arequa(f5,1),arequa(f5,2) + > ,arequa(f5,3),arequa(f5,4),cf5 + write(ulsort,texte(langue,5)) f6,arequa(f6,1),arequa(f6,2) + > ,arequa(f6,3),arequa(f6,4),cf6 +#endif +c +c 2.3. ==> noeuds milieux des faces de l'hexaedre +c + nf1 = somare(2,n1nf1) + nf2 = somare(2,n1nf2) + nf3 = somare(2,n2nf3) + nf4 = somare(2,n3nf4) + nf5 = somare(2,n4nf5) + nf6 = somare(2,n9nf6) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nf1, nf2, nf3, nf4, nf5, nf6 +#endif +c +c 2.4. ==> creation du noeud central +c . on le cree au barycentre l'hexaedre s'il n'existe pas +c en le calculant par le barycentre des milieux des faces. +c . on le recupere sinon +c + if ( noinma ) then +c + n0 = ninhex(lehexa) +c + else +c + n0 = indnoe + 1 + arenoe(n0) = 0 + do 24 , iaux = 1 , 3 + coonoe(n0,iaux) = ( coonoe(nf1,iaux) + + > coonoe(nf2,iaux) + + > coonoe(nf3,iaux) + + > coonoe(nf4,iaux) + + > coonoe(nf5,iaux) + + > coonoe(nf6,iaux) ) * unssix + 24 continue + famnoe(n0) = 1 + hetnoe(n0) = 51 + indnoe = n0 +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) n0, + > coonoe(n0,1),coonoe(n0,2),coonoe(n0,3) +#endif +c +c 2.5. ==> creation des aretes internes a l'hexaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,1) +#endif +c +c 2.5.1. ==> leurs numeros +c + nf1n0 = indare + 1 + nf2n0 = indare + 2 + nf3n0 = indare + 3 + nf4n0 = indare + 4 + nf5n0 = indare + 5 + nf6n0 = indare + 6 + indare = nf6n0 +c +c 2.5.2. ==> les numeros de leurs sommets avec la convention ad'hoc +c + somare(1,nf1n0) = nf1 + somare(2,nf1n0) = n0 + somare(1,nf2n0) = nf2 + somare(2,nf2n0) = n0 + somare(1,nf3n0) = nf3 + somare(2,nf3n0) = n0 + somare(1,nf4n0) = nf4 + somare(2,nf4n0) = n0 + somare(1,nf5n0) = nf5 + somare(2,nf5n0) = n0 + somare(1,nf6n0) = nf6 + somare(2,nf6n0) = n0 +c +c 2.5.3. ==> leur famille : libre +c + famare(nf1n0) = 1 + famare(nf2n0) = 1 + famare(nf3n0) = 1 + famare(nf4n0) = 1 + famare(nf5n0) = 1 + famare(nf6n0) = 1 +c +c 2.5.4. ==> la parente +c + hetare(nf1n0) = 50 + hetare(nf2n0) = 50 + hetare(nf3n0) = 50 + hetare(nf4n0) = 50 + hetare(nf5n0) = 50 + hetare(nf6n0) = 50 + merare(nf1n0) = 0 + merare(nf2n0) = 0 + merare(nf3n0) = 0 + merare(nf5n0) = 0 + merare(nf6n0) = 0 + merare(nf4n0) = 0 + filare(nf1n0) = 0 + filare(nf2n0) = 0 + filare(nf3n0) = 0 + filare(nf4n0) = 0 + filare(nf5n0) = 0 + filare(nf6n0) = 0 +c +c 2.6. ==> creation des faces +c +c 2.6.1. ==> recuperation du niveau commun a tous les quadrangles fils +c + niveau = nivqua(f1s1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,4) +#endif +c +c 2.6.2. ==> creation des 12 faces +c tous ces quadrangles sont crees avec le code arbitraire 1 +c et avec le meme niveau que les faces issues du decoupage + codefa = 1 +c +cgn write(ulsort,*) 'indqua',indqua +cgn write(ulsort,*) 'n5nf3, nf3n0, nf2n0, n5nf2 ', +cgn > n5nf3, nf3n0, nf2n0, n5nf2 +c + pf1n5 = indqua + 1 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf1n5, n5nf3, nf3n0, nf2n0, n5nf2 + > , codefa, niveau ) +c + pf1n6 = indqua + 2 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf1n6, n6nf2, nf2n0, nf4n0, n6nf4 + > , codefa, niveau ) +c + pf1n7 = indqua + 3 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf1n7, n7nf5, nf5n0, nf3n0, n7nf3 + > , codefa, niveau ) +c + pf1n8 = indqua + 4 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf1n8, n8nf4, nf4n0, nf5n0, n8nf5 + > , codefa, niveau ) +c + pf2n2 = indqua + 5 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf2n2, n2nf1, nf1n0, nf3n0, n2nf3 + > , codefa, niveau ) +c + pf2n3 = indqua + 6 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf2n3, n3nf4, nf4n0, nf1n0, n3nf1 + > , codefa, niveau ) +c + pf2n10 = indqua + 7 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf2n10, n10nf3, nf3n0, nf6n0, n10nf6 + > , codefa, niveau ) +c + pf2n11 = indqua + 8 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf2n11, n11nf6, nf6n0, nf4n0, n11nf4 + > , codefa, niveau ) +c + pf3n1 = indqua + 9 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3n1, n1nf2, nf2n0, nf1n0, n1nf1 + > , codefa, niveau ) +c + pf3n4 = indqua + 10 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3n4, n4nf1, nf1n0, nf5n0, n4nf5 + > , codefa, niveau ) +c + pf3n9 = indqua + 11 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3n9, n9nf6, nf6n0, nf2n0, n9nf2 + > , codefa, niveau ) +c + pf3n12 = indqua + 12 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3n12, n12nf5, nf5n0, nf6n0, n12nf6 + > , codefa, niveau ) +c + indqua = pf3n12 +c +c 2.7. ==> creation des 8 hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) +#endif +c + iaux = famhex(lehexa) +c +cgn write(ulsort,texte(langue,10)) indhex + 1, +cgn > f1s1, f2s1, f3s1, +cgn > pf3n1, pf2n2, pf1n5 + nuhexa = indhex + 1 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > f1s1, f2s1, f3s1, + > pf3n1, pf2n2, pf1n5, + > cofh25(cf1), cofh18(cf2), cofh25(cf3), + > 8, 5, 8, + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 2, +cgn > f1s2, f2s2, pf3n1, +cgn > f4s2, pf2n3, pf1n6 + nuhexa = indhex + 2 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > f1s2, f2s2, pf3n1, + > f4s2, pf2n3, pf1n6, + > cofh18(cf1), cofh25(cf2), 2, + > cofh18(cf4), 8, 5, + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 3, +cgn > f1s3, pf2n3, pf3n4, +cgn > f4s3, f5s3, pf1n8 + nuhexa = indhex + 3 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > f1s3, pf2n3, pf3n4, + > f4s3, f5s3, pf1n8, + > cofh47(cf1), 2, 1, + > cofh25(cf4), cofh18(cf5), 6, + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 4, +cgn > f1s4, pf2n2, f3s4, +cgn > pf3n4, f5s4, pf1n7 + nuhexa = indhex + 4 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > f1s4, pf2n2, f3s4, + > pf3n4, f5s4, pf1n7, + > cofh36(cf1), 1, cofh18(cf3), + > 5, cofh25(cf5), 7, + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 5, +cgn > pf1n6, f2s5, pf3n9, +cgn > f4s5, pf2n11, f6s5 + nuhexa = indhex + 5 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > pf1n6, f2s5, pf3n9, + > f4s5, pf2n11, f6s5, + > 1, cofh36(cf2), 3, + > cofh47(cf4), 7, cofh25(cf6), + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 6, +cgn > pf1n5, f2s6, f3s6, +cgn > pf3n9, pf2n10, f6s6 + nuhexa = indhex + 6 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > pf1n5, f2s6, f3s6, + > pf3n9, pf2n10, f6s6, + > 2, cofh47(cf2), cofh36(cf3), + > 7, 6, cofh18(cf6), + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 7, +cgn > pf1n7, pf2n10, f3s7, +cgn > pf3n12, f5s7, f6s7 + nuhexa = indhex + 7 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > pf1n7, pf2n10, f3s7, + > pf3n12, f5s7, f6s7, + > 3, 4, cofh47(cf3), + > 6, cofh36(cf5), cofh47(cf6), + > lehexa, iaux, nuhexa ) +c +cgn write(ulsort,texte(langue,10)) indhex + 8, +cgn > pf1n8, pf2n11, pf3n12, +cgn > f4s8, f5s8, f6s8 + nuhexa = indhex + 8 + call cmchex ( quahex, coquhe, famhex, + > hethex, filhex, perhex, + > pf1n8, pf2n11, pf3n12, + > f4s8, f5s8, f6s8, + > 4, 3, 4, + > cofh36(cf4), cofh47(cf5), cofh36(cf6), + > lehexa, iaux, nuhexa ) + + indhex = nuhexa + +c 2.8. ==> mise a jour de l'hexaedre courant et de son pere eventuel +c + filhex(lehexa) = indhex-7 + hethex(lehexa) = hethex(lehexa) + 8 + pere = perhex(lehexa) + if ( pere .ne. 0 ) then + etat = hethex(pere) + hethex(pere) = etat - mod(etat,1000) + 9 + endif +cgn stop +c + endif +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrdpe.F b/src/tool/Creation_Maillage/cmrdpe.F new file mode 100644 index 00000000..92380b68 --- /dev/null +++ b/src/tool/Creation_Maillage/cmrdpe.F @@ -0,0 +1,572 @@ + subroutine cmrdpe ( somare, hetare, filare, merare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, hetqua, + > filqua, perqua, nivqua, + > facpen, cofape, hetpen, + > filpen, perpen, + > famare, famtri, famqua, fampen, + > indare, indtri, indqua, indpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Raffinement - Decoupage des PEntaedres +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . e . nouvtr . historique de l'etat des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . pertri . e . nouvtr . pere des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . perqua . e . nouvqu . pere des quadrangles . +c . nivqua . e . nouvqu . niveau des quadrangles . +c . facpen . e .nouvpf*5. numeros des faces des pentaedres . +c . cofape . e .nouvpf*5. code des faces des pentaedres . +c . hetpen . es . nouvpe . historique de l'etat des pentaedres . +c . filpen . es . nouvpe . premier fils des pentaedres . +c . perpen . e . nouvpe . pere des pentaedres . +c . famare . es . nouvar . famille des aretes . +c . famtri . es . nouvtr . famille des triangles . +c . famqua . es . nouvqu . famille des quadrangles . +c . fampen . es . nouvpe . famille des pentaedres . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDPE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "i1i2i3.h" +#include "cofpen.h" +#include "nombpe.h" +#include "nouvnb.h" +#include "defiqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer somare(2,nouvar), hetare(nouvar), filare(nouvar) + integer merare(nouvar) + integer aretri(nouvtr,3), hettri(nouvtr) + integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr) + integer arequa(nouvqu,4), hetqua(nouvqu) + integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu) + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer hetpen(nouvpe), filpen(nouvpe), perpen(nouvpe) + integer famare(nouvar), famtri(nouvtr), famqua(nouvqu) + integer fampen(nouvpe) + integer indare, indtri, indqua, indpen +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer dt, etat, lepent, pere, nupent + integer niveau, cf1, cf2, cf3, cf4, cf5, f1, f2, f3, f4, f5 + integer codefa + integer a1ff1, a2ff1, a3ff1, a4ff2, a5ff2, a6ff2 + integer n1nf3, n9nf3, n4nf3, n7nf3 + integer n2nf4, n7nf4, n5nf4, n8nf4 + integer n3nf5, n8nf5, n6nf5, n9nf5 + integer ff1, ff2 + integer f1ff1, f2ff1, f3ff1, f4ff2, f5ff2, f6ff2 + integer f3s1, f3s3, f3s6, f3s4 + integer f4s2, f4s1, f4s4, f4s5 + integer f5s3, f5s2, f5s5, f5s6 + integer nf3, nf4, nf5 + integer nf3nf4, nf4nf5, nf5nf3 + integer pf1, pf1n7, pf1n8, pf1n9 + integer pf3f1, pf3f2, pf4f1, pf4f2, pf5f1, pf5f2 +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage du '',a,i10)' + texte(1,5) = + > '(''.. Face :'',i10,'', d''''aretes'',4i10,'', code'',i2)' + texte(1,6) = '(''.. Noeuds milieux des faces'',6i10)' + texte(1,7) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)' + texte(1,9) = '(''.. Creation des '',a,'' internes'')' + texte(1,10) = '(''.. Creation des 8 pentaedres'')' +c + texte(2,4) = '(''Splitting of '',a,'' #'',i10)' + texte(2,5) = + > '(''.. Face :'',i10,'', with edges'',4i10,'', code'',i2)' + texte(2,6) = '(''.. Center nodes for faces'',6i10)' + texte(2,7) = '(''.. Central node'',i10,'', coor :'',3g15.7)' + texte(2,9) = '(''.. Creation of internal '',a)' + texte(2,10) = '(''.. Creation of 8 pentahedrons'')' +c +c==== +c 2. decoupage en 8 des pentaedres dont les 5 faces sont coupees en 4 +c==== +c + do 200 , lepent = 1 , nbpepe +c + if ( mod(hetpen(lepent),100) .eq. 0 ) then +c +c 2.1. decoupage ? +c + dt = 0 + do 211 , iaux = 1 , 2 + jaux = facpen(lepent,iaux) + if ( mod(hettri(jaux),10).eq.4 .or. + > mod(hettri(jaux),10).eq.5 .or. + > mod(hettri(jaux),10).eq.6 .or. + > mod(hettri(jaux),10).eq.7 .or. + > mod(hettri(jaux),10).eq.9) then + dt = dt + 1 + endif + 211 continue + do 212 , iaux = 3 , 5 + jaux = facpen(lepent,iaux) + if ( mod(hetqua(jaux),100).eq.4 .or. + > mod(hetqua(jaux),100).eq.99 ) then + dt = dt + 1 + endif + 212 continue +c + if ( dt.eq.5 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,7), lepent +#endif +c +c 2.2. ==> description des 5 faces du pentaedre +c +c 2.2.1. ==> description de la face 1 +c + f1 = facpen(lepent,1) + cf1 = cofape(lepent,1) +c +c 2.2.1.1. ==> reperage des 4 triangles fils +c fiff1 : face opposee a arete ai +c ainsi f1ff1 contient le sommet s2 +c + ff1 = filtri(f1) + f1ff1 = ff1 + i1(cf1) + f2ff1 = ff1 + i2(cf1) + f3ff1 = ff1 + i3(cf1) +c +c 2.2.1.2. ==> reperage des 3 aretes internes +c aiff1 : arete de ff1 qui est // a ai +c + a1ff1 = aretri(ff1,i1(cf1)) + a2ff1 = aretri(ff1,i2(cf1)) + a3ff1 = aretri(ff1,i3(cf1)) +c +c 2.2.2. ==> description de la face 2 +c + f2 = facpen(lepent,2) + cf2 = cofape(lepent,2) +c +c 2.2.2.1. ==> reperage des 4 triangles fils +c + ff2 = filtri(f2) + f4ff2 = ff2 + i1(cf2) + f6ff2 = ff2 + i2(cf2) + f5ff2 = ff2 + i3(cf2) +c +c 2.2.2.2. ==> reperage des 3 aretes internes +c + a4ff2 = aretri(ff2,i1(cf2)) + a6ff2 = aretri(ff2,i2(cf2)) + a5ff2 = aretri(ff2,i3(cf2)) +c +c 2.2.3. ==> description de la face 3 +c + f3 = facpen(lepent,3) + cf3 = cofape(lepent,3) +c +c 2.2.3.1. ==> reperage des 4 quadrangles fils +c + f3s1 = filqua(f3) + defiq1(cf3) + f3s3 = filqua(f3) + defiq2(cf3) + f3s6 = filqua(f3) + defiq3(cf3) + f3s4 = filqua(f3) + defiq4(cf3) +c write(ulsort,*) 'f3s1, f3s3, f3s6, f3s4 ',f3s1, f3s3, f3s6,f3s4 +c +c 2.2.3.2. ==> reperage des 4 aretes internes +c + if ( cf3.lt.5 ) then + n1nf3 = arequa(f3s1,2) + n9nf3 = arequa(f3s3,2) + n4nf3 = arequa(f3s6,2) + n7nf3 = arequa(f3s4,2) + else + n1nf3 = arequa(f3s3,2) + n9nf3 = arequa(f3s6,2) + n4nf3 = arequa(f3s4,2) + n7nf3 = arequa(f3s1,2) + endif +c +c 2.2.4. ==> description de la face 4 +c + f4 = facpen(lepent,4) + cf4 = cofape(lepent,4) +c +c 2.2.4.1. ==> reperage des 4 quadrangles fils +c + f4s2 = filqua(f4) + defiq1(cf4) + f4s1 = filqua(f4) + defiq2(cf4) + f4s4 = filqua(f4) + defiq3(cf4) + f4s5 = filqua(f4) + defiq4(cf4) +c +c 2.2.4.2. ==> reperage des 4 aretes internes +c + if ( cf4.lt.5 ) then + n2nf4 = arequa(f4s2,2) + n7nf4 = arequa(f4s1,2) + n5nf4 = arequa(f4s4,2) + n8nf4 = arequa(f4s5,2) + else + n2nf4 = arequa(f4s1,2) + n7nf4 = arequa(f4s4,2) + n5nf4 = arequa(f4s5,2) + n8nf4 = arequa(f4s2,2) + endif +c +c 2.2.5. ==> description de la face 5 +c + f5 = facpen(lepent,5) + cf5 = cofape(lepent,5) +c +c 2.2.5.1. ==> reperage des 4 quadrangles fils +c + f5s3 = filqua(f5) + defiq1(cf5) + f5s2 = filqua(f5) + defiq2(cf5) + f5s5 = filqua(f5) + defiq3(cf5) + f5s6 = filqua(f5) + defiq4(cf5) +c +c 2.2.5.2. ==> reperage des 4 aretes internes +c + if ( cf5.lt.5 ) then + n3nf5 = arequa(f5s3,2) + n8nf5 = arequa(f5s2,2) + n6nf5 = arequa(f5s5,2) + n9nf5 = arequa(f5s6,2) + else + n3nf5 = arequa(f5s2,2) + n8nf5 = arequa(f5s5,2) + n6nf5 = arequa(f5s6,2) + n9nf5 = arequa(f5s3,2) + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) f1,aretri(f1,1),aretri(f1,2) + > ,aretri(f1,3),0,cf1 + write(ulsort,texte(langue,5)) f2,aretri(f2,1),aretri(f2,2) + > ,aretri(f2,3),0,cf2 + write(ulsort,texte(langue,5)) f3,arequa(f3,1),arequa(f3,2) + > ,arequa(f3,3),arequa(f3,4),cf3 + write(ulsort,texte(langue,5)) f4,arequa(f4,1),arequa(f4,2) + > ,arequa(f4,3),arequa(f4,4),cf4 + write(ulsort,texte(langue,5)) f5,arequa(f5,1),arequa(f5,2) + > ,arequa(f5,3),arequa(f5,4),cf5 +#endif +c +c 2.3. ==> noeuds milieux des faces du pentaedre +c + nf3 = somare(2,n1nf3) + nf4 = somare(2,n2nf4) + nf5 = somare(2,n3nf5) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nf3, nf4, nf5 +#endif +c +c 2.4. ==> creation des aretes internes au pentaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,1) +#endif +c +c 2.4.1. ==> leurs numeros +c + nf3nf4 = indare + 1 + nf4nf5 = indare + 2 + nf5nf3 = indare + 3 + indare = nf5nf3 +c +c 2.4.2. ==> les numeros de leurs sommets avec la convention ad'hoc +c + somare(1,nf3nf4) = min(nf3,nf4) + somare(2,nf3nf4) = max(nf3,nf4) + somare(1,nf4nf5) = min(nf4,nf5) + somare(2,nf4nf5) = max(nf4,nf5) + somare(1,nf5nf3) = min(nf3,nf5) + somare(2,nf5nf3) = max(nf3,nf5) +c +c 2.4.3. ==> leur famille : libre +c + famare(nf3nf4) = 1 + famare(nf4nf5) = 1 + famare(nf5nf3) = 1 +c +c 2.4.4. ==> la parente +c + hetare(nf3nf4) = 50 + hetare(nf4nf5) = 50 + hetare(nf5nf3) = 50 + merare(nf3nf4) = 0 + merare(nf4nf5) = 0 + merare(nf5nf3) = 0 + filare(nf3nf4) = 0 + filare(nf4nf5) = 0 + filare(nf5nf3) = 0 +c +c 2.5. ==> creation des 4 triangles internes +c 2.5.1. ==> recuperation du niveau commun a tous les triangles fils +c le code est 1 par defaut +c + niveau = nivtri(ff1) + codefa = 1 +c +c 2.5.2. ==> creation +c + pf1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > pf1, nf3nf4, nf4nf5, nf5nf3, + > codefa, niveau ) +c + pf1n7 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > pf1n7, nf3nf4, n7nf3, n7nf4, + > codefa, niveau ) +c + pf1n8 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > pf1n8, nf4nf5, n8nf4, n8nf5, + > codefa, niveau ) +c + pf1n9 = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > pf1n9, nf5nf3, n9nf5, n9nf3, + > codefa, niveau ) +c + indtri = pf1n9 +c +c 2.6. ==> creation des 6 quadrangles internes +c tous ces quadrangles sont crees avec le code arbitraire 1 +c et avec le meme niveau que les triangles +c + pf3f1 = indqua + 1 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3f1, a1ff1, n3nf5, nf4nf5, n2nf4, + > codefa, niveau ) +c + pf3f2 = indqua + 2 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf3f2, nf4nf5, n6nf5, a4ff2, n5nf4, + > codefa, niveau ) +c + pf4f1 = indqua + 3 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf4f1, a2ff1, n1nf3, nf5nf3, n3nf5, + > codefa, niveau ) +c + pf4f2 = indqua + 4 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf4f2, nf5nf3, n4nf3, a5ff2, n6nf5, + > codefa, niveau ) +c + pf5f1 = indqua + 5 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf5f1, a3ff1, n2nf4, nf3nf4, n1nf3, + > codefa, niveau ) +c + pf5f2 = indqua + 6 + call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua, + > pf5f2, nf3nf4, n5nf4, a6ff2, n4nf3, + > codefa, niveau ) +c + indqua = pf5f2 +c +c 2.7. ==> creation des 8 pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) +#endif +c + iaux = fampen(lepent) +c + nupent = indpen + 1 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > f3ff1, pf1n7, f3s1, + > f4s1, pf5f1, + > cf1, 6, cofp08(cf3,defiq1(cf3)), + > cofp08(cf4,defiq2(cf4)), 1, + > lepent, iaux, nupent ) +c + nupent = indpen + 2 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > f1ff1, pf1n8, pf3f1, + > f4s2, f5s2, + > cf1, 4, 1, + > cofp08(cf4,defiq1(cf4)), + > cofp08(cf5,defiq2(cf5)), + > lepent, iaux, nupent ) +c + nupent = indpen + 3 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > f2ff1, pf1n9, f3s3, + > pf4f1, f5s3, + > cf1, 5, cofp08(cf3,defiq2(cf3)), + > 1, cofp08(cf5,defiq1(cf5)), + > lepent, iaux, nupent ) +c + nupent = indpen + 4 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > pf1n7, f6ff2, f3s4, + > f4s4, pf5f2, + > 3, cf2, cofp08(cf3,defiq4(cf3)), + > cofp08(cf4,defiq3(cf4)), 1, + > lepent, iaux, nupent ) +c + nupent = indpen + 5 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > pf1n8, f4ff2, pf3f2, + > f4s5, f5s5, + > 1, cf2, 1, + > cofp08(cf4,defiq4(cf4)), cofp08(cf5,defiq3(cf5)), + > lepent, iaux, nupent ) +c + nupent = indpen + 6 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > pf1n9, f5ff2, f3s6, + > pf4f2, f5s6, + > 2, cf2, cofp08(cf3,defiq3(cf3)), + > 1, cofp08(cf5,defiq4(cf5)), + > lepent, iaux, nupent ) +c + nupent = indpen + 7 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > ff1, pf1, pf3f1, + > pf4f1, pf5f1, + > cf1, 6, 5, + > 5, 5, + > lepent, iaux, nupent ) +c + nupent = indpen + 8 + call cmcpen ( facpen, cofape, fampen, + > hetpen, filpen, perpen, + > pf1, ff2, pf3f2, + > pf4f2, pf5f2, + > 3, cf2, 5, + > 5, 5, + > lepent, iaux, nupent ) +c + indpen = nupent +c +c 2.7.3. ==> mise a jour du pentaedre courant et de son pere eventuel +c + filpen(lepent) = indpen - 7 + hetpen(lepent) = hetpen(lepent) + 80 + pere = perpen(lepent) + if ( pere .ne. 0 ) then + etat = hetpen(pere) + hetpen(pere) = etat - mod(etat,100) + 99 + endif +c + endif +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrdqu.F b/src/tool/Creation_Maillage/cmrdqu.F new file mode 100644 index 00000000..5ac1acbf --- /dev/null +++ b/src/tool/Creation_Maillage/cmrdqu.F @@ -0,0 +1,527 @@ + subroutine cmrdqu ( coonoe, hetnoe, arenoe, + > somare, hetare, filare, merare, + > arequa, hetqua, filqua, perqua, + > nivqua, ninqua, decfac, + > famnoe, famare, famqua, + > indnoe, indare, indqua, + > cfaqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Raffinement - Decoupage des QUadrangles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . arequa . es .nouvqu*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . nivqua . es . nouvqu . niveau des quadrangles . +c . ninqua . es . nouvqu . noeud interne au quadrangle . +c . decfac . es . -nouvqu. decision sur les faces (quad. + tri.) . +c . . . :nouvqu. . +c . famnoe . . nouvno . famille des noeuds . +c . famare . . nouvar . famille des aretes . +c . famqua . es . nouvqu . famille des quadrangles . +c . indnoe . es . 1 . indice du derniere noeud cree . +c . indare . es . 1 . indice de la derniere arete creee . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDQU' ) +c +#include "nblang.h" +#include "fractc.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombqu.h" +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer hetnoe(nouvno), arenoe(nouvno) +c + integer decfac(-nouvqu:nouvtr) + integer somare(2,nouvar), hetare(nouvar), filare(nouvar) + integer merare(nouvar) + integer arequa(nouvqu,4), hetqua(nouvqu) + integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu) + integer ninqua(nouvqu) + integer famnoe(nouvno), famare(nouvar), famqua(nouvqu) + integer indnoe, indare, indqua + integer cfaqua(nctfqu,nbfqua) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer n0, n1, n2, n3, n4 + integer a1f1, a1f2, a2f1, a2f2, a3f1, a3f2, a4f1, a4f2 + integer an1n0, an2n0, an3n0, an4n0 + integer nf1, nf2, nf3, nf4 + integer etat, niv, lepere + integer lequad +c + logical noinma +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage du quadrangle'',i10)' + texte(1,5) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)' + texte(1,6) = '(''.. Arete interne'',i10,'', de'',i10,'' a'',i10)' + texte(1,7) = '(''.. Quad fils'',i10,'', aretes :'',4i10)' +c + texte(2,4) = '(''Splitting of quadrangle #'',i10)' + texte(2,5) = '(''.. Central node'',i10,'', coor:'',3g15.7)' + texte(2,6) = + > '(''.. Internal edge'',i10,'', from'',i10,'' to'',i10)' + texte(2,7) = '(''.. Quad son'',i10,'', edges:'',4i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'entree de ',nompro + do 1101 , iaux = 1 , min(nouvar,1) + write (ulsort,90001) 'arete', iaux, + > somare(1,iaux), somare(2,iaux) + 1101 continue + do 1105 , lequad = 1 , min(nouvqu,1) + write (ulsort,90001) 'quadrangle', lequad, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4) + 1105 continue + lequad = 1 + write (ulsort,90001) 'fils du quadrangle', lequad, + > filqua(lequad) + call dmflsh (iaux) +#endif +c + if ( mod(mailet,3).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c +c==== +c 1. decoupage en 4 des quadrangles de decision 4 +c==== +c +c Quadrangle pere : +c ak = numero de la k-eme arete du quadrangle pere +c sajak = numero du noeud commun aux aretes aj et ak +c +c sa4a1 a4 sa3a4 +c ._________________________________________________. +c . . +c . . +c . . +c . . +c . . +c . . +c a1 . . a3 +c . . +c . . +c . . +c . . +c . . +c . . +c ._________________________________________________. +c sa1a2 a2 sa2a3 +c +c Remarque : on appelle ici le sens standard celui correspondant +c a l'enchainement (a1,a2,a3,a4) +c +c Quadrangles fils : +c n0 = numero du noeud barycentre des 4 sommets du quadrangle pere +c nk = numero du noeud milieu de la k-eme arete du quadrangle pere +c akf1/2 = numero des filles de la k-eme arete du quadrangle pere +c akf1 : la premiere dans le sens standard +c akf2 : la seconde dans le sens standard +c nfk = numero du k-eme quadrangle fils : celui qui contient la +c premiere (au sens standard) des filles de l'arete ak +c ankn0 = numero de l'arete qui va de nk a n0. (Par construction, +c n0>nk). Elle est commune aux filles nfk et nf(k+1). +c +c sa4a1 a4f2 a4/n4 a4f1 sa3a4 +c .________________________.________________________. +c . . . +c . . . +c . .an4n0 . +c a1f1 . nf1 . nf4 . a3f2 +c . . . +c . . . +c a1/n1 .________________________.________________________. a3/n3 +c . an1n0 .n0 an3n0 . +c . . . +c . .an2n0 . +c a1f2 . nf2 . nf3 . a3f1 +c . . . +c . . . +c .________________________.________________________. +c sa1a2 a2f1 a2/n2 a2f2 sa2a3 +c +c + do 100 , lequad = 1 , nbqupe +c +cgn write (ulsort,90002)'decision', decfac(-lequad) + if ( decfac(-lequad) .eq. 4 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lequad +#endif +c +c 1.1. ==> determination des numeros d'aretes +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +cgn write (ulsort,90002)'.. indqua',indqua +cgn write (ulsort,90002)'.. indare',indare +cgn write (ulsort,90002)'.. aretes ',a1, a2, a3, a4 +cgn write (ulsort,90002)'.. de filles ',filare(a1), filare(a2), +cgn > filare(a3), filare(a4) +c +c 1.2. ==> determination des 4 sommets +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +cgn write (ulsort,90002)'.. sommets',sa1a2, sa2a3, sa3a4, sa4a1 +c +c 1.3. ==> determination des 8 demi-aretes filles des precedentes +c + call utafqu ( somare, filare, a1, a2, a3, a4, + > a1f1, a1f2, + > a2f1, a2f2, + > a3f1, a3f2, + > a4f1, a4f2 ) +cgn write (ulsort,90002)'.. a1f1/2',a1f1,a1f2 +cgn write (ulsort,90002)'.. a2f1/2',a2f1,a2f2 +cgn write (ulsort,90002)'.. a3f1/2',a3f1,a3f2 +cgn write (ulsort,90002)'.. a4f1/2',a4f1,a4f2 +c +c 1.4. ==> determination des noeuds milieux +c + n1 = somare(2,a1f1) + n2 = somare(2,a2f1) + n3 = somare(2,a3f1) + n4 = somare(2,a4f1) +cgn write (ulsort,90002)'.. nk',n1, n2, n3, n4 +c +c 1.5. ==> le sommet central +c . on le cree au barycentre du quadrangle s'il n'existe pas +c . on le recupere sinon +c + if ( noinma ) then +c + n0 = ninqua(lequad) +c + else +c + n0 = indnoe + 1 + arenoe(n0) = 0 + coonoe(n0,1) = ( coonoe(sa4a1,1) + + > coonoe(sa1a2,1) + + > coonoe(sa2a3,1) + + > coonoe(sa3a4,1) ) * unsqu + coonoe(n0,2) = ( coonoe(sa4a1,2) + + > coonoe(sa1a2,2) + + > coonoe(sa2a3,2) + + > coonoe(sa3a4,2) ) * unsqu + if ( sdim.eq.3 ) then + coonoe(n0,3) = ( coonoe(sa4a1,3) + + > coonoe(sa1a2,3) + + > coonoe(sa2a3,3) + + > coonoe(sa3a4,3) ) * unsqu + endif + famnoe(n0) = 1 + hetnoe(n0) = 51 + indnoe = n0 +c + endif +#ifdef _DEBUG_HOMARD_ + if ( sdim.eq.3 ) then + write (ulsort,texte(langue,5)) n0, + > coonoe(n0,1),coonoe(n0,2),coonoe(n0,3) + else + write (ulsort,texte(langue,5)) n0, + > coonoe(n0,1),coonoe(n0,2) + endif +#endif +cgn write (ulsort,90002)'.. n0',n0 +c +c 1.6. ==> creation des aretes internes +c 1.6.1. ==> leurs numeros +c + an1n0 = indare + 1 + an2n0 = indare + 2 + an3n0 = indare + 3 + an4n0 = indare + 4 + indare = an4n0 +cgn write (ulsort,90002)'.. ankn0',an1n0,an2n0,an3n0,an4n0 +c +c 1.6.2. ==> les numeros de leurs sommets avec la convention ad'hoc +c + somare(1,an1n0) = n1 + somare(2,an1n0) = n0 + somare(1,an2n0) = n2 + somare(2,an2n0) = n0 + somare(1,an3n0) = n3 + somare(2,an3n0) = n0 + somare(1,an4n0) = n4 + somare(2,an4n0) = n0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) an1n0, n1, n0 + write (ulsort,texte(langue,6)) an2n0, n2, n0 + write (ulsort,texte(langue,6)) an3n0, n3, n0 + write (ulsort,texte(langue,6)) an4n0, n4, n0 +#endif +c +c 1.6.3. ==> leur famille +c +cgn write(ulsort,90002) 'famqua(lequad)',famqua(lequad) +cgn write(ulsort,90002) 'avec cfaqua', +cgn >(cfaqua(iaux,famqua(lequad)),iaux=1,nctfqu) +cgn write(ulsort,90002) '==> famare', cfaqua(cofafa,famqua(lequad)) + jaux = cfaqua(cofafa,famqua(lequad)) + famare(an1n0) = jaux + famare(an2n0) = jaux + famare(an3n0) = jaux + famare(an4n0) = jaux +c +c 1.6.4. ==> la parente +c + hetare(an1n0) = 50 + hetare(an2n0) = 50 + hetare(an3n0) = 50 + hetare(an4n0) = 50 + merare(an1n0) = 0 + merare(an2n0) = 0 + merare(an3n0) = 0 + merare(an4n0) = 0 + filare(an1n0) = 0 + filare(an2n0) = 0 + filare(an3n0) = 0 + filare(an4n0) = 0 +c +c 1.7. ==> creation des 4 quadrangles fils +c 1.7.1. ==> connectivite +c on prend soin de tourner dans le meme sens que le pere ... +c + nf1 = indqua + 1 + arequa(nf1,1) = a1f1 + arequa(nf1,2) = an1n0 + arequa(nf1,3) = an4n0 + arequa(nf1,4) = a4f2 +c + nf2 = nf1 + 1 + arequa(nf2,1) = a2f1 + arequa(nf2,2) = an2n0 + arequa(nf2,3) = an1n0 + arequa(nf2,4) = a1f2 +c + nf3 = nf2 + 1 + arequa(nf3,1) = a3f1 + arequa(nf3,2) = an3n0 + arequa(nf3,3) = an2n0 + arequa(nf3,4) = a2f2 +c + nf4 = nf3 + 1 + arequa(nf4,1) = a4f1 + arequa(nf4,2) = an4n0 + arequa(nf4,3) = an3n0 + arequa(nf4,4) = a3f2 +c + indqua = nf4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nf1, a1f1, an1n0, an4n0, a4f2 + write (ulsort,texte(langue,7)) nf2, a2f1, an2n0, an1n0, a1f2 + write (ulsort,texte(langue,7)) nf3, a3f1, an3n0, an2n0, a2f2 + write (ulsort,texte(langue,7)) nf4, a4f1, an4n0, an3n0, a3f2 +#endif +cgn cgn write (ulsort,90002) '... nf1', nf1 +cgn do 171 , iaux = 1,4 +cgn write (ulsort,17)arequa(nf1,iaux), +cgn < somare(1,arequa(nf1,iaux)),somare(2,arequa(nf1,iaux)) +cgn 171 continue +cgn cgn write (ulsort,90002) '... nf2', nf2 +cgn do 172 , iaux = 1,4 +cgn write (ulsort,17)arequa(nf2,iaux), +cgn < somare(1,arequa(nf2,iaux)),somare(2,arequa(nf2,iaux)) +cgn 172 continue +cgn cgn write (ulsort,90002) '... nf3', nf3 +cgn do 173 , iaux = 1,4 +cgn write (ulsort,17)arequa(nf3,iaux), +cgn < somare(1,arequa(nf3,iaux)),somare(2,arequa(nf3,iaux)) +cgn 173 continue +cgn cgn write (ulsort,90002) '... nf4', nf4 +cgn do 174 , iaux = 1,4 +cgn write (ulsort,17)arequa(nf4,iaux), +cgn < somare(1,arequa(nf4,iaux)),somare(2,arequa(nf4,iaux)) +cgn 174 continue +cgn 17 format('.... arete ',i6,' de ',i6,' a ',i6) +c +c 1.7.2. ==> mise a jour de la famille des 4 quadrangles fils +c + iaux = famqua(lequad) + famqua(nf1) = iaux + famqua(nf2) = iaux + famqua(nf3) = iaux + famqua(nf4) = iaux +c + hetqua(nf1) = 5500 + hetqua(nf2) = 5500 + hetqua(nf3) = 5500 + hetqua(nf4) = 5500 +c + filqua(nf1) = 0 + filqua(nf2) = 0 + filqua(nf3) = 0 + filqua(nf4) = 0 + perqua(nf1) = lequad + perqua(nf2) = lequad + perqua(nf3) = lequad + perqua(nf4) = lequad +c + niv = nivqua(lequad) + 1 + nivqua(nf1) = niv + nivqua(nf2) = niv + nivqua(nf3) = niv + nivqua(nf4) = niv +c +c 1.8. ==> mise a jour du pere et du grand-pere eventuel +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains quadrangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c + filqua(lequad) = nf1 + hetqua(lequad) = hetqua(lequad) + 4 + lepere = perqua(lequad) + if ( lepere.gt.0 ) then + etat = hetqua(lepere) + hetqua(lepere) = etat - mod(etat,100) + 99 + endif +cgn write (ulsort,90002)'.. indqua',indqua +cgn write (ulsort,90002)'.. indare',indare +c + endif +c + 100 continue +cgn write (ulsort,*) 'indqua',indqua +cgn write (ulsort,*) 'indare',indare +cgn write (ulsort,*) 'indnoe',indnoe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 1102 , iaux = 1 , min(nouvar,1) + write (ulsort,90001) 'arete', iaux, + > somare(1,iaux), somare(2,iaux) + 1102 continue + do 1106 , lequad = 1 , min(nouvqu,1) + write (ulsort,90001) 'quadrangle', lequad, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4) + 1106 continue + lequad = 1 + write (ulsort,90001) 'fils du quadrangle', lequad, + > filqua(lequad) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrdte.F b/src/tool/Creation_Maillage/cmrdte.F new file mode 100644 index 00000000..cacc8edf --- /dev/null +++ b/src/tool/Creation_Maillage/cmrdte.F @@ -0,0 +1,669 @@ + subroutine cmrdte ( coonoe, somare, hetare, filare, + > merare, aretri, hettri, + > filtri, pertri, nivtri, + > tritet, cotrte, hettet, filtet, + > pertet, + > famare, famtri, famtet, + > indare, indtri, indtet, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Raffinement - Decoupage des TEtraedres +c - - - - -- +c ______________________________________________________________________ +c remarque : on est forcement en 3d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e .nouvno*3. coordonnees des noeuds . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . e . nouvtr . historique de l'etat des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . pertri . e . nouvtr . pere des triangles . +c . nivtri . e . nouvtr . niveau des triangles . +c . tritet . e .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . filtet . es . nouvte . premier fils des tetraedres . +c . pertet . e . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famare . es . nouvar . famille des aretes . +c . famtri . es . nouvtr . famille des triangles . +c . famtet . e . nouvte . famille des tetraedres . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDTE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "i1i2i3.h" +#include "nombte.h" +#include "nouvnb.h" +#include "permut.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nouvno,sdim) +c + integer somare(2,nouvar), hetare(nouvar), filare(nouvar) + integer merare(nouvar), aretri(nouvtr,3) + integer hettri(nouvtr), filtri(nouvtr), pertri(nouvtr) + integer nivtri(nouvtr) + integer tritet(nouvtf,4), cotrte(nouvtf,4) + integer hettet(nouvte), filtet(nouvte), pertet(nouvte) + integer famare(nouvar), famtri(nouvtr), famtet(nouvte) + integer indare, indtri, indtet +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer adiag, dt, etat, letetr, nudiag, pere, typdia + integer niveau, cf1, cf2, cf3, cf4, f1, f2, f3, f4 + integer codefa, codef1, codef2, codef3, codef4 + integer a4ff1, a5ff1, a6ff1, a2ff2, a3ff2, a6ff2 + integer a1ff3, a3ff3, a5ff3, a1ff4, a2ff4, a4ff4 + integer as1n1, as1n2, as1n3, as2n4, as2n5, as3n6 + integer ff1, ff2, ff3, ff4, n1, n2, n3, n4, n5, n6 + integer f4ff1, f5ff1, f6ff1, f2ff2, f3ff2, f6ff2 + integer f1ff3, f3ff3, f5ff3, f1ff4, f2ff4, f4ff4 + integer fparf1, fparf2, fparf3, fparf4 + integer fd16n2, fd16n3, fd16n4, fd16n5 + integer fd25n1, fd25n3, fd25n4, fd25n6 + integer fd34n1, fd34n2, fd34n5, fd34n6 + integer tparf1, tparf2, tparf3, tparf4 + integer t16ff1, t16ff2, t16ff3, t16ff4 + integer t25ff1, t25ff2, t25ff3, t25ff4 + integer t34ff1, t34ff2, t34ff3, t34ff4 +c + integer iaux, jaux +c + double precision long16, long25, long34, xdiag, ydiag, zdiag +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage du '',a,i10)' +c + texte(2,4) = '(''Splitting of '',a,'' #'',i10)' +c +c==== +c 2. decoupage en 8 des tetraedres dont les 4 faces sont coupees en 4 +c==== +c + do 200 , letetr = 1 , nbtepe +c + if ( mod( hettet(letetr) , 100 ) .eq. 0 ) then +c +c 2.1. decoupage ? +c + dt = 0 + do 21 , iaux = 1 , 4 + jaux = tritet(letetr,iaux) + if ( mod(hettri(jaux),10).eq.4 .or. + > mod(hettri(jaux),10).eq.5 .or. + > mod(hettri(jaux),10).eq.6 .or. + > mod(hettri(jaux),10).eq.7 .or. + > mod(hettri(jaux),10).eq.9) then + dt = dt + 1 + endif + 21 continue +c + if ( dt.eq.4 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,3), letetr +#endif +c +c 2.2. ==> description des 4 faces du tetraedre +c +c 2.2.1. ==> description de la face 1 +c + f1 = tritet(letetr,1) + cf1 = cotrte(letetr,1) +c +c 2.2.1.1. ==> reperage des 4 triangles fils +c + ff1 = filtri(f1) + f4ff1 = ff1 + i1(cf1) + f5ff1 = ff1 + i2(cf1) + f6ff1 = ff1 + i3(cf1) +c +c 2.2.1.2. ==> reperage des 3 aretes internes +c + a4ff1 = aretri(ff1,i1(cf1)) + a5ff1 = aretri(ff1,i2(cf1)) + a6ff1 = aretri(ff1,i3(cf1)) +c +c 2.2.2. ==> description de la face 2 +c + f2 = tritet(letetr,2) + cf2 = cotrte(letetr,2) +c +c 2.2.2.1. ==> reperage des 4 triangles fils +c + ff2 = filtri(f2) + f2ff2 = ff2 + i1(cf2) + f3ff2 = ff2 + i2(cf2) + f6ff2 = ff2 + i3(cf2) +c +c 2.2.2.2. ==> reperage des 3 aretes internes +c + a2ff2 = aretri(ff2,i1(cf2)) + a3ff2 = aretri(ff2,i2(cf2)) + a6ff2 = aretri(ff2,i3(cf2)) +c +c 2.2.3. ==> description de la face 3 +c + f3 = tritet(letetr,3) + cf3 = cotrte(letetr,3) +c +c 2.2.3.1. ==> reperage des 4 triangles fils +c + ff3 = filtri(f3) + f1ff3 = ff3 + i1(cf3) + f3ff3 = ff3 + i2(cf3) + f5ff3 = ff3 + i3(cf3) +c +c 2.2.3.2. ==> reperage des 3 aretes internes +c + a1ff3 = aretri(ff3,i1(cf3)) + a3ff3 = aretri(ff3,i2(cf3)) + a5ff3 = aretri(ff3,i3(cf3)) +c +c 2.2.4. ==> description de la face 4 +c + f4 = tritet(letetr,4) + cf4 = cotrte(letetr,4) +c +c 2.2.4.1. ==> reperage des 4 triangles fils +c + ff4 = filtri(f4) + f1ff4 = ff4 + i1(cf4) + f2ff4 = ff4 + i2(cf4) + f4ff4 = ff4 + i3(cf4) +c +c 2.2.4.2. ==> reperage des 3 aretes internes +c + a1ff4 = aretri(ff4,i1(cf4)) + a2ff4 = aretri(ff4,i2(cf4)) + a4ff4 = aretri(ff4,i3(cf4)) +c +c 2.3. ==> reperage des noeuds milieux des aretes +c + as1n1 = aretri(f5ff3,i1(cf3)) + as1n2 = aretri(f6ff2,i1(cf2)) + as1n3 = aretri(f6ff2,i2(cf2)) + as2n4 = aretri(f6ff1,i1(cf1)) + as2n5 = aretri(f6ff1,i2(cf1)) + as3n6 = aretri(f5ff1,i3(cf1)) +c + n1 = somare(2,as1n1) + n2 = somare(2,as1n2) + n3 = somare(2,as1n3) + n4 = somare(2,as2n4) + n5 = somare(2,as2n5) + n6 = somare(2,as3n6) +c +c 2.4. ==> calcul des longueurs des diagonales et choix +c de la plus petite +c + xdiag = coonoe(n1,1) - coonoe(n6,1) + ydiag = coonoe(n1,2) - coonoe(n6,2) + zdiag = coonoe(n1,3) - coonoe(n6,3) + long16 = xdiag * xdiag + ydiag * ydiag + zdiag * zdiag + xdiag = coonoe(n2,1) - coonoe(n5,1) + ydiag = coonoe(n2,2) - coonoe(n5,2) + zdiag = coonoe(n2,3) - coonoe(n5,3) + long25 = xdiag * xdiag + ydiag * ydiag + zdiag * zdiag + xdiag = coonoe(n3,1) - coonoe(n4,1) + ydiag = coonoe(n3,2) - coonoe(n4,2) + zdiag = coonoe(n3,3) - coonoe(n4,3) + long34 = xdiag * xdiag + ydiag * ydiag + zdiag * zdiag +c + if ( long16 .le. long25 ) then + if ( long16 .le. long34 ) then + nudiag = 16 + typdia = 5 + else + nudiag = 34 + typdia = 7 + endif + else + if ( long25 .le. long34 ) then + nudiag = 25 + typdia = 6 + else + nudiag = 34 + typdia = 7 + endif + endif +c +c 2.5. ==> creation de l'arete diagonale +c + adiag = indare + 1 + indare = adiag +c + if ( nudiag .eq. 16 ) then + somare(1,adiag) = min ( n1 , n6 ) + somare(2,adiag) = max ( n1 , n6 ) + elseif ( nudiag .eq. 25 ) then + somare(1,adiag) = min ( n2 , n5 ) + somare(2,adiag) = max ( n2 , n5 ) + else + somare(1,adiag) = min ( n3 , n4 ) + somare(2,adiag) = max ( n3 , n4 ) + endif +c + famare(adiag) = 1 +c + hetare(adiag) = 50 + merare(adiag) = 0 + filare(adiag) = 0 +c +c 2.6. ==> creation des faces +c +c 2.6.1. ==> recuperation du niveau commun a tous les triangles fils +c + niveau = nivtri(ff1) +c +c 2.6.2. ==> creation des 4 faces d'angle +c + fparf1 = indtri + 1 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fparf1, a4ff4, a5ff3, a6ff2, + > cf1, niveau ) +c + fparf2 = indtri + 2 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fparf2, a2ff4, a3ff3, a6ff1, + > cf2, niveau ) +c + fparf3 = indtri + 3 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fparf3, a1ff4, a3ff2, a5ff1, + > cf3, niveau ) +c + fparf4 = indtri + 4 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fparf4, a1ff3, a2ff2, a4ff1, + > cf4, niveau ) +c +c 2.6.3 ==> creation des 4 faces internes en fonction de la diagonale +c +c tous ces triangles sont crees avec le code arbitraire 1 +c et avec le meme niveau que les nouvelles 4 faces d'angle +c + codefa = 1 +c + if ( nudiag .eq. 16 ) then +c + fd16n2 = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16n2, adiag, a3ff2, a4ff4, + > codefa, niveau ) +c + fd16n3 = indtri + 6 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16n3, adiag, a2ff2, a5ff3, + > codefa, niveau ) +c + fd16n4 = indtri + 7 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16n4, adiag, a2ff4, a5ff1, + > codefa, niveau ) +c + fd16n5 = indtri + 8 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd16n5, adiag, a3ff3, a4ff1, + > codefa, niveau ) +c + indtri = fd16n5 +c + elseif ( nudiag .eq. 25 ) then +c + fd25n1 = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25n1, adiag, a3ff3, a4ff4, + > codefa, niveau ) +c + fd25n3 = indtri + 6 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25n3, a1ff3, adiag, a6ff2, + > codefa, niveau ) +c + fd25n4 = indtri + 7 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25n4, adiag, a1ff4, a6ff1, + > codefa, niveau ) +c + fd25n6 = indtri + 8 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd25n6, a3ff2, adiag, a4ff1, + > codefa, niveau ) +c + indtri = fd25n6 +c + else +c + fd34n1 = indtri + 5 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34n1, adiag, a5ff3, a2ff4, + > codefa, niveau ) +c + fd34n2 = indtri + 6 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34n2, adiag, a1ff4, a6ff2, + > codefa, niveau ) +c + fd34n5 = indtri + 7 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34n5, a1ff3, adiag, a6ff1, + > codefa, niveau ) +c + fd34n6 = indtri + 8 + call cmctri ( aretri, famtri, hettri, + > filtri, pertri, nivtri, + > fd34n6, a2ff2, adiag, a5ff1, + > codefa, niveau ) +c + indtri = fd34n6 +c + endif +c +c 2.7. ==> creation des tetraedres +c + iaux = famtet(letetr) +c +c 2.7.1. ==> creation des 4 tetraedres d'angle +c + tparf1 = indtet + 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fparf1, f6ff2, f5ff3, f4ff4, + > cf1, cf2, cf3, cf4, + > letetr, iaux, tparf1 ) +c + tparf2 = indtet + 2 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f6ff1, fparf2, f3ff3, f2ff4, + > cf1, cf2, cf3, cf4, + > letetr, iaux, tparf2 ) +c + tparf3 = indtet + 3 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f5ff1, f3ff2, fparf3, f1ff4, + > cf1, cf2, cf3, cf4, + > letetr, iaux, tparf3 ) +c + tparf4 = indtet + 4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > f4ff1, f2ff2, f1ff3, fparf4, + > cf1, cf2, cf3, cf4, + > letetr, iaux, tparf4 ) +c +c 2.7.2. ==> creation des 4 tetraedres internes en fonction +c de la diagonale +c + if ( nudiag .eq. 16 ) then +c ancien 1 + t16ff1 = indtet + 5 + codef1 = cf1 + codef2 = perm3(cf2) + codef3 = 1 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1, fparf2, fd16n4, fd16n5, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t16ff1 ) +c ancien 3 + t16ff3 = indtet + 7 + codef1 = 3 + codef2 = 5 + codef3 = cf3 + codef4 = perm1(cf4) + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd16n3, fd16n5, ff3, fparf4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t16ff3 ) +c ancien 2 + t16ff2 = indtet + 6 + codef1 = perm3(cf1) + codef2 = cf2 + codef3 = 1 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fparf1, ff2, fd16n2, fd16n3, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t16ff2 ) +c ancien 4 + t16ff4 = indtet + 8 + codef1 = 5 + codef2 = 3 + codef3 = perm1(cf3) + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd16n2, fd16n4, fparf3, ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t16ff4 ) +c + indtet = t16ff4 +c + elseif ( nudiag .eq. 25 ) then +c + t25ff1 = indtet + 5 + codef1 = cf1 + codef2 = 1 + codef3 = perm3(cf3) + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1, fd25n4, fparf3, fd25n6, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t25ff1 ) +c + t25ff2 = indtet + 6 + codef1 = 1 + codef2 = cf2 + codef3 = 2 + codef4 = perm2(cf4) + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd25n3, ff2, fd25n6, fparf4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t25ff2 ) +c + t25ff3 = indtet + 7 + codef1 = perm2(cf1) + codef2 = 1 + codef3 = cf3 + codef4 = 1 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fparf1, fd25n1, ff3, fd25n3, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t25ff3 ) +c + t25ff4 = indtet + 8 + codef1 = 2 + codef2 = perm1(cf2) + codef3 = 3 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd25n1, fparf2, fd25n4, ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t25ff4 ) +c + indtet = t25ff4 +c + else +c ancien 1 + t34ff1 = indtet + 5 + codef1 = cf1 + codef2 = 1 + codef3 = 1 + codef4 = perm3(cf4) + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > ff1, fd34n5, fd34n6, fparf4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t34ff1 ) +c ancien 2 + t34ff2 = indtet + 6 + codef1 = 1 + codef2 = cf2 + codef3 = perm2(cf3) + codef4 = 2 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd34n2, ff2, fparf3, fd34n6, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t34ff2 ) +c ancien 4 + t34ff4 = indtet + 8 + codef1 = perm1(cf1) + codef2 = 2 + codef3 = 6 + codef4 = cf4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fparf1, fd34n1, fd34n2, ff4, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t34ff4 ) +c ancien 3 + t34ff3 = indtet + 7 + codef1 = 1 + codef2 = perm2(cf2) + codef3 = cf3 + codef4 = 4 + call cmctet ( tritet, cotrte, famtet, + > hettet, filtet, pertet, + > fd34n1, fparf2, ff3, fd34n5, + > codef1, codef2, codef3, codef4, + > letetr, iaux, t34ff3 ) +c + indtet = t34ff4 +c + endif +c +c 2.7.3. ==> mise a jour du tetredre courant et de son pere eventuel +c + filtet(letetr) = tparf1 + hettet(letetr) = hettet(letetr) + 80 + typdia + pere = pertet(letetr) + if ( pere .ne. 0 ) then + etat = hettet(pere) + hettet(pere) = etat - mod(etat,100) + 99 + endif +c + endif +c + endif +c + 200 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmrdtr.F b/src/tool/Creation_Maillage/cmrdtr.F new file mode 100644 index 00000000..d0389b44 --- /dev/null +++ b/src/tool/Creation_Maillage/cmrdtr.F @@ -0,0 +1,307 @@ + subroutine cmrdtr ( somare, hetare, filare, merare, + > aretri, hettri, filtri, pertri, + > nivtri, decfac, + > famare, famtri, + > indare, indtri, + > cfatri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - Raffinement - Decoupage des TRiangles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . merare . es . nouvar . mere des aretes . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . nivtri . es . nouvtr . niveau des triangles . +c . decfac . es . -nouvqu. decision sur les faces (quad. + tri.) . +c . . . :nouvtr. . +c . famare . . nouvar . famille des aretes . +c . famtri . es . nouvtr . famille des triangles . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMRDTR' ) +c +#include "nblang.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombtr.h" +#include "nouvnb.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer decfac(-nouvqu:nouvtr) + integer somare(2,nouvar), hetare(nouvar), filare(nouvar) + integer merare(nouvar), aretri(nouvtr,3), hettri(nouvtr) + integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr) + integer famare(nouvar), famtri(nouvtr) + integer indare, indtri + integer cfatri(nctftr,nbftri) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer fammer, letria + integer n1, n2, n3, as1s2, as1s3, as2s3 + integer as1n2, as1n3, as2n1, as2n3, as3n1, as3n2 + integer af1, af2, af3, etat, nf, nf1, nf2, nf3, niv + integer lepere + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decoupage du triangle'',i10)' +c + texte(2,4) = '(''Splitting of triangle #'',i10)' +c +#include "impr03.h" +c +c==== +c 1. decoupage en 4 des triangles de decision 4 +c==== +c +cgn print *,'indtri',indtri +cgn print *,'indare',indare + do 100 , letria = 1 , nbtrpe +cgn print *,letria,decfac(letria) +c + if ( decfac(letria).eq.4 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) letria +#endif +c +c 1.1. ==> determination des numeros d'aretes +c + as2s3 = aretri(letria,1) + as1s3 = aretri(letria,2) + as1s2 = aretri(letria,3) +cgn write (ulsort,90002)'.. indqua',indqua +cgn write (ulsort,90002)'.. indare',indare +cgn write (ulsort,90002)'.. aretes ',as2s3,as1s3,as1s2 +cgn write (ulsort,90002)'.. de filles ',filare(as2s3), +cgn > filare(as1s3),filare(as1s2) +c +c 1.2. ==> determination des 6 demi-aretes filles des precedentes +c + call utaftr ( somare, filare, as2s3, as1s3, as1s2, + > as2n1, as3n1, + > as3n2, as1n2, + > as1n3, as2n3 ) +c +c 1.3. ==> determination des noeuds milieux +c + n1 = somare(2,as2n1) + n2 = somare(2,as1n2) + n3 = somare(2,as1n3) +c +c 1.4. ==> creation des aretes internes +c +c 1.4.1. ==> leurs numeros +c + af1 = indare + 1 + af2 = indare + 2 + af3 = indare + 3 + indare = af3 +c +c 1.4.2. ==> les numeros de leurs sommets avec la convention ad'hoc +c + somare(1,af1) = min ( n2 , n3 ) + somare(2,af1) = max ( n2 , n3 ) + somare(1,af2) = min ( n1 , n3 ) + somare(2,af2) = max ( n1 , n3 ) + somare(1,af3) = min ( n1 , n2 ) + somare(2,af3) = max ( n1 , n2 ) +c +c 1.4.3. ==> leur famille +c +cgn write(ulsort,90002) 'famtri(letria)',famtri(letria) +cgn write(ulsort,90002) 'avec cfatri', +cgn >(cfatri(iaux,famtri(letria)),iaux=1,nctftr) +cgn write(ulsort,90002) '==> famare', cfatri(cofafa,famtri(letria)) + iaux = cfatri(cofafa,famtri(letria)) + famare(af1) = iaux + famare(af2) = iaux + famare(af3) = iaux +c +c 1.4.4. ==> la parente +c + hetare(af1) = 50 + hetare(af2) = 50 + hetare(af3) = 50 + merare(af1) = 0 + merare(af2) = 0 + merare(af3) = 0 + filare(af1) = 0 + filare(af2) = 0 + filare(af3) = 0 +c +c 1.5. ==> creation des 4 triangles fils +c +c triangle central : nf +c + nf = indtri + 1 + aretri(nf,1) = af1 + aretri(nf,2) = af2 + aretri(nf,3) = af3 +c +c triangle : nf + 1 +c + nf1 = nf + 1 + aretri(nf1,1) = af1 + aretri(nf1,2) = as1n2 + aretri(nf1,3) = as1n3 +c +c triangle : nf + 2 +c + nf2 = nf + 2 + aretri(nf2,1) = as2n1 + aretri(nf2,2) = af2 + aretri(nf2,3) = as2n3 +c +c triangle : nf + 3 +c + nf3 = nf + 3 + aretri(nf3,1) = as3n1 + aretri(nf3,2) = as3n2 + aretri(nf3,3) = af3 +c + indtri = nf + 3 +c +c 1.6. ==> mise a jour de la famille des 4 triangles fils +c + fammer = famtri(letria) + famtri(nf) = fammer + famtri(nf1) = fammer + famtri(nf2) = fammer + famtri(nf3) = fammer +c + hettri(nf) = 50 + hettri(nf1) = 50 + hettri(nf2) = 50 + hettri(nf3) = 50 + filtri(nf) = 0 + filtri(nf1) = 0 + filtri(nf2) = 0 + filtri(nf3) = 0 + pertri(nf) = letria + pertri(nf1) = letria + pertri(nf2) = letria + pertri(nf3) = letria + niv = nivtri(letria) + 1 + nivtri(nf) = niv + nivtri(nf1) = niv + nivtri(nf2) = niv + nivtri(nf3) = niv +c +c 1.7. ==> mise a jour du pere et du grand-pere eventuel +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains triangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c Le cas des peres negatif parce que quadrangle de conformite +c n'existe plus a ce stade : ces triangles ont ete detruits +c en amont +c + filtri(letria) = nf + hettri(letria) = hettri(letria) + 4 + lepere = pertri(letria) + if ( lepere.gt.0 ) then + etat = hettri(lepere) + hettri(lepere) = etat - mod(etat,10) + 9 + endif +c + endif +c + 100 continue +cgn print *,'indtri',indtri +cgn print *,'indare',indare +c +c==== +c 2. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Creation_Maillage/cmtrnp.F b/src/tool/Creation_Maillage/cmtrnp.F new file mode 100644 index 00000000..213c4906 --- /dev/null +++ b/src/tool/Creation_Maillage/cmtrnp.F @@ -0,0 +1,506 @@ + subroutine cmtrnp ( nohman, nohmap, typnom, + > lgopti, taopti, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Creation du Maillage - TRansfert du maillage N dans le maillage N+1 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohman . e . ch8 . nom de l'objet contenant le maillage n . +c . nohmap . es . ch8 . nom de l'objet contenant le maillage n+1 . +c . typnom . e . 1 . type du nom de l'objet maillage n+1 . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'CMTRNP' ) +c +#include "nblang.h" +#include "envca1.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nohman, nohmap +c + integer typnom +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' TRANSFERT DU MAILLAGE'')' + texte(1,5) = '(28(''=''),/)' + texte(1,6) ='(''De la structure '',a8,'' vers la structure '',a8)' +c + texte(2,4) = '(/,a6,'' TRANSFER OF ADAPTED MESH'')' + texte(2,5) = '(31(''=''),/)' + texte(2,6) = '(''From structure '',a8,'' to structure '',a8)' +c +#include "impr03.h" +c +c 1.2. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.3. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nohman, nohmap + call gmprsx (nompro, nohman ) +#endif +c +c==== +c 2. recuperation de la structure generale +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nohman, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. transfert de la structure de l'iteration n vers n+1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Transfert ; codret', codret +#endif +c +c 3.1. ==> allocation de la tete du maillage HOMARD +c + if ( typnom.eq.0 ) then +c + call gmalot ( nohmap, 'HOM_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nohmap, 'HOM_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + else +c + codret = -1 +c + endif +c +c 3.2. ==> on recopie les attributs qui ne varient pas +c + if ( codret.eq.0 ) then +c + call gmecat ( nohmap, 1, sdim, codre1 ) + call gmecat ( nohmap, 2, mdim, codre2 ) + call gmecat ( nohmap, 3, degre, codre3 ) + call gmecat ( nohmap, 5, homolo, codre4 ) + call gmecat ( nohmap, 6, hierar, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmecat ( nohmap, 8, nbmane, codre1 ) + call gmecat ( nohmap, 9, typcca, codre2 ) + call gmecat ( nohmap,10, typsfr, codre3 ) + call gmecat ( nohmap,11, maextr, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 3.3. ==> nombre de mailles ignorees +c + if ( codret.eq.0 ) then +c + call gmliat ( nhelig, 1, iaux, codret ) +c + endif +c +c 3.4. ==> on etablit l'attribut qui precise comment on a obtenu +c le maillage +c 0 : macro-maillage +c 1 : le maillage est inchange +c 2 : le maillage est issu du raffinement pur +c d'un autre maillage +c 3 : le maillage est issu du deraffinement +c pur d'un autre maillage +c 4 : le maillage est issu de raffinement et +c de deraffinement d'un autre maillage +c 12 : le maillage est un maillage passe de degre 1 a 2 +c 21 : le maillage est un maillage passe de degre 2 a 1 +c 31 : le maillage est un maillage avec ajout des joints +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. Attribut rafdef ; codret', codret + write (ulsort,90002) '.. taopti(4)', taopti(4) + write (ulsort,90002) '.. taopti(31)', taopti(31) + write (ulsort,90002) '.. taopti(31)', taopti(31) + write (ulsort,90002) '.. taopti(41)', taopti(41) + write (ulsort,90002) '.. taopti(42)', taopti(42) + write (ulsort,90002) '.. degre', degre +#endif + if ( codret.eq.0 ) then +c + if ( taopti(4).ne.3 ) then +c + if ( taopti(31).eq.0 ) then + if ( taopti(32).eq.0 ) then + rafdef = 1 + else + rafdef = 3 + endif + else + if ( taopti(32).eq.0 ) then + rafdef = 2 + else + if ( rafdef.eq.0 ) then + rafdef = 2 + else + rafdef = 4 + endif + endif + endif +c + else +c + if ( taopti(41).eq.1 ) then + if ( degre.eq.2 ) then + rafdef = 12 + else + rafdef = 21 + endif + elseif ( taopti(42).eq.1 ) then + rafdef = 31 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> rafdef', rafdef +#endif +c + call gmecat ( nohmap, 7, rafdef, codret ) +c + endif +c +c 3.5. ==> conformite du maillage +c . si dans cette etape de raffinement, on a demande du +c non-conforme, alors on suppose que le maillage le sera. +c La caracteristique est : +c 0 : conforme +c 1 : non-conforme avec au minimum 2 aretes non decoupees en 2 +c par face (triangle ou quadrangle) +c 2 : non-conforme avec 1 seul noeud pendant par arete +c 3 : non-conforme fidele a l'indicateur +c -1 : conforme, avec des boites pour les quadrangles, hexaedres +c et pentaedres +c -2 : non-conforme avec au maximum 1 arete decoupee en 2 et des +c boites pour les quadrangles, hexaedres et pentaedres +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(30)', taopti(30) + write (ulsort,90002) 'maconf initial', maconf +#endif +c + if ( taopti(30).eq.-2 ) then + maconf = -2 + elseif ( taopti(30).eq.-1 ) then + maconf = -1 + elseif ( taopti(30).eq.1 ) then + maconf = 1 + elseif ( taopti(30).eq.2 ) then + maconf = 2 + elseif ( taopti(30).eq.3 ) then + maconf = 3 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maconf nouveau', maconf +#endif +c + call gmecat ( nohmap, 4, maconf, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 3.5. ==> on attache les champs du nouveau maillage +c attention : pour les descriptions des aretes, des faces +c et des volumes, la structure a un niveau inferieur. Il faut +c dans ce cas donner le nom complet dans l'appel a gmatoj. +c dans les autres cas (noeuds, voisins, ...), ce sont des +c objets simples que l'on peut attacher par leur nom. +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. Attachement ; codret', codret +#endif +c +c 3.5.1. ==> les noeuds +c + if ( codret.eq.0 ) then +c + call gmobal ( nhnoeu, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Noeud', nhnoeu, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.2. ==> les mailles-points +c + if ( codret.eq.0 ) then +c + call gmobal ( nhmapo, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Ma_Point', nhmapo, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.3. ==> les aretes +c + if ( codret.eq.0 ) then +c + call gmobal ( nharet, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Arete', nohman//'.Arete', codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.4. ==> les faces +c + if ( codret.eq.0 ) then +c + call gmobal ( nhtria, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Face', nohman//'.Face', codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.5. ==> les volumes +c + if ( codret.eq.0 ) then +c + call gmobal ( nhtetr, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Volume', nohman//'.Volume', codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.6. ==> les voisinages +c + if ( codret.eq.0 ) then +c + call gmobal ( nhvois, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.Voisins', nhvois, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.7. ==> les mailles eliminees +c + if ( codret.eq.0 ) then +c + call gmobal ( nhelig, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.ElemIgno', nhelig, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +c 3.5.8. ==> les informations supplementaires +c + if ( codret.eq.0 ) then +c + call gmobal ( nhsupe, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.InfoSupE', nhsupe, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmobal ( nhsups, codre1 ) + if ( codre1.eq.1 ) then + call gmatoj ( nohmap//'.InfoSupS', nhsups, codre0 ) + codret = max ( abs(codre0), codret ) + elseif ( codre1.ne.0 ) then + codret = 2 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nohmap ) + call gmprsx (nompro, nohmap//'.InfoSupS' ) + call gmprsx (nompro, nohmap//'.InfoSupS.Tab3' ) +#endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/CMakeLists.txt b/src/tool/Decision/CMakeLists.txt new file mode 100644 index 00000000..6d978e06 --- /dev/null +++ b/src/tool/Decision/CMakeLists.txt @@ -0,0 +1,134 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Decision + +SET(Decision_SOURCES + ./deard0.F + ./debil1.F + ./debila.F + ./decfs0.F + ./decfs1.F + ./decfs2.F + ./decfs3.F + ./decfsu.F + ./decine.F + ./decora.F + ./decpt0.F + ./decpte.F + ./decr02.F + ./decr03.F + ./decr05.F + ./dedco1.F + ./dedco2.F + ./dedcon.F + ./dedera.F + ./dedin1.F + ./dedin2.F + ./dedini.F + ./deeli1.F + ./deelig.F + ./dehist.F + ./dehmaj.F + ./dehom1.F + ./dehomo.F + ./dehova.F + ./dehovf.F + ./deiard.F + ./deiari.F + ./deiarr.F + ./deihed.F + ./deihei.F + ./deiher.F + ./deinb1.F + ./deinbi.F + ./deinfi.F + ./deini0.F + ./deini2.F + ./deini3.F + ./deini4.F + ./deini5.F + ./deinii.F + ./deinit.F + ./deinnu.F + ./deinod.F + ./deinoi.F + ./deinor.F + ./deinri.F + ./deinse.F + ./deinst.F + ./deinti.F + ./deinun.F + ./deinz0.F + ./deinz1.F + ./deinz2.F + ./deinzr.F + ./deiped.F + ./deipei.F + ./deiper.F + ./deipyd.F + ./deipyi.F + ./deipyr.F + ./deiqud.F + ./deiqui.F + ./deiqur.F + ./deisa1.F + ./deisa2.F + ./deisau.F + ./deisfa.F + ./deisno.F + ./deisv0.F + ./deisv1.F + ./deisv2.F + ./deisv3.F + ./deisv4.F + ./deisv5.F + ./deisv6.F + ./deisv7.F + ./deisv8.F + ./deited.F + ./deitei.F + ./deiter.F + ./deitrd.F + ./deitri.F + ./deitrr.F + ./deiuc0.F + ./deiucm.F + ./delis1.F + ./delist.F + ./deraff.F + ./derco1.F + ./derco2.F + ./derco3.F + ./derco4.F + ./derco5.F + ./derco6.F + ./derco7.F + ./derco8.F + ./derco9.F + ./dercon.F + ./desmaj.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Decision ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Decision ${Decision_SOURCES}) + +INSTALL(TARGETS Decision EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Decision/deard0.F b/src/tool/Decision/deard0.F new file mode 100644 index 00000000..42b659f7 --- /dev/null +++ b/src/tool/Decision/deard0.F @@ -0,0 +1,231 @@ + subroutine deard0 ( nomail, ntrav1, ntrav2, ntrav3, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, + > phethe, pquahe, pcoquh, + > phetpy, pfacpy, pcofay, + > phetpe, pfacpe, pcofap, + > pposif, pfacar, + > advotr, advoqu, adpptr, adppqu, + > pdecfa, pdecar, + > adhoar, adhotr, adhoqu, + > ptrav3, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Adresses pour le Raffinement +c -- - - +c et le Deraffinement - phase 0 +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEARD0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*8 nomail, ntrav1, ntrav2, ntrav3 +c + integer phetar, psomar, pfilar, pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer phette, ptrite + integer phethe, pquahe, pcoquh + integer phetpy, pfacpy, pcofay + integer phetpe, pfacpe, pcofap + integer pposif, pfacar + integer advotr, advoqu, adpptr, adppqu + integer pdecfa, pdecar + integer adhoar, adhotr, adhoqu + integer ptrav3 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre0 + integer codre1, codre2 +c + integer adnmtr + integer adnmqu +c + character*8 nharet, nhtria, nhquad + character*8 nhvois +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. structure generale +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD99', nompro +#endif + call utad99 ( nomail, + > phetar, psomar, pfilar, pmerar, adhoar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > adnmqu, adhoqu, + > phette, ptrite, + > phethe, pquahe, pcoquh, + > phetpy, pfacpy, pcofay, + > phetpe, pfacpe, pcofap, + > nhvois, nharet, nhtria, nhquad, + > ulsort, langue, codret ) +c +c==== +c 3. les voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. les voisinages ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*13*17 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. les decisions et les homologues +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. decisions/homologues ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 5. allocations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. alloc supplementaires ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbtrac + nbquac + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/debil1.F b/src/tool/Decision/debil1.F new file mode 100644 index 00000000..e0edac16 --- /dev/null +++ b/src/tool/Decision/debil1.F @@ -0,0 +1,516 @@ + subroutine debil1 ( tyconf, + > decfac, decare, + > hetare, + > hettri, aretri, + > hetqua, arequa, + > hethex, quahex, + > hetpen, facpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - BILan de la conformite - 1 +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . decare . es . nbarto . decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : il existe encore des non conformites . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEBIL1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer decfac(-nbquto:nbtrto), decare(0:nbarto) + integer hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer hethex(nbheto), quahex(nbhecf,6) + integer hetpen(nbpeto), facpen(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer laface, faced, etatfa + integer larelo, larete, etatar + integer typenh, nbento, nbaret + integer nbarpb, nbarp0, nbarp1, nbarp2, aret01 + integer lepent + integer lehexa +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Probleme avec un '',a)' + texte(1,5) = + > '(a,''numero '',i10,'' : decision ='',i2,'', etat ='',i5)' + texte(1,6) = '(''Examen du '',a,'' numero'',i10)' +c + texte(2,4) = '(''Problem with a '',a)' + texte(2,5) = + > '(a,''#'',i10,'' : decision='',i2,'', status='',i5)' + texte(2,6) = '(''Examination of the '',a,'' #'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +c==== +c 2. on explore tous les faces actives a garder +c on verifie que les seules situations autorisees sont : +c pilraf = 1 ou 2 : libre +c pilraf = 3 : non-conforme avec 1 arete decoupee unique par element +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------- --------------- +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c --------------- --------X------ +c . . . . +c . . . . +c X . . . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c ==> il reste au moins deux aretes non coupees +c <==> le nombre d'aretes active ou a reactiver vaut : +c . 2 ou 3 pour un triangle +c . 2, 3 ou 4 pour un quadrangle +c +c pilraf = 4 : non-conforme avec 1 noeud pendant unique par arete +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------- --------------- +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c +c . --------------- +c . . . . +c . . . . +c X . X . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c +c -------X------- -------X------- +c . . . . +c . . . . +c . . X . +c . . . . +c . . . . +c . . . . +c --------X------ --------X------ +c ==> tout est possible, sauf toutes les aretes coupees +c <==> le nombre d'aretes active ou a reactiver vaut : +c . 1, 2 ou 3 pour un triangle +c . 1, 2, 3 ou 4 pour un quadrangle +c==== +c + codret = 0 + nbarp0 = 0 + nbarp1 = 1 +c + do 2 , typenh = 2, 4, 2 +cgn write (ulsort,*) mess14(langue,2,typenh) +c + if ( typenh.eq.2 ) then + nbento = nbtrto + nbaret = 3 + nbarp2 = 1 + else + nbento = nbquto + nbaret = 4 + if ( tyconf.lt.0 ) then + nbarp2 = 2 + else + nbarp2 = 1 + endif + endif +c + do 20, laface = 1 , nbento +c + if ( typenh.eq.2 ) then + etatfa = mod( hettri(laface) , 10 ) + faced = laface + else + etatfa = mod( hetqua(laface) , 100 ) + faced = -laface + endif +cgn write (ulsort,1789)mess14(langue,1,typenh), +cgn > laface,etatfa,decfac(faced) +cgn 1789 format(a,i6,' etat=',i4,' decision=',i2) +c + if ( etatfa.eq.0 ) then +c + if ( decfac(faced).eq.0 ) then +c +c 2.1. ==> on compte les aretes actives a garder et les aretes +c inactives a reactiver +c + nbarpb = 0 + aret01 = 0 +c + do 200 , larelo = 1 , nbaret + if ( typenh.eq.2 ) then + larete = aretri(laface,larelo) + else + larete = arequa(laface,larelo) + endif +cgn write (ulsort,1789)'arete',larete,hetare(larete),decare(larete) + if ( decare(larete).eq.0 ) then + etatar = mod( hetare(larete) , 10 ) + if ( etatar.eq.0 ) then + nbarpb = nbarpb + 1 + if ( aret01.eq.0 ) then + aret01 = larete + endif + endif + elseif ( decare(larete).eq.-1 ) then + nbarpb = nbarpb + 1 + if ( aret01.eq.0 ) then + aret01 = larete + endif + endif + 200 continue +cgn write (ulsort,*)'==> nbarpb = ',nbarpb +c +c 2.2. ==> probleme : les decisions sur les aretes sont incoherentes +c avec les decisions sur les faces +c + if ( nbarpb.eq.nbarp0 .or. nbarpb.eq.nbarp1 .or. + > nbarpb.eq.nbarp2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,typenh) + if ( typenh.eq.2 ) then + iaux = hettri(laface) + else + iaux = hetqua(laface) + endif + write (ulsort,texte(langue,5)) mess14(langue,2,typenh), + > laface, decfac(faced), iaux + do 220 , larelo = 1 , nbaret + if ( typenh.eq.2 ) then + larete = aretri(laface,larelo) + else + larete = arequa(laface,larelo) + endif + write (ulsort,texte(langue,5)) mess14(langue,2,1), + > larete, decare(larete), hetare(larete) + 220 continue +#endif + codret = 1 + goto 21 + endif +c + endif +c + endif +c + 20 continue +c + 2 continue +c + 21 continue +c +c==== +c 3. Cas des pentaedres et du raffinement libre : tant que le +c raffinement par conformite des pentaedres ne sait pas gerer les +c escaliers, il faut forcer un raffinement local par boites de +c ces pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Cas des pentaedres ; codret', codret + write(ulsort,90002) 'nbpeto', nbpeto +#endif +c + if ( ( tyconf.eq.0 ) .and. ( nbpeto.ne.0 ) ) then +c + do 30 , lepent = 1 , nbpeto +c + if ( mod(hetpen(lepent),100).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent +#endif + do 31 , iaux = 3, 5 +c + laface = facpen(lepent,iaux) +c + if ( decfac(-laface).eq.0 ) then + nbarpb = 0 + do 311 , larelo = 1 , 4 + larete = arequa(laface,larelo) + if ( decare(larete).eq.0 ) then + etatar = mod( hetare(larete) , 10 ) + if ( etatar.eq.2 ) then + nbarpb = nbarpb + 1 + endif + elseif ( decare(larete).eq.2 ) then + nbarpb = nbarpb + 1 + endif + 311 continue +cgn if ( nbarpb.ne.0 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent +cgn write(ulsort,90002) '.. nbarpb', nbarpb +cgn endif + if ( nbarpb.eq.2 ) then + do 312 , larelo = 1 , 4 + larete = arequa(laface,larelo) + if ( decare(larete).eq.0 ) then + etatar = mod( hetare(larete) , 10 ) + if ( etatar.eq.0 ) then + decare(larete) = 2 + endif + endif + 312 continue + decfac(-laface) = 4 + codret = 1 + endif +c + endif +c + 31 continue +c + endif +c + 30 continue +c + endif +c +c==== +c 4. On ne peut pas deraffiner sur deux niveaux d'un coup en presence +c de quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. deraffinement 2 coups ; codret', codret +#endif +c +c 4.1. Cas des hexaedres +c Vu avec test_5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. Cas des hexaedres ; codret', codret + write (ulsort,90002) 'nbhecf', nbhecf +#endif +c + if ( nbhecf.ne.0 ) then +c + do 410 , lehexa = 1 , nbhecf +c + if ( mod(hethex(lehexa),100).eq.9 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,6), lehexa +#endif +cgn if ( lehexa.eq.244 .or. lehexa.eq.344 .or. +cgn > (lehexa.ge.1017 .and. lehexa.le.1024))then +cgn write(ulsort,90112)'hethex', lehexa, hethex(lehexa) +cgn do 241 , iaux=1,6 +cgn write(ulsort,90112)' decfac', quahex(lehexa,iaux), +cgn > decfac(-quahex(lehexa,iaux)) +cgn 241 continue +cgn endif + do 411 , iaux = 1, 6 +c + laface = quahex(lehexa,iaux) +c + if ( decfac(-laface).eq.-1 ) then + do 4111 , larelo = 1 , 4 + larete = arequa(laface,larelo) + if ( decare(larete).eq. -1 ) then + decare(larete) = 0 + endif + 4111 continue + decfac(-laface) = 0 + codret = 1 +c + endif +c + 411 continue +c + endif +c + 410 continue +c + endif +c +c 4.2. Cas des pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. Cas des pentaedres ; codret', codret + write (ulsort,90002) 'nbpecf', nbpecf +#endif +c + if ( nbpecf.ne.0 ) then +c + do 420 , lepent = 1 , nbpecf +c + if ( mod(hetpen(lepent),100).eq.9 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent +#endif + do 421 , iaux = 3, 5 +c + laface = facpen(lepent,iaux) +c + if ( decfac(-laface).eq.-1 ) then + do 4211 , larelo = 1 , 4 + larete = arequa(laface,larelo) + if ( decare(larete).eq. -1 ) then + decare(larete) = 0 + endif + 4211 continue + decfac(-laface) = 0 + codret = 1 +c + endif +c + 421 continue +c + endif +c + 420 continue +c + endif +c +c==== +c 5. la fin +c en mode normal, on imprime seulement s'il y a un pb de memoire +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +#else + if ( codret.ne.0 .and. codret.ne.1 ) then +#endif +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/debila.F b/src/tool/Decision/debila.F new file mode 100644 index 00000000..08cbec66 --- /dev/null +++ b/src/tool/Decision/debila.F @@ -0,0 +1,291 @@ + subroutine debila ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - BILAn +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : encore des incoherences de conformites . +c . . . . 2 : probleme de memoire . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEBILA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "nombqu.h" +#include "nombtr.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux +c + integer phetar + integer phettr, paretr + integer phetqu, parequ + integer phethe, pquahe + integer phetpe, pfacpe +c + integer pdecar, pdecfa +c + integer codre0, codre1, codre2 +c + character*6 saux + character*8 ntrav1, ntrav2 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONTROLE DES DECISIONS'')' + texte(1,5) = '(29(''=''),/)' + texte(1,10) = '(''Code retour de '',a6,'' ='',i4,/)' +c + texte(2,4) = '(/,a6,'' CONTROL OF DECISIONS'')' + texte(2,5) = '(27(''=''),/)' + texte(2,10) = '(''Error code from '',a6,'' ='',i4,/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + call gmadoj ( nharet//'.HistEtat', phetar, iaux, codret ) +c + if ( nbtrto.ne.0 ) then + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) + endif +c + if ( nbquto.ne.0 ) then + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpecf.ne.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. bilan des decisions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. bilan des decisions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEBIL1', nompro +#endif +c + call debil1 + > ( taopti(30), + > imem(pdecfa), imem(pdecar), + > imem(phetar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(phethe), imem(pquahe), + > imem(phetpe), imem(pfacpe), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'DEBIL1', codret +#endif +c + endif +c +c==== +c 4. la fin +c en mode normal, on imprime seulement s'il y a un pb de memoire +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.-1789 ) then +#else + if ( codret.eq.2 ) then +#endif +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + end diff --git a/src/tool/Decision/decfs0.F b/src/tool/Decision/decfs0.F new file mode 100644 index 00000000..8b843ce1 --- /dev/null +++ b/src/tool/Decision/decfs0.F @@ -0,0 +1,641 @@ + subroutine decfs0 ( hettri, filtri, + > hetqua, filqua, + > hettet, filtet, + > hethex, filhex, fhpyte, + > hetpen, filpen, fppyte, + > nbvtri, nbvqua, + > nbvtet, nbvpyr, + > trindr, trsupp, + > quindr, qusupp, + > teindr, tesupp, + > heindr, hesupp, + > pyindr, pysupp, + > peindr, pesupp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise en ConFormite - Suppression +c -- - - - +c des fils +c - usacmp = 2 : valeur relative +c ______________________________________________________________________ +c On parcourt toutes les entites qui sont decoupees par conformite : +c . si un indicateur d'erreur a ete defini sur au moins un des fils, +c on recupere la plus grande valeur +c Remarque : decfs0 et decfs1 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . fils des hexaedres . +c . fhpyte . e .2*nbhedc. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) = -j. +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . nbvpyr . e . 1 . nombre de valeurs par pyramides . +c . nbvtet . e . 1 . nombre de valeurs par tetraedres . +c . nbvqua . e . 1 . nombre de valeurs par quadrangles . +c . nbvtri . e . 1 . nombre de valeurs par triangles . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindr . es . nbtrto . valeurs reelles pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindr . es . nbquto . valeurs reelles pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindr . es . nbteto . valeurs reelles pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindr . es . nbheto . valeurs reelles pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindr . es . nbpyto . valeurs reelles pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindr . es . nbpeto . valeurs reelles pour les pentaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : nombre de tetraedres a problemes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECFS0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +#include "impr02.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer hettri(nbtrto), filtri(nbtrto) + integer hetqua(nbquto), filqua(nbquto) + integer hettet(nbteto), filtet(nbteto) + integer hethex(nbheto), filhex(nbheto) + integer fhpyte(2,nbheco) + integer hetpen(nbpeto), filpen(nbpeto) + integer fppyte(2,nbpeco) + integer nbvtri, nbvqua + integer nbvtet, nbvpyr + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + integer ulsort, langue, codret +c + double precision trindr(nbtrto) + double precision quindr(nbquto) + double precision teindr(nbteto) + double precision heindr(nbheto) + double precision pyindr(nbpyto) + double precision peindr(nbpeto) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer fils + integer nbte, nbte0, nbte1, nbte2, nbte3, nbte4, nbte5 + integer nbpy, nbpy0, nbpy1, nbpy2, nbpy3, nbpy4, nbpy5 + integer etat, bindec +c + double precision daux +c + logical yaconf + logical yaintr, yainte, yainpy, yainqu +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Suppression des conformites pour les '',a)' +c + texte(2,4) = '(''Suppression of the conformities for '',a)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. les triangles : transfert en presence d'indicateur d'erreurs +c sur les fils de conformite +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2) + write (ulsort,90002) 'nbvtri', nbvtri +#endif +c + if ( nbvtri.gt.0 ) then +c + yaintr = .true. +c + do 20 , iaux = 1 , nbtrto +c + etat = mod( hettri(iaux), 10 ) +c + if ( etat.ge.1 .and. etat.le.3 ) then +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,2), iaux, +cgn > ' : ',etat +c + daux = vinfne + do 201 , kaux = 0, 1 + jaux = filtri(iaux) + kaux + if ( trsupp(jaux).ne.0 ) then + daux = max(daux,trindr(jaux)) + trsupp(iaux) = 1 + endif + 201 continue +c + if ( trsupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de trsupp(',iaux,'), valeur = ',daux + trindr(iaux) = daux + endif +c + endif +c + 20 continue +c + else +c + yaintr = .false. +c + endif +c +c==== +c 3. les quadrangles : transfert en presence d'indicateur d'erreurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Quadrangles ; codret = ', codret +#endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) +#endif +c + if ( nbvqua.gt.0 ) then + yainqu = .true. + else + yainqu = .false. + endif +c + if ( yainqu .or. yaintr ) then +c + do 30 , iaux = 1 , nbquto +c + etat = mod( hetqua(iaux), 100 ) +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,4), iaux, +cgn > ' : ',etat +c +c 3.1. ==> les fils de conformite sont des quadrangles +c + if ( ( etat.eq.21 .or. etat.eq.22 .or. + > ( etat.ge.41 .and. etat.le.44 ) ) .and. yainqu ) then +c + daux = vinfne + fils = filqua(iaux) + if ( etat.eq.21 .or. etat.eq.22 ) then + laux = 1 + else + laux = 2 + endif + do 301 , kaux = 0, laux + jaux = fils + kaux + if ( qusupp(jaux).ne.0 ) then + daux = max(daux,quindr(jaux)) + qusupp(iaux) = 1 + endif + 301 continue +c + if ( qusupp(iaux).ne.0 ) then + quindr(iaux) = daux + endif +c +c 3.2. ==> les fils de conformite qui sont des triangles +c + elseif ( etat.ge.31 .and. etat.le.34 .and. yaintr ) then +c + daux = vinfne + fils = -filqua(iaux) + do 302 , kaux = 0, 2 + jaux = fils + kaux + if ( trsupp(jaux).ne.0 ) then + daux = max(daux,trindr(jaux)) + qusupp(iaux) = 1 + endif + 302 continue +c + if ( qusupp(iaux).ne.0 ) then + quindr(iaux) = daux + endif +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. les tetraedres : transfert en presence d'indicateur d'erreurs +c sur les fils de conformite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Tetraedres ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3) + write (ulsort,90002) 'nbvtet', nbvtet +#endif +c + if ( nbvtet.gt.0 ) then +c + yainte = .true. +c + nbte1 = 1 + nbte2 = 3 +c + do 40 , iaux = 1 , nbteto +c + etat = mod( hettet(iaux), 100 ) + yaconf = .false. +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,3), iaux, +cgn > ' : ',etat +c +c nombre d'entites de conformite selon les modes de decoupage +c + if ( ( etat.ge.21 .and. etat.le.36 ) ) then +c + nbte = nbte1 + yaconf = .true. +c + elseif ( etat.ge.41 .and. etat.le.47 ) then +c + nbte = nbte2 + yaconf = .true. +c + endif +c + if ( yaconf ) then +c + daux = vinfne + do 401 , kaux = 0, nbte + jaux = filtet(iaux) + kaux + if ( tesupp(jaux).ne.0 ) then + daux = max(daux,teindr(jaux)) + tesupp(iaux) = 1 + endif + 401 continue +c + if ( tesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de tesupp(',iaux,'), valeur = ',daux + teindr(iaux) = daux + endif +c + endif +c + 40 continue +c + else +c + yainte = .false. +c + endif +c +c==== +c 5. les pyramides : pas de transfert car pas de decoupage mais +c reperage de la presence d'indicateurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. pyramides ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,5) + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + if ( nbvpyr.gt.0 ) then +c + yainpy = .true. +c + else +c + yainpy = .false. +c + endif +c +c==== +c 6. les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Hexaedres ; codret = ', codret +#endif +c + if ( nbheto.ne.0 .and. ( yainte .or. yainpy ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,6) + write (ulsort,90002) 'nbvtet', nbvtet + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + do 60 , iaux = 1 , nbheto +c + etat = mod(hethex(iaux),1000) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Etat du '//mess14(langue,1,6), iaux, + > ' : ',etat +#endif +c +c nombre d'entites de conformite selon les modes de decoupage +c + if ( etat.ge.11 ) then +c + bindec = chbiet(etat) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etat, ' ==> code binaire', bindec +#endif +c + if ( nbvpyr.gt.0 ) then + nbpy = chnpy(bindec) + else + nbpy = -1 + endif + if ( nbvtet.gt.0 ) then + nbte = chnte(bindec) + else + nbte = -1 + endif + yaconf = .true. +c + else +c + yaconf = .false. +c + endif +c + if ( yaconf ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... nbpy/nbte', nbpy, nbte +#endif +c + daux = vinfne +c + fils = fhpyte(1,-filhex(iaux)) +cgn write (ulsort,*) '.. fils pyramide = ', fils + do 601 , kaux = 1, nbpy +cgn write (ulsort,*) '.... pyramide ', fils, pysupp(fils) + if ( pysupp(fils).ne.0 ) then +cgn write (ulsort,*) '.... ', fils, pyindr(fils) + daux = max(daux,pyindr(fils)) + hesupp(iaux) = 1 + endif + fils = fils + 1 + 601 continue +c + fils = fhpyte(2,-filhex(iaux)) +cgn write (ulsort,*) '.. fils tetraedre = ', fils + do 602 , kaux = 1, nbte +cgn write (ulsort,*) '.... tetraedre ', fils, tesupp(fils) + if ( tesupp(fils).ne.0 ) then + daux = max(daux,teindr(fils)) + hesupp(iaux) = 1 + endif + fils = fils + 1 + 602 continue +c + if ( hesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de hesupp(',iaux,'), valeur = ',daux + heindr(iaux) = daux + endif +c + endif +c + 60 continue +c + endif +c +c==== +c 7. les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. Pentaedres ; codret = ', codret +#endif +c + if ( nbpeto.ne.0 .and. ( yainte .or. yainpy ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,7) + write (ulsort,90002) 'nbvtet', nbvtet + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + if ( nbvtet.gt.0 ) then + nbte0 = 0 + nbte1 = 1 + nbte2 = 5 + nbte3 = 9 + nbte4 = 1 + nbte5 = 10 + else + nbte0 = -1 + nbte1 = -1 + nbte2 = -1 + nbte3 = -1 + nbte4 = -1 + nbte5 = -1 + endif +c + if ( nbvpyr.gt.0 ) then + nbpy0 = 1 + nbpy1 = 0 + nbpy2 = -1 + nbpy3 = 0 + nbpy4 = 3 + nbpy5 = -1 + else + nbpy0 = -1 + nbpy1 = -1 + nbpy2 = -1 + nbpy3 = -1 + nbpy4 = -1 + nbpy5 = -1 + endif +c + do 70 , iaux = 1 , nbpeto +c + etat = mod( hetpen(iaux), 100 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Etat du '//mess14(langue,1,7), iaux, + > ' : ',etat +#endif +c + yaconf = .false. + if ( ( etat.ge. 1 .and. etat.le.6 ) ) then +c + nbpy = nbpy0 + nbte = nbte0 + yaconf = .true. +c + elseif ( ( etat.ge.17 .and. etat.le.19 ) ) then +c + nbpy = nbpy1 + nbte = nbte1 + yaconf = .true. +c + elseif ( etat.ge.21 .and. etat.le.26 ) then +c + nbpy = nbpy2 + nbte = nbte2 + yaconf = .true. +c + elseif ( etat.ge.31 .and. etat.le.36 ) then +c + nbpy = nbpy3 + nbte = nbte3 + yaconf = .true. +c + elseif ( etat.ge.43 .and. etat.le.45 ) then +c + nbpy = nbpy4 + nbte = nbte4 + yaconf = .true. +c + elseif ( etat.ge.51 .and. etat.le.52 ) then +c + nbpy = nbpy5 + nbte = nbte5 + yaconf = .true. +c + endif +c + if ( yaconf ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... nbpy/nbte', nbpy, nbte +#endif +c + daux = vinfne +c + fils = fppyte(1,-filpen(iaux)) +cgn write (ulsort,*) '.. fils pyramide = ', fils + do 701 , kaux = 0, nbpy + jaux = fils + kaux +cgn write (ulsort,*) '.... pyramide ', jaux, pysupp(jaux) + if ( pysupp(jaux).ne.0 ) then +cgn write (ulsort,*) '.... ', jaux, pyindr(jaux) + daux = max(daux,pyindr(jaux)) + pesupp(iaux) = 1 + endif + 701 continue +c + fils = fppyte(2,-filpen(iaux)) +cgn write (ulsort,*) '.. fils tetraedre = ', fils + do 702 , kaux = 0, nbte + jaux = fils + kaux + if ( tesupp(jaux).ne.0 ) then +cgn write (ulsort,*) '.... ', jaux, teindr(jaux) + daux = max(daux,teindr(jaux)) + pesupp(iaux) = 1 + endif + 702 continue +c + if ( pesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de pesupp(',iaux,'), valeur = ',daux + peindr(iaux) = daux + endif +c + endif +c + 70 continue +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,6)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decfs1.F b/src/tool/Decision/decfs1.F new file mode 100644 index 00000000..749e3479 --- /dev/null +++ b/src/tool/Decision/decfs1.F @@ -0,0 +1,644 @@ + subroutine decfs1 ( hettri, filtri, + > hetqua, filqua, + > hettet, filtet, + > hethex, filhex, fhpyte, + > hetpen, filpen, fppyte, + > nbvtri, nbvqua, + > nbvtet, nbvpyr, + > trindr, trsupp, + > quindr, qusupp, + > teindr, tesupp, + > heindr, hesupp, + > pyindr, pysupp, + > peindr, pesupp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise en ConFormite - Suppression +c -- - - - +c des fils +c - usacmp = 0 : norme L2 +c - usacmp = 1 : norme infinie +c ______________________________________________________________________ +c On parcourt toutes les entites qui sont decoupees par conformite : +c . si un indicateur d'erreur a ete defini sur au moins un des fils, +c on recupere la plus grande valeur +c Remarque : decfs0 et decfs1 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . fils des hexaedres . +c . fhpyte . e .2*nbhedc. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) = -j. +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . nbvpyr . e . 1 . nombre de valeurs par pyramides . +c . nbvtet . e . 1 . nombre de valeurs par tetraedres . +c . nbvqua . e . 1 . nombre de valeurs par quadrangles . +c . nbvtri . e . 1 . nombre de valeurs par triangles . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindr . es . nbtrto . valeurs reelles pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindr . es . nbquto . valeurs reelles pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindr . es . nbteto . valeurs reelles pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindr . es . nbheto . valeurs reelles pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindr . es . nbpyto . valeurs reelles pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindr . es . nbpeto . valeurs reelles pour les pentaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : nombre de tetraedres a problemes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECFS1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +#include "impr02.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer hettri(nbtrto), filtri(nbtrto) + integer hetqua(nbquto), filqua(nbquto) + integer hettet(nbteto), filtet(nbteto) + integer hethex(nbheto), filhex(nbheto) + integer fhpyte(2,nbheco) + integer hetpen(nbpeto), filpen(nbpeto) + integer fppyte(2,nbpeco) + integer nbvtri, nbvqua + integer nbvtet, nbvpyr + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + integer ulsort, langue, codret +c + double precision trindr(nbtrto) + double precision quindr(nbquto) + double precision teindr(nbteto) + double precision heindr(nbheto) + double precision pyindr(nbpyto) + double precision peindr(nbpeto) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer fils + integer nbte, nbte0, nbte1, nbte2, nbte3, nbte4, nbte5 + integer nbpy, nbpy0, nbpy1, nbpy2, nbpy3, nbpy4, nbpy5 + integer etat, bindec +c + double precision daux +c + logical yaconf + logical yaintr, yainte, yainpy, yainqu +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Suppression des conformites pour les '',a)' +c + texte(2,4) = '(''Suppression of the conformities for '',a)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. les triangles : transfert en presence d'indicateur d'erreurs +c sur les fils de conformite +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2) + write (ulsort,90002) 'nbvtri', nbvtri +#endif +c + if ( nbvtri.gt.0 ) then +c + yaintr = .true. +c + do 20 , iaux = 1 , nbtrto +c + etat = mod( hettri(iaux), 10 ) +c + if ( etat.ge.1 .and. etat.le.3 ) then +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,2), iaux, +cgn > ' : ',etat +c + daux = vinfne + do 201 , kaux = 0, 1 + jaux = filtri(iaux) + kaux + if ( trsupp(jaux).ne.0 ) then + daux = max(daux,abs(trindr(jaux))) + trsupp(iaux) = 1 + endif + 201 continue +c + if ( trsupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de trsupp(',iaux,'), valeur = ',daux + trindr(iaux) = daux + endif +c + endif +c + 20 continue +c + else +c + yaintr = .false. +c + endif +c +c==== +c 3. les quadrangles : transfert en presence d'indicateur d'erreurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Quadrangles ; codret = ', codret + write (ulsort,90002) 'nbvqua', nbvqua +#endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) +#endif +c + if ( nbvqua.gt.0 ) then + yainqu = .true. + else + yainqu = .false. + endif +c + if ( yainqu .or. yaintr ) then +c + do 30 , iaux = 1 , nbquto +c + etat = mod( hetqua(iaux), 100 ) +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,4), iaux, +cgn > ' : ',etat +c +c 3.1. ==> les fils de conformite sont des quadrangles +c + if ( ( etat.eq.21 .or. etat.eq.22 .or. + > ( etat.ge.41 .and. etat.le.44 ) ) .and. yainqu ) then +c + daux = vinfne + fils = filqua(iaux) + if ( etat.eq.21 .or. etat.eq.22 ) then + laux = 1 + else + laux = 2 + endif + do 301 , kaux = 0, laux + jaux = fils + kaux + if ( qusupp(jaux).ne.0 ) then + daux = max(daux,abs(quindr(jaux))) + qusupp(iaux) = 1 + endif + 301 continue +c + if ( qusupp(iaux).ne.0 ) then + quindr(iaux) = daux + endif +c +c 3.2. ==> les fils de conformite qui sont des triangles +c + elseif ( etat.ge.31 .and. etat.le.34 .and. yaintr ) then +c + daux = vinfne + fils = -filqua(iaux) + do 302 , kaux = 0, 2 + jaux = fils + kaux + if ( trsupp(jaux).ne.0 ) then + daux = max(daux,abs(trindr(jaux))) + qusupp(iaux) = 1 + endif + 302 continue +c + if ( qusupp(iaux).ne.0 ) then + quindr(iaux) = daux + endif +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. les tetraedres : transfert en presence d'indicateur d'erreurs +c sur les fils de conformite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Tetraedres ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3) + write (ulsort,90002) 'nbvtet', nbvtet +#endif +c + if ( nbvtet.gt.0 ) then +c + yainte = .true. +c + nbte1 = 1 + nbte2 = 3 +c + do 40 , iaux = 1 , nbteto +c + etat = mod( hettet(iaux), 100 ) + yaconf = .false. +cgn write (ulsort,90015) 'Etat du '//mess14(langue,1,3), iaux, +cgn > ' : ',etat +c +c nombre d'entites de conformite selon les modes de decoupage +c + if ( ( etat.ge.21 .and. etat.le.36 ) ) then +c + nbte = nbte1 + yaconf = .true. +c + elseif ( etat.ge.41 .and. etat.le.47 ) then +c + nbte = nbte2 + yaconf = .true. +c + endif +c + if ( yaconf ) then +c + daux = vinfne + do 401 , kaux = 0, nbte + jaux = filtet(iaux) + kaux + if ( tesupp(jaux).ne.0 ) then + daux = max(daux,abs(teindr(jaux))) +cgn write (ulsort,*) '... valeur = ',daux + tesupp(iaux) = 1 + endif + 401 continue +c + if ( tesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de tesupp(',iaux,'), valeur = ',daux + teindr(iaux) = daux + endif +c + endif +c + 40 continue +c + else +c + yainte = .false. +c + endif +c +c==== +c 5. les pyramides : pas de transfert car pas de decoupage mais +c reperage de la presence d'indicateurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. pyramides ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,5) + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + if ( nbvpyr.gt.0 ) then +c + yainpy = .true. +c + else +c + yainpy = .false. +c + endif +c +c==== +c 6. les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Hexaedres ; codret = ', codret +#endif +c + if ( nbheto.ne.0 .and. ( yainte .or. yainpy ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,6) + write (ulsort,90002) 'nbvtet', nbvtet + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + do 60 , iaux = 1 , nbheto +c + etat = mod(hethex(iaux),1000) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Etat du '//mess14(langue,1,6), iaux, + > ' : ',etat +#endif +c +c nombre d'entites de conformite selon les modes de decoupage +c + if ( etat.ge.11 ) then +c + bindec = chbiet(etat) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etat, ' ==> code binaire', bindec +#endif +c + if ( nbvpyr.gt.0 ) then + nbpy = chnpy(bindec) + else + nbpy = -1 + endif + if ( nbvtet.gt.0 ) then + nbte = chnte(bindec) + else + nbte = -1 + endif + yaconf = .true. +c + else +c + yaconf = .false. +c + endif +c + if ( yaconf ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... nbpy/nbte', nbpy, nbte +#endif +c + daux = vinfne +c + fils = fhpyte(1,-filhex(iaux)) +cgn write (ulsort,*) '.. fils pyramide = ', fils + do 601 , kaux = 1, nbpy +cgn write (ulsort,*) '.... pyramide ', fils, pysupp(fils) + if ( pysupp(fils).ne.0 ) then +cgn write (ulsort,*) '.... ', fils, pyindr(fils) + daux = max(daux,abs(pyindr(fils))) + hesupp(iaux) = 1 + endif + fils = fils + 1 + 601 continue +c + fils = fhpyte(2,-filhex(iaux)) +cgn write (ulsort,*) '.. fils tetraedre = ', fils + do 602 , kaux = 1, nbte +cgn write (ulsort,*) '.... tetraedre ', fils, tesupp(fils) + if ( tesupp(fils).ne.0 ) then + daux = max(daux,abs(teindr(fils))) + hesupp(iaux) = 1 + endif + fils = fils + 1 + 602 continue +c + if ( hesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de hesupp(',iaux,'), valeur = ',daux + heindr(iaux) = daux + endif +c + endif +c + 60 continue +c + endif +c +c==== +c 7. les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. Pentaedres ; codret = ', codret +#endif +c + if ( nbpeto.ne.0 .and. ( yainte .or. yainpy ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,7) + write (ulsort,90002) 'nbvtet', nbvtet + write (ulsort,90002) 'nbvpyr', nbvpyr +#endif +c + if ( nbvtet.gt.0 ) then + nbte0 = 0 + nbte1 = 1 + nbte2 = 5 + nbte3 = 9 + nbte4 = 1 + nbte5 = 10 + else + nbte0 = -1 + nbte1 = -1 + nbte2 = -1 + nbte3 = -1 + nbte4 = -1 + nbte5 = -1 + endif +c + if ( nbvpyr.gt.0 ) then + nbpy0 = 1 + nbpy1 = 0 + nbpy2 = -1 + nbpy3 = 0 + nbpy4 = 3 + nbpy5 = -1 + else + nbpy0 = -1 + nbpy1 = -1 + nbpy2 = -1 + nbpy3 = -1 + nbpy4 = -1 + nbpy5 = -1 + endif +c + do 70 , iaux = 1 , nbpeto +c + etat = mod( hetpen(iaux), 100 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Etat du '//mess14(langue,1,7), iaux, + > ' : ',etat +#endif +c + yaconf = .false. + if ( ( etat.ge. 1 .and. etat.le.6 ) ) then +c + nbpy = nbpy0 + nbte = nbte0 + yaconf = .true. +c + elseif ( ( etat.ge.17 .and. etat.le.19 ) ) then +c + nbpy = nbpy1 + nbte = nbte1 + yaconf = .true. +c + elseif ( etat.ge.21 .and. etat.le.26 ) then +c + nbpy = nbpy2 + nbte = nbte2 + yaconf = .true. +c + elseif ( etat.ge.31 .and. etat.le.36 ) then +c + nbpy = nbpy3 + nbte = nbte3 + yaconf = .true. +c + elseif ( etat.ge.43 .and. etat.le.45 ) then +c + nbpy = nbpy4 + nbte = nbte4 + yaconf = .true. +c + elseif ( etat.ge.51 .and. etat.le.52 ) then +c + nbpy = nbpy5 + nbte = nbte5 + yaconf = .true. +c + endif +c + if ( yaconf ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... nbpy/nbte', nbpy, nbte +#endif +c + daux = vinfne +c + fils = fppyte(1,-filpen(iaux)) +cgn write (ulsort,*) '.. fils pyramide = ', fils + do 701 , kaux = 0, nbpy + jaux = fils + kaux +cgn write (ulsort,*) '.... pyramide ', jaux, pysupp(jaux) + if ( pysupp(jaux).ne.0 ) then +cgn write (ulsort,*) '.... ', jaux, pyindr(jaux) + daux = max(daux,abs(pyindr(jaux))) + pesupp(iaux) = 1 + endif + 701 continue +c + fils = fppyte(2,-filpen(iaux)) +cgn write (ulsort,*) '.. fils tetraedre = ', fils + do 702 , kaux = 0, nbte + jaux = fils + kaux + if ( tesupp(jaux).ne.0 ) then +cgn write (ulsort,*) '.... ', jaux, teindr(jaux) + daux = max(daux,abs(teindr(jaux))) + pesupp(iaux) = 1 + endif + 702 continue +c + if ( pesupp(iaux).ne.0 ) then +cgn write (ulsort,*) 'modif de pesupp(',iaux,'), valeur = ',daux + peindr(iaux) = daux + endif +c + endif +c + 70 continue +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,6)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decfs2.F b/src/tool/Decision/decfs2.F new file mode 100644 index 00000000..c137acb3 --- /dev/null +++ b/src/tool/Decision/decfs2.F @@ -0,0 +1,456 @@ + subroutine decfs2 ( disnoe, ancnoe, nounoe, + > hetnoe, famnoe, arenoe, + > noehom, coonoe, + > np2are, somare, + > aretri, + > hetqua, arequa, filqua, + > tritet, cotrte, aretet, + > hethex, filhex, fhpyte, + > facpyr, cofapy, arepyr, + > hetpen, filpen, fppyte, + > typind, iindno, rindno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise en ConFormite - Suppression - 2 +c -- - - - - +c Renumerotation des tableaux lies aux noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disnoe . aux . nancno . indicateurs de disparition des noeuds . +c . ancnoe . s . nbnoto . anciens numeros des noeuds conserves . +c . nounoe . s .0:nbnoto. nouveaux numeros des noeuds conserves . +c . hetnoe . e/s . nbnoto . historique de l'etat des noeuds . +c . np2are . e . nancar . numero des noeuds p2 milieux d'aretes . +c . somare . e .2*nancar. numeros des extremites d'arete . +c . aretri . e .nanctr*3. numeros des 3 aretes des triangles . +c . hetqua . e . nancqu . historique de l'etat des quadrangles . +c . arequa . e .nancqu*3. numeros des 4 aretes des quadrangles . +c . filqua . e . nancqu . premier fils des quadrangles . +c . tritet . e .nancte*4. numeros des triangles des tetraedres . +c . cotrte . e .nancte*4. codes des triangles des tetraedres . +c . aretet . e .nancta*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nanche . historique de l'etat des hexaedres . +c . filhex . e . nanche . premier fils des hexaedres . +c . fhpyte . e . 2** . fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nancyf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nancyf*5. codes des faces des pyramides . +c . arepyr . e .nancya*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nancpe . historique de l'etat des pentaedres . +c . filpen . e . nancpe . premier fils des pentaedres . +c . fppyte . e . 2** . fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . typind . e . 1 . type de valeurs pour l'indicateur . +c . . . . 0 : aucune . +c . . . . 2 : entieres . +c . . . . 3 : reelles . +c . iindno . e . * . indicateur entier sur les noeuds . +c . rindno . e . * . indicateur reel sur les noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECFS2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +#include "nancnb.h" +#include "nombno.h" +#include "nombar.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer disnoe(nancno) + integer ancnoe(nbnoto), nounoe(0:nancno) + integer hetnoe(nancno), famnoe(nancno) + integer arenoe(nancno), noehom(nancno) + integer np2are(nancar), somare(2,nancar) + integer aretri(nanctr,3) + integer hetqua(nancqu), arequa(nancqu,4), filqua(nancqu) + integer tritet(nanctf,4), cotrte(nanctf,4), aretet(nancta,6) + integer hethex(nanche), filhex(nanche) + integer fhpyte(2,*) + integer facpyr(nancyf,5), cofapy(nancyf,5), arepyr(nancya,8) + integer hetpen(nancpe), filpen(nancpe) + integer fppyte(2,*) + integer typind, iindno(*) +c + double precision coonoe(nancno,sdim) + double precision rindno(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letetr, lapyra, lequad, larete, lenoeu + integer listar(8), listso(5) + integer nbnore, nbp2re, nbimre + integer bindec +c + integer etat +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Binaire du decoupage de conformite :'',i5)' +c + texte(2,4) = '(''Cut for conformity; binary code:'',i5)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Reperage des noeuds a faire disparaitre +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Reperage ; codret = ', codret +#endif +cgn write (ulsort,90002) nompro//'nancno', nancno +c +c 2.1. ==> A priori, tout reste +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nancno + disnoe(iaux) = 0 + ancnoe(iaux) = iaux + 21 continue +c + endif +c +c 2.2. ==> Les noeuds P2 sur les aretes de conformite +c + if ( codret.eq.0 ) then +c + do 22 , iaux = nbarpe+1 , nancar +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'noeud sur l''arete', iaux, ':', np2are(iaux) +#endif + disnoe(np2are(iaux)) = 1 + 22 continue +c + endif +c +c 2.3. ==> Les noeuds centraux des quadrangles coupes en 3 quadrangles +c . Le noeud central est le second sommet de la derniere arete +c du fils aine (voir cmcdq5 pour les conventions) +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , nancqu +c + etat = mod(hetqua(iaux),100) +c + if ( ( etat.ge.41 .and. etat.le.44 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,4), iaux + write (ulsort,texte(langue,4)) etat +#endif + lequad = filqua(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,4), lequad +#endif +c + lenoeu = somare(2,arequa(lequad,4)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,-1), lenoeu +#endif + disnoe(lenoeu) = 1 +c + endif +c + 23 continue +c + endif +c +c 2.4. ==> Les noeuds centraux des hexaedres coupes +c Selon l'etat, il y a ou non un sommet interne +c . le noeud central est le sommet S1 de chacun des tetraedres +c . le noeud central est le sommet S5 de chacune des pyramides +c + if ( codret.eq.0 ) then +c + do 24 , iaux = 1 , nanche +c + etat = mod(hethex(iaux),1000) +c + if ( etat.gt.10 ) then +c + bindec = chbiet(etat) + if ( chnp1(bindec).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,6), iaux + write (ulsort,texte(langue,4)) bindec +#endif + jaux = filhex(iaux) +c +c 2.4.1. ==> Au moins un tetraedre fils +c + if ( chnte(bindec).gt.0 ) then +c + letetr = fhpyte(2,-jaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,3), letetr +#endif +c + call utaste ( letetr, + > nanctr, nanctf, nancta, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + lenoeu = listso(1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,-1), lenoeu +#endif + disnoe(lenoeu) = 1 +c +c 2.4.2. ==> Au moins une pyramide fille +c + elseif ( chnpy(bindec).gt.0 ) then +c + lapyra = fhpyte(1,-jaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,6), lapyra +#endif +c + call utaspy ( lapyra, + > nanctr, nancyf, nancya, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c + lenoeu = listso(5) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,-1), lenoeu +#endif + disnoe(lenoeu) = 1 +c + endif +c + endif +c + endif +c + 24 continue +c + endif +c +c 2.5. ==> Les noeuds centraux des pentaedres coupes selon +c le mode 3 ou 5 +c . Decoupage selon 2 aretes de triangle : le noeud central est +c le sommet S1 de chacun des 10 tetraedres +c . Decoupage selon 1 face de triangle : le noeud central est +c le sommet S1 du 10eme tetraedre +c + if ( codret.eq.0 ) then +c + do 25 , iaux = 1 , nancpe +c + etat = mod(hetpen(iaux),100) +c + if ( ( etat.ge.31 .and. etat.le.36 ) .or. + > ( etat.ge.51 .and. etat.le.52 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,7), iaux + write (ulsort,texte(langue,4)) etat +#endif + jaux = filpen(iaux) + letetr = fppyte(2,-jaux) + 9 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,3), letetr +#endif +c + call utaste ( letetr, + > nanctr, nanctf, nancta, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + lenoeu = listso(1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,-1), lenoeu +#endif + disnoe(lenoeu) = 1 +c + endif +c + 25 continue +c + endif +c +c==== +c 3. Suppression des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Suppression des noeuds ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUNO', nompro +#endif + call utsuno ( nancno, nbnoto, disnoe, + > hetnoe, ancnoe, nounoe, + > nbnore, nbp2re, nbimre ) +c + endif +c +c==== +c 4. Compactage de la numerotation +c Remarque : c'est un melange de utcnno et utcnar +c sachant qu'ici les aretes ne changent pas de numero +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Compactage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 4.1. ==> Les tableaux du maillage +c + do 41 , lenoeu = 1 , nbnore +c + if ( ancnoe(lenoeu).ne.lenoeu ) then + do 410, iaux = 1 , sdim + coonoe(lenoeu,iaux) = coonoe(ancnoe(lenoeu),iaux) + 410 continue + hetnoe(lenoeu) = hetnoe(ancnoe(lenoeu)) + famnoe(lenoeu) = famnoe(ancnoe(lenoeu)) + arenoe(lenoeu) = arenoe(ancnoe(lenoeu)) + endif +c + 41 continue +c +c 4.2. ==> Les eventuels noeuds homologues +c + if ( homolo.ge.1 ) then +c + do 42 , lenoeu = 1 , nbnore + if ( noehom(ancnoe(lenoeu)).ge.0 ) then + noehom(lenoeu) = nounoe(noehom(ancnoe(lenoeu))) + else + noehom(lenoeu) = - nounoe(abs(noehom(ancnoe(lenoeu)))) + endif + 42 continue +c + endif +c +c 4.3. ==> La description des aretes +c + do 43 , larete = 1 , nancar +c + somare(1,larete) = nounoe(somare(1,larete)) + somare(2,larete) = nounoe(somare(2,larete)) + np2are(larete) = nounoe(np2are(larete)) +c + 43 continue +c +c 4.4. ==> Les eventuels indicateurs d'erreur +c + if ( typind.eq.2 ) then +c + do 441 , lenoeu = 1 , nbnore + if ( ancnoe(lenoeu).ne.lenoeu ) then + iindno(lenoeu) = iindno(ancnoe(lenoeu)) + endif + 441 continue +c + elseif ( typind.eq.3 ) then +c + do 442 , lenoeu = 1 , nbnore + if ( ancnoe(lenoeu).ne.lenoeu ) then + rindno(lenoeu) = rindno(ancnoe(lenoeu)) + endif + 442 continue +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decfs3.F b/src/tool/Decision/decfs3.F new file mode 100644 index 00000000..4682aef6 --- /dev/null +++ b/src/tool/Decision/decfs3.F @@ -0,0 +1,285 @@ + subroutine decfs3 ( hettri, filtri, + > hetqua, filqua, + > hettet, filtet, + > hethex, filhex, + > hetpen, filpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise en ConFormite - Suppression +c -- - - - +c des fils +c ______________________________________________________________________ +c On parcourt toutes les entites qui sont decoupees par conformite : +c . on supprime la reference aux fils +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . fils des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : nombre de tetraedres a problemes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECFS3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer hettri(nbtrto), filtri(nbtrto) + integer hetqua(nbquto), filqua(nbquto) + integer hettet(nbteto), filtet(nbteto) + integer hethex(nbheto), filhex(nbheto) + integer hetpen(nbpeto), filpen(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer etat +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Suppression des fils de conformites pour les '',a)' +c + texte(2,4) = + > '(''Suppression of the sons for the conformities for '',a)' +c + codret = 0 +c +c==== +c 2. les triangles +c==== +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2) +#endif +c +cgn 1793 format('Etat du ',a,i10,' :',i4) + do 22 , iaux = 1 , nbtrto +c + etat = mod(hettri(iaux),10) +c + if ( etat.ge.1 .and. etat.le.3 ) then +cgn write (ulsort,1793) mess14(langue,1,2), iaux, etat +c + filtri(iaux) = 0 +c + endif +c + 22 continue +c + endif +c +c==== +c 3. les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Quadrangles ; codret = ', codret +#endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) +#endif +c + do 32 , iaux = 1 , nbquto +c + etat = mod(hetqua(iaux),100) +c + if ( etat.eq.21 .or. etat.eq.22 .or. + > ( etat.ge.31 .and. etat.le.34 ) .or. + > ( etat.ge.41 .and. etat.le.44 ) ) then +cgn write (ulsort,1793) mess14(langue,1,4), iaux, etat +c + filqua(iaux) = 0 +c + endif +c + 32 continue +c + endif +c +c==== +c 4. les tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Tetraedres ; codret = ', codret +#endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3) +#endif +c + do 42 , iaux = 1 , nbteto +c + etat = mod(hettet(iaux),100) +c + if ( ( etat.ge.21 .and. etat.le.36 ) .or. + > ( etat.ge.41 .and. etat.le.47 ) ) then +c + filtet(iaux) = 0 +c + endif +c + 42 continue +c +cgn write (ulsort,1790) (iaux,teindr(iaux),iaux = 1 , nbteto) +cgn 1790 format(5(i4,' :',g12.5)) + endif +c +c==== +c 5. les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Hexaedres ; codret = ', codret +#endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,6) +#endif +c + do 52 , iaux = 1 , nbheto +c + etat = mod(hethex(iaux),1000) +c + if ( etat.ge.11 ) then +c + filhex(iaux) = 0 +c + endif +c + 52 continue +c + endif +c +c==== +c 6. les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Pentaedres ; codret = ', codret +#endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,7) +#endif +c + do 62 , iaux = 1 , nbpeto +c + etat = mod(hetpen(iaux),100) +c + if ( ( etat.ge. 1 .and. etat.le. 6 ) .or. + > ( etat.ge.17 .and. etat.le.19 ) .or. + > ( etat.ge.21 .and. etat.le.26 ) .or. + > ( etat.ge.31 .and. etat.le.36 ) .or. + > ( etat.ge.43 .and. etat.le.45 ) .or. + > ( etat.ge.51 .and. etat.le.52 ) ) then +c + filpen(iaux) = 0 +c + endif +c + 62 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,6)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decfsu.F b/src/tool/Decision/decfsu.F new file mode 100644 index 00000000..7c760374 --- /dev/null +++ b/src/tool/Decision/decfsu.F @@ -0,0 +1,925 @@ + subroutine decfsu ( nomail, nohind, + > lgopti, taopti, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise en ConFormite - SUppression +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECFSU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nancnb.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nohind +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux, jaux, kaux +c + integer nbtran, nbquan + integer nbtean + integer nbhean + integer nbpyan + integer nbpean +c + integer pcoono, phetno, pareno + integer adhono + integer pposif, pfacar + integer phetar, psomar, pfilar, pmerar, pancar, pnp2ar + integer adhoar + integer phettr, paretr, pfiltr, ppertr, panctr, pnivtr + integer adpetr, adnmtr + integer adhotr + integer phetqu, parequ, pfilqu, pperqu, pancqu, pnivqu + integer adhequ, adnmqu + integer adhoqu + integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche + integer adnmhe + integer adhes2 + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe + integer adpes2 + integer pfamno, pcfano + integer pfamar + integer pfamtr + integer pfamqu + integer pfamte + integer pfampy + integer pfamhe + integer pfampe + integer voarno, vofaar, vovoar, vovofa + integer adnoin, adnorn, adnosu + integer adarin, adarrn, adarsu + integer adtrin, adtrrn, adtrsu + integer adquin, adqurn, adqusu + integer adtein, adtern, adtesu + integer adhein, adhern, adhesu + integer adpyin, adpyrn, adpysu + integer adpein, adpern, adpesu + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen + integer typind, ncmpin + integer pdisno, pancno, pnouno +c + logical afaire +c + integer codre0 + integer codre1, codre2, codre3 +c + character*6 saux + character*8 saux08 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ndisno, nnouno +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +#include "impr02.h" +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = '(/,a6,'' SUPPRESSION DE LA CONFORMITE'')' + texte(1,5) = '(35(''=''),/)' + texte(1,6) = '(''Modification de taille des tableaux des '',a)' + texte(1,7) = '(''et renumerotation.'')' + texte(1,8) = '(5x,''==> code de retour :'',i8)' +c + texte(2,4) = '(/,a6,'' SUPPRESSION OF CONFORMITY'')' + texte(2,5) = '(32(''=''),/)' + texte(2,6) = '(''Size modification of arrays for '',a)' + texte(2,7) = '(''and renumbering.'')' + texte(2,8) = '(5x,''==> error code :'',i8)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + iaux = 210 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, adhono, jaux, + > ulsort, langue, codret ) +c + iaux = 2 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux , jaux , + > jaux, jaux, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 30*11 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 30*11 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 78 + if ( nancta.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, jaux, + > jaux, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 6 + if ( nbheco.ne.0 ) then + iaux = iaux*17 + endif + if ( nancha.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, adhes2, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 6 + if ( nbpeco.ne.0 ) then + iaux = iaux*17 + endif + if ( nancpa.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, adpes2, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 6 + if ( nancya.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, pcofay, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> si le raffinement ou le deraffinement sont pilotes par un +c indicateur, recuperation de l'indicateur +c + nbvtri = 0 + nbvqua = 0 + nbvtet = 0 + nbvhex = 0 + nbvpyr = 0 + nbvpen = 0 +c + if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and. + > taopti(37).eq.0 ) then +c +c 2.3.1. ==> la situation actuelle +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI0', nompro +#endif + call deini0 ( nohind, typind, ncmpin, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > adnoin, adnorn, adnosu, + > adarin, adarrn, adarsu, + > adtrin, adtrrn, adtrsu, + > adquin, adqurn, adqusu, + > adtein, adtern, adtesu, + > adhein, adhern, adhesu, + > adpyin, adpyrn, adpysu, + > adpein, adpern, adpesu, + > ulsort, langue, codret ) +c + endif +c +c 2.3.2. ==> complement eventuels +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI2', nompro +#endif + call deini2 ( nohind, typind, ncmpin, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, + > adquin, adqurn, adqusu, + > adhein, adhern, adhesu, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbvnoe', nbvnoe + write (ulsort,90002) 'nbvare', nbvare + write (ulsort,90002) 'nbvtri', nbvtri + write (ulsort,90002) 'nbvqua', nbvqua + write (ulsort,90002) 'nbvtet', nbvtet + write (ulsort,90002) 'nbvhex', nbvhex + write (ulsort,90002) 'nbvpyr', nbvpyr + write (ulsort,90002) 'nbvpen', nbvpen +#endif +c +c==== +c 3. Transfert de l'indicateur s'il est defini par maille +c Remarque : on suppose que s'il est defini sur les noeuds, il ne +c peut pas avoir de valeurs sur les mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Transfert ; codret', codret +#endif +c + if ( nbvnoe.eq.0 ) then +c +c 3.1. ==> Indicateur pris en valeur relative +c + if ( taopti(8).eq.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECFS0', nompro +#endif + call decfs0 ( imem(phettr), imem(pfiltr), + > imem(phetqu), imem(pfilqu), + > imem(phette), imem(pfilte), + > imem(phethe), imem(pfilhe), imem(adhes2), + > imem(phetpe), imem(pfilpe), imem(adpes2), + > nbvtri, nbvqua, + > nbvtet, nbvpyr, + > rmem(adtrrn), imem(adtrsu), + > rmem(adqurn), imem(adqusu), + > rmem(adtern), imem(adtesu), + > rmem(adhern), imem(adhesu), + > rmem(adpyrn), imem(adpysu), + > rmem(adpern), imem(adpesu), + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Indicateur pris en valeur absolue : norme L2 ou infinie +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECFS1', nompro +#endif + call decfs1 ( imem(phettr), imem(pfiltr), + > imem(phetqu), imem(pfilqu), + > imem(phette), imem(pfilte), + > imem(phethe), imem(pfilhe), imem(adhes2), + > imem(phetpe), imem(pfilpe), imem(adpes2), + > nbvtri, nbvqua, + > nbvtet, nbvpyr, + > rmem(adtrrn), imem(adtrsu), + > rmem(adqurn), imem(adqusu), + > rmem(adtern), imem(adtesu), + > rmem(adhern), imem(adhesu), + > rmem(adpyrn), imem(adpysu), + > rmem(adpern), imem(adpesu), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. mise a jour de certaines donnees concernant le maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. mise a jour ; codret', codret + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'nbnoto, nbnop1, nbnop2', + > nbnoto, nbnop1, nbnop2 +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DESMAJ', nompro +#endif + call desmaj ( nhnoeu, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > afaire, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'nancno', nancno, ' ==> nbnoto', nbnoto + write (ulsort,90015) 'nancar', nancar, ' ==> nbarto', nbarto + write (ulsort,90015) 'nanctr', nanctr, ' ==> nbtrto', nbtrto + write (ulsort,90015) 'nancqu', nancqu, ' ==> nbquto', nbquto + write (ulsort,99001) 'afaire', afaire +#endif + endif +c +c==== +c 5. Gestion des tableaux dont la taille a ete modifiee +c Attention : il faut commencer par les noeuds car on a besoin +c de la structure complete du maillage pour les renumerotations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. tableaux ; codret', codret + write (ulsort,90002) 'nancno', nancno + write (ulsort,90002) 'nbnoto', nbnoto +#endif +c +c 5.1. ==> Les noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1 degre 2 ; codret', codret +#endif +c +c 5.1.1. ==> Renumerotation eventuelle +c + if ( nancno.ne.nbnoto ) then +c +c 5.1.1.1. ==> Les tableaux +c + if ( afaire ) then +c + if ( codret.eq.0 ) then +c + call gmalot ( ndisno, 'entier ', nancno, pdisno, codre1 ) + call gmaloj ( nhnoeu//'.Deraffin', ' ', + > nancno, pancno, codre2 ) + iaux = nancno + 1 + call gmalot ( nnouno, 'entier ', iaux, pnouno, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + iaux = 0 + if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and. + > taopti(37).eq.0 ) then +c + if ( typind.eq.2 ) then + saux08 = 'ValeursE' + else + saux08 = 'ValeursR' + endif + call gmobal ( nohind//'.Noeud.'//saux08, codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( nohind//'.Noeud.'//saux08, + > jaux, iaux, codre0 ) + codret = max (codret, abs(codre0) ) + iaux = typind + endif +c + endif +c +c 5.1.1.2. ==> La renumerotation des tableaux lies aux noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1.1.2 Renumerotation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECFS2', nompro +#endif + call decfs2 ( imem(pdisno), imem(pancno), imem(pnouno), + > imem(phetno), imem(pfamno), imem(pareno), + > imem(adhono), rmem(pcoono), + > imem(pnp2ar), imem(psomar), + > imem(paretr), + > imem(phetqu), imem(parequ), imem(pfilqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phethe), imem(pfilhe), imem(adhes2), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpe), imem(pfilpe), imem(adpes2), + > iaux, imem(jaux), rmem(jaux), + > ulsort, langue, codret ) +c + endif +c +c 5.1.1.3. ==> Le menage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1.1.3 Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ndisno, codre1 ) + call gmlboj ( nnouno, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c 5.1.2. ==> Raccourcissement des tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1.2 Raccourcissement ; codret', codret + write (ulsort,90002) 'nancno', nancno + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nancar', nancar + write (ulsort,90002) 'nbarto', nbarto +#endif +c + if ( codret.eq.0 ) then +c + iaux = 210 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif + if ( afaire ) then + iaux = iaux*13 + endif + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + call utad05 ( iaux, jaux, nhnoeu, + > nancno, nbnoto, sdim, + > phetno, + > pfamno, + > pcoono, pareno, adhono, pancno, + > ulsort, langue, codret ) +c + call gmecat ( nhnoeu, 1, nbnoto, codre0 ) +c + codret = max ( abs(codre0), codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1.2 nohind ; codret', codret +#endif +c + if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and. + > taopti(37).eq.0 ) then +c + if ( typind.eq.2 ) then + saux08 = 'ValeursE' + else + saux08 = 'ValeursR' + endif + call gmobal ( nohind//'.Noeud.'//saux08, codre0 ) + if ( codre0.eq.2 ) then + call gmmod ( nohind//'.Noeud.'//saux08, + > jaux, nancno, nbnoto, ncmpin, ncmpin, codre0 ) + codret = max ( abs(codre0), codret ) + endif + if ( typind.eq.2 ) then + adnoin = jaux + else + adnorn = jaux + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 'noeuds' + write (ulsort,texte(langue,8)) codret +#endif +c +c 5.2. ==> Suppression des fils de mise en conformite +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2 Suppression fils ; codret', codret +#endif +c + if ( codret.eq.0 ) then + call gmobal ( nhhexa//'.InfoSup2', codre0 ) + if ( codre0.eq.2 ) then + call gmlboj ( nhhexa//'.InfoSup2', codret ) + endif + endif +c + if ( codret.eq.0 ) then + call gmobal ( nhpent//'.InfoSup2', codre0 ) + if ( codre0.eq.2 ) then + call gmlboj ( nhpent//'.InfoSup2', codret ) + endif + endif +c + if ( codret.eq.0 ) then + call gmobal ( nhtetr//'.InfoSup2', codre0 ) + if ( codre0.eq.2 ) then + call gmlboj ( nhtetr//'.InfoSup2', codret ) + endif + endif +c + if ( codret.eq.0 ) then + call gmobal ( nhpyra//'.InfoSup2', codre0 ) + if ( codre0.eq.2 ) then + call gmlboj ( nhpyra//'.InfoSup2', codret ) + endif + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECFS3', nompro +#endif + call decfs3 ( imem(phettr), imem(pfiltr), + > imem(phetqu), imem(pfilqu), + > imem(phette), imem(pfilte), + > imem(phethe), imem(pfilhe), + > imem(phetpe), imem(pfilpe), + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> Redimensionnement des tableaux du maillage +c On detruit les objets de tailles nulles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.3. Redim maillage ; codret', codret + write (ulsort,90002) 'nbtrto, nanctr', nbtrto, nanctr + write (ulsort,90002) 'nbquto, nancqu', nbquto, nancqu + write (ulsort,90002) 'nbteto, nancte', nbteto, nancte + write (ulsort,90002) 'nbheto, nanche', nbheto, nanche + write (ulsort,90002) 'nbpyto, nancpy', nbpyto, nancpy + write (ulsort,90002) 'nbpeto, nancpe', nbpeto, nancpe +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 0 + if ( nbtrto.ne.0 .or. nanctr.ne.0 ) then + nbtran = nanctr + else + nbtran = -1 + endif + if ( nbquto.ne.0 .or. nancqu.ne.0 ) then + nbquan = nancqu + else + nbquan = -1 + endif + if ( nbteto.ne.0 .or. nancte.ne.0 ) then + nbtean = nancte + else + nbtean = -1 + endif + if ( nbheto.ne.0 .or. nanche.ne.0 ) then + nbhean = nanche + else + nbhean = -1 + endif + if ( nbpyto.ne.0 .or. nancpy.ne.0 ) then + nbpyan = nancpy + else + nbpyan = -1 + endif + if ( nbpeto.ne.0 .or. nancpe.ne.0 ) then + nbpean = nancpe + else + nbpean = -1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtran', nbtran + write (ulsort,90002) 'nbquan', nbquan + write (ulsort,90002) 'nbtean', nbtean + write (ulsort,90002) 'nbhean', nbhean + write (ulsort,90002) 'nbpyan', nbpyan + write (ulsort,90002) 'nbpean', nbpean +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD98', nompro +#endif + call utad98 ( nomail, iaux, jaux, + > nancar, nbarto, + > nbtran, nbtrto, + > nbquan, nbquto, + > nbtean, nbteto, nancta, kaux, + > nbhean, nbheto, nancha, kaux, + > nbpyan, nbpyto, nancya, kaux, + > nbpean, nbpeto, nancpa, kaux, + > phetar, psomar, pfilar, pmerar, pancar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, panctr, + > pnivtr, adpetr, adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pancqu, + > pnivqu, adhequ, adnmqu, adhoqu, + > phette, ptrite, pcotrt, parete, + > pfilte, pperte, pancte, + > phethe, pquahe, pcoquh, parehe, + > pfilhe, pperhe, panche, adnmhe, + > phetpy, pfacpy, pcofay, parepy, + > pfilpy, pperpy, pancpy, + > phetpe, pfacpe, pcofap, parepe, + > pfilpe, pperpe, pancpe, + > pfamar, pfamtr, pfamqu, + > pfamte, pfamhe, pfampy, pfampe, + > ulsort, langue, codret ) +c + endif +c +c 5.4. ==> si le raffinement ou le deraffinement sont pilotes par un +c indicateur, suppression des structures inutiles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.4. suppression ; codret', codret +#endif +c + if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and. + > taopti(37).eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI3', nompro +#endif + call deini3 ( nohind, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. determination des voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. voisinage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + voarno = 0 + vofaar = 1 + vovoar = 0 + vovofa = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > iaux , jaux , + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres 6. voisinages : codret', codret +#endif +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/decine.F b/src/tool/Decision/decine.F new file mode 100644 index 00000000..e5d6c6a4 --- /dev/null +++ b/src/tool/Decision/decine.F @@ -0,0 +1,474 @@ + subroutine decine ( nupaci, nbsoci, nbsoav, + > seuilh, seuinf, seusup, + > nomail, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c DEcision - CIble - Noeud ou Elements +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nupaci . es . 1 . numero du passage en cours pour la . +c . . . . recherche de cible . +c . . . . vaut -1 si la cible est atteinte . +c . nbsoci . e . 1 . cible en nombre de sommets (-1 si non) . +c . nbmaci . e . 1 . cible en nombre de mailles (-1 si non) . +c . nbsoav . es . 1 . nombre de sommetes aux etapes anterieures . +c . seuilh . es . 1 . borne superieure de l'erreur (absolue) . +c . seuinf . es . 1 . meilleur seuil inferieur en nombre noeuds . +c . seusup . es . 1 . meilleur seuil superieur en nombre noeuds . +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indnp2 . es . 1 . nombre de noeuds p2 en vigueur . +c . indnim . es . 1 . nombre de noeuds internes en vigueur . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECINE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombno.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer nupaci, nbsoci + integer nbsoav(6) +c + character*8 nomail +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen +c + double precision seuilh, seuinf, seusup +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer nbsoan, nbsono + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpean, nbpeno + integer nbpyan, nbpyno +c + double precision daux +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ndecar, ndecfa +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nupaci', nupaci +#endif +c + texte(1,4) = '(/,a6,'' DECOMPTE DES NOUVELLES ENTITES'')' + texte(1,5) = '(37(''=''),/)' + texte(1,6) = '(''Pas assez de raffinement '',a)' + texte(1,7) = '(''Trop de raffinement '',a)' + texte(1,8) = '(''La cible est atteinte.'')' + texte(1,9) = '(''Le nombre de noeuds ne bouge plus.'')' + texte(1,10) = '(''Le nombre de noeuds alterne.'')' + texte(1,11) = '(''Arret du processus.'')' +c + texte(2,4) = '(/,a6,'' COUNTING OF NEW ENTITIES'')' + texte(2,5) = '(31(''=''),/)' + texte(2,6) = '(''Not enough refinement '',a)' + texte(2,7) = '(''Too many refinement '',a)' + texte(2,8) = '(''The target is reached.'')' + texte(2,9) = '(''No more evolution of the number of nodes.'')' + texte(2,10) = '(''The number of nodes alternates.'')' + texte(2,11) = '(''The process is over.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. programmes generiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. programmes generiques ; codret', codret +#endif +c +c 3.1. ==> Base +c + if ( codret.eq.0 ) then +c + ndecar = taopts(11) + ndecfa = taopts(12) +c + endif +c +c 3.2. ==> Nombre de valeurs +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + jaux = 1 +#else + jaux = 0 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL00', nompro +#endif + call utal00 ( iaux, jaux, + > nomail, ndecar, ndecfa, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > nbsoan, nbsono, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, + > nbhean, nbheno, + > nbpean, nbpeno, + > nbpyan, nbpyno, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Evaluation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. programmes generiques ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'seuilh', seuilh + write (ulsort,90004) 'seuinf avant', seuinf + write (ulsort,90004) 'seusup avant', seusup + write (ulsort,90002) 'nbsoav avant', nbsoav + write (ulsort,90002) 'nbnop1', nbnop1 + write (ulsort,90002) 'nbsono', nbsono + write (ulsort,90002) 'nbsoci', nbsoci +#endif +c +c 4.1. ==> Miracle ! La cible est atteinte : on arrete +c + if ( nbsono.eq.nbsoci ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) +#endif +c + nupaci = -1 +c + endif +c +c 4.2. ==> La cible n'est pas atteinte au premier passage : +c on applique un pourcentage de 20% +c + if ( nupaci.eq.1 ) then +c +c 4.2.1. ==> Pas assez de raffinement +c + if ( nbsono.lt.nbsoci ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) ' ' +#endif + if ( seuilh.gt.0.d0 ) then + daux = 0.8d0 + else + daux = 1.2d0 + endif + seuinf = seuilh +c +c 4.2.2. ==> Trop de raffinement +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) ' ' +#endif + if ( seuilh.gt.0.d0 ) then + daux = 1.2d0 + else + daux = 0.8d0 + endif + seusup = seuilh + endif +c +c 4.2.3. ==> Nouveau seuil +c + seuilh = seuilh*daux +c + endif +c +c 4.3. ==> Arret eventuel aux passages suivants +c Si on alterne, on arrete au meilleur choix +c + if ( nupaci.gt.1 ) then +c + if ( nbsono.eq.nbsoav(2) .and. + > nbsono.eq.nbsoav(4) .and. + > nbsono.eq.nbsoav(6) .and. + > nbsoav(1).eq.nbsoav(3) .and. + > nbsoav(3).eq.nbsoav(5) ) then +c + iaux = abs(nbsono-nbsoci) + jaux = abs(nbsoav(1)-nbsoci) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbsono-nbsoci', iaux + write (ulsort,90002) 'nbsoav(1)-nbsoci', jaux +#endif + if ( iaux.le.jaux ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) +#endif + nupaci = -1 + endif +c + endif +c + endif +c +c 4.4. ==> Poursuite aux passages suivants +c On decale de la meme quantite quand on progresse dans +c le meme sens, sinon dichotomie +c + if ( nupaci.gt.1 ) then +c +c 4.4.1. ==> Si pas assez de raffinement +c + if ( nbsono.lt.nbsoci ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) ' ' +#endif +c Pas assez de raffinement au passage precedent + if ( nbsoav(1).lt.nbsoci ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 'avant' +#endif + daux = seuilh - seuinf + seuinf = seuilh + seuilh = min(seusup, seuilh+daux) + else + seuinf = seuilh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'avant' +#endif + seuilh = 0.5d0*(seusup+seuilh) + endif +c +c 4.4.2. ==> Si trop de raffinement +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) ' ' +#endif +c Pas assez de raffinement au passage precedent + if ( nbsoav(1).lt.nbsoci ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 'avant' +#endif + seusup = seuilh + seuilh = 0.5d0*(seuilh+seuinf) + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'avant' +#endif + daux = seuilh - seusup + seusup = seuilh + seuilh = max(seuinf, seuilh+daux) + endif +c + endif +c + endif +c +c 4.5. ==> Preparation de l'etape suivante +c + if ( nupaci.ge.1 ) then +c + do 45 , iaux = 6, 2, -1 + nbsoav(iaux) = nbsoav(iaux-1) + 45 continue + nbsoav(1) = nbsono +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbsoav apres', nbsoav + write (ulsort,90004) 'seuilh apres', seuilh + write (ulsort,90004) 'seuinf apres', seuinf + write (ulsort,90004) 'seusup apres', seusup +#endif +c + nupaci = nupaci + 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nupaci', nupaci +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( nupaci.lt.0 ) then + write (ulsort,texte(langue,11)) + endif +#endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/decora.F b/src/tool/Decision/decora.F new file mode 100644 index 00000000..e5b2f038 --- /dev/null +++ b/src/tool/Decision/decora.F @@ -0,0 +1,524 @@ + subroutine decora ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > afaire, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - COntraintes de RAffinement +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . afaire . s . 1 . que faire a la sortie . +c . . . . 0 : aucune action . +c . . . . 1 : refaire une iteration de l'algorithme . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECORA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer afaire + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux +c + integer psomar, phetar, pfilar, pmerar, pposif, pfacar + integer phettr, paretr, pnivtr, advotr + integer phetqu, parequ, pnivqu, advoqu + integer phette, ptrite + integer phethe, pquahe, pcoquh +c + integer pdecar, pdecfa + integer adhoar + integer adtra3, adtra4, adtra5, adtra6 +c + integer codre0, codre1, codre2, codre3, codre4 +c + character*6 saux + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5, ntrav6 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.3. ==> les messages +c + texte(1,4) = '(/,a6,'' CONTRAINTES POUR LE RAFFINEMENT'')' + texte(1,5) = '(38(''=''),/)' + texte(1,6) = '(5x,''Toutes les contraintes sont respectees.'')' + texte(1,7) = '(''Option choisie :'',i4)' + texte(1,9) = '(''Cette option est impossible en dimension'',i2,/)' + texte(1,10) = '(''Decision en retour de '',a6,'' ='',i2,/)' +c + texte(2,4) = '(/,a6,'' REFINEMENT CONDITIONS'')' + texte(2,5) = '(28(''=''),/)' + texte(2,6) = '(5x,''No more unfilled conditions.'')' + texte(2,7) = '(''Selected option :'',i4)' + texte(2,9) = + > '(''This option is not available with dimension'',i4,/)' + texte(2,10) = '(''Decision code from '',a6,'' ='',i4,/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) taopti(36) +#endif +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. tableaux ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(36)', taopti(36) +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(taopti(36),2).eq.0 ) then + iaux = 10 + elseif ( mod(taopti(36),3).eq.0 ) then + iaux = 2 + elseif ( mod(taopti(36),5).eq.0 ) then + iaux = 6 + else + codret = 2 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'iaux, codret', iaux, codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + if ( mod(taopti(36),2).eq.0 ) then + iaux = 22 + else + iaux = 2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux , jaux , + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + if ( mod(taopti(36),2).eq.0 ) then + iaux = 22 + else + iaux = 2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux , jaux , + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + if ( mod(taopti(36),5).eq.0 ) then + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux , + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) + endif +c + endif +c + if ( nbheto.ne.0 ) then +c + if ( mod(taopti(36),5).eq.0 ) then + iaux = 26 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux , + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) + endif +c + endif +c +c 2.3. ==> voisinages +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. voisinages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( mod(taopti(36),2).eq.0 .or. + > mod(taopti(36),5).eq.0 ) then + if ( nbteto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 ) then + iaux = iaux*7 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> decisions +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. decisions ; codret', codret +#endif +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c 2.5. ==> auxiliaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. auxiliaires ; codret', codret +#endif +c + iaux = 2 * ( nbtrto + nbquto ) + call gmalot ( ntrav3, 'entier', iaux, adtra3, codre1 ) + iaux = nbnoto + call gmalot ( ntrav4, 'entier', iaux, adtra4, codre2 ) + iaux = nbarto + call gmalot ( ntrav5, 'entier', iaux, adtra5, codre3 ) + iaux = nbtrto + nbquto + call gmalot ( ntrav6, 'entier', iaux, adtra6, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. Application des contraintes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Application contraintes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + afaire = 0 +c +c 3.1. ==> Decalage de deux elements avant un changement de niveau +c operationnel en 2D uniquement aujourd'hui +c + if ( mod(taopti(36),2).eq.0 ) then +c + if ( sdim.ne.2 ) then +c + write (ulsort,texte(langue,7)) taopti(36) + write (ulsort,texte(langue,9)) sdim + codret = 3 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECR02', nompro +#endif + call decr02 ( imem(pdecfa), imem(pdecar), + > imem(psomar), + > imem(pfilar), imem(pmerar), imem(phetar), + > imem(pposif), imem(pfacar), + > imem(phettr), imem(paretr), imem(pnivtr), + > imem(advotr), + > imem(phetqu), imem(parequ), imem(pnivqu), + > imem(adtra3), imem(adtra4), + > imem(adtra5), imem(adtra6), + > afaire, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'DECR02', afaire +#endif + endif +c + endif +c +c 3.2. ==> Bande de raffinement interdite +c operationnel en 2D uniquement aujourd'hui +c + if ( mod(taopti(36),3).eq.0 ) then +c + if ( sdim.ne.2 ) then +c + write (ulsort,texte(langue,7)) taopti(36) + write (ulsort,texte(langue,9)) sdim + codret = 3 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECR03', nompro +#endif + call decr03 ( imem(pdecfa), imem(pdecar), + > imem(phetar), imem(pposif), imem(pfacar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(adtra3), + > afaire, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'DECR03', afaire +#endif + endif +c + endif +c +c 3.3. ==> Pas d'elements decoupes seul : +c . Pas de segments sans la ou les faces auxquelles +c il appartient +c . Pas de face sans le ou les volumes auxquels il appartient +c + if ( mod(taopti(36),5).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECR05', nompro +#endif + call decr05 ( taopti(31), homolo, + > imem(pdecfa), imem(pdecar), + > imem(phetar), imem(pfilar), + > imem(pposif), imem(pfacar), + > imem(phettr), imem(paretr), imem(advotr), + > imem(phetqu), imem(parequ), imem(advoqu), + > imem(ptrite), + > imem(pquahe), imem(pcoquh), + > imem(adhoar), + > afaire, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 'DECR05', afaire +#endif +c + endif +c + endif +c +c==== +c 4. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav3, codre1 ) + call gmlboj ( ntrav4, codre2 ) + call gmlboj ( ntrav5, codre3 ) + call gmlboj ( ntrav6, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.eq.0 ) then + if ( afaire.eq.0 ) then + write (ulsort,texte(langue,6)) + endif + endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decpt0.F b/src/tool/Decision/decpt0.F new file mode 100644 index 00000000..a0412ac3 --- /dev/null +++ b/src/tool/Decision/decpt0.F @@ -0,0 +1,377 @@ + subroutine decpt0 ( decare, decfac, + > hettri, hetqua, + > tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > narde2, narra2, + > ntrde4, ntrra4, + > nqude4, nqura4, + > ntede8, ntera8, + > nhede8, nhera8, + > npyder, npyraf, + > npeder, nperaf, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - ComPTage - phase 0 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . e .0:nbarto. decisions des aretes . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . narde2 . s . 1 . nb d'aretes avec decision de deraffinement . +c . narra2 . s . 1 . nb d'aretes avec decision de raffinement . +c . ntrde4 . s . 1 . nb de triangles avec decision de deraffinem. +c . ntrra4 . s . 1 . nb de triangles avec decision de raffinemen. +c . ntede8 . s . 1 . nb de tetraedres avec decision de deraffine. +c . ntera8 . s . 1 . nb de tetraedres avec decision de raffinem . +c . nhede8 . s . 1 . nb d'hexaedres avec decision de deraffine . +c . nhera8 . s . 1 . nb de hexaedres avec decision de raffinem . +c . npyder . s . 1 . nb de pyramides avec decision de deraffine . +c . npyraf . s . 1 . nb de pyramides avec decision de raffinem . +c . npeder . s . 1 . nb de pentaedres avec decision de deraffine. +c . nperaf . s . 1 . nb de pentaedres avec decision de raffinem . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECPT0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer narde2, narra2 + integer ntrde4, ntrra4 + integer nqude4, nqura4 + integer ntede8, ntera8 + integer nhede8, nhera8 + integer npyder, npyraf + integer npeder, nperaf +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer larete, letria, lequad, letetr, lehexa, lapyra, lepent + integer dt, etat +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. decompte des entites a decouper et a supprimer et impressions +c==== +c +c 2.1. ==> rien a priori +c + ntera8 = 0 + nhera8 = 0 + nqura4 = 0 + ntrra4 = 0 + narra2 = 0 + ntede8 = 0 + nhede8 = 0 + nqude4 = 0 + ntrde4 = 0 + narde2 = 0 + npyraf = 0 + npyder = 0 + nperaf = 0 + npeder = 0 +c +c 2.2. ==> les indications portent sur les tetraedres +c + if ( nbteto.ne.0 ) then +c + do 22 , letetr = 1, nbteto +c + dt = decfac(tritet(letetr,1)) + decfac(tritet(letetr,2)) + > + decfac(tritet(letetr,3)) + decfac(tritet(letetr,4)) +c + etat = mod ( hettet(letetr) , 100 ) +c + if ( etat.eq.0 ) then +c + dt = dt + mod( hettri(tritet(letetr,1)) , 10 ) + > + mod( hettri(tritet(letetr,2)) , 10 ) + > + mod( hettri(tritet(letetr,3)) , 10 ) + > + mod( hettri(tritet(letetr,4)) , 10 ) +c + endif +c + if ( dt.eq.16 ) then + ntera8 = ntera8 + 1 + elseif ( (dt.eq.-3) .or. (dt.eq.-4) ) then + ntede8 = ntede8 + 1 +cgn if ( letetr.eq.58 ) then +cgn write (ulsort,90015) 'tetr', letetr, ' faces, etat/dt', +cgn > tritet(letetr,1),tritet(letetr,2), +cgn > tritet(letetr,3),tritet(letetr,4),etat, dt +cgn write (ulsort,90015) 'tetr', letetr, ' deci f', +cgn > decfac(tritet(letetr,1)),decfac(tritet(letetr,2)), +cgn > decfac(tritet(letetr,3)),decfac(tritet(letetr,4)) +cgn endif + endif +c + 22 continue +c + endif +c +c 2.3. ==> les indications portent sur les pyramides +c + if ( nbpyto.ne.0 ) then +c + do 23 , lapyra = 1, nbpyto +c + dt = decfac(facpyr(lapyra,1)) + decfac(facpyr(lapyra,2)) + > + decfac(facpyr(lapyra,3)) + decfac(facpyr(lapyra,4)) + > + decfac(-facpyr(lapyra,5)) +cgn write(ulsort,90002) lapyra,dt +cgn if ( dt.ne.0 ) then +cgn print *,' ',facpyr(lapyra,1),decfac(facpyr(lapyra,1)) +cgn print *,' ',facpyr(lapyra,2),decfac(facpyr(lapyra,2)) +cgn print *,' ',facpyr(lapyra,3),decfac(facpyr(lapyra,3)) +cgn print *,' ',facpyr(lapyra,4),decfac(facpyr(lapyra,4)) +cgn print *,' ',facpyr(lapyra,5),decfac(-facpyr(lapyra,5)) +cgn endif +c + etat = mod ( hetpyr(lapyra) , 100 ) +c + if ( etat.eq.0 ) then +c + dt = dt + mod( hettri(facpyr(lapyra,1)) , 10 ) + > + mod( hettri(facpyr(lapyra,2)) , 10 ) + > + mod( hettri(facpyr(lapyra,3)) , 10 ) + > + mod( hettri(facpyr(lapyra,4)) , 10 ) + > + mod( hetqua(facpyr(lapyra,5)) , 100 ) +c + endif +c + if ( dt.eq.20 ) then + npyraf = npyraf + 1 + elseif ( (dt.eq.-3) .or. (dt.eq.-4) ) then + npyder = npyder + 1 + endif +c + 23 continue +c + endif +c +c 2.4. ==> les indications portent sur les hexaedres +c + if ( nbheto.ne.0 ) then +c + do 24 , lehexa = 1, nbheto +cgn if ( (lehexa.eq.57693) .or. (lehexa.eq.60646) ) then +cgn write(ulsort,90112)'hethex', lehexa, hethex(lehexa) +cgn do 241 , iaux=1,6 +cgn write(ulsort,90112)' decfac', quahex(lehexa,iaux), +cgn > decfac(-quahex(lehexa,iaux)) +cgn 241 continue +cgn endif +c + dt = decfac(-quahex(lehexa,1)) + decfac(-quahex(lehexa,2)) + > + decfac(-quahex(lehexa,3)) + decfac(-quahex(lehexa,4)) + > + decfac(-quahex(lehexa,5)) + decfac(-quahex(lehexa,6)) +c + etat = mod (hethex(lehexa),1000) +c + if ( etat.eq.0 ) then +c + dt = dt + mod( hetqua(quahex(lehexa,1)) , 100 ) + > + mod( hetqua(quahex(lehexa,2)) , 100 ) + > + mod( hetqua(quahex(lehexa,3)) , 100 ) + > + mod( hetqua(quahex(lehexa,4)) , 100 ) + > + mod( hetqua(quahex(lehexa,5)) , 100 ) + > + mod( hetqua(quahex(lehexa,6)) , 100 ) +c + endif +c + if ( dt.eq.24 ) then +cgn write(ulsort,90112)'raff. hethex', lehexa, hethex(lehexa) + nhera8 = nhera8 + 1 + elseif ( (dt.eq.-4) .or. (dt.eq.-5) .or. (dt.eq.-6) ) then +cgn write(ulsort,90112)'reac. hethex', lehexa, hethex(lehexa) + nhede8 = nhede8 + 1 + endif +c + 24 continue +c + endif +c +c 2.5. ==> les indications portent sur les pentaedres +c + if ( nbpeto.ne.0 ) then +c + do 25 , lepent = 1, nbpeto +c + dt = decfac(facpen(lepent,1)) + decfac(facpen(lepent,2)) + > + decfac(-facpen(lepent,3)) + decfac(-facpen(lepent,4)) + > + decfac(-facpen(lepent,5)) +cgn write(ulsort,90002) lepent,dt + if ( dt.ne.0 ) then +cgn print *,' ',facpen(lepent,1),decfac(facpen(lepent,1)) +cgn print *,' ',facpen(lepent,2),decfac(facpen(lepent,2)) +cgn print *,' ',facpen(lepent,3),decfac(-facpen(lepent,3)) +cgn print *,' ',facpen(lepent,4),decfac(-facpen(lepent,4)) +cgn print *,' ',facpen(lepent,5),decfac(-facpen(lepent,5)) + endif +c + etat = mod ( hetpen(lepent) , 100 ) +c + if ( etat.eq.0 ) then +c + dt = dt + mod( hettri(facpen(lepent,1)) , 10 ) + > + mod( hettri(facpen(lepent,2)) , 10 ) + > + mod( hetqua(facpen(lepent,3)) , 100 ) + > + mod( hetqua(facpen(lepent,4)) , 100 ) + > + mod( hetqua(facpen(lepent,5)) , 100 ) +c + endif +cgn write(ulsort,90002)'==> dt final = ',dt +c + if ( dt.eq.20 ) then + nperaf = nperaf + 1 + elseif ( dt.eq.-5 ) then + npeder = npeder + 1 + endif +c + 25 continue +c + endif +c +c 2.6. ==> bilan sur les triangles +c + do 26 , letria = 1, nbtrto + if ( decfac(letria).eq.4 ) then + ntrra4 = ntrra4 + 1 + elseif ( decfac(letria).eq.-1 ) then + ntrde4 = ntrde4 + 1 + endif + 26 continue +c +c 2.7. ==> bilan sur les quadrangles +c + do 27 , lequad = 1, nbquto + if ( decfac(-lequad).eq.4 ) then + nqura4 = nqura4 + 1 + elseif ( decfac(-lequad).eq.-1 ) then + nqude4 = nqude4 + 1 + endif + 27 continue +c +c 2.8. ==> bilan sur les aretes +c + do 28 , larete = 1, nbarto + if ( decare(larete).eq.2 ) then + narra2 = narra2 + 1 + elseif ( decare(larete).eq.-1 ) then + narde2 = narde2 + 1 + endif + 28 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decpte.F b/src/tool/Decision/decpte.F new file mode 100644 index 00000000..eea3330a --- /dev/null +++ b/src/tool/Decision/decpte.F @@ -0,0 +1,266 @@ + subroutine decpte ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, + > tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - ComPTagE +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . . . . -1 : deraffinement uniforme . +c . decare . e .0:nbarto. decisions des aretes . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECPTE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer pilraf, pilder + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer narde2, narra2 + integer ntrde4, ntrra4 + integer nqude4, nqura4 + integer ntede8, ntera8 + integer nhede8, nhera8 + integer npyder, npyraf + integer npeder, nperaf +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,7x,''Nombre de '',a,'' a decouper en '',i1,'' : '',i10)' + texte(1,5) = + > '(/,7x,''Nombre de '',a,'' a reactiver : '',i10)' + texte(1,6) = + > '(/,7x,''Nombre de '',a,'' a decouper : '',i10)' +c + texte(2,4) = + > '(/,7x,''Number of '',a,'' to divide into '',i1,'' : '',i10)' + texte(2,5) = + > '(/,7x,''Number of '',a,'' to reactivate : '',i10)' + texte(2,6) = + > '(/,7x,''Number of '',a,'' to divide : '',i10)' +c + codret = 0 +c +#include "impr03.h" +c +c==== +c 2. decompte des entites a decouper et a supprimer et impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPT0', nompro +#endif + call decpt0 ( decare, decfac, + > hettri, hetqua, + > tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > narde2, narra2, + > ntrde4, ntrra4, + > nqude4, nqura4, + > ntede8, ntera8, + > nhede8, nhera8, + > npyder, npyraf, + > npeder, nperaf, + > ulsort, langue, codret ) +c +c==== +c 3. impressions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. impressions ; codret', codret +#endif +c +c 3.1. ==> raffinement +c +#ifdef _DEBUG_HOMARD_ + if ( pilraf.ne.-100 ) then +#else + if ( pilraf.ne.0 ) then +#endif +c + if ( nbteto.ne.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,3), 8, ntera8 + endif + if ( nbheto.ne.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,6), 8, nhera8 + endif + if ( nbpyto.ne.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,5), npyraf + endif + if ( nbpeto.ne.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,7), 8, nperaf + endif + if ( nbquto.ne.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,4), 4, nqura4 + endif + if ( nbtrto.ne.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,2), 4, ntrra4 + endif + write(ulsort,texte(langue,4)) mess14(langue,3,1), 2, narra2 +c + endif +c +c 3.2. ==> deraffinement +c + if ( nbiter.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( pilder.ne.-100 ) then +#else + if ( pilder.ne.0 ) then +#endif +c + if ( nbteto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,3), ntede8 + endif + if ( nbheto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,6), nhede8 + endif + if ( nbpyto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,5), npyder + endif + if ( nbpeto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,7), npeder + endif + if ( nbquto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,4), nqude4 + endif + if ( nbtrto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,2), ntrde4 + endif + write(ulsort,texte(langue,5)) mess14(langue,3,1), narde2 +c + endif +c + endif +c + write(ulsort,*) ' ' +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decr02.F b/src/tool/Decision/decr02.F new file mode 100644 index 00000000..1aff0fce --- /dev/null +++ b/src/tool/Decision/decr02.F @@ -0,0 +1,398 @@ + subroutine decr02 ( decfac, decare, + > somare, + > filare, merare, hetare, + > posifa, facare, + > hettri, aretri, nivtri, + > voltri, + > hetqua, arequa, nivqua, + > list1f, bornoe, borare, list2f, + > afaire, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Contraintes de Raffinement - 02 +c -- - - -- +c Decalage de deux mailles avant un changement de niveau +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . decare . es . nbarto . decisions des aretes . +c . somare . e .nbarto*2. numeros des extremites d'arete . +c . filare . e . nbarto . fille ainee de chaque arete . +c . merare . e . nbarto . mere de chaque arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . list1f . aux . nbquto/. auxiliaire sur les faces (quad. + tri.) . +c . . . nbtrto . . +c . bornoe . aux . nbnoto . auxiliaire sur les noeuds . +c . borare . aux . nbarto . auxiliaire sur les aretes . +c . afaire . es . 1 . que faire a la sortie . +c . . . . 0 : aucune action . +c . . . . 1 : refaire une iteration de l'algorithme . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECR02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "impr02.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer decfac(-nbquto:nbtrto), decare(0:nbarto) + integer somare(2,nbarto) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer list1f(2,*), bornoe(*), borare(*), list2f(*) + integer afaire +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer ipos + integer iaux, ideb, ifin + integer laface, faced, etatfa + integer larelo, lardeb, larfin, larete, iface + integer option, nbento, nbaret + integer nbfac1, nbfac2 + integer nbnobo, nbar2d, nbar3d +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Au moins 2 mailles entre 2 niveaux.'')' + texte(1,5) = '(7x,''Nombre de faces a reconsiderer :'',i6,/)' +c + texte(2,4) = '(5x,''A least 2 meshes between 2 levels.'')' + texte(2,5) = '(7x,''Number of faces to deal with :'',i6,/)' +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c + write (ulsort,texte(langue,4)) +c +c==== +c 2. recherche des noeuds a la limite entre deux zones de raffinement de +c niveau different, sans tenir compte du bord exterieur +c==== +c + if ( codret.eq.0 ) then +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBONO', nompro +#endif + call utbono ( iaux, + > nbnoto, nbarto, nbtrto, nbquto, nbteto, nbfaar, + > somare, + > filare, hetare, + > posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, + > nbnobo, bornoe, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. recherche des aretes a la limite entre deux zones de raffinement de +c niveau different, sans tenir compte du bord exterieur +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recherche aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOAR', nompro +#endif + call utboar ( iaux, + > nbarto, nbtrto, nbquto, nbteto, nbfaar, + > hetare, filare, + > posifa, facare, + > aretri, hettri, voltri, + > arequa, hetqua, + > nbar2d, nbar3d, borare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. recherche des faces : +c . dont une des aretes est a la limite entre deux zones de +c raffinement de niveau different, sans tenir compte du bord +c exterieur +c . qui sont actives +c . qui sont a garder dans l'adaptation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. recherche faces ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nbfac1 = 0 +c + do 4 , option = 2, 4, 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) mess14(langue,2,option) +#endif +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 40 , laface = 1 , nbento +c + if ( option.eq.2 ) then + etatfa = mod( hettri(laface) , 10 ) + faced = laface + else + etatfa = mod( hetqua(laface) , 100 ) + faced = -laface + endif +c + if ( etatfa.eq.0 .and. decfac(faced).eq.0 ) then +c + do 41 , larelo = 1 , nbaret +c + if ( option.eq.2 ) then + larete = aretri(laface,larelo) + else + larete = arequa(laface,larelo) + endif + if ( borare(larete).eq.1 ) then + nbfac1 = nbfac1 + 1 + list1f(1,nbfac1) = faced + list1f(2,nbfac1) = larelo + goto 40 + endif +c + 41 continue +c + endif +c + 40 continue +c + 4 continue +c + endif +cgn write (ulsort,1789)(list1f(1,iaux),list1f(2,iaux), +cgn >iaux=1,nbfac1) +cgn 1789 format(10(i8,i2)) +c +c==== +c 5. pour chacune des faces trouvees a l'etape 4 : +c . on cherche leur voisine par l'arete parallele au bord +c . si cette voisine est a couper en 4, on coupera la face +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. voisines ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nbfac2 = 0 +c + do 5 , iaux = 1 , nbfac1 +c + faced = list1f(1,iaux) + if ( faced.gt.0 ) then + lardeb = 1 + larfin = 3 + else + lardeb = per1a4(2,list1f(2,iaux)) + larfin = lardeb + endif +c + do 51 , larelo = lardeb , larfin +c + if ( faced.gt.0 ) then + larete = aretri(faced,larelo) + else + larete = arequa(-faced,larelo) + endif +c + if ( decare(larete).eq.2 ) then +c + ideb = posifa(larete-1)+1 + ifin = posifa(larete) +c + do 511 , ipos = ideb , ifin + iface = facare(ipos) + if ( iface.ne.faced) then + if ( decfac(iface).eq.4 ) then + nbfac2 = nbfac2 + 1 + list2f(nbfac2) = faced + endif + endif + 511 continue +c + endif +c + 51 continue +c + 5 continue +c + endif +c +c==== +c 6. modifications des decisions des faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. modifications decfac ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfac2.gt.0 ) then + write (ulsort,texte(langue,5)) nbfac2 + afaire = 1 + endif +c + do 61 , iaux = 1 , nbfac2 +c + laface = list2f(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decfac',laface,4,' ' +#endif + decfac(laface) = 4 +c + if ( laface.gt.0 ) then + nbaret = 3 + else + nbaret = 4 + endif +c + do 611 , larelo = 1 , nbaret +c + if ( laface.gt.0 ) then + larete = aretri(laface,larelo) + else + larete = arequa(-laface,larelo) + endif +c + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 + endif + elseif ( decare(larete).eq.-1 ) then + decare(larete) = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', larete,decare(larete),' ' +#endif +c + 611 continue +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decr03.F b/src/tool/Decision/decr03.F new file mode 100644 index 00000000..525a57e3 --- /dev/null +++ b/src/tool/Decision/decr03.F @@ -0,0 +1,522 @@ + subroutine decr03 ( decfac, decare, + > hetare, posifa, facare, + > hettri, aretri, + > hetqua, arequa, + > listef, + > afaire, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Contraintes de Raffinement - 03 +c -- - - -- +c Bande de raffinement interdite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . decare . es . nbarto . decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . listef . aux . nbquto/. auxiliaire sur les faces (quad. + tri.) . +c . . . nbtrto . . +c . afaire . es . 1 . que faire a la sortie . +c . . . . 0 : aucune action . +c . . . . 1 : refaire une iteration de l'algorithme . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECR03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decfac(-nbquto:nbtrto), decare(0:nbarto) + integer hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer listef(*) + integer afaire +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer ipos + integer iaux, ideb, ifin + integer laface, faced, etatfa + integer larelo, larete, iface + integer option, nbento, nbaret + integer nbface, nbarpb + integer infare(4), listar(4) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Bande interdite.'')' + texte(1,5) = '(7x,''Nombre de faces a reconsiderer :'',i6,/)' + texte(1,6) = '(''. Probleme avec le '',a,i6)' + texte(1,7) = + > '(a,''numero '',i6,'' : decision ='',i2,'', etat ='',i5)' +c + texte(2,4) = '(5x,''No band.'')' + texte(2,5) = '(7x,''Number of faces to deal with :'',i6,/)' + texte(2,6) = '(''. Problem with '',a,''#'',i6)' + texte(2,7) = + > '(a,''#'',i6,'' : decision ='',i2,'', status ='',i5)' +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c + write (ulsort,texte(langue,4)) +c +c==== +c 2. on interdit les situations ou on aurait apparition d'une bande : +c En triangle : +c . un triangle coupe dont aucun voisin ne serait decoupe +c . .-------------. +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c .-------------. .-------------. +c . . .. . . . . .. . . +c . . . . . . . . . . . . +c . . . .. . . . . .. . +c . .-----. . . .-----. . +c . . . . . . . . +c . . . . . . . . +c -------------.------------- -------------.------------- +c +c . un triangle coupe dont un seul voisin est decoupe +c . +c . . +c . . +c . . +c . . +c . . +c . . +c .-------------. +c . . .. . . +c . . . . . . +c . . . .. . +c . .-----. ------. +c . . . . . . +c . . . . . . +c -------------.------.------ +c +c En quadrangle : +c . un quadrangle coupe dont aucun voisin ne serait decoupe +c +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c . . . . . +c . . . . . +c . .-------------. . +c . . . . . +c . . . . . +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c +c . un quadrangle coupe dont aucun voisin ne serait decoupe +c dans une direction +c +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c . . . . . . +c . . . . . . +c . .-------------.-------------. +c . . . . . . +c . . . . . . +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c . . . . . . . +c . . . . . . . +c .-------------.-------------.-------------. +c . . . . . . . +c . . . . . . . +c ------------------------------------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------------------------------------------- +c +c Dans ces cas-la, il faut imposer le decoupage sur 1 ou 2 voisins +c +c On parcourt les faces coupees ou a couper. On compte combien elles +c possedent de faces voisines coupees ou a couper +c==== +c + nbface = 0 +c + do 2 , option = 2, 4, 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) mess14(langue,2,option) +#endif +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 20 , laface = 1 , nbento +c + if ( option.eq.2 ) then + etatfa = mod( hettri(laface) , 10 ) + faced = laface + else + etatfa = mod( hetqua(laface) , 100 ) + faced = -laface + endif +c + if ( ( etatfa.eq.0 .and. decfac(faced).eq.4 ) .or. + > etatfa.eq.4 .and. decfac(faced).ne.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*)' ' + write (ulsort,texte(langue,7))mess14(langue,1,option), + > laface,decfac(faced),etatfa +#endif +c +c 2.1. ==> on parcourt chacune des aretes ; on remplit le tableau infare +c infare(ar) = 0 : une au moins des faces s'appuyant sur +c l'arete restera non decoupee +c infare(ar) = 2 : toutes les faces s'appuyant sur l'arete +c sont coupees ou a couper +c infare(ar) = -1 : l'arete est au bord +c + do 21 , larelo = 1 , nbaret +c + if ( option.eq.2 ) then + larete = aretri(laface,larelo) + else + larete = arequa(laface,larelo) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1), + > larete,decare(larete),hetare(larete) +#endif + ideb = posifa(larete-1)+1 + ifin = posifa(larete) +c + if ( ideb.eq.ifin ) then + infare(larelo) = -1 + else +c + infare(larelo) = 2 + do 211 , ipos = ideb , ifin + iface = facare(ipos) + if ( iface.ne.faced) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7))'.... '//mess14(langue,1,option), + > abs(iface),decfac(iface),etatfa +#endif + if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then + goto 21 + else if ( decfac(iface).eq.4 ) then + goto 21 + else + infare(larelo) = 0 + endif + endif + 211 continue +c + endif +c + 21 continue +c +c 2.2. ==> analyse +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==> infare : ',infare +#endif + nbarpb = 0 +c +c 2.2.1. ==> liste des aretes a traiter dans le cas du triangle +c + if ( option.eq.2 ) then +c + write (ulsort,*) 'pas glop' + codret = 12 +c +c 2.2.2. ==> liste des aretes a traiter dans le cas cas du quadrangle +c on explore les aretes par paire : on intervient quand +c deux aretes en vis-a-vis sont a garder ou qu'une arete a +c garder est en face d'une arete de bord. +c + else +c + do 222 , iaux = 1 , 2 +c + larelo = 0 + if ( infare(iaux).eq.0 .and. + > infare(iaux+2).eq.-1 ) then + larelo = iaux + elseif ( infare(iaux).eq.-1 .and. + > infare(iaux+2).eq.0 ) then + larelo = iaux+2 + elseif ( infare(iaux).eq.0 .and. + > infare(iaux+2).eq.0 ) then + larelo = iaux + endif +c + if ( larelo.ne.0 ) then + nbarpb = nbarpb + 1 + listar(nbarpb) = arequa(laface,larelo) + endif +c + 222 continue +c + endif +c +c 2.2.3. ==> liste des faces voisines de ces aretes a traiter +c + if ( nbarpb.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,option),laface + write (ulsort,*)(listar(iaux),iaux=1,nbarpb) +#endif +c + do 223 , iaux = 1 , nbarpb +c + larete = listar(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1), + > larete,decare(larete),hetare(larete) +#endif + ideb = posifa(larete-1)+1 + ifin = posifa(larete) +c + do 2231 , ipos = ideb , ifin + iface = facare(ipos) + if ( iface.ne.faced) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7))'.... '//mess14(langue,1,4), + > -iface,decfac(iface),hetqua(-iface) +#endif + endif + if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then + goto 223 + else if ( decfac(iface).eq.4 ) then + goto 223 + else + nbface = nbface + 1 + listef(nbface) = iface + endif + endif + 2231 continue +c + 223 continue +c + endif +c + endif +c + 20 continue +c + 2 continue +c +c==== +c 3. modification des decisions +c attention : il faut le faire seulement a la toute fin, sinon on +c risque de propager le raffinement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. modifications decfac ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbface.ne.0 ) then +c + write (ulsort,texte(langue,5)) nbface + afaire = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*)(listef(iaux),iaux=1,nbface) +#endif +c + do 31 , iaux = 1 , nbface +c + laface = listef(iaux) + if ( decfac(laface).eq.0 ) then + decfac(laface) = 4 + else + decfac(laface) = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*)' ' + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + nbaret = 0 + if ( laface.gt.0 ) then + do 311 , larelo = 1 , 3 + larete = aretri(laface,larelo) + if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then + nbaret = nbaret + 1 + infare(nbaret) = larete + endif + 311 continue + else + do 312 , larelo = 1 , 4 + larete = arequa(-laface,larelo) + if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then + nbaret = nbaret + 1 + infare(nbaret) = larete + endif + 312 continue + endif +c + do 313 , larelo = 1 , nbaret + larete = infare(larelo) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 + endif + elseif ( decare(larete).eq.-1 ) then + decare(larete) = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', larete,decare(larete),' ' +#endif + 313 continue +c + 31 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/decr05.F b/src/tool/Decision/decr05.F new file mode 100644 index 00000000..42892951 --- /dev/null +++ b/src/tool/Decision/decr05.F @@ -0,0 +1,821 @@ + subroutine decr05 ( tyconf, homolo, + > decfac, decare, + > hetare, filare, posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, volqua, + > tritet, quahex, coquhe, + > arehom, + > afaire, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Contraintes de Raffinement - 05 +c -- - - -- +c Pas de segments decoupes sans sa face voisine, ni de face decoupee +c sans son volume voisin +c Il faut faire ce controle a la fin de l'algorithme sur la +c propagation du raffinement, car on ne peut pas prevoir au depart +c tout ce qui va se passer. En particulier dans des cas bizarres pour +c lesquels on aurait plusieurs boites. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . homolo . e . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . decare . es . nbarto . decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . afaire . es . 1 . que faire a la sortie . +c . . . . 0 : aucune action . +c . . . . 1 : refaire une iteration de l'algorithme . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DECR05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer tyconf, homolo + integer decfac(-nbquto:nbtrto), decare(0:nbarto) + integer hetare(nbarto), filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3), voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), volqua(2,nbquto) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer arehom(nbarto) +c + integer afaire +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer ipos + integer iaux, jaux, kaux + integer ideb, ifin + integer etatar, etatfa + integer larete, laret1, larelo, laface, iface, letetr, lehexa + integer nbarpb, nbfapb + integer nbaret, listar(12) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(5x,''Pas de maille de bord decoupe sans son voisin.'',/)' + texte(1,5) = '(7x,''Nombre de '',a,''a reconsiderer :'',i6,/)' + texte(1,6) = '(7x,''Aucun changement.'')' + texte(1,7) = '(7x,''Apres l''''analyse '',a)' + texte(1,8) = '(a,''numero '',i8,'' : decision ='',i2)' + texte(1,9) = + > '(a,''numero '',i8,'' : decision ='',i2,'', etat ='',i5)' + texte(1,10) = '(/,i1,''. Examen des'',i10,1x,a,)' +c + texte(2,4) = + > '(5x,''No border mesh cut without its neighbour.'',/)' + texte(2,5) = '(7x,''Number of'',a,''to deal with :'',i6,/)' + texte(2,6) = '(7x,''No modification.'')' + texte(2,7) = '(7x,''After analysis '',a)' + texte(2,8) = '(a,''#'',i8,'' : decision ='',i25)' + texte(2,9) = + > '(a,''#'',i8,'' : decision ='',i2,'', status ='',i5)' + texte(2,10) = '(/,''Examination of the'',i10,1x,a,)' +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c + write (ulsort,texte(langue,4)) +c + nbarpb = 0 + nbfapb = 0 +c +c==== +c 2. on interdit les situations ou on aurait un segment decoupe alors +c qu'aucune des faces auxquelles il appartient ne le serait. +c Cela peut arriver si on a fait du decoupage selon une zone +c geometrique et que cette zone incluait une serie d'aretes. +c Ou avec un indicateur sur aretes ou noeuds et que ce seul +c segment a ete retenu. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. face/arete ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 1, nbarto, mess14(langue,3,1) +#endif +c + do 20 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,1), + > larete,decare(larete) +#endif +c + if ( decare(larete).eq.2 ) then +c +c 2.1. ==> on parcourt chacune des faces voisines de l'arete +c on compte le nombre de faces a couper ou a reactualiser +c s'il y a des equivalences, il faut traiter ensemble une +c arete et son homologue +c + kaux = 0 +c + nbaret = 1 + listar(1) = larete + if ( homolo.ge.2 ) then + laret1 = arehom(larete) + if ( laret1.ne.0 ) then + listar(2) = abs(laret1) + nbaret = 2 + endif + endif +c + do 211 , iaux = 1 , nbaret +c + laret1 = listar(iaux) +c + ideb = posifa(laret1-1)+1 + ifin = posifa(laret1) +c + do 2111 , ipos = ideb , ifin +c + iface = facare(ipos) + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,8), + > abs(iface),decfac(iface),etatfa +#endif + if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then + goto 20 + else if ( decfac(iface).eq.4 ) then + goto 20 + else + kaux = kaux + 1 + endif +c + 2111 continue +c + 211 continue +c +c 2.2. ==> aucune face n'est a couper ou a reactualiser, on ne doit pas +c couper l'arete +c + if ( kaux.gt.0 ) then + nbarpb = nbarpb + 1 + do 22 , iaux = 1 , nbaret + laret1 = listar(iaux) + decare(laret1) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', laret1,decare(laret1),' ' + write (ulsort,*)' ' +#endif + 22 continue + endif +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'face/arete' + if ( nbarpb.gt.0 .or. nbfapb.gt.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarpb + write (ulsort,texte(langue,5)) mess14(langue,3,8), nbfapb + else + write (ulsort,texte(langue,6)) + endif +#endif +c +c==== +c 3. on interdit les situations ou on aurait un triangle decoupe alors +c qu'aucun de ses tetraedres voisins ne le serait. +c Cela peut arriver si on a fait du decoupage selon une zone +c geometrique et que cette zone incluait une zone purement 2D. +c Ou avec un indicateur sur faces ou noeuds et que cette seule +c face a ete retenue. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. tetr/tria ; codret', codret +#endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 2, nbtrto, mess14(langue,3,2) +#endif +c + do 30 , laface = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,2), + > laface,decfac(laface) +#endif +c + if ( decfac(laface).eq.4 ) then +c + kaux = 0 +c +c 3.1. ==> on parcourt chacun des tetraedres voisins du triangle +c un tetraedre sera coupe si au moins une autre de ses faces +c l'est +c ATTENTION A FAIRE COMME LES HEXAS +c + do 31 , iaux = 1 , 2 +c + letetr = voltri(iaux,laface) +c + if ( letetr.gt.0 ) then +c + do 311 , jaux = 1 , 4 +c + iface = tritet(letetr,jaux) +c + if ( iface.ne.laface ) then +c + etatfa = mod( hettri(iface) , 10 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,2), + > iface,decfac(iface),etatfa +#endif + if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then + goto 30 + else if ( decfac(iface).eq.4 ) then + goto 30 + else + kaux = kaux + 1 + endif +c + endif +c + 311 continue +c + endif +c + 31 continue +c +c 3.2. ==> aucun tetraedre n'est a couper ou a reactualiser, on ne doit +c pas couper le triangle, ni ses aretes +c + if ( kaux.gt.0 ) then + nbfapb = nbfapb + 1 + decfac(laface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + do 32 , larelo = 1 , 3 + larete = aretri(laface,larelo) + if ( decare(larete).eq.2 ) then + nbarpb = nbarpb + 1 + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', larete,decare(larete),' ' +#endif + endif + 32 continue + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*)' ' +#endif +c + endif +c + 30 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'tetr/tria' + if ( nbarpb.gt.0 .or. nbfapb.gt.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarpb + write (ulsort,texte(langue,5)) mess14(langue,3,8), nbfapb + else + write (ulsort,texte(langue,6)) + endif +#endif +c +c==== +c 4. on interdit les situations ou on aurait un quadrangle decoupe alors +c qu'aucun de ses hexaedres voisins ne le serait. +c Cela peut arriver si on a fait du decoupage selon une zone +c geometrique et que cette zone incluait une zone purement 2D. +c Ou avec un indicateur sur faces ou noeuds et que cette seule +c face a ete retenue. +c Cela peut aussi arriver par contamination entre faces. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. hexa/quad ; codret', codret +#endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 3, nbquto, mess14(langue,3,4) +#endif +c + do 40 , laface = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + if ( laface.eq.215996 .or. + > laface.eq.66980 ) then + glop=1 + else + glop=0 + endif + if ( glop.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,4), + > laface,decfac(-laface) + write (ulsort,*) ' volqua(*,laface) : ', + > volqua(1,laface),volqua(2,laface) + do 401 , iaux = 1 , 2 + lehexa = volqua(iaux,laface) + if ( lehexa.gt.0 ) then + write (ulsort,*)'.. hexaedre ', lehexa + do 4011 , jaux = 1 , 6 + iface = quahex(lehexa,jaux) + etatfa = mod( hetqua(iface) , 100 ) + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,4), + > iface,decfac(-iface),etatfa + 4011 continue + endif + 401 continue + endif +#endif +c + if ( decfac(-laface).eq.4 ) then +c +c 4.1. ==> on parcourt chacun des hexaedres voisins du quadrangle +c un hexaedre sera coupe si toutes ses faces le sont +c kaux = nombre de faces coupees ou a couper pour le +c iaux-ime hexaedre +c + do 41 , iaux = 1 , 2 +c + lehexa = volqua(iaux,laface) +c + kaux = 1 +c + if ( lehexa.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,*)'.. hexaedre ', lehexa + endif +#endif +c + do 411 , jaux = 1 , 6 +c + iface = quahex(lehexa,jaux) +c + if ( iface.ne.laface ) then +c + etatfa = mod( hetqua(iface) , 100 ) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,4), + > iface,decfac(-iface),etatfa + endif +#endif + if ( etatfa.ne.0 .and. decfac(-iface).ne.-1 ) then + kaux = kaux + 1 + else if ( decfac(-iface).eq.4 ) then + kaux = kaux + 1 + endif +c + endif +c + 411 continue +c +c les 6 faces de l'hexaedre seront coupees, donc RAS +c + if ( kaux.eq.6 ) then + goto 40 + endif +c + endif +c + 41 continue +c +c 4.2. ==> si on arrive ici, c'est qu'aucun des hexaedres voisins +c n'est a couper +c 2 cas se presentent : +c A. . si on est en mode non-conforme fidele a l'indicateur +c . ou si les aretes de chacun des hexaedres voisins ne +c sont pas decoupees plus d'une fois +c ==> ne pas couper le quadrangle courant, ni ses aretes +c B. . si on n'est pas en non-conforme fidele a l'indicateur +c . et si au moins une des aretes des hexaedres voisins +c a une de ses filles a couper +c ==> couper toutes les faces et toutes les aretes du ou des +c hexaedres voisins dont une face aura une fille coupee +c +c Remarque : le cas A apparait dans le cas d'une contamination +c par la regle des 2 voisins +c le cas B apparait dans le cas d'une contamination +c par la regle des ecarts de niveau +c +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,*) ' ' + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,4), + > laface,decfac(-laface),mod( hetqua(laface) , 100 ) + endif +#endif +c + kaux = 0 + if ( tyconf.lt.3 ) then +c + do 42 , iaux = 1 , 2 +c + lehexa = volqua(iaux,laface) +c + if ( lehexa.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,*)'.. hexaedre voisin : ', lehexa + endif +#endif +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + do 421 , jaux = 1 , 12 +c + larete = listar(jaux) +c + etatar = mod( hetare(larete) , 10 ) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,9))'.... '//mess14(langue,1,1), + > larete,decare(larete),etatar + endif +#endif + if ( etatar.eq.2 ) then + if ( decare(filare(larete)) .eq.2 .or. + > decare(filare(larete)+1).eq.2 ) then + kaux = 1 + goto 43 + endif + endif +c + 421 continue +c + endif +c + 42 continue +c + endif +c +c 4.3. ==> modification des decisions +c + 43 continue +c +c 4.3.1. ==> Cas A : ne pas couper le quadrangle courant, ni ses aretes +c + if ( kaux.eq.0 ) then +c + nbfapb = nbfapb + 1 + decfac(-laface) = 0 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30))'decfac',laface,decfac(-laface),' ' + endif +#endif + do 431 , larelo = 1 , 4 + larete = arequa(laface,larelo) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,9))'. . '//mess14(langue,1,1), + > larete,decare(larete),mod( hetare(larete) , 10 ) + endif +#endif + if ( decare(larete).eq.2 ) then + nbarpb = nbarpb + 1 + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30))'decare', larete,decare(larete),' ' + endif +#endif + endif +c + 431 continue +c +c 4.3.2. ==> Cas B : couper toutes les faces et toutes les aretes du ou +c des hexaedres voisins +c + else +c + do 432 , iaux = 1 , 2 +c + lehexa = volqua(iaux,laface) +c + if ( lehexa.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,*)'.. hexaedre voisin : ', lehexa + endif +#endif + do 4321 , jaux = 1 , 6 +c + iface = quahex(lehexa,jaux) + etatfa = mod( hetqua(iface) , 100 ) + if ( etatfa.ne.0 .and. decfac(-iface).eq.-1 ) then + nbfapb = nbfapb + 1 + decfac(-iface) = 0 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30))'decfac',iface,decfac(-iface),' ' + endif +#endif + else if ( etatfa.eq.0 .and. decfac(-iface).eq.0 ) then + nbfapb = nbfapb + 1 + decfac(-iface) = 4 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30))'decfac',iface,decfac(-iface),' ' + endif +#endif + endif +c + 4321 continue +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + do 4322 , jaux = 1 , 12 +c + larete = listar(jaux) + etatar = mod( hetare(larete) , 10 ) + if ( etatar.eq.2 .and. decare(larete).eq.-1 ) then + nbarpb = nbarpb + 1 + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30)) 'decare',larete,decare(larete) + endif +#endif + elseif ( etatar.eq.0 .and. decare(larete).eq.0 ) then + nbarpb = nbarpb + 1 + decare(larete) = 2 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,30)) 'decare',larete,decare(larete) + endif +#endif + endif +c + 4322 continue +c + endif +c + 432 continue + endif +c + endif +c + 40 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'hexa/quad' + if ( nbarpb.gt.0 .or. nbfapb.gt.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarpb + write (ulsort,texte(langue,5)) mess14(langue,3,8), nbfapb + else + write (ulsort,texte(langue,6)) + endif +#endif +c +c==== +c 5. Les suppressions de decoupage d'aretes peuvent etre nefastes +c pour les faces voisines. Il faut parcourir toutes les faces a +c couper et controler que toutes leurs aretes sont soit coupees, soit +c a couper. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 50 , laface = -nbquto, nbtrto +#ifdef _DEBUG_HOMARD_ + if ( laface.eq.-215996 .or. + > laface.eq.20633 ) then + glop=1 + else + glop=0 + endif + if ( glop.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,4), + > -laface,decfac(laface) + write (ulsort,*) ' volqua(*,laface) : ', + > volqua(1,-laface),volqua(2,-laface) + do 501 , larelo = 1 , 4 + larete = arequa(-laface,larelo) + write (ulsort,texte(langue,9))'.. '//mess14(langue,1,1), + > larete,decare(larete),hetare(larete) + 501 continue + endif +#endif +c + if ( decfac(laface).eq.4 ) then +c + if ( laface.lt.0 ) then +c + do 51 , larelo = 1 , 4 + larete = arequa(-laface,larelo) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 + nbarpb = nbarpb - 1 + endif + endif + 51 continue +c + else +c + do 52 , larelo = 1 , 3 + larete = aretri(laface,larelo) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 + nbarpb = nbarpb - 1 + endif + endif + 52 continue +c + endif +c + endif +c + 50 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'de coherence' + if ( nbarpb.gt.0 .or. nbfapb.gt.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarpb + write (ulsort,texte(langue,5)) mess14(langue,3,8), nbfapb + else + write (ulsort,texte(langue,6)) + endif +#endif +c +c==== +c 6. bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. bilan ; codret', codret +#endif +c + if ( nbarpb.gt.0 .or. nbfapb.gt.0 ) then +c + afaire = 1 + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbarpb + write (ulsort,texte(langue,5)) mess14(langue,3,8), nbfapb +c +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,6)) +#endif + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedco1.F b/src/tool/Decision/dedco1.F new file mode 100644 index 00000000..918e361f --- /dev/null +++ b/src/tool/Decision/dedco1.F @@ -0,0 +1,687 @@ + subroutine dedco1 ( tyconf, + > decare, decfac, + > posifa, facare, + > hetare, merare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : COntamination - option 1 +c -- - -- - +c cas sans homologues +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . merare . e . nbarto . mere des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDCO1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetare(nbarto), merare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nivdeb, nivfin, niveau + integer nbfali, laface, etatfa + integer facact, iarelo, iarete, etatar + integer nbaret, nbar00, anodec(4) + integer iaux, ideb, ifin + integer ipos, iface, ifacli, merear, jarelo + integer jarete + integer nbare1, liare1(4), nbare2, liare2(4) +#ifdef _DEBUG_HOMARD_ + integer jaux + integer option +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,90003) 'Entree de ',nompro + do 1106 , iaux = 1 , nbtrto, -1 + write (ulsort,90015) 'triangle', iaux, ' decision,niveau,etat', + > decfac(iaux), nivtri(iaux), hettri(iaux) + write (ulsort,90002) 'aretes', aretri(iaux,1), + > aretri(iaux,2), aretri(iaux,3) + write (ulsort,90002) 'decare', decare(aretri(iaux,1)), + > decare(aretri(iaux,2)), decare(aretri(iaux,3)) + 1106 continue + jaux=0 + do 1105 , iaux = 1 , nbquto + if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then + write (ulsort,90015) 'quadrangle', iaux, ' decision,niveau,etat', + > decfac(-iaux), nivqua(iaux), hetqua(iaux) + write (ulsort,90002) 'aretes', + > arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'decare', + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + jaux=jaux+1 + if ( jaux.eq.10) then + goto 1115 + endif + endif + 1105 continue + 1115 continue + do 1104 , iaux = 1 , nbarto, -1 + write (ulsort,90001) 'decision arete', iaux, decare(iaux) + 1104 continue +c + do 1108 , iaux = 1 , min(2,nbquto), -1 + write (ulsort,90001) 'decfac pour quadrangle ', iaux, + >decfac(-iaux) + write (ulsort,90001) 'aretes du quadrangle ', iaux, + >arequa(iaux,1), arequa(iaux,2), + >arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + 1108 continue +#endif +c +c==== +c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 2', codret +#endif +c initialisation vide de la liste de faces a examiner +c + nbfali = 0 +c +c initialisation du nombre d'aretes decoupees possibles +c pour un quadrangle dans le cas de l'adaptation conforme + if ( tyconf.ge.0 ) then + nbar00 = -2 + else + nbar00 = 2 + endif +c + nivdeb = nivsup - 1 + nivfin = max(nivinf-1,0) + do 100 , niveau = nivdeb , nivfin , -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c +c 2.1. ==> traitement des faces pour la regle des deux voisins +c =================================================== +c elle s'applique aux cas d'adaptation : +c tyconf = 0 ; conforme +c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees +c tyconf = -1 ; conforme avec boites +c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee +c + if ( tyconf.le.1 ) then +c + do 21 , laface = -nbquto , nbtrto +c +c on regarde les faces meres d'actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c +#ifdef _DEBUG_HOMARD_ + if ( etatfa.gt.0 ) then + if ( laface.gt.0 ) then + option = 2 + iaux=nivtri(laface) + else + option = 4 + iaux=nivqua(-laface) + endif + if ( ( laface.ge.-144699 .and. laface.le.-144690 ) .or. + > ( laface.eq.-164226 ) ) then + write (ulsort,texte(langue,29)) mess14(langue,1,option), + > abs(laface), iaux,etatfa, decfac(laface) + endif + endif +#endif +c + if ( etatfa.ge.4 .and. etatfa.le.8 ) then +c + facact = laface +c +c -------- + 200 continue +c -------- +c debut du traitement de la face courante +c *************************************** +c +c on ne regarde que les faces "a reactiver" +c + if ( decfac(facact).eq.-1 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( facact.gt.0 ) then + option = 2 + iaux=nivtri(facact) + ipos=hettri(facact) + else + option = 4 + iaux=nivqua(-facact) + ipos=hetqua(-facact) + endif + if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or. + > ( facact.eq.-164226 ) ) then + write (ulsort,texte(langue,29)) + >'. '//mess14(langue,1,option),abs(facact),iaux,ipos,decfac(facact) + endif +#endif +c +c 2.1.1. ==> on compte les aretes inactives a garder +c + if ( facact.gt.0 ) then + nbare1 = 3 + do 2111 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(facact,iarelo) + 2111 continue + else + nbare1 = 4 + iaux = -facact + do 2112 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 2112 continue + endif +#ifdef _DEBUG_HOMARD_ + if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or. + > ( facact.eq.-164226 ) ) then + write (ulsort,90002) 'nbare1', nbare1 + write (ulsort,90002) 'liare1', liare1 + endif +#endif +c +c nbaret = nombre d'aretes coupees en deux et a garder +c nbare2 = nombre d'aretes a reactiver +c + nbaret = 0 + nbare2 = 0 + do 2113 , iarelo = 1 , nbare1 + iarete = liare1(iarelo) +#ifdef _DEBUG_HOMARD_ + if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or. + > ( facact.eq.-164226 ) ) then + write (ulsort,90001) '. decision arete', iarete,decare(iarete) + write (ulsort,90001) '. etat arete', iarete,hetare(iarete) + endif +#endif + if ( decare(iarete).eq.0 ) then + etatar = mod( hetare(iarete) , 10 ) + if ( etatar.eq.2 .or. etatar.eq.9 ) then + nbaret = nbaret + 1 + endif + else + nbare2 = nbare2 + 1 + anodec(nbare2) = iarete + liare2(nbare2) = iarelo + endif + 2113 continue +#ifdef _DEBUG_HOMARD_ + if ( ( facact.ge.-144699 .and. facact.le.-144690 ) .or. + > ( facact.eq.-164226 ) ) then + write (ulsort,texte(langue,22)) nbaret, nbare2 + endif +#endif +c + if ( nbaret.eq.nbare1 ) then +c +c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder +c -------------------------------------------------- +c on declare la face "a garder" +c + decfac(facact) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif +c + elseif ( nbaret.eq.(nbare1-1) ) then +c +c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder +c ----------------------------------------------------------- +c on declare la face et la derniere arete "a garder" +c + decfac(facact) = 0 + decare(anodec(1)) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( anodec(1).eq.156780 ) then + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' + write (ulsort,texte(langue,30))'decare', + >anodec(1),decare(anodec(1)),' (arete encore a reactiver)' + endif +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives +c "a reactiver" +c + ideb = posifa(anodec(1)-1)+1 + ifin = posifa(anodec(1)) + do 2131 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2132 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2133 + endif + 2132 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2133 continue + endif + endif + 2131 continue +c + elseif ( facact.lt.0 ) then +c + if ( nbaret.eq.nbar00 ) then +c +c 2.1.4. ==> pour un quadrangle, deux aretes sont +c ------------------------------------ +c des actives a garder si on veut des boites +c ------------------------------------------ +c on declare la face et les 2 dernieres aretes "a garder" +c + decfac(facact) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif +c + do 214 , iaux = 1 , 2 +c + decare(anodec(iaux)) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( anodec(iaux).eq.156780 ) then + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' + write (ulsort,texte(langue,30))'decare', + >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)' + endif +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives +c "a reactiver" +c + ideb = posifa(anodec(iaux)-1)+1 + ifin = posifa(anodec(iaux)) + do 2141 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2142 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2143 + endif + 2142 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2143 continue + endif + endif + 2141 continue +c + 214 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c 2.1.n. ==> toutes les aretes sont a reactiver : OK +c + elseif ( nbare2.eq.nbare1 ) then +c + write (ulsort,texte(langue,15)) +#endif +c + endif +c + endif +c + if ( nbfali.gt.0 ) then +c +c on passe a la face suivante de la liste +c --------------------------------------- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,21)) nbfali + write (ulsort,*) (listfa(iaux),iaux=1,nbfali) +#endif +c + facact = listfa(nbfali) + nbfali = nbfali - 1 + goto 200 +c + endif +c + endif +c + 21 continue +c + endif +c +c 2.2. ==> regle des ecarts de niveau +c ========================== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,13)) niveau, niveau-1 +#endif +c + do 22 , laface = -nbquto , nbtrto +c +c on passe en revue les faces : +c . du niveau courant +c . actives +c + etatfa = -1 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif +c + endif +c + if ( etatfa.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( laface.gt.0 ) then + option = 2 + elseif ( laface.lt.0 ) then + option = 4 + endif + write (ulsort,texte(langue,29)) mess14(langue,1,option), + > abs(laface), niveau,etatfa, decfac(laface) +#endif +c +c 2.2.1. ==> liste des aretes ayant une mere +c + if ( laface.gt.0 ) then + nbare2 = 3 + do 2211 , iarelo = 1 , nbare2 + liare2(iarelo) = aretri(laface,iarelo) + 2211 continue + else + nbare2 = 4 + iaux = -laface + do 2212 , iarelo = 1 , nbare2 + liare2(iarelo) = arequa(iaux,iarelo) + 2212 continue + endif +c + nbare1 = 0 + do 2213 , iaux = 1 , nbare2 + if ( merare(liare2(iaux)).gt.0 ) then + nbare1 = nbare1 + 1 + liare1(nbare1) = liare2(iaux) + endif + 2213 continue +c +c 2.2.2. ==> on parcourt les aretes retenues +c + do 222 , iarelo = 1 , nbare1 +c + iarete = liare1(iarelo) + merear = merare(iarete) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,23)) iarete, decare(iarete), merear +#endif +c +c on regarde toutes les faces actives qui s'appuient +c sur cette arete, et on marque comme etant "a garder" +c celles qui sont "a reactiver" +c + ideb = posifa(merear - 1) + 1 + ifin = posifa(merear) + do 2221 , ipos = ideb , ifin +c + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then +c + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + decfac(iface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decfac', + > iface, decfac(iface), ' (face voisine)' +#endif + if ( iface.gt.0 ) then + do 2222 , jarelo = 1 , 3 + jarete = aretri(iface,jarelo) + if ( decare(jarete).eq.-1 ) then + decare(jarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete) +#endif + endif + 2222 continue + else + iaux = -iface + do 2223 , jarelo = 1 , 4 + jarete = arequa(iaux,jarelo) + if ( decare(jarete).eq.-1 ) then + decare(jarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decare',jarete, decare(jarete) +#endif + endif + 2223 continue + endif +c + endif +c + endif +c + 2221 continue +c + 222 continue +c + endif +c + 22 continue +c + 100 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,90003) 'Sortie de ',nompro + do 9906 , iaux = 1 , nbtrto, -1 + write (ulsort,90001) 'decision triangle', iaux, decfac(iaux) + 9906 continue + jaux=0 + do 9905 , iaux = 1 , nbquto + if ( nivqua(iaux).eq.3 .and. decfac(-iaux).lt.0) then + write (ulsort,90001) 'decision quadrangle', iaux, decfac(-iaux) + write (ulsort,90002) 'aretes', + > arequa(iaux,1), arequa(iaux,2), arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'decare', + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + jaux=jaux+1 + if ( jaux.eq.10) then + goto 9995 + endif + endif + 9905 continue + 9995 continue + do 9904 , iaux = 1 , nbarto, -1 + write (ulsort,90001) 'decision arete', iaux,decare(iaux) + 9904 continue +c + do 9908 , iaux = 1 , min(2,nbquto), -1 + write (ulsort,90001) 'decfac pour quadrangle ', iaux, + >decfac(-iaux) + write (ulsort,90001) 'aretes du quadrangle ', iaux, + >arequa(iaux,1), arequa(iaux,2), + >arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + 9908 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedco2.F b/src/tool/Decision/dedco2.F new file mode 100644 index 00000000..ac6e429a --- /dev/null +++ b/src/tool/Decision/dedco2.F @@ -0,0 +1,704 @@ + subroutine dedco2 ( tyconf, + > decare, decfac, + > posifa, facare, + > hetare, merare, arehom, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : COntamination - option 2 +c -- - -- - +c prise en compte des homologues +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . merare . e . nbarto . mere des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDCO2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#ifdef _DEBUG_HOMARD_ +#include "impr02.h" +#endif +c +c 0.3. ==> arguments +c + integer tyconf + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetare(nbarto), merare(nbarto), arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nivdeb, nivfin, niveau + integer nbfali, laface, etatfa + integer facact, iarelo, iarete, etatar + integer nbaret, nbar00, anodec(4) + integer iaux, ideb, ifin + integer jaux, jfin + integer ipos, iface, ifacli, merear, jarelo + integer jarete + integer kaux + integer nbare1, liare1(4), nbare2, liare2(4), liare3(2) +#ifdef _DEBUG_HOMARD_ + integer option +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,*) 'en entree de ',nompro +cgn write (ulsort,*) 'quadrangle 5, de niveau ',nivqua(5) +cgn write (ulsort,*) 'decfac(q5) =',decfac(-5) +cgn write (ulsort,*) arequa(5,1),arequa(5,2), +cgn >arequa(5,3),arequa(5,4) +cgn write (ulsort,*) decare(arequa(5,1)),decare(arequa(5,2)), +cgn >decare(arequa(5,3)),decare(arequa(5,4)) +cgn write (ulsort,*) hetare(arequa(5,1)),hetare(arequa(5,2)), +cgn >hetare(arequa(5,3)),hetare(arequa(5,4)) +cgn write (ulsort,*) ' ' +#endif +c +c==== +c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 3', codret +#endif +c initialisation vide de la liste de faces a examiner +c + nbfali = 0 +c +c initialisation du nombre d'aretes decoupees possibles +c pour un quadrangle dans le cas de l'adaptation conforme + if ( tyconf.ge.0 ) then + nbar00 = -2 + else + nbar00 = 2 + endif +c + nivdeb = nivsup - 1 + nivfin = max(nivinf-1,0) + do 100 , niveau = nivdeb , nivfin , -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +cgn write (ulsort,texte(langue,12)) niveau +cgn write (ulsort,*) 'quadrangle 5, de niveau ',nivqua(5) +cgn write (ulsort,*) 'decfac(q5) =',decfac(-5) +cgn write (ulsort,*) arequa(5,1),arequa(5,2), +cgn >arequa(5,3),arequa(5,4) +cgn write (ulsort,*) decare(arequa(5,1)),decare(arequa(5,2)), +cgn >decare(arequa(5,3)),decare(arequa(5,4)) +cgn write (ulsort,*) hetare(arequa(5,1)),hetare(arequa(5,2)), +cgn >hetare(arequa(5,3)),hetare(arequa(5,4)) +cgn write (ulsort,*) ' ' +cgn write (ulsort,*) ' ' +#endif +c +c 2.1. ==> traitement des faces pour la regle des deux voisins +c =================================================== +c + do 21 , laface = -nbquto , nbtrto +c +c on regarde les faces meres d'actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c +#ifdef _DEBUG_HOMARD_ + if ( etatfa.gt.0 ) then + if ( laface.gt.0 ) then + option = 2 + iaux=nivtri(laface) + else + option = 4 + iaux=nivqua(-laface) + endif + write (ulsort,texte(langue,29)) mess14(langue,1,option), + > abs(laface), iaux,etatfa, decfac(laface) + endif +#endif +c + if ( etatfa.ge.4 .and. etatfa.le.8 ) then +c + facact = laface +c +c -------- + 200 continue +c -------- debut du traitement de la face courante +c *************************************** +c +c on ne regarde que les faces "a reactiver" +c + if ( decfac(facact).eq.-1 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( facact.gt.0 ) then + option = 2 + iaux=nivtri(facact) + else + option = 4 + iaux=nivqua(-facact) + endif + write (ulsort,texte(langue,29)) + >'. '//mess14(langue,1,option),abs(facact), + > iaux,-99999, decfac(facact) +#endif +c +c 2.1.1. ==> on compte les aretes inactives a garder +c + if ( facact.gt.0 ) then + nbare1 = 3 + do 2111 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(facact,iarelo) + 2111 continue + else + nbare1 = 4 + iaux = -facact + do 2112 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 2112 continue + endif +c +c nbaret = nombre d'aretes coupees en deux et a garder +c nbare2 = nombre d'aretes a reactiver +c + nbaret = 0 + nbare2 = 0 + do 2113 , iarelo = 1 , nbare1 + iarete = liare1(iarelo) +cgn write (ulsort,*) '... arete ',iarelo,' : ',iarete + if ( decare(iarete).eq.0 ) then + etatar = mod( hetare(iarete) , 10 ) + if ( etatar.eq.2 ) then + nbaret = nbaret + 1 + endif + else + nbare2 = nbare2 + 1 + anodec(nbare2) = iarete + liare2(nbare2) = iarelo + endif + 2113 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,22)) nbaret, nbare2 +#endif +c + if ( nbaret.eq.nbare1 ) then +c +c 2.1.2. ==> toutes les aretes sont coupees en deux et a garder +c -------------------------------------------------- +c on declare la face "a garder" +c + decfac(facact) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif +c + elseif ( nbaret.eq.(nbare1-1) ) then +c +c 2.1.3. ==> toutes les aretes sauf une sont coupees en deux et a garder +c ----------------------------------------------------------- +c on declare la face et la derniere arete "a garder" +c + decfac(facact) = 0 + decare(anodec(1)) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' + write (ulsort,texte(langue,30))'decare', + >anodec(1),decare(anodec(1)),' (arete encore a reactiver)' +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives +c "a reactiver" +c + ideb = posifa(anodec(1)-1)+1 + ifin = posifa(anodec(1)) + do 2131 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2132 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2133 + endif + 2132 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2133 continue + endif + endif + 2131 continue +c +c on regarde si l'arete a une homologue +c --------- +c + if ( arehom(anodec(1)).ne.0 ) then +c + kaux = abs( arehom(anodec(1)) ) +c +c l'arete homologue est declaree "a garder" +c + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', + >kaux,decare(kaux),' (homologue)' +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives "a +c reactiver" +c + ideb = posifa(kaux-1) + 1 + ifin = posifa(kaux) +c + do 2134, ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2135 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2136 + endif + 2135 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2136 continue + endif + endif + 2134 continue +c + endif +c + elseif ( facact.lt.0 ) then +c + if ( nbaret.eq.nbar00 ) then +c +c 2.1.4. ==> pour un quadrangle, deux aretes sont +c ------------------------------------ +c des actives a garder si on veut des boites +c ------------------------------------------ +c on declare la face et les 2 dernieres aretes "a garder" +c + decfac(facact) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif +c + do 214 , iaux = 1 , 2 +c + decare(anodec(iaux)) = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', + >anodec(iaux),decare(anodec(iaux)),' (arete encore a reactiver)' +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives +c "a reactiver" +c + ideb = posifa(anodec(iaux)-1)+1 + ifin = posifa(anodec(iaux)) + do 2141 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2142 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2143 + endif + 2142 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2143 continue + endif + endif + 2141 continue +c +c on regarde si l'arete a une homologue +c --------- +c + if ( arehom(anodec(iaux)).ne.0 ) then +c + kaux = abs( arehom(anodec(iaux)) ) +c +c l'arete homologue est declaree "a garder" +c + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', + >kaux,decare(kaux),' (homologue)' +#endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont non actives "a +c reactiver" +c + ideb = posifa(kaux-1) + 1 + ifin = posifa(kaux) +c + do 2144, ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.ge.4 .and. etatfa.le.8 ) then + do 2145 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2146 + endif + 2145 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2146 continue + endif + endif + 2144 continue +c + endif +c + 214 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c 2.1.n. ==> toutes les aretes sont a reactiver : OK +c + elseif ( nbare2.eq.nbare1 ) then +c + write (ulsort,texte(langue,15)) +#endif +c + endif +c + endif +c + if ( nbfali.gt.0 ) then +c +c on passe a la face suivante de la liste +c --------------------------------------- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,21)) nbfali + write (ulsort,*) (listfa(iaux),iaux=1,nbfali) +#endif +c + facact = listfa(nbfali) + nbfali = nbfali - 1 + goto 200 +c + endif +c + endif +c + 21 continue +c +c 2.2. ==> regle des ecarts de niveau +c ========================== +c + do 22 , laface = -nbquto , nbtrto +c +c on passe en revue les faces : +c . du niveau courant +c . actives +c + etatfa = -1 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif +c + endif +c + if ( etatfa.eq.0 ) then +c +c 2.2.1. ==> liste des aretes ayant une mere +c + if ( laface.gt.0 ) then + nbare2 = 3 + do 2211 , iarelo = 1 , nbare2 + liare2(iarelo) = aretri(laface,iarelo) + 2211 continue + else + nbare2 = 4 + iaux = -laface + do 2212 , iarelo = 1 , nbare2 + liare2(iarelo) = arequa(iaux,iarelo) + 2212 continue + endif +c + nbare1 = 0 + do 2213 , iaux = 1 , nbare2 + if ( merare(liare2(iaux)).gt.0 ) then + nbare1 = nbare1 + 1 + liare1(nbare1) = liare2(iaux) + endif + 2213 continue +c +c 2.2.2. ==> on parcourt les aretes retenues +c + do 222 , iarelo = 1 , nbare1 +c + iarete = liare1(iarelo) + merear = merare(iarete) +c +c on explore les faces qui s'enroulent autour de +c l'arete merear et celles qui s'enroulent autour +c de son eventuelle homologue +c + liare3(1) = merear + if ( arehom(merear).eq.0 ) then + jfin = 1 + else + liare3(2) = abs(arehom(merear)) + jfin = 2 + endif +c + do 2220 , jaux = 1 , jfin +c +c on marque comme etant "a garder" +c celles qui sont "a reactiver" +c + ideb = posifa(liare3(jaux)-1)+1 + ifin = posifa(liare3(jaux)) + do 2221 , ipos = ideb , ifin +c + iface = facare(ipos) + if ( decfac(iface).eq.-1 ) then +c + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + decfac(iface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decfac', + > iface, decfac(iface), ' (face voisine)' +#endif + if ( iface.gt.0 ) then + nbare2 = 3 + do 2222 , jarelo = 1 , nbare2 + liare2(jarelo) = aretri(iface,jarelo) + 2222 continue + else + nbare2 = 4 + iaux = -iface + do 2223 , jarelo = 1 , nbare2 + liare2(jarelo) = arequa(iaux,jarelo) + 2223 continue + endif + do 2224 , jarelo = 1 , nbare2 + jarete = liare2(jarelo) + if ( decare(jarete).eq.-1 ) then + decare(jarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', + >jarete,decare(jarete),' ' +#endif + if ( arehom(jarete).lt.0 ) then + if ( decare(abs(arehom(jarete))).eq.-1 )then + decare(abs(arehom(jarete))) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare', + >abs(arehom(jarete)),decare(abs(arehom(jarete))),' (homologue)' +#endif + endif + endif + endif + 2224 continue + endif +c + endif +c + 2221 continue +c + 2220 continue +c + 222 continue +c + endif +c + 22 continue +c + 100 continue +c +#ifdef _DEBUG_HOMARD_ +c==== +c 3. verification +c==== +c + if ( codret.eq.0 ) then +c + call dehova ( arehom, decare, + > nompro, 1, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedcon.F b/src/tool/Decision/dedcon.F new file mode 100644 index 00000000..e2ccb9cc --- /dev/null +++ b/src/tool/Decision/dedcon.F @@ -0,0 +1,289 @@ + subroutine dedcon ( tyconf, homolo, + > decare, decfac, + > posifa, facare, + > hetare, merare, arehom, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : CONtamination +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . homolo . e . 1 . presence d'homologue . +c . . . . 0 : non . +c . . . . 1 : il existe des noeuds homologues . +c . . . . 2 : il existe des aretes homologues . +c . . . . 3 : il existe des faces homologues . +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . merare . e . nbarto . mere des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDCON' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer tyconf, homolo + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetare(nbarto), merare(nbarto), arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "derco1.h" +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ +cgn do 1105 , iaux = 1 , nbquto +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) +cgn 1105 continue +#endif +c +#ifdef _DEBUG_HOMARD_ + do 1103 , iaux = 1 , nbarto + if ( iaux.eq.2183 .or. iaux.eq.14556 + > .or. iaux.eq.1658 .or. iaux.eq.1661 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 1103 continue +#endif +#ifdef _DEBUG_HOMARD_ + do 1104 , iaux = 1 , nbtrto + if ( iaux.eq.-830 .or. iaux.eq.-800) then + write (ulsort,90001) '.triangle', iaux, + > aretri(iaux,1), aretri(iaux,2), + > aretri(iaux,3) + write (ulsort,90002) 'niveau et decision', + > nivtri(iaux), decfac(iaux) + do 11041 ,jaux=1,3 + write (ulsort,90001) 'arete e/d', aretri(iaux,jaux), + > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux)) +11041 continue + endif + 1104 continue + do 1105 , iaux = 1 , nbquto + if ( iaux.eq.-2311 ) then +cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or. +cgn > iaux.eq.333 .or. iaux.eq.1662.or. +cgn > iaux.eq.1658 .or. iaux.eq.1666 .or. +cgn > iaux.eq.729 .or. iaux.eq.721 ) then + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'niveau et decision', + > nivqua(iaux), decfac(-iaux) + do 11051 ,jaux=1,4 + write (ulsort,90001) 'arete e/d', arequa(iaux,jaux), + > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux)) +11051 continue + endif + 1105 continue +#endif +c +c==== +c 2. contamination des decisions pour le deraffinement +c==== +c +c 2.1. ==> cas sans entites homologues, sauf eventuellement des noeuds +c + if ( homolo.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDCO1', nompro +#endif + call dedco1 ( tyconf, + > decare, decfac, + > posifa, facare, + > hetare, merare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c + else +c +c 2.2. ==> cas avec homologue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDCO2', nompro +#endif + call dedco2 ( tyconf, + > decare, decfac, + > posifa, facare, + > hetare, merare, arehom, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + do 2103 , iaux = 1 , nbarto + if ( iaux.eq.2183 .or. iaux.eq.14556 + > .or. iaux.eq.1658 .or. iaux.eq.1661 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 2103 continue + do 2104 , iaux = 1 , nbtrto + if ( iaux.eq.-830 .or. iaux.eq.-833 .or. iaux.eq.-800) then + write (ulsort,90001) '.triangle', iaux, + > aretri(iaux,1), aretri(iaux,2), + > aretri(iaux,3) + write (ulsort,90002) '.. niveau et decision', + > nivtri(iaux), decfac(iaux) + do 21041 ,jaux=1,3 + write (ulsort,90001) '.. arete e/d', aretri(iaux,jaux), + > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux)) +21041 continue + endif + 2104 continue + do 2105 , iaux = 1 , nbquto + if ( iaux.eq.-2311 ) then +cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or. +cgn > iaux.eq.333 .or. iaux.eq.1662 .or. +cgn > iaux.eq.1658 .or. iaux.eq.1666 .or. +cgn > iaux.eq.729 .or. iaux.eq.721 ) then + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'de decision', decfac(-iaux) + do 21051 ,jaux=1,4 + write (ulsort,90001) 'arete e/d', arequa(iaux,jaux), + > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux)) +21051 continue + endif + 2105 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedera.F b/src/tool/Decision/dedera.F new file mode 100644 index 00000000..36d86ef8 --- /dev/null +++ b/src/tool/Decision/dedera.F @@ -0,0 +1,423 @@ + subroutine dedera ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - DERAffinement +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDERA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + integer phetar, psomar, pfilar, pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer phette, ptrite + integer phethe, pquahe, pcoquh + integer phetpy, pfacpy, pcofay + integer phetpe, pfacpe, pcofap + integer pposif, pfacar + integer advotr, advoqu, adpptr, adppqu + integer pdecfa, pdecar + integer adhoar, adhotr, adhoqu + integer ptrav3 +c + character*6 saux + character*8 ntrav3 +c + logical prem +c +#ifdef _DEBUG_HOMARD_ + character*6 nompra +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + if ( prem ) then + nrosec = taetco(4) + endif + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = '(/,a6,'' DECISIONS POUR LE DERAFFINEMENT'')' + texte(1,5) = '(38(''=''),/)' +c + texte(2,4) = '(/,a6,'' UNREFINEMENT DECISIONS'')' + texte(2,5) = '(29(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEARD0', nompro +#endif + call deard0 ( nomail, taopts(11), taopts(12), ntrav3, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, + > phethe, pquahe, pcoquh, + > phetpy, pfacpy, pcofay, + > phetpe, pfacpe, pcofap, + > pposif, pfacar, + > advotr, advoqu, adpptr, adppqu, + > pdecfa, pdecar, + > adhoar, adhotr, adhoqu, + > ptrav3, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. mise en coherence des decisions pour le deraffinement +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. coherence ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,3)) 'DELIST avant dedini', nompro +c + nompra = 'dedini' + iaux = 1 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDINI', nompro +#endif + call dedini + > ( homolo, + > imem(pdecar), imem(pdecfa), + > imem(pposif), imem(pfacar), + > imem(adhoar), + > imem(phettr), imem(paretr), imem(pfiltr), imem(pnivtr), + > imem(phetqu), imem(parequ), imem(pfilqu), imem(pnivqu), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST apres dedini', nompro + nompra = 'dedini' + iaux = 2 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 4. contamination du deraffinement +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '4. contamination ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST avant dedcon', nompro + nompra = 'dedcon' + iaux = 1 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDCON', nompro +#endif + call dedcon + > ( taopti(30), homolo, + > imem(pdecar), imem(pdecfa), + > imem(pposif), imem(pfacar), + > imem(phetar), imem(pmerar), imem(adhoar), + > imem(phettr), imem(paretr), imem(pnivtr), + > imem(phetqu), imem(parequ), imem(pnivqu), + > imem(ptrav3), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST apres dedcon', nompro + nompra = 'dedcon' + iaux = 2 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 5. decompte des decisions +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5. decompte des decisions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPTE', nompro +#endif + call decpte ( taopti(31), taopti(32), + > imem(pdecar), imem(pdecfa), + > imem(phettr), imem(phetqu), + > imem(ptrite), imem(phette), + > imem(pquahe), imem(phethe), + > imem(pfacpy), imem(phetpy), + > imem(pfacpe), imem(phetpe), + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. desallocations des tableaux de travail +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '6. desallocations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav3 , codret ) +c + endif +c +c==== +c 7. verification des decisions s'il existe des homologues +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '7. verification homologue ; codret', codret +#endif +c +c 7.1. ==> sur les aretes +c + if ( homolo.ge.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVA', nompro +#endif + call dehova ( imem(adhoar), imem(pdecar), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 7.2. ==> sur les triangles +c + if ( homolo.ge.3 .and. nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 2 + call dehovf ( iaux, + > nbtrto, imem(adhotr), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 7.3. ==> sur les quadrangles +c + if ( homolo.ge.3 .and. nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 4 + call dehovf ( iaux, + > nbquto, imem(adhoqu), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c +c 8.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 8.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + prem = .false. +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/dedin1.F b/src/tool/Decision/dedin1.F new file mode 100644 index 00000000..17eb0bf2 --- /dev/null +++ b/src/tool/Decision/dedin1.F @@ -0,0 +1,351 @@ + subroutine dedin1 ( decare, decfac, + > posifa, facare, + > hettri, aretri, filtri, nivtri, + > hetqua, arequa, filqua, nivqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : Initialisation - option 1 +c -- - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDIN1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), nivqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, larete, niveau, numfac, etatfa, nuarvo, nufavo + integer iaux, ideb, ifin, jdeb, jfin, facvoi, iarelo + integer nivdeb, nivfin + integer nbare1, liare1(4), nbare2, liare2(4) + integer kaux, option, ipos +c + logical afaire +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. on regarde tous les niveaux dans l'ordre croissant +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 2', codret +#endif +c + nivdeb = max(nivinf-1,0) + nivfin = nivsup - 1 + do 100 , niveau = nivdeb , nivfin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) niveau +#endif +c +c boucle sur toutes les faces marquee "a reactiver" +c dans le niveau courant +c + do 2 , laface = -nbquto , nbtrto +c + if ( decfac(laface).eq.-1 ) then +c +c on regarde toutes les faces meres d'actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c + if ( etatfa.ge.4 .and. etatfa.le.8 ) then +c +c 2.1. ==> liste des aretes de la face "a reactiver" +c + if ( laface.gt.0 ) then + nbare1 = 3 + do 211 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(laface,iarelo) + 211 continue + else + nbare1 = 4 + iaux = -laface + do 212 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 212 continue + endif +c +c 2.2. ==> Pour un triangle, si le premier triangle fils (central) est +c marque "a couper" (on ne teste ici que le premier fils +c car les trois autres sont testes ensuite), le triangle pere +c est a garder, de meme que ses aretes +c + if ( laface.gt.0 ) then +c + numfac = filtri(laface) +c + if ( decfac(numfac).gt.0 ) then +c + decfac(laface) = 0 + do 221 , iarelo = 1 , nbare1 + larete = liare1(iarelo) + decare(larete) = max(0,decare(larete)) + 221 continue +c + endif +c + ideb = filtri(laface) + 1 + ifin = ideb + 2 +c + else +c + ideb = - filqua(-laface) - 3 + ifin = ideb + 3 +c + endif +c +c 2.3. ==> si l'une des faces filles sur le bord de la face est marquee +c "a couper", on empeche le deraffinement de la mere et +c des faces voisines de la face-mere +c + do 231 , numfac = ideb , ifin +c + if ( decfac(numfac).gt.0 ) then +c + decfac(laface) = 0 +c + do 232 , iarelo = 1 , nbare1 +c + larete = liare1(iarelo) + decare(larete) = max(0,decare(larete)) +c + jdeb = posifa(larete-1) + 1 + jfin = posifa(larete) +c + do 233 , nufavo = jdeb , jfin +c + facvoi = facare(nufavo) + decfac(facvoi) = 0 +c + if ( facvoi.gt.0 ) then + nbare2 = 3 + do 234 , nuarvo = 1 , nbare2 + liare2(nuarvo) = aretri(facvoi,nuarvo) + 234 continue + else + iaux = -facvoi + nbare2 = 4 + do 235 , nuarvo = 1 , nbare2 + liare2(nuarvo) = arequa(iaux,nuarvo) + 235 continue + endif +c + do 236 , nuarvo = 1 , nbare2 + decare(liare2(nuarvo)) = + > max(0,decare(liare2(nuarvo))) + 236 continue +c + 233 continue +c + 232 continue +c + endif +c + 231 continue +c + endif +c + endif +c + 2 continue +c + 100 continue +c +c==== +c 3. on bascule "a garder" toutes les aretes des faces meres +c non actives "a garder". cette etape est indispensable au +c fonctionnement correct de la regle des deux voisins. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 3', codret + write (ulsort,texte(langue,11)) +#endif +c + do 30 , laface = -nbquto , nbtrto +c + if ( decfac(laface).eq.0 ) then +c + afaire = .false. + if ( laface.gt.0 ) then + etatfa = mod( hettri(laface) , 10 ) + if ( etatfa.ge.4 .and. etatfa.le.9 ) then + afaire = .true. + endif + elseif ( laface.lt.0 ) then + iaux = -laface + etatfa = mod( hetqua(iaux) , 100 ) + if ( etatfa.eq.4 .or. etatfa.eq.99 ) then + afaire = .true. + endif + endif +c + if ( afaire ) then +#ifdef _DEBUG_HOMARD_ + if ( laface.gt.0 ) then + option = 2 + iaux=nivtri(laface) + ipos=hettri(laface) + else + option = 4 + iaux=nivqua(-laface) + ipos=hetqua(-laface) + endif + write (ulsort,texte(langue,29)) + >mess14(langue,1,option),abs(laface),iaux,ipos,decfac(laface) +#endif + if ( laface.gt.0 ) then + nbare1 = 3 + do 31 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(laface,iarelo) + 31 continue + else + nbare1 = 4 + iaux = -laface + do 32 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 32 continue + endif + do 33 , iarelo = 1 , nbare1 + kaux = liare1(iarelo) + if ( decare(kaux).eq.-1 ) then + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decare', kaux, decare(kaux),' ' +#endif + endif + 33 continue + endif +c + endif +c + 30 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedin2.F b/src/tool/Decision/dedin2.F new file mode 100644 index 00000000..72c0ca7a --- /dev/null +++ b/src/tool/Decision/dedin2.F @@ -0,0 +1,369 @@ + subroutine dedin2 ( decare, decfac, + > posifa, facare, + > arehom, + > hettri, aretri, filtri, nivtri, + > hetqua, arequa, filqua, nivqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : Initialisation - option 2 +c -- - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDIN2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), nivqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, larete, niveau, numfac, etatfa, nuarvo, nufavo + integer iaux, ideb, ifin, jdeb, jfin, arevoi, facvoi, iarelo + integer nivdeb, nivfin + integer nbare1, liare1(4), nbare2, liare2(4) + integer kaux, option +c + logical afaire +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. on regarde tous les niveaux dans l'ordre croissant +c==== +c + nivdeb = max(nivinf-1,0) + nivfin = nivsup - 1 + do 100 , niveau = nivdeb , nivfin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) niveau +#endif +c +c boucle sur toutes les faces marquee "a reactiver" +c dans le niveau courant +c + do 2 , laface = -nbquto , nbtrto +c + if ( decfac(laface).eq.-1 ) then +c +c on regarde toutes les faces meres d'actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c + if ( etatfa.ge.4 .and. etatfa.le.8 ) then +c +c 2.1. ==> liste des aretes de la face "a reactiver" +c + if ( laface.gt.0 ) then + nbare1 = 3 + do 211 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(laface,iarelo) + 211 continue + else + nbare1 = 4 + iaux = -laface + do 212 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 212 continue + endif +c +c 2.2. ==> Pour un triangle, si le premier triangle fils (central) est +c marque "a couper" (on ne teste ici que le premier fils +c car les trois autres sont testes ensuite), le triangle pere +c est a garder, de meme que ses aretes +c + if ( laface.gt.0 ) then +c + numfac = filtri(laface) +c + if ( decfac(numfac).gt.0 ) then +c + decfac(laface) = max(0,decfac(laface)) + do 221 , iarelo = 1 , nbare1 + larete = liare1(iarelo) + decare(larete) = max(0,decare(larete)) + if ( arehom(larete).ne.0 ) then + decare(abs(arehom(larete))) = + > max(0,decare(abs(arehom(larete)))) + endif + 221 continue +c + endif +c + ideb = filtri(laface) + 1 + ifin = ideb + 2 +c + else +c + ideb = - filqua(-laface) - 3 + ifin = ideb + 3 +c + endif +c +c 2.3. ==> si l'une des faces filles sur le bord de la face est marquee +c "a couper", on empeche le deraffinement de la mere et +c des faces voisines de la face-mere +c + do 231 , numfac = ideb , ifin +c + if ( decfac(numfac).gt.0 ) then +c + decfac(laface) = 0 +c + do 232 , iarelo = 1 , nbare1 +c + larete = liare1(iarelo) + decare(larete) = max(0,decare(larete)) + if ( arehom(larete).ne.0 ) then + decare(abs(arehom(larete))) = + > max(0,decare(abs(arehom(larete)))) + endif +c + jdeb = posifa(larete-1) + 1 + jfin = posifa(larete) +c + do 233 , nufavo = jdeb , jfin +c + facvoi = facare(nufavo) + decfac(facvoi) = 0 +c + if ( facvoi.gt.0 ) then + nbare2 = 3 + do 234 , nuarvo = 1 , nbare2 + liare2(nuarvo) = aretri(facvoi,nuarvo) + 234 continue + else + iaux = -facvoi + nbare2 = 4 + do 235 , nuarvo = 1 , nbare2 + liare2(nuarvo) = arequa(iaux,nuarvo) + 235 continue + endif +c + do 236 , nuarvo = 1 , nbare2 + arevoi = liare2(nuarvo) + decare(arevoi) = max(0,decare(arevoi)) + if ( arehom(arevoi).ne.0 ) then + decare(abs(arehom(arevoi))) = + > max(0,decare(abs(arehom(arevoi)))) + endif + 236 continue +c + 233 continue +c + 232 continue +c + endif +c + 231 continue +c + endif +c + endif +c + 2 continue +c + 100 continue +c +c==== +c 3. on bascule "a garder" toutes les aretes des faces meres +c non actives "a garder". cette etape est indispensable au +c fonctionnement correct de la regle des deux voisins. +c Il faut le transmettre aux eventuelles aretes homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 3', codret +#endif +c + do 30 , laface = -nbquto , nbtrto +c + if ( decfac(laface).eq.0 ) then +c + afaire = .false. + if ( laface.gt.0 ) then + etatfa = mod( hettri(laface) , 10 ) + if ( etatfa.ge.4 .and. etatfa.le.9 ) then + afaire = .true. + endif + elseif ( laface.lt.0 ) then + iaux = -laface + etatfa = mod( hetqua(iaux) , 100 ) + if ( etatfa.eq.4 .or. etatfa.eq.99 ) then + afaire = .true. + endif + endif +c + if ( afaire ) then +#ifdef _DEBUG_HOMARD_ + if ( laface.gt.0 ) then + option = 2 + iaux=nivtri(laface) + else + option = 4 + iaux=nivqua(-laface) + endif + write (ulsort,texte(langue,29)) mess14(langue,1,option), + > abs(laface), iaux,etatfa, decfac(laface) +#endif + if ( laface.gt.0 ) then + nbare1 = 3 + do 31 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(laface,iarelo) + 31 continue + else + nbare1 = 4 + iaux = -laface + do 32 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 32 continue + endif + do 33 , iarelo = 1 , nbare1 + kaux = liare1(iarelo) + if ( decare(kaux).eq.-1 ) then + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decare', kaux, decare(kaux),' ' +#endif + endif + if ( arehom(kaux).ne.0 ) then + if ( decare(abs(arehom(kaux))).eq.-1 ) then + decare(abs(arehom(kaux))) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) 'decare', + > abs(arehom(kaux)), decare(abs(arehom(kaux))), '(homologue)' +#endif + endif + endif + 33 continue + endif +c + endif +c + 30 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dedini.F b/src/tool/Decision/dedini.F new file mode 100644 index 00000000..54fa02f2 --- /dev/null +++ b/src/tool/Decision/dedini.F @@ -0,0 +1,172 @@ + subroutine dedini ( homolo, + > decare, decfac, + > posifa, facare, + > arehom, + > hettri, aretri, filtri, nivtri, + > hetqua, arequa, filqua, nivqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Deraffinement : INItialisation +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . homolo . e . 1 . presence d'homologue . +c . . . . 0 : non . +c . . . . 1 : il existe des noeuds homologues . +c . . . . 2 : il existe des aretes homologues . +c . . . . 3 : il existe des faces homologues . +c . decare . e/s . nbarto . decisions des aretes . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEDINI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer homolo + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), nivqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. initialisation des decisions pour le deraffinement +c==== +c +c 2.1. ==> cas sans entites homologues, sauf eventuellement des noeuds +c + if ( homolo.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDIN1', nompro +#endif + call dedin1 ( decare, decfac, + > posifa, facare, + > hettri, aretri, filtri, nivtri, + > hetqua, arequa, filqua, nivqua, + > ulsort, langue, codret ) +c + else +c +c 2.2. ==> cas avec homologue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDIN2', nompro +#endif + call dedin2 ( decare, decfac, + > posifa, facare, + > arehom, + > hettri, aretri, filtri, nivtri, + > hetqua, arequa, filqua, nivqua, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deeli1.F b/src/tool/Decision/deeli1.F new file mode 100644 index 00000000..69e1d52c --- /dev/null +++ b/src/tool/Decision/deeli1.F @@ -0,0 +1,162 @@ + subroutine deeli1 ( insoar, decare, hetare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - ELements Ignores - 1 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . insoar . e . nbarma . information sur les sommets des aretes . +c . . . . 0 : ses deux sommets appartiennent . +c . . . . exclusivement a un element soumis a . +c . . . . l'adaptation . +c . . . . -1 : son 1er sommet appartient a un element. +c . . . . ignore . +c . . . . le 2nd sommet appartient exclusivement. +c . . . . a un element soumis a l'adaptation . +c . . . . -2 : son 2nd sommet appartient a un element. +c . . . . ignore . +c . . . . le 1er sommet appartient exclusivement. +c . . . . a un element soumis a l'adaptation +c . . . . 2 : ses deux sommets appartiennent a un . +c . . . . element ignore . +c . decare . e . nbarto . decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : il existe encore des non conformites . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEELI1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto) + integer hetare(nbarto) + integer insoar(nbarma) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer larete, etatar +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,9) = '(''Le raffinement atteint la zone interdite'')' + texte(1,10) = '(''Nombre d''''aretes touchees :'',i6)' +c + texte(2,9) ='(''Refinement reached the forbidden zone'')' + texte(2,10) ='(''Number of reached edges :'',i6)' +c +#include "impr03.h" +c +c==== +c 2. on explore toutes les aretes actives du macro-maillage : il ne +c sert a rien de controle des aretes filles car elles ne peuvent pas +c avoir ete creees ! +c on verifie qu'il n'y a pas de situation pour laquelle +c l'arete d'un element ignore a ete decoupee +c==== +c + codret = 0 +c + do 20 , larete = 1 , nbarma +c + etatar = mod( hetare(larete) , 10 ) +c + if ( etatar.eq.0 ) then +c + if ( decare(larete).eq.2 ) then +c + if ( insoar(larete).eq.2 ) then +c + codret = codret + 1 +c + endif +c + endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,9)) + write (ulsort,texte(langue,10)) codret + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deelig.F b/src/tool/Decision/deelig.F new file mode 100644 index 00000000..5f58dda9 --- /dev/null +++ b/src/tool/Decision/deelig.F @@ -0,0 +1,213 @@ + subroutine deelig ( nomail, + > lgopts, taopts, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - ELements IGnores +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : il existe encore des non conformites . +c . . . . 2 : probleme de memoire . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEELIG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopts + character*8 taopts(lgopts) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer phetar, pdecar + integer adars2, nbelig +c + integer codre0, codre1, codre2, codre3 +c + character*8 ntrav1 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Code retour de '',a6,'' ='',i4,/)' +c + texte(2,4) = '(''Error code from '',a6,'' ='',i4,/)' +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + call gmliat ( nhelig, 1, nbelig, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbelig', nbelig +#endif +c + if ( codret.eq.0 ) then +c + if ( nbelig.ne.0 ) then +c + call gmadoj ( nharet//'.HistEtat', phetar, iaux, codre1 ) + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre2 ) + call gmadoj ( nharet//'.InfoSup2', adars2, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3) +c + endif +c + endif +c +c==== +c 3. bilan des decisions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. bilan des decisions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbelig.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEELI1', nompro +#endif + call deeli1 + > ( imem(adars2), imem(pdecar),imem(phetar), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'DEELI1', codret +#endif +c + endif +c + else +c + codret = 2 +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +cgn print *,nompro,nbelig,codret +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dehist.F b/src/tool/Decision/dehist.F new file mode 100644 index 00000000..d4c3ca89 --- /dev/null +++ b/src/tool/Decision/dehist.F @@ -0,0 +1,274 @@ + subroutine dehist ( nomail, + > lgopti, taopti, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - mise a jour des HISToriques +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHIST' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + integer phetno, phetar, phettr, phetqu + integer phette, phethe, phetpe, phetpy + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' MISE A JOUR DES HISTORIQUES'')' + texte(1,5) = '(34(''=''),/)' +c + texte(2,4) = '(/,a6,'' UPDATING OF HISTORY'')' + texte(2,5) = '(26(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhnoeu//'.HistEtat', phetno, iaux, codre1 ) + call gmadoj ( nharet//'.HistEtat', phetar, iaux, codre2 ) + if ( nbtrto.ne.0 ) then + call gmadoj ( nhtria//'.HistEtat', phettr, iaux, codre3 ) + else + codre3 = 0 + endif + if ( nbquto.ne.0 ) then + call gmadoj ( nhquad//'.HistEtat', phetqu, iaux, codre4 ) + else + codre4 = 0 + endif + if ( nbteto.ne.0 ) then + call gmadoj ( nhtetr//'.HistEtat', phette, iaux, codre5 ) + else + codre5 = 0 + endif + if ( nbheto.ne.0 ) then + call gmadoj ( nhhexa//'.HistEtat', phethe, iaux, codre6 ) + else + codre6 = 0 + endif + if ( nbpeto.ne.0 ) then + call gmadoj ( nhpent//'.HistEtat', phetpe, iaux, codre7 ) + else + codre7 = 0 + endif + if ( nbpyto.ne.0 ) then + call gmadoj ( nhpyra//'.HistEtat', phetpy, iaux, codre8 ) + else + codre8 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + endif +c +c==== +c 3. mise a jour effective +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. mise a jour effective ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(31).ne.0 .or. taopti(32).ne.0 ) then + iaux = 0 + else + iaux = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHMAJ', nompro +#endif + call dehmaj ( iaux, + > imem(phetno), imem(phetar), + > imem(phettr), imem(phetqu), + > imem(phette), imem(phethe), + > imem(phetpe), imem(phetpy), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/dehmaj.F b/src/tool/Decision/dehmaj.F new file mode 100644 index 00000000..61c17b66 --- /dev/null +++ b/src/tool/Decision/dehmaj.F @@ -0,0 +1,440 @@ + subroutine dehmaj ( option, + > hetnoe, hetare, + > hettri, hetqua, + > hettet, hethex, + > hetpen, hetpyr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Historique - Mis A Jour vraie +c -- - - - - +c ______________________________________________________________________ +c +c but : mise a jour effective des historiques +c de maniere generale, l'historique des etats est un nombre a 2k +c chiffres. les k premiers decrivent l'etat de l'entite avant le +c processus de raffinement/deraffinement. les k derniers decrivent +c l'etat apres. a ce stade, nous sommes au depart du processus. il +c faut basculer l'etat "apres" pour le maillage n vers ce qui va etre +c l'etat "avant" pour le maillage n+1. les k premiers chiffres sont +c donc remplaces par les k derniers. les k derniers chiffres +c decrivent alors l'etat courant, une fois les entites de mise en +c conformite supprimees. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 0 : tri selon la conformite . +c . . . . 1 : transfert direct . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . hettet . es . nbteto . historique de l'etat des tetraedres . +c . hethex . es . nbheto . historique de l'etat des hexaedres . +c . hetpen . es . nbpeto . historique de l'etat des pentaedres . +c . hetpyr . es . nbpyto . historique de l'etat des pyramides . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHMAJ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer hetnoe(nbnoto) + integer hetare(nbarto) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer hettet(nbteto) + integer hethex(nbheto) + integer hetpen(nbpeto) + integer hetpyr(nbpyto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer etat +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Nombre d''''entites dont on modifie l''''historique'')' +c + texte(2,4) = + > '(5x,''Number of entities whose history is modified'')' +c +10000 format(7x,a,' : ',i10) +10001 format(1x) +c + codret = 0 +c + write (ulsort,texte(langue,4)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,10000) 'Option', option +#endif +c +c==== +c 1. historique des noeuds +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | noeud isole | +c | 1 | degre 1 = p1 | +c | 2 | degre 2 = p2 | +c | 3 | noeud de maille-point uniquement | +c | 5 | inexistant | +c | 9 | detruit | +c |------------------|----------------------------------------------| +c +c==== +c + write (ulsort,10000) mess14(langue,4,-1), nbnoto +c + do 10 , iaux = 1 , nbnoto +c + etat = mod(hetnoe(iaux),10) +c + hetnoe(iaux) = etat * 11 +c + 10 continue +c +c==== +c 2. historique des aretes +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | active | +c | 2 | coupee en 2 et ses 2 filles sont actives | +c | 5 | inexistante | +c | 9 | coupee en 2 et un de ses filles est inactive | +c |------------------|----------------------------------------------| +c +c==== +c + write (ulsort,10000) mess14(langue,4,1), nbarto +c + do 20 , iaux = 1 , nbarto +c + etat = mod(hetare(iaux),10) +c + hetare(iaux) = etat * 11 +c + 20 continue +c +c==== +c 3. historique des triangles +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | actif | +c | 1 | coupe en 2 par sa premiere arete | +c | 2 | coupe en 2 par sa deuxieme arete | +c | 3 | coupe en 2 par sa troisieme arete | +c | 4 | coupe en 4 et ses 4 fils sont actifs | +c | 5 | inexistant | +c | 6 | coupe en 4 et bascule de la premiere arete | +c | | ses 4 fils sont actifs | +c | 7 | idem avec la deuxieme arete | +c | 8 | idem avec la troisieme arete | +c | 9 | coupe en 4 et un de ses fils est inactif | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbtrto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,2), nbtrto +c + jaux = 10 + option +c + do 30 , iaux = 1 , nbtrto +c + etat = mod(hettri(iaux),10) +c + if ( etat.lt.4 ) then + hettri(iaux) = etat * jaux + else + hettri(iaux) = etat * 11 + endif +c + 30 continue +c + endif +c +c==== +c 4. historique des quadrangles +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | actif | +c | 4 | coupe en 4 et ses 4 fils sont actifs | +c | 21 | coupe en 2 quadrangles par les aretes 1 et 3 | +c | 22 | coupe en 2 quadrangles par les aretes 2 et 4 | +c | 31 | coupe en 3 triangles par son arete numero 1 | +c | 32 | coupe en 3 triangles par son arete numero 2 | +c | 33 | coupe en 3 triangles par son arete numero 2 | +c | 34 | coupe en 3 triangles par son arete numero 4 | +c | 41 | coupe en 3 quadrangles par les aretes 1 et 2 | +c | 42 | coupe en 3 quadrangles par les aretes 2 et 3 | +c | 43 | coupe en 3 quadrangles par les aretes 3 et 4 | +c | 44 | coupe en 3 quadrangles par les aretes 4 et 1 | +c | 55 | inexistant | +c | 99 | coupe en 4 et un de ses fils est inactif | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbquto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,4), nbquto +c + jaux = 100 + option +c + do 40 , iaux = 1 , nbquto +c + etat = mod(hetqua(iaux),100) +c + if ( etat.ge.21 .and. etat.le.44 ) then + hetqua(iaux) = etat * jaux + else + hetqua(iaux) = etat * 101 + endif +c + 40 continue +c + endif +c +c==== +c 5. historique des tetraedres +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | actif | +c | 2i i=1,2,3,4,5,6 | coupe en 2 par sa i-eme arete | +c | 4i i=1,2,3,4 | coupe en 4 par sa i-eme face | +c | 4i i=5,6,7 | coupe en 4 par la diagonale 1-6,2-5,3-4 | +c | 55 | inexistant | +c | 8i i=5,6,7 | coupe en 8 par la diagonale 1-6,2-5,3-4 | +c | 99 | coupe en 8 et un de ses fils est inactif | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbteto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,3), nbteto +c + jaux = 100 + option +c + do 50 , iaux = 1 , nbteto +c + etat = mod(hettet(iaux),100) +c + if ( etat.lt.55 ) then + hettet(iaux) = etat * jaux + else + hettet(iaux) = etat * 101 + endif +c + 50 continue +c + endif +c +c==== +c 6. historique des hexaedres +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | actif | +c | 5 | inexistant | +c | 8 | coupe en 8 | +c | 9 | coupe en 8 et un de ses fils est inactif | +c | 11 | coupe par conformite | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbheto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,6), nbheto +c + jaux = 1000 + option +c + do 60 , iaux = 1 , nbheto +c + etat = mod(hethex(iaux),1000) +c + if ( etat.ge.11 ) then + hethex(iaux) = etat * jaux + else + hethex(iaux) = etat * 1001 + endif +c + 60 continue +c + endif +c +c==== +c 7. historique des pyramides +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | active | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbpyto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,5), nbpyto +c + jaux = 100 + option +c + do 70 , iaux = 1 , nbpyto +c + etat = mod(hetpyr(iaux),100) +c + if ( etat.eq.0 ) then + hetpyr(iaux) = etat * jaux + else + codret = 70 + endif +c + 70 continue +c + endif +c +c==== +c 8. historique des pentaedres +c +c |------------------|----------------------------------------------| +c | etat | description | +c |------------------|----------------------------------------------| +c | 0 | actif | +c | i i=1, ..., 6 | coupee par l'arete i | +c | i i=17, 18, 19 | coupee par l'arete i-10 | +c | i i=21, ..., 26 | coupee par 2 aretes tria & quad | +c | i i=31, ..., 36 | coupee par 2 aretes tria & tria | +c | i i=43, 44, 45 | coupee par une face quad | +c | i i=51, 52 | coupee par une face tria | +c | 55 | inexistant | +c | 80 | coupe en 8 | +c | 99 | coupe en 8 et un de ses fils est inactif | +c |------------------|----------------------------------------------| +c +c==== +c + if ( nbpeto.ne.0 ) then +c + write (ulsort,10000) mess14(langue,4,7), nbpeto +c + jaux = 100 + option +c + do 80 , iaux = 1 , nbpeto +c + etat = mod(hetpen(iaux),100) +c + if ( etat.lt.55 ) then + hetpen(iaux) = etat * jaux + else + hetpen(iaux) = etat * 101 + endif +c + 80 continue +c + endif +c +c==== +c 9. la fin +c==== +c + write (ulsort,10001) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dehom1.F b/src/tool/Decision/dehom1.F new file mode 100644 index 00000000..535be3c7 --- /dev/null +++ b/src/tool/Decision/dehom1.F @@ -0,0 +1,496 @@ + subroutine dehom1 ( pilraf, pilder, + > hetare, + > hettri, aretri, + > hetqua, arequa, + > arehom, homtri, quahom, + > decare, decfac, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - HOMologue - phase 1 +c -- --- - +c rmq : on ne peut pas utiliser les tables ho1are ... car elle ne +c sont plus a jour apres suppression de la conformite +c +c rmq : le raffinement est prioritaire sur le deraffinement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . -1 : deraffinement uniforme . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . homtri . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHOM1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envada.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer pilraf, pilder + integer hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer arehom(nbarto), homtri(nbtrto), quahom(nbquto) + integer decare(0:nbarto), decfac(-nbquto:nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer arete1, arete2, face1, face2a, face2d, laface + integer arete(4) + integer etatar, etatfa + integer areloc, letria + integer nbarhd, nbarhg, nbarhr + integer nbtrhd, nbtrhr + integer nbquhd, nbquhr + integer option, nbento, nbaret +c + logical afaire +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(/,7x,''Nombre de '',a,''a garder par equivalence :'',i10)' + texte(1,5) = + >'(/,7x,''Nombre de '',a,''a decouper par equivalence :'',i10)' + texte(1,6) = + >'(/,7x,''Nombre de '',a,''a reactiver par equivalence :'',i10)' +c + texte(2,4) = + > '(/,7x,a,'' to keep due to equivalence :'',i10)' + texte(2,5) = + > '(/,7x,a,'' to divide due to equivalence :'',i10)' + texte(2,6) = + > '(/,7x,a,'' to reactivate due to equivalence :'',i10)' +c + codret = 0 +c + nbarhg = 0 + nbarhr = 0 + nbarhd = 0 +c + nbtrhd = 0 + nbtrhr = 0 +c + nbquhd = 0 + nbquhr = 0 +c +c==== +c 2. dans le cas de deux aretes homologues, dont l'une est a reactiver +c et l'autre doit etre maintenue parce elle borde une face a couper : +c il faut empecher le deraffinement. +c cela se produit apres une suppression de conformite +c +c chiffres arabes : decision sur les faces (decfac) +c chiffres romains : decision sur les aretes (decare) +c x : noeuds +c +c maillage n : on derafine a gauche et on raffine a droite +c apres l'initialisation des decisions on en est a : +c +c x x +c . . ... +c . . . . . +c . -1 . <--> . . . +c -I x.......x -I I . . . I +c . . . . . . . +c . .-1 . . . 1 . 0 . +c . -1 . . -1 . . . . +c . . . . . . +c x--------x--------x x--------x--------x +c -I 0 +c +c +c maillage n apres suppression de la conformite : +c +c x x +c . . . . +c . . . . +c . -1 . <--> . . +c -I x.......x -I I . . I +c . . . . . . +c . .-1 . . . 1 . +c . -1 . . -1 . . . +c . . . . . +c x--------x--------x x--------x--------x +c -I 0 +c +c Il faut donc inhiber le -I sur l'arete homologue de gauche : +c +c x x +c . . . . +c . . . . +c . -1 . <--> . . +c -I x.......x -I I . . I +c . . . . . . +c . .-1 . . . 1 . +c . -1 . . -1 . . . +c . . . . . +c x--------x--------x x--------x--------x +c 0 0 +c +c pour obtenir : +c +c +c x x +c ... . . +c . . . . . +c . . . <--> . . +c . . . I . . I +c . . . . . +c . . . . 1 . +c . . . . . +c . . . . . +c x--------x--------x x--------x--------x +c +c il faut commencer par cette inhibition et ensuite seulement +c transferer arete par arete +c=== +c + if ( homolo.ge.2 ) then +c + if ( pilder.gt.0 .and. nbiter.ne.0 ) then +c + do 21, letria = 1, nbtrto +c + if ( decfac(letria).eq.4 ) then +c + do 211 , areloc = 1, 3 + arete1 = aretri(letria,areloc) + arete2 = abs(arehom(arete1)) + if ( arete2.ne.0 ) then + if ( decare(arete2).eq.-1 ) then + decare(arete2) = 0 + nbarhg = nbarhg + 1 +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Gar. arete1 = ',arete1,' ==> arete2 ',arete2 +#endif + endif + endif + 211 continue +c + endif +c + 21 continue +c + endif +c + endif +c +c==== +c 3. on complete les tables de decisions pour les faces en 3D +c attention, il faut le faire avant les aretes pour pouvoir unifier +c les decisions sur toutes les aretes +c==== +c + if ( homolo.ge.3 ) then +c + do 3 , option = 2, 4, 2 +c + if ( option.eq.2 ) then + nbento = nbtrto + nbaret = 3 + else + nbento = nbquto + nbaret = 4 + endif +c + do 30, face1 = 1 , nbento +c + if ( option.eq.2) then + laface = face1 + face2a = abs(homtri(face1)) + face2d = face2a + else + laface = -face1 + face2a = abs(quahom(face1)) + face2d = -face2a + endif +c + if ( face2a.ne.0 ) then +c +c 3.1. ==> unification du deraffinement +c + if ( decfac(laface).eq.-1 .and. decfac(face2d).eq.0 ) then +c +c 3.1.1. ==> on controle si toutes les aretes de face2 sont a deraffiner +c ou a garder +c + afaire = .true. + if ( option.eq.2) then + do 311 , areloc = 1, nbaret + arete(areloc) = aretri(face2a,areloc) + 311 continue + else + do 312 , areloc = 1, nbaret + arete(areloc) = arequa(face2a,areloc) + 312 continue + endif +c + do 313 , areloc = 1, nbaret + if ( decare(arete(areloc)).gt.0 ) then + afaire = .false. + endif + 313 continue +c +c 3.1.2. ==> les aretes de face2 sont toutes a deraffiner ==> on +c deraffine la face face2 et ses aretes +c + if ( afaire ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Der. face1 = ',laface,' ==> face2 ',face2d +#endif + decfac(face2d) = -1 + if ( option.eq.2 ) then + nbtrhd = nbtrhd + 1 + else + nbquhd = nbquhd + 1 + endif +c + do 314 , areloc = 1, nbaret + if ( decare(arete(areloc)).ne.-1 ) then + decare(arete(areloc)) = -1 + nbarhg = nbarhg + 1 +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Der. arete1 = ',arete(areloc) +#endif + endif + 314 continue + endif +c + endif +c +c 3.2. ==> unification du raffinement +c + if ( decfac(laface).eq.4 .and. decfac(face2d).ne.4 ) then +c + if ( option.eq.2 ) then + etatfa = mod(hettri(face2a),10) + else + etatfa = mod(hetqua(face2a),100) + endif + if ( etatfa.eq.0 ) then + decfac(face2d) = 4 + if ( option.eq.2 ) then + nbtrhr = nbtrhr + 1 + else + nbquhr = nbquhr + 1 + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Raf. face1 = ',laface,' ==> face2 ',face2d +#endif + endif +c + do 321 , areloc = 1, nbaret + if ( option.eq.2 ) then + arete1 = aretri(face2a,areloc) + else + arete1 = arequa(face2a,areloc) + endif + etatar = mod( hetare(arete1) , 10 ) + if ( decare(arete1).ne.2 .and. etatar.eq.0 ) then + decare(arete1) = 2 + nbarhd = nbarhd + 1 +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) ' ==> Raf. arete1 = ',arete1 +#endif + endif + 321 continue +c + endif +c + endif +c + 30 continue +c + 3 continue +c + endif +c +c==== +c 4. on complete les tables de decisions pour les aretes +c pour chaque entite qui est "a decouper" et qui possede une entite +c homologue, on declare "a decouper" l'entite homologue si elle ne +c l'est pas deja (ce qui permet d'en faire le compte) +c==== +c + if ( homolo.ge.2 ) then +c + do 41, arete1 = 1, nbarto +c + arete2 = abs(arehom(arete1)) +c + if ( arete2.ne.0 ) then +c +c 4.1. ==> unification du deraffinement +c A condition que l'arete homologue ne soit pas grand-mere ! +c Sinon, on inhibe le deraffinement sur la premiere +c + if ( decare(arete1).eq.-1 .and. decare(arete2).eq.0 ) then + etatar = mod( hetare(arete2) , 10 ) + if ( etatar.eq.9 ) then + decare(arete1) = 0 + nbarhg = nbarhg + 1 + else +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Der. arete1 = ',arete1,' ==> arete2 ',arete2 +#endif + decare(arete2) = -1 + nbarhd = nbarhd + 1 + endif + endif +c +c 4.2. ==> unification du raffinement +c + if ( decare(arete1).eq.2 .and. decare(arete2).ne.2 ) then + etatar = mod( hetare(arete2) , 10 ) + if ( etatar.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Raf. arete1 = ',arete1,' ==> arete2 ',arete2 +#endif + decare(arete2) = 2 + nbarhr = nbarhr + 1 + endif + endif + endif +c + 41 continue +c + endif +c +c==== +c 5. messages +c==== +c + if ( homolo.ge.2 ) then +c + if ( pilder.gt.0 ) then + write(ulsort,texte(langue,6)) mess14(langue,3,1), nbarhd + write(ulsort,texte(langue,4)) mess14(langue,3,1), nbarhg + endif + if ( pilraf.gt.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,1), nbarhr + endif +c + endif +c + if ( homolo.ge.3 ) then +c + if ( pilder.gt.0 ) then + if ( nbtrto.gt.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,2), nbtrhd + endif + if ( nbquto.gt.0 ) then + write(ulsort,texte(langue,4)) mess14(langue,3,4), nbquhd + endif + endif + if ( pilraf.gt.0 ) then + if ( nbtrto.gt.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,2), nbtrhr + endif + if ( nbquto.gt.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,4), nbquhr + endif + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dehomo.F b/src/tool/Decision/dehomo.F new file mode 100644 index 00000000..7f8928be --- /dev/null +++ b/src/tool/Decision/dehomo.F @@ -0,0 +1,373 @@ + subroutine dehomo ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - HOMOlogues +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : erreur . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHOMO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux + integer jaux +c + integer phetar, psomar + integer phettr, paretr + integer phetqu, parequ +c + integer pdecar, pdecfa + integer adhoar, adhotr, adhoqu +c + integer codre0 + integer codre1, codre2 +c + character*6 saux + character*8 ntrav1, ntrav2 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.0. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c======================================================================= + if ( homolo.ge.2 ) then +c======================================================================= +c +c 1.3. ==> les messages +c + texte(1,4) = '(/,a6,'' PRISE EN COMPTE DES HOMOLOGUES'')' + texte(1,5) = '(37(''=''),/)' +c + texte(2,4) = '(/,a6,'' HOMOLOGOUS INFLUENCE'')' + texte(2,5) = '(28(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST en entree de ', nompro + iaux = 1 + call delist ( nomail, nompro, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c + iaux = 2 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 2 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 2 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. influence des homologues +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOM1', nompro +#endif + call dehom1 ( taopti(31), taopti(32), + > imem(phetar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(adhoar), imem(adhotr), imem(adhoqu), + > imem(pdecar), imem(pdecfa), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. verification +c==== +c +c 4.1. ==> sur les aretes +c + if ( homolo.ge.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVA', nompro +#endif + call dehova ( imem(adhoar), imem(pdecar), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.2. ==> sur les triangles +c + if ( homolo.ge.3 .and. nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 2 + call dehovf ( iaux, + > nbtrto, imem(adhotr), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.3. ==> sur les quadrangles +c + if ( homolo.ge.3 .and. nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 4 + call dehovf ( iaux, + > nbquto, imem(adhoqu), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST', nompro + iaux = 2 + call delist ( nomail, nompro, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/dehova.F b/src/tool/Decision/dehova.F new file mode 100644 index 00000000..5dfd1685 --- /dev/null +++ b/src/tool/Decision/dehova.F @@ -0,0 +1,177 @@ + subroutine dehova ( arehom, decare, + > nompra, phase, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - HOmologues - Verification des Aretes +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . arehom . e . nbarto . ensemble des aretes homologues . +c . decare . e . nbarto . decisions des aretes . +c . nompra . e . char6 . nom du programme appelant . +c . phase . e . 1 . phase du programme appelant . +c . . . . 0 : debut . +c . . . . 1 : fin . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : desaccord sur les decisions entre . +c . . . . entites homologues . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHOVA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer arehom(nbarto) + integer decare(0:nbarto) + integer phase + character*6 nompra +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*9 saux09(nblang,0:1) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Pour les deux aretes homologues'',i6,'' et'',i6)' + texte(1,5) = '(''. Arete numero'',i10,'' : decision = '',i2)' + texte(1,6) = '(''... Probleme ...'')' + texte(1,7) = '(/,a8,a6,'' : '',i8,'' erreur(s) sur les aretes.'')' +c + texte(2,4) = + > '(''For the two homologous edges'',i6,'' and'',i6)' + texte(2,5) = '(''. Edge #'',i10,'' : decision = '',i2)' + texte(2,6) = '(''... Problem ...'')' + texte(2,7) = '(/,a8,a6,'' : '',i8,'' error(s) over edges.'')' +c +c 123456789 + saux09(1,0) = 'Debut de ' + saux09(1,1) = 'Fin de ' + saux09(2,0) = 'Start of ' + saux09(2,1) = 'End of ' +c +c==== +c 2. controle des decisions sur les aretes +c on boucle uniquement sur les aretes de la face periodique 2 +c==== +c + jaux = 0 +c + if ( homolo.ge.2 ) then +c + do 21 , iaux = 1 , nbarto +c + if ( arehom(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) iaux, arehom(iaux) + write (ulsort,texte(langue,5)) + > iaux, decare(iaux) + write (ulsort,texte(langue,5)) + > abs(arehom(iaux)), decare(arehom(iaux)) +#endif +c + if ( decare(iaux).ne.decare(arehom(iaux)) ) then + write (ulsort,texte(langue,4)) iaux, arehom(iaux) + write (ulsort,texte(langue,5)) + > iaux, decare(iaux) + write (ulsort,texte(langue,5)) + > abs(arehom(iaux)), decare(arehom(iaux)) + write (ulsort,texte(langue,6)) + jaux = jaux + 1 + endif +c + endif +c + 21 continue +c + if ( jaux.ne.0 ) then + write (ulsort,texte(langue,7)) + > saux09(langue,phase), nompra, jaux + codret = 1 + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dehovf.F b/src/tool/Decision/dehovf.F new file mode 100644 index 00000000..0a0119b5 --- /dev/null +++ b/src/tool/Decision/dehovf.F @@ -0,0 +1,198 @@ + subroutine dehovf ( option, + > nbento, enthom, decfac, + > nompra, phase, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - HOmologues - Verification des Faces +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . variantes . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . nbento . e . 1 . nombre d'entites total . +c . enthom . e . nbento . ensemble des entites homologues . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . nompra . e . char6 . nom du programme appelant . +c . phase . e . 1 . phase du programme appelant . +c . . . . 0 : debut . +c . . . . 1 : fin . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : desaccord sur les decisions entre . +c . . . . entites homologues . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEHOVF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer option + integer nbento + integer enthom(nbento) + integer decfac(-nbquto:nbtrto) + integer phase + character*6 nompra +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer face1 , face2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*9 saux09(nblang,0:1) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Pour les deux '',a,'' homologues'',i6,'' et'',i6)' + texte(1,5) = '(''. '',a,'' numero'',i7,'' : decision = '',i2)' + texte(1,6) = '(''... Probleme ...'')' + texte(1,7) = + > '(/,a8,a6,'' : '',i8,'' erreur(s) sur les '',a,''.'')' +c + texte(2,4) = + > '(''For the two homologous '',a,i6,'' and'',i6)' + texte(2,5) = '(''. '',a,'' #'',i7,'' : decision = '',i2)' + texte(2,6) = '(''... Problem ...'')' + texte(2,7) = '(/,a8,a6,'' : '',i8,'' error(s) over '',a,''.'')' +c +c 123456789 + saux09(1,0) = 'Debut de ' + saux09(1,1) = 'Fin de ' + saux09(2,0) = 'Start of ' + saux09(2,1) = 'End of ' +c +c==== +c 2. controle des decisions sur les faces +c on boucle uniquement sur les faces de la face periodique 2 +c==== +c + jaux = 0 +c + if ( homolo.ge.3 ) then +c + do 21 , iaux = 1 , nbento +c + if ( enthom(iaux).gt.0 ) then +c + face1 = iaux + face2 = enthom(iaux) + if ( option.eq.4 ) then + face1 = -face1 + face2 = -face2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,option), + > iaux, enthom(iaux) + write (ulsort,texte(langue,5)) mess14(langue,2,option), + > iaux, decfac(face1) + write (ulsort,texte(langue,5)) mess14(langue,2,option), + > enthom(iaux), decfac(face2) +#endif +c + if ( decfac(face1).ne.decfac(face2) ) then + write (ulsort,texte(langue,4)) mess14(langue,3,option), + > iaux, enthom(iaux) + write (ulsort,texte(langue,5)) mess14(langue,2,option), + > iaux, decfac(face1) + write (ulsort,texte(langue,5)) mess14(langue,2,option), + > enthom(iaux), decfac(face2) + write (ulsort,texte(langue,6)) + jaux = jaux + 1 + endif +c + endif +c + 21 continue +c + if ( jaux.ne.0 ) then + write (ulsort,texte(langue,7)) + > saux09(langue,phase), nompra, jaux, mess14(langue,3,option) + codret = 1 + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiard.F b/src/tool/Decision/deiard.F new file mode 100644 index 00000000..ad1285bc --- /dev/null +++ b/src/tool/Decision/deiard.F @@ -0,0 +1,231 @@ + subroutine deiard ( nivmin, + > decare, decfac, + > hetare, filare, + > posifa, facare, + > aretri, hettri, nivtri, + > arequa, hetqua, nivqua, + > arsupp, arindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des ARetes - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . arsupp . e . nbarto . support pour les aretes . +c . arindi . e . nbarto . valeurs entieres pour les aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIARD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto), filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto) + integer nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer nivqua(nbquto) + integer arsupp(nbarto), arindi(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer somdec, etat + integer larete, letria, lequad + integer fille1 + integer iaux, jaux, kaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les aretes +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'une arete est identifie a celui de l'une quelconque de +c ses faces voisines quand elle en a. Sinon, on ne filtre pas. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , larete = 1, nbarto +c + etat = mod(hetare(larete),10) + if ( etat.ge.2 ) then + fille1 = filare(larete) + if ( arsupp(fille1) .ne.0 .and. + > arsupp(fille1+1).ne.0 ) then + if ( arindi(fille1) .eq.-1 .and. + > arindi(fille1+1).eq.-1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.lt.nivmin ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then + decare(larete) = -1 +cgn write(ulsort,*) 'mise a -1 de decare pour arete', larete, +cgn > ', de filles', fille1, fille1+1 + else + iaux = iaux + 1 + endif + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,1) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c + do 22 , letria = 1, nbtrto + etat = mod(hettri(letria),10) + if ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then + somdec = decare(aretri(letria,1)) + > + decare(aretri(letria,2)) + > + decare(aretri(letria,3)) + if (somdec.eq.-3) then +cgn write(ulsort,*) 'Triangle', letria, ' a reactiver' + decfac(letria) = -1 + endif + endif + 22 continue +c + do 23 , lequad = 1, nbquto + etat = mod(hetqua(lequad),100) + if ( etat.eq.4 ) then + somdec = decare(arequa(lequad,1)) + > + decare(arequa(lequad,2)) + > + decare(arequa(lequad,3)) + > + decare(arequa(lequad,4)) + if (somdec.eq.-4) then +cgn write(ulsort,*) 'Quadrangle', lequad, ' a reactiver' + decfac(-lequad) = -1 + endif + endif + 23 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiari.F b/src/tool/Decision/deiari.F new file mode 100644 index 00000000..3481c15d --- /dev/null +++ b/src/tool/Decision/deiari.F @@ -0,0 +1,172 @@ + subroutine deiari ( decare, decfac, + > merare, + > posifa, facare, + > arsupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des ARetes - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . merare . e . nbarto . mere des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . arsupp . e . nbarto . support pour les aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIARI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer merare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer arsupp(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete, lamere + integer iaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,1) +#endif +c + do 21 , larete = 1, nbarto +c + if ( arsupp(larete).ne.0 ) then +c +c 2.1. ==> Inhibition du raffinement par defaut : on garde l'arete +c designee et les faces qui la contiennent +c + decare(larete) = 0 +cgn write(ulsort,*) 'Arete', larete, ' a garder' + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + do 211 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux), ' a garder' + decfac(facare(iaux)) = 0 + 211 continue +c +c 2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de l'arete designee si elle existe et des faces qui +c la contiennent +c + lamere = merare(larete) +c + if ( lamere.gt.0 ) then +c + decare(lamere) = 0 +cgn write(ulsort,*) 'Arete', lamere, ' a garder' + ideb = posifa(lamere-1)+1 + ifin = posifa(lamere) + do 212 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux), ' a garder' + decfac(facare(iaux)) = 0 + 212 continue +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiarr.F b/src/tool/Decision/deiarr.F new file mode 100644 index 00000000..78dabfb0 --- /dev/null +++ b/src/tool/Decision/deiarr.F @@ -0,0 +1,189 @@ + subroutine deiarr ( nivmax, + > decare, + > hetare, + > posifa, facare, + > nivtri, + > nivqua, + > arsupp, arindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des ARetes - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . nivtri . e . nbtrto . niveau des triangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . arsupp . e . nbarto . support pour les aretes . +c . arindi . e . nbarto . valeurs entieres pour les aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIARR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto) + integer hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer nivtri(nbtrto) + integer nivqua(nbquto) + integer arsupp(nbarto), arindi(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer larete + integer iaux, jaux, kaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les aretes +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'une arete est identifie a celui de l'une quelconque de +c ses faces voisines quand elle en a. Sinon, on ne filtre pas. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , larete = 1, nbarto +c + if ( arsupp(larete).ne.0 ) then + etat = mod(hetare(larete),10) + if ( etat.eq.0 ) then + if ( arindi(larete).eq.1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb .and. nivmax.ge.0 ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.ge.nivmax ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then + decare(larete) = 2 +cgn write(ulsort,*) 'mise a 2 de decare pour arete', larete + else + iaux = iaux + 1 + endif + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,1) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deihed.F b/src/tool/Decision/deihed.F new file mode 100644 index 00000000..bb449f99 --- /dev/null +++ b/src/tool/Decision/deihed.F @@ -0,0 +1,197 @@ + subroutine deihed ( nivmin, + > decare, decfac, + > arequa, nivqua, + > quahex, hethex, filhex, + > hesupp, heindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des HExaedres - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . e . nbheto . valeurs entieres pour les hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIHED' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer arequa(nbquto,4), nivqua(nbquto) + integer quahex(nbhecf,6), hethex(nbheto), filhex(nbheto) + integer hesupp(nbheto), heindi(nbheto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc, etat + integer lequad, lehexa + integer fils1 + integer iaux, jaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les hexaedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un hexaedre est identifie a celui de n'importe lequel +c de ses quadrangles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,6) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , lehexa = 1, nbheto +c + etat = mod(hethex(lehexa),1000) + if ( etat.eq.8 ) then + fils1 = filhex(lehexa) + if ( hesupp(fils1) .ne. 0 .and. + > hesupp(fils1+1) .ne. 0 .and. + > hesupp(fils1+2) .ne. 0 .and. + > hesupp(fils1+3) .ne. 0 .and. + > hesupp(fils1+4) .ne. 0 .and. + > hesupp(fils1+5) .ne. 0 .and. + > hesupp(fils1+6) .ne. 0 .and. + > hesupp(fils1+7) .ne. 0 ) then + if ( heindi(fils1) .eq. -1 .and. + > heindi(fils1+1) .eq. -1 .and. + > heindi(fils1+2) .eq. -1 .and. + > heindi(fils1+3) .eq. -1 .and. + > heindi(fils1+4) .eq. -1 .and. + > heindi(fils1+5) .eq. -1 .and. + > heindi(fils1+6) .eq. -1 .and. + > heindi(fils1+7) .eq. -1 ) then + jaux = quahex(lehexa,1) + if ( nivqua(jaux).lt.nivmin ) then + iaux = iaux + 8 + else + do 22 , facloc = 1, 6 + lequad = quahex(lehexa,facloc) + decfac(-lequad) = -1 + do 23 , areloc = 1, 4 + decare(arequa(lequad,areloc)) = -1 + 23 continue + 22 continue + endif + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,6) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deihei.F b/src/tool/Decision/deihei.F new file mode 100644 index 00000000..92bbe5a2 --- /dev/null +++ b/src/tool/Decision/deihei.F @@ -0,0 +1,172 @@ + subroutine deihei ( decare, decfac, + > arequa, perqua, + > quahex, + > hesupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des HExaedres - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIHEI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer arequa(nbquto,4), perqua(nbquto) + integer quahex(nbhecf,6) + integer hesupp(nbheto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer lequad, lehexa, lepere + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 3. traitement des indicateurs portant sur les hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,6) +#endif +c + do 21 , lehexa = 1, nbheto +c + if ( hesupp(lehexa).ne.0 ) then +c + do 22 , facloc = 1, 6 +c + lequad = quahex(lehexa,facloc) +c +c 2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(-lequad) = 0 + do 221 , areloc = 1, 4 + decare(arequa(lequad,areloc)) = 0 + 221 continue +cgn write(ulsort,*) 'decision finale',decfac(-lequad) +c +c 2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lepere = perqua(lequad) +c + if ( lepere.gt.0 ) then +c + decfac(-lepere) = 0 + do 222 , areloc = 1, 4 + decare(arequa(lepere,areloc)) = 0 + 222 continue +c + endif +c + 22 continue +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiher.F b/src/tool/Decision/deiher.F new file mode 100644 index 00000000..7ace19fe --- /dev/null +++ b/src/tool/Decision/deiher.F @@ -0,0 +1,189 @@ + subroutine deiher ( nivmax, + > decare, decfac, + > hetare, + > arequa, hetqua, nivqua, + > quahex, + > hesupp, heindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des HExaedres - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . e . nbheto . valeurs entieres pour les hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIHER' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer quahex(nbhecf,6) + integer hesupp(nbheto), heindi(nbheto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer lequad, lehexa + integer iaux, jaux, kaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 3. traitement des indicateurs portant sur les hexaedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un hexaedre est identifie a celui de n'importe lequel +c de ses quadrangles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,6) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , lehexa = 1, nbheto +c + if ( hesupp(lehexa).ne.0 ) then + if ( heindi(lehexa).eq.1 ) then + jaux = quahex(lehexa,1) + if ( nivmax.ge.0 .and. nivqua(jaux).ge.nivmax ) then + iaux = iaux + 1 + else + do 22 , facloc = 1, 6 + lequad = quahex(lehexa,facloc) +cgn write(ulsort,*) 'lequad', lequad,hetqua(lequad),decfac(-lequad) + if ( mod(hetqua(lequad),100).eq.0 ) then + decfac(-lequad) = 4 + endif + do 23 , areloc = 1, 4 + kaux = arequa(lequad,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 + endif + 23 continue +cgn write(ulsort,*) 'decision finale',decfac(-lequad) + 22 continue + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,6) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinb1.F b/src/tool/Decision/deinb1.F new file mode 100644 index 00000000..06ce7d46 --- /dev/null +++ b/src/tool/Decision/deinb1.F @@ -0,0 +1,442 @@ + subroutine deinb1 ( typenh, nbento, ncmpin, + > ensupp, enindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisations - Bilan - etape 1 +c -- -- - - +c but : impression des bilans de l'indicateur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbento . e . 1 . nombre total d'entites . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . ensupp . e . nbento . support pour les entites . +c . enindi . e . nbento . valeurs pour les entites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINB1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +c +#include "infini.h" +#include "envada.h" +#include "impr02.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer typenh + integer ncmpin + integer nbento + integer ensupp(nbento) +c + integer ulsort, langue, codret +c + double precision enindi(nbento,ncmpin) +c +c 0.4. ==> variables locales +c + integer nbclas + parameter (nbclas=20) +c + integer histog(nbclas) + integer iclass(0:nbclas) + double precision rclass(0:nbclas) +c + character*8 ntrav1 + character*8 titcou(6) + character*10 saux10 +c + integer iaux, jaux + integer ulhist, ulxmgr + integer lnomfl + integer ival(1), nbval + integer adtra1 + integer codre1, codre2, codre3 + integer codre0 +#ifdef _DEBUG_HOMARD_ + integer ulbrut +#endif +c + double precision valmin, valmax + double precision vamiar, vamaar, valdif + double precision xlow +c + logical consta +c + character*200 nomflo +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*54 mess54(nblang,nbmess) +c + character*8 mess08(nblang,2) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Impression du bilan de l''''indicateur sur les '',a)' + texte(1,5) = '(''.. Valeur '',a,'' :'',g16.8)' + texte(1,6) = '(''--> valeur arrondie pour le '',a,'' :'',g16.8)' +c + texte(2,4) = + > '(''Printing of summary of indicator over '',a)' + texte(2,5) = '(''.. Value '',a,'' :'',g16.8)' + texte(2,6) = '(''--> round value for '',a,'' :'',g16.8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c + codret = 0 +c +c=== +c 2. tableaux de travail +c=== +c 2.1. ==> Allocation +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'reel ', nbento, adtra1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.2. ==> Copie des valeurs filtrees +c + if ( codret.eq.0 ) then +c + nbval = 0 + do 22 , iaux = 1 , nbento +c + if ( ensupp(iaux).eq.1 ) then + nbval = nbval + 1 + rmem(adtra1+nbval-1) = enindi(iaux,1) + if ( nbval.eq.1 ) then + valmin = enindi(iaux,1) + valmax = enindi(iaux,1) + else + valmin = min (valmin,enindi(iaux,1)) + valmax = max (valmax,enindi(iaux,1)) + endif + endif +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) 'min', valmin + write (ulsort,texte(langue,5)) 'max', valmax +#endif +c + endif +c +c 2.3. ==> arrondis des valeurs extremes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARRO', nompro +#endif + call utarro ( valmin, valmax, vamiar, vamaar, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 'min', vamiar + write (ulsort,texte(langue,6)) 'max', vamaar +#endif +c + valdif = ( vamaar - vamiar ) * 1.05d0 + if ( valdif.le.zeroma ) then + consta = .true. + else + consta = .false. + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'valdif', valdif + write (ulsort,99001) 'consta', consta +#endif +c + endif +c +c==== +c 3. Ecriture des bilans +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Ecriture des bilans ; codret', codret +#endif +c +10100 format(/,5x,64('*')) +10200 format( 5x,64('*')) +11100 format( 5x,'* ',a54,' *') +11200 format( 5x,'*',14x,2a8,i10,1x,a14,7x,'*') +c +c 3.1. ==> Les fichiers +c 3.1.1. ==> Le fichier d'historique +c + if ( codret.eq.0 ) then +c +c 1234567890 + saux10 = 'indic.'//suffix(2,typenh)(1:4) + iaux = 3 + jaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI_hist', nompro +#endif + call utulbi ( ulhist, nomflo, lnomfl, + > iaux, saux10, nbiter, jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.1.2. ==> Le fichier pour xmgrace +c + if ( .not.consta ) then +c + if ( codret.eq.0 ) then +c + saux10 = 'indic.'//suffix(2,typenh)(1:4) + iaux = 2 + jaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI_xmgr', nompro +#endif + call utulbi ( ulxmgr, nomflo, lnomfl, + > iaux, saux10, nbiter, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c 3.1.3. ==> Le fichier des valeurs brutes +c + if ( codret.eq.0 ) then +c +c 1234 56 7890 + saux10 = 'ind.'//suffix(4,typenh)(1:2)//' ' + iaux = 10 + jaux = -1 + write (ulsort,texte(langue,3)) 'UTULBI_brut', nompro + call utulbi ( ulbrut, nomflo, lnomfl, + > iaux, saux10, nbiter, jaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c 3.2. ==> Les en-tetes +c + if ( codret.eq.0 ) then +c +c 123456789012345678901234567890123456789012345678901234' + mess54(1,1) = + > ' Champ pilotant l''adaptation ' + mess54(1,2) = + > ' Valeur constante : ' +c + mess54(2,1) = + > ' Governing field over the mesh ' + mess54(2,2) = + > ' Constant value : ' +c + mess08(1,1) = 'Valeur s' + mess08(1,2) = 'ur les ' +c + mess08(2,1) = 'Value ov' + mess08(2,2) = 'er the ' +c + write (ulhist,10100) + write (ulhist,11100) mess54(langue,1) + write (ulhist,11200) mess08(langue,1), mess08(langue,2), + > nbval, mess14(langue,3,typenh) +c + endif +c +c 3.3. ==> message si constant +c + if ( codret.eq.0 ) then +c + if ( consta ) then +c + write (ulhist,10200) + write (mess54(langue,2)(32:42),'(f11.4)') valmin + write (ulhist,11100) mess54(langue,2) + write (ulhist,10200) +c + endif +c + endif +c +c 3.4. ==> Classement +c + if ( .not.consta ) then +c + if ( codret.eq.0 ) then +c + valdif = (vamaar-vamiar)/dble(nbclas) + rclass(0) = vamiar + do 34 , iaux = 1 , nbclas-1 + rclass(iaux) = vamiar + valdif*dble(iaux) + 34 continue + rclass(nbclas) = vamaar +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'valdif', valdif + do 3434 , iaux = 0 , nbclas + write (ulsort,90024) 'rclass', iaux, rclass(iaux) + 3434 continue +#endif +c + endif +c + if ( codret.eq.0 ) then +c + titcou(1) = mess08(langue,1) + titcou(2) = mess08(langue,2)(1:7)//mess14(langue,3,typenh)(1:1) + titcou(3) = mess14(langue,3,typenh)(2:9) + titcou(4) = mess14(langue,3,typenh)(10:14)//' ' + titcou(5) = mess08(langue,1)(1:6) + xlow = vamiar + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCRHI', nompro +#endif + call utcrhi ( nbclas, rclass, iclass, histog, + > nbval, iaux, rmem(adtra1), ival, + > titcou, xlow, ulhist, ulxmgr, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +c 3.5. ==> Ecriture des valeurs brutes +c + if ( codret.eq.0 ) then +c + do 35 , iaux = 1 , nbval + write(ulbrut,92010) rmem(adtra1+iaux-1) + 35 continue +c + endif +#endif +c +c 3.6. ==> Fermeture +c + if ( codret.eq.0 ) then +c + call gufeul ( ulhist, codre1 ) + if ( .not.consta ) then + call gufeul ( ulxmgr, codre2 ) + else + codre2 = 0 + endif + codre3 = 0 +#ifdef _DEBUG_HOMARD_ + call gufeul ( ulbrut, codre3 ) +#endif +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c==== +c 4. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinbi.F b/src/tool/Decision/deinbi.F new file mode 100644 index 00000000..4edb3131 --- /dev/null +++ b/src/tool/Decision/deinbi.F @@ -0,0 +1,270 @@ + subroutine deinbi ( nbvent, ncmpin, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, + > hesupp, heindi, + > pysupp, pyindi, + > pesupp, peindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisations - BIlan +c -- -- -- +c impression des histogrammes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type . +c . . . . d'element au sens HOMARD avec indicateur . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . e . nbnoto . valeurs pour les noeuds . +c . arsupp . e . nbarto . support pour les aretes . +c . arindi . e . nbarto . valeurs pour les aretes . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . e . nbtrto . valeurs pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . e . nbquto . valeurs pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . e . nbteto . valeurs pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . e . nbheto . valeurs pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . e . nbpyto . valeurs pour les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINBI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbvent(-1:7) + integer ncmpin + integer nosupp(nbnoto) + integer arsupp(nbarto) + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + integer ulsort, langue, codret +c + double precision noindi(nbnoto,ncmpin) + double precision arindi(nbarto,ncmpin) + double precision trindi(nbtrto,ncmpin) + double precision quindi(nbquto,ncmpin) + double precision teindi(nbteto,ncmpin) + double precision heindi(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin) + double precision peindi(nbpeto,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. impression selon le type d'entite +c==== +c +c 2.1. ==> au moins un indicateur est exprime sur les tetraedres +c + iaux = 3 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_te', nompro +#endif + call deinb1 ( iaux, nbteto, ncmpin, + > tesupp, teindi, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> au moins un indicateur est exprime sur les quadrangles +c + iaux = 4 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_qu', nompro +#endif + call deinb1 ( iaux, nbquto, ncmpin, + > qusupp, quindi, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> au moins un indicateur est exprime sur les triangles +c + iaux = 2 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_tr', nompro +#endif + call deinb1 ( iaux, nbtrto, ncmpin, + > trsupp, trindi, + > ulsort, langue, codret) +c + endif +c +c 2.4. ==> au moins un indicateur est exprime sur les aretes +c + iaux = 1 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_ar', nompro +#endif + call deinb1 ( iaux, nbarto, ncmpin, + > arsupp, arindi, + > ulsort, langue, codret) +c + endif +c +c 2.5. ==> au moins un indicateur est exprime sur les noeuds +c + iaux = -1 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_no', nompro +#endif + call deinb1 ( iaux, nbnoto, ncmpin, + > nosupp, noindi, + > ulsort, langue, codret) +c + endif +c +c 2.5. ==> au moins un indicateur est exprime sur les pyramides +c + iaux = 5 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_py', nompro +#endif + call deinb1 ( iaux, nbpyto, ncmpin, + > pysupp, pyindi, + > ulsort, langue, codret) +c + endif +c +c 2.5. ==> au moins un indicateur est exprime sur les hexaedres +c + iaux = 6 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_he', nompro +#endif + call deinb1 ( iaux, nbheto, ncmpin, + > hesupp, heindi, + > ulsort, langue, codret) +c + endif +c +c 2.6. ==> au moins un indicateur est exprime sur les pentaedres +c + iaux = 7 + if ( nbvent(iaux).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINB1_pe', nompro +#endif + call deinb1 ( iaux, nbpeto, ncmpin, + > pesupp, peindi, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinfi.F b/src/tool/Decision/deinfi.F new file mode 100644 index 00000000..01c4751f --- /dev/null +++ b/src/tool/Decision/deinfi.F @@ -0,0 +1,527 @@ + subroutine deinfi ( option, obfiad, + > decare, decfac, iniada, + > filtar, filtfa, + > povoso, voisom, + > noempo, + > somare, + > aretri, + > arequa, + > tritet, + > quahex, + > facpyr, + > facpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisations - FIltrage +c -- -- -- +c ______________________________________________________________________ +c Modification des decisions pour tenir compte du filtrage +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 0 : on retire les entites filtrees . +c . . . . 1 : on ajoute les entites filtrees . +c . obfiad . e . char*8 . memorisation du filtrage de l'adaptation . +c . decare . es .0:nbarto. decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . iniada . e . 1 . initialisation de l'adaptation . +c . . . . 0 : on garde tout (defaut) . +c . . . .-1 : reactivation des mailles ou aucun . +c . . . . indicateur n'est defini . +c . . . . 1 : raffinement des mailles ou aucun . +c . . . . indicateur n'est defini . +c . filtar . a . nbarto . filtrage des aretes . +c . filtfa . a . -nbquto. filtrage sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINFI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option +c + character*8 obfiad +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer iniada + integer filtar(nbarto), filtfa(-nbquto:nbtrto) + integer povoso(0:nbnoto), voisom(*) + integer noempo(nbmpto) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6) + integer facpyr(nbpycf,5) + integer facpen(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer kdeb, kfin + integer larete, lesomm + integer nbvent, adfilt + integer typenh + integer valdef, valmod + integer nbpass +c + character*5 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data nbpass / 0 / +c ______________________________________________________________________ +c +c==== +c 1. Initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> Les messages +c + texte(1,4) = '(5x,''Filtrage'',i2)' + texte(1,5) = '(5x,''Retrait des entites filtrees'')' + texte(1,6) = '(5x,''Ajout des entites filtrees'')' + texte(1,7) = '(''Filtrage pour les '',a)' +c + texte(2,4) = '(5x,''Filtering #'',i2)' + texte(2,5) = '(5x,''Removal of filtered entities'')' + texte(2,6) = '(5x,''Addition of filtered entities'')' + texte(2,7) = '(''Filtering for the '',a)' +c +#include "impr03.h" +c + nbpass = nbpass + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpass + write (ulsort,texte(langue,5+option)) +#endif +c + codret = 0 +c +c 1.2. ==> Au depart rien n'est retenu +c + if ( option.eq.0 ) then + valdef = 1 + valmod = 0 + elseif ( option.eq.1 ) then + valdef = 0 + valmod = 1 + else + codret = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option + write (ulsort,90002) 'valdef', valdef + write (ulsort,90002) 'valmod', valmod +#endif +c + if ( codret.eq.0 ) then +c + do 121 , iaux = 1 , nbarto + filtar(iaux) = valdef + 121 continue +c + do 122 , iaux = -nbquto , nbtrto + filtfa(iaux) = valdef + 122 continue +c + endif +c +c==== +c 2. Boucle sur tous les types d'entites mailles (cf. vcfia0) +c==== +cgn write (ulsort,90003) 'obfiad', obfiad +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, obfiad ) +#endif +c + do 21 , typenh = -1 , 7 +c +c 2.1. ==> Nombre de valeurs +c + if ( codret.eq.0 ) then +c + iaux = typenh + 2 + call gmliat ( obfiad, iaux, nbvent, codret ) +c + endif +c +c 2.2. ==> Adresse des valeurs s'il y en a +c + if ( codret.eq.0 ) then +c + if ( nbvent.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,typenh) +#endif +c + if ( codret.eq.0 ) then +c + iaux = typenh + 2 + call utench ( iaux, 'g', jaux, saux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + saux = '.Tab'//saux(1:1) + call gmadoj ( obfiad//saux, adfilt, iaux, codret ) + adfilt = adfilt - 1 +c + endif +c + endif +c + endif +c +c 2.3. ==> Prise en compte selon le type de mailles +c On boucle sur le nombre de mailles courantes. Ce n'est pas +c toujours egal au nombre de valeurs du fait de la suppression +c eventuelle de mailles de mise en conformite. Ce n'est pas +c grave car dans la creation de obfiad (vcfiad), on a pris en +c compte toutes les entites, quel que soit leur statut. +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. '//mess14(langue,3,typenh)//' codret', + > codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvent.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, obfiad//saux ) +#endif +c +c 2.3.1. ==> Les sommets : on traite les aretes dont les deux +c extremites sont dans le filtre +c + if ( typenh.eq.-1 ) then +c + do 231 , iaux = 1 , nbarto + if ( imem(adfilt+somare(1,iaux)).ne.0 .and. + > imem(adfilt+somare(2,iaux)).ne.0 ) then +cgn write (ulsort,90002) 'arete ', iaux + filtar(iaux) = valmod + endif + 231 continue +c +c 2.3.2. ==> Les mailles-points : +c Pour une maille-point retenue, on parcourt toutes les +c aretes qui ont le noeud sous-jacent pour extremite. Pour +c chacune de ces aretes, on regarde l'autre sommet. Si une +c maille-point retenue est basee sur cet autre sommet, on +c declare l'arete comme faisant partie des candidats a +c l'adaptation. +c Remarque : il n'est pas trop grave de faire la double +c boucle car il y a peu de mailles-points ! +c + elseif ( typenh.eq.0 ) then +c + do 232 , iaux = 1 , nbmpto +c + if ( imem(adfilt+iaux).ne.0 ) then +c + jaux = noempo(iaux) + kdeb = povoso(jaux-1) + 1 + kfin = povoso(jaux) +c + do 2321 , kaux = kdeb, kfin + larete = voisom(kaux) + if ( somare(1,larete).eq.jaux ) then + lesomm = somare(2,larete) + else + lesomm = somare(1,larete) + endif + do 23211 , laux = 1 , nbmpto + if ( noempo(laux).eq.lesomm ) then + if ( imem(adfilt+laux).ne.0 ) then + filtar(larete) = valmod + goto 232 + endif + endif +23211 continue + 2321 continue +c + endif +c + 232 continue +c +c 2.3.3. ==> Les aretes : chacune est traitee +c + elseif ( typenh.eq.1 ) then +c + do 233 , iaux = 1 , nbarto +cgn write (ulsort,90002) 'arete ', iaux + if ( imem(adfilt+iaux).ne.0 ) then +cgn write (ulsort,90002) '==> passage a', valmod + filtar(iaux) = valmod + endif + 233 continue +c +c 2.3.4. ==> Les triangles : chacun est traite, de meme que ses aretes +c + elseif ( typenh.eq.2 ) then +c + do 234 , iaux = 1 , nbtrto +cgn write (ulsort,90002) 'triangle ', iaux,imem(adfilt+iaux),decfac(iaux) + if ( imem(adfilt+iaux).ne.0 ) then +cgn write (ulsort,90002) '==> passage a', valmod +cgn write (ulsort,90002) '==> modif aretes', (aretri(iaux,jaux),jaux=1,3) + filtfa(iaux) = valmod + filtar(aretri(iaux,1)) = valmod + filtar(aretri(iaux,2)) = valmod + filtar(aretri(iaux,3)) = valmod + endif + 234 continue +c +c 2.3.5. ==> Les tetraedres : chacune de ses faces et de ses aretes est +c traitee +c + elseif ( typenh.eq.3 ) then +c + do 235 , iaux = 1 , nbteto +cgn print *,'tetr',iaux,imem(adfilt+iaux) + if ( imem(adfilt+iaux).ne.0 ) then + do 2351 , jaux = 1 , 4 + kaux = tritet(iaux,jaux) + filtfa(kaux) = valmod + filtar(aretri(kaux,1)) = valmod + filtar(aretri(kaux,2)) = valmod + filtar(aretri(kaux,3)) = valmod + 2351 continue + endif + 235 continue +c +c 2.3.6. ==> Les quadrangles : chacun est traite, de meme que ses aretes +c + elseif ( typenh.eq.4 ) then +c + do 236 , iaux = 1 , nbquto + if ( imem(adfilt+iaux).ne.0 ) then + filtfa(-iaux) = valmod + filtar(arequa(iaux,1)) = valmod + filtar(arequa(iaux,2)) = valmod + filtar(arequa(iaux,3)) = valmod + filtar(arequa(iaux,4)) = valmod + endif + 236 continue +c +c 2.3.7. ==> Les pyramides : chacune de ses faces et de ses aretes est +c traitee +c Remarque : comme on affecte valmod a toutes les aretes des +c triangles, il est inutile de se preoccuper des +c aretes du quadrangle car elles sont deja traitees +c + elseif ( typenh.eq.5 ) then +c + do 237 , iaux = 1 , nbpyto + if ( imem(adfilt+iaux).ne.0 ) then + do 2371 , jaux = 1 , 4 + kaux = facpyr(iaux,jaux) + filtfa(kaux) = valmod + filtar(aretri(kaux,1)) = valmod + filtar(aretri(kaux,2)) = valmod + filtar(aretri(kaux,3)) = valmod + 2371 continue + kaux = facpyr(iaux,5) + filtfa(-kaux) = valmod + endif + 237 continue +c +c 2.3.8. ==> Les hexaedres : chacune de ses faces et de ses aretes est +c traitee +c + elseif ( typenh.eq.6 ) then +c + do 238 , iaux = 1 , nbheto + if ( imem(adfilt+iaux).ne.0 ) then +cgn write(*,*)'.. hexaedre', iaux + do 2381 , jaux = 1 , 6 + kaux = quahex(iaux,jaux) + filtfa(-kaux) = valmod + filtar(arequa(kaux,1)) = valmod + filtar(arequa(kaux,2)) = valmod + filtar(arequa(kaux,3)) = valmod + filtar(arequa(kaux,4)) = valmod +cgn write(*,*)'.... face', kaux + 2381 continue + endif + 238 continue +c +c 2.3.9. ==> Les pentaedres : chacune de ses faces et de ses aretes est +c traitee +c Remarque : comme on affecte valmod a toutes les aretes des +c quadrangles, il est inutile de se preoccuper des +c aretes des triangles car elles sont deja traitees +c + elseif ( typenh.eq.7 ) then +c + do 239 , iaux = 1 , nbpeto +cgn write(ulsort,*)'.... pentaedre', iaux + if ( imem(adfilt+iaux).ne.0 ) then + do 2391 , jaux = 1 , 2 + kaux = facpen(iaux,jaux) + filtfa(kaux) = valmod + 2391 continue + do 2392 , jaux = 3 , 5 + kaux = facpen(iaux,jaux) +cgn write(ulsort,*)'.... face', kaux +cgn write(ulsort,*)'.... aretes', arequa(kaux,1), +cgn > arequa(kaux,2),arequa(kaux,3),arequa(kaux,4) + filtfa(-kaux) = valmod + filtar(arequa(kaux,1)) = valmod + filtar(arequa(kaux,2)) = valmod + filtar(arequa(kaux,3)) = valmod + filtar(arequa(kaux,4)) = valmod + 2392 continue + endif + 239 continue +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. Applications aux decisions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Applications ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( iniada.eq.1 ) then + valmod = 2 + else + valmod = iniada + endif +c + do 31 , iaux = 1 , nbarto + if ( filtar(iaux).eq.0 ) then +cgn if ( decare(iaux).gt.0 ) then +cgn write(ulsort,*)' suppression pour arete', iaux + decare(iaux) = valmod +cgn endif + endif + 31 continue +c + if ( iniada.eq.1 ) then + valmod = 4 + else + valmod = iniada + endif +c + do 32 , iaux = -nbquto , nbtrto + if ( filtfa(iaux).eq.0 ) then +cgn if ( decfac(iaux).gt.0 ) then + decfac(iaux) = valmod +cgn endif + endif + 32 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deini0.F b/src/tool/Decision/deini0.F new file mode 100644 index 00000000..4f1e3b10 --- /dev/null +++ b/src/tool/Decision/deini0.F @@ -0,0 +1,507 @@ + subroutine deini0 ( nohind, typind, ncmpin, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > adnoin, adnorn, adnosu, + > adarin, adarrn, adarsu, + > adtrin, adtrrn, adtrsu, + > adquin, adqurn, adqusu, + > adtein, adtern, adtesu, + > adhein, adhern, adhesu, + > adpyin, adpyrn, adpysu, + > adpein, adpern, adpesu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INITialisations - phase 0 +c -- --- - +c ______________________________________________________________________ +c Recuperation des adresses pour les indicateurs +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . typind . s . 1 . type de valeurs . +c . . . . 2 : entieres . +c . . . . 3 : reelles . +c . ncmpin . s . 1 . nombre de composantes de l'indicateur . +c . nbvent . s . 1 . nombre de valeurs pour l'entite . +c . adensu . s . 1 . adresse du support . +c . adenin . s . 1 . adresse des valeurs entieres . +c . adenrn . s . 1 . adresse des valeurs reelles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINI0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#ifdef _DEBUG_HOMARD_ +#include "nombar.h" +#include "nombno.h" +#include "enti01.h" +#endif +c +c 0.3. ==> arguments +c + character*8 nohind +c + integer typind, ncmpin + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen + integer adnoin, adnorn, adnosu + integer adarin, adarrn, adarsu + integer adtrin, adtrrn, adtrsu + integer adquin, adqurn, adqusu + integer adtein, adtern, adtesu + integer adhein, adhern, adhesu + integer adpyin, adpyrn, adpysu + integer adpein, adpern, adpesu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer typin0(-1:7) + integer ncmpi0(-1:7) +c + integer codre0 +c +#ifdef _DEBUG_HOMARD_ + integer kaux + character*15 saux15 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==>les messages +c + texte(1,4) = '(''La structure nohind est inconnue.'')' + texte(1,5) = '(a,'' pour les '',a,'' :'',i4)' + texte(1,6) = '(''Les types d''''indicateurs sont incoherents.'')' + texte(1,7) = '(''Les nombres de composantes sont incoherents.'')' +c + texte(2,4) = '(''nohind structure is unknown.'')' + texte(2,5) = '(a,'' for the '',a,'':'',i4)' + texte(2,6) = '(''Non coherent types for indicators.'')' + texte(2,7) = '(''Non coherent numbers for components.'')' +c +#include "impr03.h" +c +c 1.2. ==> les types d'indicateurs : aucun pour le moment +c + do 12 , iaux = -1 , 7 + typin0(iaux) = 0 + ncmpi0(iaux) = 0 + 12 continue +c + codret = 0 +c +c==== +c 2. La structure generale de l'indicateur d'erreur +c==== +c + call gmobal ( nohind, codre0 ) + if ( codre0.ne.1 ) then + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nohind ) + do 23000 , iaux = 1 , 1 +cgn do 23000 , iaux = 1 , 2 + if ( iaux.eq.1 ) then + saux15(8:15) = 'ValeursR' + else + saux15(8:15) = 'ValeursE' + endif + do 2999 , jaux = -1, 7 + kaux = 0 + if ( jaux.eq.-1 ) then + kaux = nbnoto + elseif ( jaux.eq.1 ) then + kaux = nbarto + elseif ( jaux.eq.2 ) then + kaux = nbtrto + elseif ( jaux.eq.3 ) then + kaux = nbteto + elseif ( jaux.eq.4 ) then + kaux = nbquto + elseif ( jaux.eq.5 ) then + kaux = nbpyto + elseif ( jaux.eq.6 ) then + kaux = nbheto + elseif ( jaux.eq.7 ) then + kaux = nbpeto + endif + if ( kaux.gt.0 ) then + saux15(1:7) = '.'//suffix(1,jaux)(1:5)//'.' + call gmobal ( nohind//saux15, codre0 ) + if ( codre0.eq.2 ) then +cgn call gmprsx ( nompro, nohind//saux15 ) + call gmprot (nompro, nohind//saux15, 1, min(kaux,50) ) + if ( kaux.gt.50 ) then + call gmprot (nompro, nohind//saux15, + > max(1,kaux-49),kaux) + endif + endif + endif + 2999 continue +23000 continue + endif +#endif +c +c==== +c 3. Les adresses par type d'entites +c Le type (entier/reel) doit etre le meme pour toutes +c==== +c +c 3.1. ==> noeuds +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_no', nompro +#endif + iaux = -30 + jaux = -1 + call utad31 ( iaux, nohind, jaux, + > nbvnoe, ncmpin, + > adnosu, adnoin, adnorn, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c +c 3.2. ==> aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_ar', nompro +#endif + iaux = -30 + jaux = 1 + call utad31 ( iaux, nohind, jaux, + > nbvare, ncmpin, + > adarsu, adarin, adarrn, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c +c 3.3. ==> triangles +c + if ( nbtrto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_tr', nompro +#endif + iaux = -30 + jaux = 2 + call utad31 ( iaux, nohind, jaux, + > nbvtri, ncmpin, + > adtrsu, adtrin, adtrrn, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvtri = 0 +c + endif +c +c 3.4. ==> quadrangles +c + if ( nbquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_qu', nompro +#endif + iaux = -30 + jaux = 4 + call utad31 ( iaux, nohind, jaux, + > nbvqua, ncmpin, + > adqusu, adquin, adqurn, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvqua = 0 +c + endif +c +c 3.5. ==> tetraedres +c + if ( nbteto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_te', nompro +#endif + iaux = -30 + jaux = 3 + call utad31 ( iaux, nohind, jaux, + > nbvtet, ncmpin, + > adtesu, adtein, adtern, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvtet = 0 +c + endif +c +c 3.6. ==> pyramides +c + if ( nbpyto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_py', nompro +#endif + iaux = -30 + jaux = 5 + call utad31 ( iaux, nohind, jaux, + > nbvpyr, ncmpin, + > adpysu, adpyin, adpyrn, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvpyr = 0 +c + endif +c +c 3.7. ==> hexaedres +c + if ( nbheto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_he', nompro +#endif + iaux = -30 + jaux = 6 + call utad31 ( iaux, nohind, jaux, + > nbvhex, ncmpin, + > adhesu, adhein, adhern, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvhex = 0 +c + endif +c +c 3.8. ==> pentaedres +c + if ( nbpeto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD31_pe', nompro +#endif + iaux = -30 + jaux = 7 + call utad31 ( iaux, nohind, jaux, + > nbvpen, ncmpin, + > adpesu, adpein, adpern, typind, + > ulsort, langue, codret ) + typin0(jaux) = typind + ncmpi0(jaux) = ncmpin +c + endif +c + else +c + nbvpen = 0 +c + endif +c +c==== +c 4. Le type (entier/reel) doit etre le meme pour toutes les entites +c Idem pour le nombre de composantes +c==== +c + if ( codret.eq.0 ) then +c + typind = 0 + ncmpin = 0 + do 41 , iaux = -1 , 7 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) 'typind', + > mess14(langue,3,iaux), typin0(iaux) + write (ulsort,texte(langue,5)) 'ncmpin', + > mess14(langue,3,iaux), ncmpi0(iaux) +#endif + if ( typin0(iaux).ne.0 ) then + if ( typind.eq.0 ) then + typind = typin0(iaux) + else + if ( typind.ne.typin0(iaux) ) then + codret = 2 + endif + endif + endif + if ( ncmpi0(iaux).ne.0 ) then + if ( ncmpin.eq.0 ) then + ncmpin = ncmpi0(iaux) + else + if ( ncmpin.ne.ncmpi0(iaux) ) then + codret = 3 + endif + endif + endif +c + 41 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) + >'nbvnoe, nbvare, nbvtri, nbvqua, nbvtet, nbvhex, nbvpyr, nbvpen', + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.1 ) then + write (ulsort,texte(langue,4)) + elseif ( codret.eq.2 ) then + do 51 , iaux = -1 , 7 +#ifdef _DEBUG_HOMARD_ + if ( typin0(iaux).ge.0 ) then +#else + if ( typin0(iaux).ne.0 ) then +#endif + write (ulsort,texte(langue,5)) 'typind', + > mess14(langue,3,iaux), typin0(iaux) + endif + 51 continue + write (ulsort,texte(langue,6)) + elseif ( codret.eq.3 ) then + do 52 , iaux = -1 , 7 +#ifdef _DEBUG_HOMARD_ + if ( ncmpi0(iaux).ge.0 ) then +#else + if ( ncmpi0(iaux).ne.0 ) then +#endif + write (ulsort,texte(langue,5)) 'ncmpin', + > mess14(langue,3,iaux), ncmpi0(iaux) + endif + 52 continue + write (ulsort,texte(langue,7)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deini2.F b/src/tool/Decision/deini2.F new file mode 100644 index 00000000..b012fc07 --- /dev/null +++ b/src/tool/Decision/deini2.F @@ -0,0 +1,229 @@ + subroutine deini2 ( nohind, typind, ncmpin, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, + > adquin, adqurn, adqusu, + > adhein, adhern, adhesu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INITialisations - phase 2 +c -- --- - +c ______________________________________________________________________ +c Allocations de structures supplementaires pour accueillir des valeurs +c d'indicateurs en prevision de la suppression de la conformite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . typind . e . 1 . type de valeurs . +c . . . . 2 : entieres . +c . . . . 3 : reelles . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . nbvent . es . 1 . nombre de valeurs pour l'entite . +c . adensu . es . 1 . adresse du support . +c . adenin . es . 1 . adresse des valeurs entieres . +c . adenrn . es . 1 . adresse des valeurs reelles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINI2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombqu.h" +#include "nombhe.h" +#ifdef _DEBUG_HOMARD_ +#include "enti01.h" +#endif +c +c 0.3. ==> arguments +c + character*8 nohind +c + integer typind, ncmpin + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr + integer adquin, adqurn, adqusu + integer adhein, adhern, adhesu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer typenh +c +#ifdef _DEBUG_HOMARD_ + integer codre0 +#endif + character*8 motaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Type d''''indicateur inconnu :'',i8)' +c + texte(2,4) = '(''Indicator type is unknown :'',i8)' +c + if ( typind.eq.2 ) then + motaux = 'ValeursE' + elseif ( typind.eq.3 ) then + motaux = 'ValeursR' + else + write (ulsort,texte(langue,4)) typind + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nohind ) + do 1999 , iaux = 4, 6, 2 + motaux = '.'//suffix(1,iaux)(1:5)//' ' + call gmobal ( nohind//motaux, codre0 ) + if ( codre0.eq.1 ) then + call gmprsx (nompro, nohind//motaux ) + endif + 1999 continue + endif +#endif +c +c==== +c 2. Les quadrangles +c Dans le cas suivant : +c . Des quadrangles existent +c . Aucun indicateur n'a ete defini sur les quadrangles +c . Un indicateur a ete defini sur les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. quadrangles ; codret = ', codret +#endif +c + if ( nbquto.ne.0 .and. nbvqua.eq.0 .and. nbvtri.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_qu', nompro +#endif + typenh = 4 + call utalih ( nohind, typenh, nbquto, ncmpin, motaux, + > adquin, adqusu, + > ulsort, langue, codret) +c + if ( typind.eq.2 ) then + adquin = adquin + else + adqurn = adquin + endif + nbvqua = 1 +c + endif +c + endif +c +c==== +c 3. Les hexaedres +c Dans le cas suivant : +c . Des hexaedres existent +c . Aucun indicateur n'a ete defini sur les hexaedres +c . Un indicateur a ete defini sur les tetraedres ou les pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. hexaedres ; codret = ', codret +#endif +c + if ( nbheto.ne.0 .and. nbvhex.eq.0 .and. + > ( nbvtet.ne.0 .or. nbvpyr.ne.0 ) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_he', nompro +#endif + typenh = 6 + call utalih ( nohind, typenh, nbheto, ncmpin, motaux, + > adhein, adhesu, + > ulsort, langue, codret) +c + if ( typind.eq.2 ) then + adhein = adhein + else + adhern = adhein + endif + nbvhex = 1 +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deini3.F b/src/tool/Decision/deini3.F new file mode 100644 index 00000000..35fa4401 --- /dev/null +++ b/src/tool/Decision/deini3.F @@ -0,0 +1,187 @@ + subroutine deini3 ( nohind, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INITialisations - phase 3 +c -- --- - +c ______________________________________________________________________ +c Suppressions de structures apres suppression de la conformite : +c on supprime la branche d'une entite s'il n'y en a plus (nbento=0) et +c s'il y avait un indicateur auparavant (nbvent>0) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . nbvent . es . 1 . nombre de valeurs pour l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINI3' ) +c +#include "nblang.h" +#include "impr02.h" +c +c 0.2. ==> communs +c +#include "enti01.h" +#include "envex1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*8 nohind +c + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Suppression de la branche sur les '',a)' +c + texte(2,4) = '(''. Suppression of branch for '',a)' +c +c==== +c 2. Par type de mailles +c==== +c + do 21 , iaux = 2, 7 +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.2 ) then + jaux = nbvtri + kaux = nbtrto + elseif ( iaux.eq.3 ) then + jaux = nbvtet + kaux = nbteto + elseif ( iaux.eq.4 ) then + jaux = nbvqua + kaux = nbquto + elseif ( iaux.eq.5 ) then + jaux = nbvpyr + kaux = nbpyto + elseif ( iaux.eq.6 ) then + jaux = nbvhex + kaux = nbheto + else + jaux = nbvpen + kaux = nbpeto + endif +c + if ( jaux.ne.0 .and. kaux.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,iaux) +#endif + call gmsgoj ( nohind//'.'//suffix(1,iaux)(1:5) , codret ) +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.2 ) then + nbvtri = 0 + elseif ( iaux.eq.3 ) then + nbvtet = 0 + elseif ( iaux.eq.4 ) then + nbvqua = 0 + elseif ( iaux.eq.5 ) then + nbvpyr = 0 + elseif ( iaux.eq.6 ) then + nbvhex = 0 + else + nbvpen = 0 + endif +c + else +c + jaux = iaux +c + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,jaux) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deini4.F b/src/tool/Decision/deini4.F new file mode 100644 index 00000000..41123526 --- /dev/null +++ b/src/tool/Decision/deini4.F @@ -0,0 +1,691 @@ + subroutine deini4 ( tyconf, + > decare, decfac, + > hetare, filare, + > aretri, hettri, filtri, + > voltri, pypetr, + > arequa, hetqua, + > volqua, + > tritet, quahex, facpen, facpyr, + > tabaux, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur entier +c -- -- +c ______________________________________________________________________ +c +c but : correction des decisions +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . decare . es .0:nbarto. decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . tabaux . a . -nbquto. tableau auxiliaire sur les faces . +c . . . :nbtrto. (quad. + tri.) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINI4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto), filare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), filtri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer arequa(nbquto,4), hetqua(nbquto) + integer volqua(2,nbquto) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) + integer facpyr(nbpycf,5) + integer tabaux(-nbquto:nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lehexa, letetr, lapyra, lepent, letria, lequad, lequa0 + integer etat + integer nbquad, iquad, liquad(11) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Correction pour le mode conforme - phase'',i2)' + texte(1,5) = '(5x,''Correction pour le mode non conforme'')' +c + texte(2,4) = '(5x,''Correction for conformal mode - phase #'',i1)' + texte(2,5) = '(5x,''Correction for non conformal mode'')' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'entree de ',nompro + do 1111 , iaux = 1 , nbarto + if ( iaux.eq.-50 .or. iaux.eq.-51 .or. + > iaux.eq.-53 .or. iaux.eq.-57 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +cgn if ( decare(iaux).ne.0 ) then +cgn write (ulsort,90001) '.. arete e/d', iaux, +cgn > hetare(iaux), decare(iaux) +cgn endif + 1111 continue +#endif +c +c==== +c 2. Correction pour le mode conforme - phase 1 +c A. Il est possible que l'on demande une reactivation de +c triangles ou de quadrangles alors que leurs aretes +c sont deja decoupees a 2 niveaux. +c Il faut alors annuler la demande de deraffinement. +c B. Du fait de filtrages, il est possible qu'une demande de +c raffinement sur une face soit liee a une restriction sur une +c arete. +c Il faut alors imposer le raffinement de l'arete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. correction conforme 1 ; codret', codret +#endif +c + if ( ( tyconf.eq.0 ) .or. ( tyconf.eq.-1 ) ) then +c + write(ulsort,texte(langue,4)) 1 +c +c 2.1. ==> Aucune correction de deraffinement au depart +c + do 21 , iaux = -nbquto, nbtrto + tabaux(iaux) = 0 + 21 continue +c +c 2.2. ==> Corrections pour les triangles +c +cgn write(ulsort,90002) 'nbtrto', nbtrto + do 22 , iaux = 1, nbtrto +c +c 2.2.1. ==> Le triangle est a deraffiner +c + if ( decfac(iaux).eq.-1 ) then +c +c 2.2.1.1. ==> On voudrait reactiver le triangle, mais au moins une +c de ses aretes est coupee deux fois ==> impossible +c +cgn write(ulsort,90015) 'Triangle',iaux,', etat',hettri(iaux) + if ( mod(hetare(aretri(iaux,1)),10).gt.2 .or. + > mod(hetare(aretri(iaux,2)),10).gt.2 .or. + > mod(hetare(aretri(iaux,3)),10).gt.2 ) then + tabaux(iaux) = 1 +cgn write(ulsort,90002) 'Annulation reactivation du triangle',iaux + endif +c +c 2.2.1.2. ==> Prise en compte du voisinage quand le fils central +c du triangle a une de ses aretes deja coupee : il faut +c traiter les faces des volumes qui s'appuient sur +c ce triangle fils +c +cgn write(ulsort,*) 'filtri(',iaux,') :',filtri(iaux) +cgn write(ulsort,90002) 'hetare(aretri(filtri(iaux),1))', +cgn > hetare(aretri(filtri(iaux),1)) +cgn write(ulsort,90002) 'hetare(aretri(filtri(iaux),1))', +cgn > hetare(aretri(filtri(iaux),1)) +cgn write(ulsort,90002) 'hetare(aretri(filtri(iaux),2))', +cgn > hetare(aretri(filtri(iaux),2)) +cgn write(ulsort,90002) 'hetare(aretri(filtri(iaux),3))', +cgn > hetare(aretri(filtri(iaux),3)) + if ( nbteto.gt.0 .or. nbpeto.gt.0 .or. nbpyto.gt.0 ) then +c + if ( mod(hettri(iaux),10).eq.9 .or. + > mod(hetare(aretri(filtri(iaux),1)),10).gt.0 .or. + > mod(hetare(aretri(filtri(iaux),2)),10).gt.0 .or. + > mod(hetare(aretri(filtri(iaux),3)),10).gt.0 ) then +c + do 2212 , jaux = 1, 2 +c + letetr = voltri(jaux,iaux) + if ( letetr.gt.0 ) then +cgn write(ulsort,90002) 'Tetraedre', letetr + do 22121 , kaux = 1, 4 + letria = tritet(letetr,kaux) + tabaux(letria) = 1 +22121 continue + elseif ( letetr.lt.0 ) then + lapyra = pypetr(1,-letetr) + if ( lapyra.ne.0 ) then +cgn write(ulsort,90002) 'Pyramide', lapyra + do 22122 , kaux = 1, 4 + letria = facpyr(lapyra,kaux) + tabaux(letria) = 1 +22122 continue + tabaux(-facpyr(lapyra,5)) = 1 + endif + lepent = pypetr(2,-letetr) + if ( lepent.ne.0 ) then +cgn write(ulsort,90002) 'Pentaedre', lepent + do 22123 , kaux = 1, 2 + letria = facpen(lepent,kaux) + tabaux(letria) = 1 +22123 continue + do 22124 , kaux = 3, 5 + lequad = facpen(lepent,kaux) + tabaux(-lequad) = 1 +22124 continue + endif + endif +c + 2212 continue +c + endif +c + endif +c +c 2.2.2. ==> Le triangle est a raffiner : toutes ses aretes +c doivent l'etre +c + elseif ( decfac(iaux).eq.4 ) then +c + do 222 , jaux = 1, 3 + if ( mod(hetare(aretri(iaux,jaux)),10).eq.0 ) then + decare(aretri(iaux,jaux)) = 2 + endif + 222 continue +c + endif +c + 22 continue +c +c 2.3. ==> Corrections pour les quadrangles +c +cgn write(ulsort,90002) 'nbquto', nbquto + do 23 , iaux = 1, nbquto +c +c 2.3.1. ==> Le quadrangle est a deraffiner +c + if ( decfac(-iaux).eq.-1 ) then +c +c 2.3.1.1. ==> On voudrait reactiver le quadrangle, mais au moins une +c de ses aretes est coupee deux fois ==> impossible +c + if ( mod(hetare(arequa(iaux,1)),10).gt.2 .or. + > mod(hetare(arequa(iaux,2)),10).gt.2 .or. + > mod(hetare(arequa(iaux,3)),10).gt.2 .or. + > mod(hetare(arequa(iaux,4)),10).gt.2 ) then + tabaux(-iaux) = 1 +cgn write(ulsort,90002) 'Annulation reactivation du quadrangle',iaux + endif +c +c 2.3.2. ==> Le quadrangle est a raffiner : toutes ses aretes +c doivent l'etre +c + elseif ( decfac(-iaux).eq.4 ) then +c + do 232 , jaux = 1, 4 + if ( mod(hetare(arequa(iaux,jaux)),10).eq.0 ) then + decare(arequa(iaux,jaux)) = 2 + endif + 232 continue +c + endif +c + 23 continue +c +c 2.4. ==> Mise en place des corrections de deraffinement +c + do 241 , iaux = 1, nbquto + if ( tabaux(-iaux).gt.0 ) then +cgn write(ulsort,90002) 'Annulation reactivation du quadrangle',iaux +cgn write(ulsort,90002) 'decare(arequa(iaux,1))', +cgn > decare(arequa(iaux,1)) +cgn write(ulsort,90002) 'decare(arequa(iaux,2))', +cgn > decare(arequa(iaux,2)) +cgn write(ulsort,90002) 'decare(arequa(iaux,3))', +cgn > decare(arequa(iaux,3)) +cgn write(ulsort,90002) 'decare(arequa(iaux,4))', +cgn > decare(arequa(iaux,4)) + decfac (-iaux) = 0 + do 2411 , jaux = 1, 4 + decare(arequa(iaux,jaux)) = + > max(0,decare(arequa(iaux,jaux))) + 2411 continue + endif + 241 continue +c + do 242 , iaux = 1, nbtrto + if ( tabaux(iaux).gt.0 ) then +cgn write(ulsort,90002) 'Annulation reactivation du triangle',iaux +cgn write(ulsort,90002) 'decare(aretri(iaux,1))', +cgn > decare(aretri(iaux,1)) +cgn write(ulsort,90002) 'decare(aretri(iaux,2))', +cgn > decare(aretri(iaux,2)) +cgn write(ulsort,90002) 'decare(aretri(iaux,3))', +cgn > decare(aretri(iaux,3)) + decfac (iaux) = 0 + do 2421 , jaux = 1, 3 + decare(aretri(iaux,jaux)) = + > max(0,decare(aretri(iaux,jaux))) + 2421 continue + endif + 242 continue +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'apres 2 de ',nompro + do 22222 , iaux = 1 , nbarto + if ( iaux.eq.-50 .or. iaux.eq.-51 .or. + > iaux.eq.-53 .or. iaux.eq.-57 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +22222 continue +#endif +c +c==== +c 3. Correction pour le mode conforme - phase 2 +c Dans le cas particulier de raffinement par des indicateurs +c aux noeuds ou aux aretes, on peut se trouver ainsi : +c Mail 1 Mail 1 +c avec dec de conformite apres suppr +c sur l'arete horizontale de la conformite +c decare=2 en X +c o o +c . | . . . +c . | . . . +c . | . . . +c o..X.o....o o..X.o....o +c . | . . . +c . | . . . +c . | . . . +c o o +c +c Si on ne fait rien, le triangle du haut ne sera jamais coupe car la +c gestion des ecarts de niveau passe par les faces coupees. Il faut +c donc s'en occuper ici. Il faut declarer a couper toutes les faces +c qui contiennent cette arete. +c o +c . . +c T T T +c . . +c o..X.o....o +c . . +c T T T +c . . +c o +c +c Le traitement est similaire pour les quadrangles. +c Remarque : cette configuration ne peut pas reapparaitre ensuite +c +c En mode "conforme par boites", tout volume contenant une arete +c coupee deux fois sera decoupe en standard car les deux faces +c qui contiennent l'arete l'auront ete. L'algorithme de contamination +c gere cela. +c En mode conforme pur, le meme raisonnement s'applique aux volumes +c borde par un triangle : tetraedre ou pentaedre. En revanche, pour un +c hexaedre, le decoupage des deux quadrangles partageant l'arete ne +c suffira pas a enclencher le decoupage standard de l'hexaedre. Il faut +c le forcer ici. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. correction conforme 2 ; codret', codret + write (ulsort,90002) 'tyconf', tyconf +#endif +c + if ( ( tyconf.eq.0 ) .or. ( tyconf.eq.-1 ) ) then +c + write(ulsort,texte(langue,4)) 2 +c +c 3.1. ==> Triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1 Triangles ; codret', codret +#endif +c + do 31 , iaux = 1, nbtrto +c + if ( decfac(iaux).eq.0 .and. + > mod(hettri(iaux),10).eq.0 ) then +cgn write(ulsort,90002) 'Triangle', iaux +c + do 311 , jaux = 1, 3 + kaux = aretri(iaux,jaux) + if ( mod(hetare(kaux),10).ge.2 ) then + if ( decare(filare(kaux)).ge.2 ) then +cgn write(ulsort,90002) '. Arete', kaux + goto 312 + elseif ( decare(filare(kaux)+1).ge.2 ) then +cgn write(ulsort,90002) '. Arete', kaux + goto 312 + endif + endif + 311 continue +c + goto 31 +c + 312 continue +c + do 313 , jaux = 1, 3 + kaux = aretri(iaux,jaux) + if ( mod(hetare(kaux),10).eq.0 ) then +cgn write(ulsort,90002) '==> Triangle', iaux +cgn write(ulsort,90002) '==> Decoupage de l''arete', kaux + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).ge.2 ) then +cgn write(ulsort,90002) '==> Triangle', iaux +cgn write(ulsort,90002) '==> Decoupage de l''arete', kaux + decare(kaux) = max(0,decare(kaux)) + endif + 313 continue +cgn write(ulsort,90002) '.==> Decoupage du triangle', iaux + decfac(iaux) = 4 +c + endif +c + 31 continue +c +c 3.2. ==> Quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. Quadrangles ; codret', codret +#endif +c + do 32 , lequad = 1, nbquto +c +cgn if ( lequad.eq.38 ) then +cgn write(ulsort,90002) 'Quadrangle', +cgn > lequad,decfac(-lequad),hetqua(lequad) +cgn endif + if ( decfac(-lequad).eq.0 ) then +cgn write(ulsort,90002) 'Quadrangle', lequad +c + do 321 , jaux = 1, 4 + kaux = arequa(lequad,jaux) + if ( mod(hetare(kaux),10).ge.2 ) then + if ( decare(filare(kaux)).ge.2 ) then +cgn write(ulsort,90002) '. Arete', kaux + goto 33 + elseif ( decare(filare(kaux)+1).ge.2 ) then +cgn write(ulsort,90002) '. Arete', kaux + goto 33 + endif + endif + 321 continue +c + goto 32 +c +c 3.2.2. ==> Le quadrangle lequad est a traiter +c On lui ajoute tous les quadrangles des hexaedres voisins +c + 33 continue +c + nbquad = 1 + liquad(1) = lequad +cgn if ( lequad.eq.-417 ) then +cgn write(ulsort,90002) 'Quadrangle', lequad +cgn endif +c + if ( nbheto.gt.0 ) then +c + do 322 , jaux = 1 , 2 +c + lehexa = volqua(jaux,lequad) +c + if ( lehexa.gt.0 ) then +c + do 3221 , kaux = 1 , 6 + if ( quahex(lehexa,kaux).ne.lequad ) then + nbquad = nbquad + 1 + liquad(nbquad) = quahex(lehexa,kaux) + endif + 3221 continue +c + endif +c + 322 continue +c + endif +cgn if ( lequad.eq.-417 ) then +cgn write(ulsort,90002) 'nbquad', nbquad +cgn endif +c +c 3.2.3. ==> Traitement des quadrangles enregistres +c + do 323 , iquad = 1, nbquad +c + lequa0 = liquad(iquad) + if ( lequad.eq.-417 ) then + write(ulsort,90002) '.. lequa0', lequa0,decfac(-lequa0) + endif +c + do 3231 , jaux = 1, 4 + kaux = arequa(lequa0,jaux) +cgn if ( lequad.eq.-417 ) then +cgn write(ulsort,90002) '.... arete', kaux,hetare(kaux),decare(kaux) +cgn endif + if ( mod(hetare(kaux),10).eq.0 ) then +cgn if ( kaux.eq.50 .or. kaux.eq.51 .or. +cgn > kaux.eq.53 .or. kaux.eq.57 ) then +cgn write(ulsort,90002) '==> Quadrangle', lequa0 +cgn write(ulsort,90002) '==> Decoupage de l''arete', kaux +cgn endif + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).ge.2 ) then +cgn write(ulsort,90002) '==> Quadrangle', lequa0 +cgn write(ulsort,90002) '==> Decoupage de l''arete', kaux + decare(kaux) = max(0,decare(kaux)) + endif + 3231 continue +c + 323 continue + if ( mod(hetqua(lequad),100).eq.0 ) then +cgn write(ulsort,90002) '==> Decoupage du quadrangle', lequad + decfac(-lequad) = 4 + endif +c + endif +c + 32 continue +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'apres 3 de ',nompro + do 33333 , iaux = 1 , nbarto + if ( iaux.eq.-50 .or. iaux.eq.-51 .or. + > iaux.eq.-53 .or. iaux.eq.-57 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +33333 continue +#endif +c +c==== +c 4. Correction pour le mode non conforme +c Il est possible que l'on demande du decoupage d'aretes ou de +c triangles ou de quadrangles alors qu'ils le sont deja. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. correction non conforme ; codret', codret +#endif +c + if ( ( tyconf.gt.0 ) .or. ( tyconf.eq.-2 ) ) then +c + write(ulsort,texte(langue,5)) +c + do 41 , iaux = 1, nbtrto + if ( decfac (iaux).eq.4 ) then + etat = mod(hettri(iaux),10) + if ( etat.eq.4 .or. + > etat.eq.5 .or. etat.eq.6 .or. etat.eq.7 .or. + > etat.eq.9 ) then + decfac (iaux) = 0 + endif + endif + 41 continue +c + do 42 , iaux = 1, nbquto + if ( decfac (-iaux).eq.4 ) then + etat = mod(hetqua(iaux),100) + if ( etat.eq.4 .or. etat.eq.99) then + decfac (-iaux) = 0 + endif + endif + 42 continue +c + do 43 , iaux = 1, nbarto + if ( decare (iaux).eq.2 ) then + etat = mod(hetare(iaux),10) + if (etat.eq.2 .or. etat.eq.9 ) then + decare (iaux) = 0 + endif + endif + 43 continue +c + endif +c +cgn do 444 , iaux = -nbquto, nbtrto +cgn if ( decfac(iaux).eq.-1 ) then +cgn write(ulsort,90002) '.Reactivation de la face', iaux +cgn endif +cgn 444 continue +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 5555 , iaux = 1 , nbarto + if ( iaux.eq.-50 .or. iaux.eq.-51 .or. + > iaux.eq.-53 .or. iaux.eq.-57 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 5555 continue +#endif +c +cgn iaux = 8384 +cgn write (ulsort,90015) 'decision triangle', iaux, ' :', decfac(iaux) +cgn write (ulsort,90015) 'decision arete', aretri(iaux,1), ' :', +cgn > decare(aretri(iaux,1)) +cgn write (ulsort,90015) 'decision arete', aretri(iaux,2), ' :', +cgn > decare(aretri(iaux,2)) +cgn write (ulsort,90015) 'decision arete', aretri(iaux,3), ' :', +cgn > decare(aretri(iaux,3)) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deini5.F b/src/tool/Decision/deini5.F new file mode 100644 index 00000000..2bde7044 --- /dev/null +++ b/src/tool/Decision/deini5.F @@ -0,0 +1,181 @@ + subroutine deini5 ( obfigr, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INITialisations - phase 5 +c -- --- - +c ______________________________________________________________________ +c Recuperation des nombres de valeurs d'entites concernees par +c l'option de raffinement uniforme par des groupes. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obfigr . e . char*8 . filtrage de l'adaptation selon des groupes . +c . nbvent . s . 1 . nombre de valeurs pour l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINI5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 obfigr +c + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer typenh +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==>les messages +c + texte(1,4) = '(''Donnees pour les '',a)' +c + texte(2,4) = '(''Data for the '',a)' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, obfigr ) +#endif +c +c==== +c 2. Boucle sur tous les types d'entites (cf. vcfia0) +c==== +c + do 21 , typenh = -1 , 7 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c 2.1. ==> Longueur de la branche de memorisation +c + if ( codret.eq.0 ) then +c + iaux = typenh + 2 + call gmliat ( obfigr, iaux, jaux, codret ) +c + endif +c +c 2.2. ==> Enregistrement +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nbvnoe = jaux +ccc elseif ( typenh.eq.0 ) then +ccc nbvmpo = jaux + elseif ( typenh.eq.1 ) then + nbvare = jaux + elseif ( typenh.eq.2 ) then + nbvtri = jaux + elseif ( typenh.eq.3 ) then + nbvtet = jaux + elseif ( typenh.eq.4 ) then + nbvqua = jaux + elseif ( typenh.eq.5 ) then + nbvpyr = jaux + elseif ( typenh.eq.6 ) then + nbvhex = jaux + elseif ( typenh.eq.7 ) then + nbvpen = jaux + endif +c + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) + >' nbvnoe, nbvare, nbvtri, nbvqua, nbvtet, nbvhex, nbvpyr, nbvpen' + write (ulsort,4444) nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen + 4444 format(8i8) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinii.F b/src/tool/Decision/deinii.F new file mode 100644 index 00000000..925f6c5c --- /dev/null +++ b/src/tool/Decision/deinii.F @@ -0,0 +1,1042 @@ + subroutine deinii ( pilraf, pilder, nivmax, nivmin, iniada, + > decare, decfac, + > somare, hetare, filare, merare, np2are, + > posifa, facare, + > aretri, hettri, filtri, pertri, nivtri, + > arequa, hetqua, filqua, perqua, nivqua, + > tritet, hettet, filtet, + > quahex, hethex, filhex, + > facpyr, hetpyr, + > facpen, hetpen, filpen, + > nbvpen, nbvpyr, nbvhex, nbvtet, + > nbvqua, nbvtri, nbvare, nbvnoe, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, + > hesupp, heindi, + > pysupp, pyindi, + > pesupp, peindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur entier +c -- -- +c ______________________________________________________________________ +c +c but : initialisation des decisions sur les faces et les aretes +c dans le cas ou les valeurs de l'indicateur sont entieres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . -1 : deraffinement uniforme . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . iniada . e . 1 . initialisation de l'adaptation . +c . . . . 0 : on garde tout (defaut) . +c . . . .-1 : reactivation des mailles ou aucun . +c . . . . indicateur n'est defini . +c . . . . 1 : raffinement des mailles ou aucun . +c . . . . indicateur n'est defini . +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . merare . e . nbarto . mere des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . nbvpen . e . 1 . nombre de valeurs par pentaedres . +c . nbvpyr . e . 1 . nombre de valeurs par pyramides . +c . nbvhex . e . 1 . nombre de valeurs par hexaedres . +c . nbvtet . e . 1 . nombre de valeurs par tetraedres . +c . nbvqua . e . 1 . nombre de valeurs par quadrangles . +c . nbvtri . e . 1 . nombre de valeurs par triangles . +c . nbvare . e . 1 . nombre de valeurs par aretes . +c . nbvnoe . e . 1 . nombre de valeurs par noeuds . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . e . nbnoto . valeurs entieres pour les noeuds . +c . arsupp . e . nbarto . support pour les aretes . +c . arindi . e . nbarto . valeurs entieres pour les aretes . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . e . nbtrto . valeurs entieres pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . e . nbquto . valeurs entieres pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . e . nbteto . valeurs entieres pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . e . nbheto . valeurs entieres pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . e . nbpyto . valeurs entieres pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . e . nbpeto . valeurs entieres pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINII' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envada.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer pilraf, pilder, nivmax, nivmin, iniada + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer somare(2,nbarto) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer tritet(nbtecf,4), hettet(nbteto), filtet(nbteto) + integer quahex(nbhecf,6), hethex(nbheto), filhex(nbheto) + integer facpyr(nbpycf,5), hetpyr(nbpyto) + integer facpen(nbpecf,5), hetpen(nbpeto), filpen(nbpeto) + integer nbvpen, nbvpyr, nbvhex, nbvtet + integer nbvqua, nbvtri, nbvare, nbvnoe + integer nosupp(nbnoto), noindi(nbnoto) + integer arsupp(nbarto), arindi(nbarto) + integer trsupp(nbtrto), trindi(nbtrto) + integer qusupp(nbquto), quindi(nbquto) + integer tesupp(nbteto), teindi(nbteto) + integer hesupp(nbheto), heindi(nbheto) + integer pysupp(nbpyto), pyindi(nbpyto) + integer pesupp(nbpeto), peindi(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer etat +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/5x,''Deraffinement des mailles sans indicateur'')' + texte(1,5) = + > '(/5x,''Raffinement des mailles sans indicateur'')' + texte(1,6) = '(''Apres initialisation brute'')' + texte(1,7) = '(''Apres prise en compte des lieux du champ'')' + texte(1,8) = '(5x,''Apres prise en compte du deraffinement'')' + texte(1,9) = '(5x,''Apres prise en compte du raffinement'')' +c + texte(2,4) = + > '(/5x,''Unrefinement of the meshes without any indicator'')' + texte(2,5) = + > '(/5x,''Refinement of the meshes without any indicator'')' + texte(2,6) = '(''After brute initialization'')' + texte(2,7) = '(''After localization of the field'')' + texte(2,8) = '(5x,''After unrefinement indications'')' + texte(2,9) = '(5x,''After refinement indications'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Initialisations des tableaux de decisions +c . Dans l'option 0, les decisions sont initialisees a 0, ce qui +c veut dire qu'a priori, rien ne se passe +c . Dans l'option -1, les decisions sont initialisees a -1 partout +c ou l'indicateur n'est pas defini ; cela force le deraffinement +c des regions ou rien n'a ete precise +c . Dans l'option 1, les decisions sont initialisees a 2 partout +c ou l'indicateur n'est pas defini ; cela force le raffinement +c des regions ou rien n'a ete precise +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. initialisations ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbiter', nbiter + write (ulsort,90002) 'iniada', iniada +#endif +c + if ( nbiter.gt.0 .and. iniada.ne.0 ) then +c +c 2.0. ==> initialisations au defaut +c + if ( iniada.eq.-1 ) then +c + write (ulsort,texte(langue,4)) +c +cgn write(ulsort,*) 'aretes' + do 201 , iaux = 1, nbarto + if ( mod(hetare(iaux),10).ge.2 ) then + decare (iaux) = -1 +cgn write(ulsort,*) iaux + endif + 201 continue +c +cgn write(ulsort,*) 'triangles' + do 202 , iaux = 1, nbtrto + etat = mod(hettri(iaux),10) + if ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 .or. + > etat.eq.9 ) then + decfac (iaux) = -1 +cgn write(ulsort,*) iaux + endif + 202 continue +c +cgn write(ulsort,*) 'quadrangles' + do 203 , iaux = 1, nbquto + etat = mod(hetqua(iaux),100) + if ( etat.eq.4 .or. + > etat.eq.99 ) then + decfac (-iaux) = -1 + endif + 203 continue +c + elseif ( iniada.eq.1 ) then +c + write (ulsort,texte(langue,5)) +c +cgn write(ulsort,*) 'aretes' + do 204 , iaux = 1, nbarto + if ( mod(hetare(iaux),10).eq.0 ) then + decare (iaux) = 2 +cgn write(ulsort,*) iaux + endif + 204 continue +c +cgn write(ulsort,*) 'triangles' + do 205 , iaux = 1, nbtrto + if ( mod(hettri(iaux),10).eq.0 ) then + decfac (iaux) = 4 +cgn write(ulsort,*) iaux + endif + 205 continue +c +cgn write(ulsort,*) 'quadrangles' + do 206 , iaux = 1, nbquto + if ( mod(hetqua(iaux),100).eq.0 ) then + decfac (-iaux) = 4 + endif + 206 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,6)) +c + call decpte ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c +#endif +c +c 2.1. ==> traitement des indicateurs portant sur les noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvnoe.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINOI', nompro +#endif + call deinoi ( decare, decfac, + > somare, merare, + > np2are, posifa, facare, + > nosupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.2. ==> traitement des indicateurs portant sur les aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvare.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIARI', nompro +#endif + call deiari ( decare, decfac, + > merare, + > posifa, facare, + > arsupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.3. ==> traitement des indicateurs portant sur les triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. Triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtri.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITRI', nompro +#endif + call deitri ( decare, decfac, + > aretri, pertri, + > trsupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.4. ==> traitement des indicateurs portant sur les quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. Quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvqua.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIQUI', nompro +#endif + call deiqui ( decare, decfac, + > arequa, perqua, + > qusupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.5. ==> traitement des indicateurs portant sur les tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. Tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtet.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITEI', nompro +#endif + call deitei ( decare, decfac, + > aretri, pertri, + > tritet, + > tesupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.6. ==> traitement des indicateurs portant sur les hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.6. Hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvhex.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIHEI', nompro +#endif + call deihei ( decare, decfac, + > arequa, perqua, + > quahex, + > hesupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.7. ==> traitement des indicateurs portant sur les pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.7. Pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpyr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPYI', nompro +#endif + call deipyi ( decare, decfac, + > aretri, pertri, + > arequa, perqua, + > facpyr, + > pysupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.8. ==> traitement des indicateurs portant sur les pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.8. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpen.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPEI', nompro +#endif + call deipei ( decare, decfac, + > aretri, pertri, + > arequa, perqua, + > facpen, + > pesupp, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.9. ==> Bilan +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) +#endif +c + call decpte + > ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. traitement du deraffinement +c il faut d'abord examiner les decisions de deraffinement exprimees +c sur tous les types d'entites. ensuite, on examinera les decisions +c de raffinement. ainsi, en cas de conflit, on est certain d'avoir +c ecrasement du deraffinement par le raffinement. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. deraffinement ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbiter', nbiter + write (ulsort,90002) 'pilder', pilder +#endif +c + if ( pilder.ne.0 .and. nbiter.ne.0 ) then +c +c 3.1. ==> traitement des indicateurs portant sur les noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvnoe.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINOD', nompro +#endif + call deinod ( nivmin, + > decare, decfac, + > somare, hetare, filare, + > np2are, posifa, facare, + > aretri, hettri, nivtri, + > arequa, hetqua, nivqua, + > nosupp, noindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.2. ==> traitement des indicateurs portant sur les aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvare.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIARD', nompro +#endif + call deiard ( nivmin, + > decare, decfac, + > hetare, filare, + > posifa, facare, + > aretri, hettri, nivtri, + > arequa, hetqua, nivqua, + > arsupp, arindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.3. ==> traitement des indicateurs portant sur les triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. Triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtri.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITRD', nompro +#endif + call deitrd ( nivmin, + > decare, decfac, + > aretri, hettri, filtri, nivtri, + > trsupp, trindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.4. ==> traitement des indicateurs portant sur les quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. Quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvqua.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIQUD', nompro +#endif + call deiqud ( nivmin, + > decare, decfac, + > arequa, hetqua, filqua, nivqua, + > qusupp, quindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.5. ==> traitement des indicateurs portant sur les tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. Tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtet.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITED', nompro +#endif + call deited ( nivmin, + > decare, decfac, + > aretri, nivtri, + > tritet, hettet, filtet, + > tesupp, teindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.6. ==> traitement des indicateurs portant sur les hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. Hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvhex.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIHED', nompro +#endif + call deihed ( nivmin, + > decare, decfac, + > arequa, nivqua, + > quahex, hethex, filhex, + > hesupp, heindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.7. ==> traitement des indicateurs portant sur les pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7. Pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpyr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPYD', nompro +#endif + call deipyd ( nivmin, + > hetpyr, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.8. ==> traitement des indicateurs portant sur les pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.8. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpen.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPED', nompro +#endif + call deiped ( nivmin, + > decare, decfac, + > aretri, nivtri, + > arequa, + > facpen, hetpen, filpen, + > pesupp, peindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,8)) +c + call decpte + > ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. traitement du raffinement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. raffinement ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'pilraf', pilraf +#endif +c + if ( pilraf.ne.0 ) then +c +c 4.1. ==> traitement des indicateurs portant sur les noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvnoe.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINOR', nompro +#endif + call deinor ( nivmax, + > decare, + > somare, hetare, + > np2are, posifa, facare, + > nivtri, + > nivqua, + > nosupp, noindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.2. ==> traitement des indicateurs portant sur les aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvare.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIARR', nompro +#endif + call deiarr ( nivmax, + > decare, + > hetare, + > posifa, facare, + > nivtri, + > nivqua, + > arsupp, arindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.3. ==> traitement des indicateurs portant sur les triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. Triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtri.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITRR', nompro +#endif + call deitrr ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > trsupp, trindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.4. ==> traitement des indicateurs portant sur les quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. Quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvqua.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIQUR', nompro +#endif + call deiqur ( nivmax, + > decare, decfac, + > hetare, + > arequa, hetqua, nivqua, + > qusupp, quindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.5. ==> traitement des indicateurs portant sur les tetraedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.5. Tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvtet.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEITER', nompro +#endif + call deiter ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > tritet, + > tesupp, teindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.6. ==> traitement des indicateurs portant sur les hexaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.6. Hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvhex.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIHER', nompro +#endif + call deiher ( nivmax, + > decare, decfac, + > hetare, + > arequa, hetqua, nivqua, + > quahex, + > hesupp, heindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.7. ==> traitement des indicateurs portant sur les pyramides +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.7. Pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpyr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPYR', nompro +#endif + call deipyr ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > arequa, hetqua, + > facpyr, + > pysupp, pyindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.8. ==> traitement des indicateurs portant sur les pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.8. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvpen.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIPER', nompro +#endif + call deiper ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > arequa, hetqua, + > facpen, + > pesupp, peindi, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,9)) +c + call decpte + > ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,*) 'en sortie de ', nompro +cgn do 1105 , iaux = 1 , nbquto +cgn write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) +cgn 1105 continue +#endif +cgn iaux = 14808 +cgn write (ulsort,90002) 'quadrangle ', iaux +cgn write (ulsort,*) 'decfac(',iaux,') =',decfac(-iaux) +cgn write (ulsort,*) arequa(iaux,1),arequa(iaux,2), +cgn >arequa(iaux,3),arequa(iaux,4) +cgn write (ulsort,*) decare(arequa(iaux,1)),decare(arequa(iaux,2)), +cgn >decare(arequa(iaux,3)),decare(arequa(iaux,4)) +cgn write (ulsort,*) hetare(arequa(iaux,1)),hetare(arequa(iaux,2)), +cgn >hetare(arequa(iaux,3)),hetare(arequa(iaux,4)) +cgn write (ulsort,*) ' ' +cgn print 1789,(iaux, decfac(iaux),iaux = 0, nbtrto) +cgn print 1789,(iaux, decfac(iaux),iaux = -nbquto,0) +cgn print 1789,(iaux, decare(iaux),iaux = 1, nbarto) +c +cgn write (ulsort,*) 'decision triangle' +cgn write (ulsort,91030) (decfac(iaux),iaux= 1 , nbtrto) +cgn write (ulsort,*) 'decision quadrangle' +cgn write (ulsort,91030) (decfac(-iaux),iaux= 1 , nbquto) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinit.F b/src/tool/Decision/deinit.F new file mode 100644 index 00000000..3112f6b4 --- /dev/null +++ b/src/tool/Decision/deinit.F @@ -0,0 +1,658 @@ + subroutine deinit ( nomail, nohind, + > lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INITialisations +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . e . lgoptr . tableau des options reelles . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINIT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envca1.h" +#include "envada.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nohind +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux, jaux + integer ideb, ifin +c + integer pdecfa, pdecar + integer ppovos, pvoiso + integer pnoemp, phetmp + integer psomar, phetar, pfilar, pmerar, pnp2ar + integer pposif, pfacar + integer paretr, phettr, pfiltr, ppertr, pnivtr, advotr + integer parequ, phetqu, pfilqu, pperqu, pnivqu, advoqu + integer ptrite, phette, pfilte + integer pfacpy, phetpy + integer pquahe, phethe, pfilhe + integer pfacpe, phetpe, pfilpe + integer adpptr, adppqu + integer adtra3 +c + integer codre0, codre1, codre2 +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = + > '(/,a6,'' INITIALISATION ET FILTRAGE DES DECISIONS'')' + texte(1,5) = '(47(''=''),/)' + texte(1,6) = '(/,''Decisions sur les '',a)' + texte(1,7) = '(/,5x,''Bilan de l''''initialisation'')' +c + texte(2,4) = + > '(/,a6,'' INITIALISATION AND FILTERING OF DECISIONS'')' + texte(2,5) = '(48(''=''),/)' + texte(2,6) = '(/,''Decisions over '',a)' + texte(2,7) = '(/,5x,''Summary after the initialisation'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. gestion des tableaux +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + if ( nbmpto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhmapo, + > phetmp, pnoemp, jaux , jaux , + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( taopti(19).gt.0 ) then +c + if ( nbmpto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGAN', nompro +#endif +c + iaux = 1 + call utvgan ( nhvois, nhnoeu, nharet, + > iaux, + > ppovos, pvoiso, + > ulsort, langue, codret) +c + endif +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 6 + if ( nbiter.gt.0 .and. taopti(38).ne.0 ) then + iaux = iaux*5 + endif + if ( degre.eq.2 ) then + iaux = iaux*13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > jaux, jaux, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbtrto.ne.0 ) then +c + iaux = 66 + if ( nbiter.gt.0 .and. taopti(38).ne.0 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 330 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*221 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> les decisions sur les faces et les aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. decare/decfac ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbarto + 1 + call gmalot ( ntrav1, 'entier ', iaux, pdecar, codre1 ) + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav2, 'entier ', iaux, pdecfa, codre2 ) + codre0 = min ( codre1, codre2) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then + taopts(11) = ntrav1 + taopts(12) = ntrav2 + endif +c +c A priori, rien ne se passe, donc on met 0 +c + if ( codret.eq.0 ) then +c + ideb = pdecar + ifin = pdecar + nbarto + do 231 , iaux = ideb , ifin + imem(iaux) = 0 + 231 continue +c + ideb = pdecfa + ifin = pdecfa + nbtrto + nbquto + do 232 , iaux = ideb , ifin + imem(iaux) = 0 + 232 continue +c + endif +c +c 2.4. ==> tableau de travail +c + if ( codret.eq.0 ) then +c + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav3, 'entier ', iaux, adtra3, codret ) +c + endif +c +c==== +c 3. initialisations des tableaux des decisions sur les faces et +c les aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. initialisations ; codret', codret + write (ulsort,90002) 'taopti(31)/pilraf', taopti(31) + write (ulsort,90002) 'taopti(32)/pilder', taopti(32) + write (ulsort,90002) 'taopti(19)/filada', taopti(19) + write (ulsort,90004) 'taoptr( 3)/diammi', taoptr( 3) +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Cas du raffinement uniforme sans filtrage +c + if ( taopti(31).eq.-1 .and. + > ( taopti(19).eq.0 .and. taoptr(3).le.0.d0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINUN', nompro +cgn call gmprsx (nompro,nhvois) +#endif + call deinun + > ( taopti(31), taopti(32), taopti(33), taopti(34), + > imem(pdecfa), imem(pdecar), + > imem(phetar), + > imem(phettr), + > imem(phetqu), + > ulsort, langue, codret ) +c +c 3.2. ==> Cas du pilotage par zone, par indicateur ou raffinement +c uniforme avec filtrage ou deraffinement uniforme +c + elseif ( taopti(31).gt.0 .or. taopti(32).gt.0 .or. + > ( taopti(31).eq.-1 .and. + > ( taopti(19).gt.0 .or. taoptr(3).gt.0.d0 ) ) .or. + > taopti(32).eq.-1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINNU', nompro +#endif +c + call deinnu + > ( nomail, nohind, + > taopti(30), taopti(31), taopti(32), + > taopti(33), taopti(34), + > taopti( 6), taopti( 7), taoptr( 1), taoptr( 2), + > taopti( 8), + > taopti(19), taoptr( 3), taopti(37), taopti(38), + > taopti(44), + > imem(pdecar), imem(pdecfa), + > imem(ppovos), imem(pvoiso), + > imem(pnoemp), + > imem(psomar), imem(phetar), imem(pfilar), imem(pmerar), + > imem(pnp2ar), imem(pposif), imem(pfacar), + > imem(paretr), imem(phettr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(advotr), imem(adpptr), + > imem(parequ), imem(phetqu), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(advoqu), + > imem(ptrite), imem(phette), imem(pfilte), + > imem(pquahe), imem(phethe), imem(pfilhe), + > imem(pfacpy), imem(phetpy), + > imem(pfacpe), imem(phetpe), imem(pfilpe), + > imem(adtra3), + > lgopts, taopts, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 2 + call delist ( nomail, 'DEINNU', iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c + endif +c + endif +c +c==== +c 4. Menage du fitrage eventuel +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(19).gt.0 ) then +c + if ( nbmpto.ne.0 ) then + call gmsgoj ( nhvois//'.0D/1D' , codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + endif +c + endif +c +c==== +c 5. decompte des decisions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. decompte des decisions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,7)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPTE', nompro +#endif + call decpte + > ( taopti(31), taopti(32), + > imem(pdecar), imem(pdecfa), + > imem(phettr), imem(phetqu), imem(ptrite), imem(phette), + > imem(pquahe), imem(phethe), + > imem(pfacpy), imem(phetpy), + > imem(pfacpe), imem(phetpe), + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav3, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,1) + call gmprot ( 'DECARE a la fin de '//nompro, + > ntrav1 , 1, min(50,nbarto+1) ) + if ( nbarto.gt.50 ) then + call gmprot ( 'DECARE a la fin de '//nompro, + > ntrav1 , max(51,nbarto-49), nbarto+1 ) + endif + write (ulsort,texte(langue,6)) mess14(langue,3,8) + call gmprot ( 'DECFAC a la fin de '//nompro, + > ntrav2 , 1, min(50,nbtrto+nbquto+1) ) + if ( nbtrto+nbquto.gt.50 ) then + call gmprot ( 'DECFAC a la fin de '//nompro, + > ntrav2 , max(51,nbtrto+nbquto-49), nbtrto+nbquto+1) + endif + endif +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'en sortie de ',nompro +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,91010) (imem(pdecfa+nbquto+iaux),iaux=1,nbtrto) + write (ulsort,91010) (imem(pdecar+iaux),iaux=0,nbarto) +#endif +#ifdef _DEBUG_HOMARD_ + do 111,iaux=1,nbtrto + if (imem(pdecfa+nbquto+iaux).ne.0 ) then + write (ulsort,90002) 'tr ',iaux + endif + 111 continue +#endif +#ifdef _DEBUG_HOMARD_ + do 112,iaux=1,nbquto + if (imem(pdecfa-1+iaux).ne.0 ) then + write (ulsort,90002) 'qu ',iaux + endif + 112 continue +#ifdef _DEBUG_HOMARD_ +#endif + do 113,iaux=1,nbarto + if (imem(pdecar+iaux-1).ne.0 ) then + write (ulsort,90002) 'ar ',iaux + endif + 113 continue +#endif +c +c 6.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 6.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/deinnu.F b/src/tool/Decision/deinnu.F new file mode 100644 index 00000000..01be21da --- /dev/null +++ b/src/tool/Decision/deinnu.F @@ -0,0 +1,986 @@ + subroutine deinnu ( nomail, nohind, + > tyconf, pilraf, pilder, nivmax, nivmin, + > typseh, typseb, seuilh, seuilb, usacmp, + > filada, diammi, nbzord, iniada, + > nbsoci, + > decare, decfac, + > povoso, voisom, + > noempo, + > somare, hetare, filare, merare, + > np2are, posifa, facare, + > aretri, hettri, filtri, pertri, nivtri, + > voltri, pypetr, + > arequa, hetqua, filqua, perqua, nivqua, + > volqua, + > tritet, hettet, filtet, + > quahex, hethex, filhex, + > facpyr, hetpyr, + > facpen, hetpen, filpen, + > tabaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisations - Non Uniforme +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . . . . -1 : deraffinement uniforme . +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . typseh . e . 1 . type de seuil haut . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne + nh*ecart-type . +c . . . . 5 : cible en nombre de noeuds . +c . typseb . e . 1 . type de seuil bas . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne - nb*ecart-type . +c . seuilh . e . 1 . borne superieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nh) . +c . seuilb . e . 1 . borne inferieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nb) . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . filada . e . 1 . filtrage de l'adaptation . +c . . . . 0 : pas de filtrage . +c . . . . >0 : filtrage . +c . diammi . e . 1 . diametre minimal voulu . +c . nbzord . e . 1 . nombre de zones a raffiner/deraffiner . +c . iniada . e . 1 . initialisation de l'adaptation . +c . . . . 0 : on garde tout (defaut) . +c . . . .-1 : reactivation des mailles ou aucun . +c . . . . indicateur n'est defini . +c . . . . 1 : raffinement des mailles ou aucun . +c . . . . indicateur n'est defini . +c . nbsoci . e . 1 . cible en nombre de sommets (-1 si non) . +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . merare . e . nbarto . mere des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . tabaux . a . -nbquto. tableau auxiliaire sur les faces . +c . . . :nbtrto. (quad. + tri.) . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINNU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nohind +c + integer tyconf, pilraf, pilder, nivmax, nivmin + integer typseh, typseb + integer usacmp + integer nbzord + integer filada, iniada + integer nbsoci + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer povoso(0:nbnoto), voisom(*) + integer noempo(nbmpto) + integer somare(2,nbarto) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer volqua(2,nbquto) + integer tritet(nbtecf,4), hettet(nbteto), filtet(nbteto) + integer quahex(nbhecf,6), hethex(nbheto), filhex(nbheto) + integer facpyr(nbpycf,5), hetpyr(nbpyto) + integer facpen(nbpecf,5), hetpen(nbpeto), filpen(nbpeto) + integer tabaux(-nbquto:nbtrto) +c + double precision seuilb, seuilh + double precision diammi +c + integer lgopts + character*8 taopts(lgopts) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer pcoono + integer adnoin, adnorn, adnosu + integer adarin, adarrn, adarsu + integer adtrin, adtrrn, adtrsu + integer adquin, adqurn, adqusu + integer adtein, adtern, adtesu + integer adhein, adhern, adhesu + integer adpyin, adpyrn, adpysu + integer adpein, adpern, adpesu + integer adzord + integer adtra3, adtra4 + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen + integer dimcst, adcocs +c + integer codre0, codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 +c + integer typind, ncmpin +c + character*8 ncazor + character*8 obfigr, obfidm + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3, ntrav4 + character*8 ntrano, ntraar, ntratr, ntraqu + character*8 ntrate, ntrahe, ntrapy, ntrape +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + character*1 saux01(3) + data saux01 / 'X', 'Y', 'Z' / +#endif +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Erreur de programmation etape 3'')' + texte(1,5) = '(''Coordonnee '',a,'' constante :'',g13.5)' + texte(1,6) = '(/,5x,''Filtrage par les groupes'')' + texte(1,7) = '(/,5x,''Filtrage par le diametre minimal'')' +c + texte(2,4) = '(''Programming error in stage 3'')' + texte(2,5) = '(''Coordinate '',a,'' constant:'',g13.5)' + texte(2,6) = '(/,5x,''Filtering by the groups'')' + texte(2,7) = '(/,5x,''Filtering by the minimal diametre'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf + write (ulsort,90002) 'pilraf', pilraf + write (ulsort,90002) 'pilder', pilder + write (ulsort,90002) 'usacmp', usacmp + write (ulsort,90002) 'nivmax', nivmax + write (ulsort,90002) 'nivmin', nivmin + write (ulsort,90002) 'typseh', typseh + write (ulsort,90004) 'seuilh', seuilh + write (ulsort,90002) 'typseb', typseb + write (ulsort,90004) 'seuilb', seuilb + write (ulsort,90002) 'filada', filada + write (ulsort,90002) 'nbzord', nbzord + write (ulsort,90004) 'diammi', diammi +#endif +c + obfigr = taopts(29) +cgn write (ulsort,90003) 'obfigr', obfigr + obfidm = taopts(28) +cgn write (ulsort,90003) 'obfidm', obfidm +c +c==== +c 2. gestion des tableaux +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( nbzord.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 57 + call utad01 ( iaux, nhnoeu, + > jaux, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, adcocs, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhnoeu, 2, dimcst, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( dimcst.ne.0 ) then + write (ulsort,texte(langue,5)) saux01(dimcst), rmem(adcocs) + endif +#endif +c + endif +c +c==== +c 3. Decompte des nombres de valeurs pour les 'faux' indicateurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Decompte ; codret', codret +#endif +c + nbvnoe = 0 + nbvare = 0 + nbvtri = 0 + nbvqua = 0 + nbvtet = 0 + nbvpyr = 0 + nbvhex = 0 + nbvpen = 0 +c +c 3.1. ==> Uniforme et filtre +c + if ( ( pilraf.eq.-1 .or. pilder.eq.-1 ) .and. + > ( filada.ne.0 .or. diammi.gt.0.d0 ) ) then +c + if ( codret.eq.0 ) then +c + if ( filada.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI5', nompro +#endif + call deini5 ( obfigr, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > ulsort, langue, codret ) +c + endif +c + endif + typind = 1 +c +c 3.2. ==> Par zone +c + elseif ( ( pilraf.gt.0 .or. pilder.gt.0 ) .and. + > nbzord.ne.0 ) then +c + if ( codret.eq.0 ) then +c + nbvare = nbarto + typind = 0 +c + endif +c +c 3.3. ==> Cas du raffinement ou deraffinement par un indicateur +c + elseif ( ( pilraf.gt.0 .or. pilder.gt.0 ) .and. + > nbzord.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI0', nompro +#endif + call deini0 ( nohind, typind, ncmpin, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > adnoin, adnorn, adnosu, + > adarin, adarrn, adarsu, + > adtrin, adtrrn, adtrsu, + > adquin, adqurn, adqusu, + > adtein, adtern, adtesu, + > adhein, adhern, adhesu, + > adpyin, adpyrn, adpysu, + > adpein, adpern, adpesu, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> Autres cas impossibles +c + elseif ( pilder.ne.-1 ) then +c + codret = 2 + write (ulsort,texte(langue,4)) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typind', typind + write (ulsort,90002) 'ncmpin', ncmpin + write (ulsort,90002) + >' nbvnoe, nbvare, nbvtri, nbvqua, nbvtet, nbvhex, nbvpyr, nbvpen', + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen +#endif +c +c==== +c 4. Allocations des eventuels tableaux entiers : +c . pour une adaptation selon des zones +c . pour un indicateur reel +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Allocations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typind.eq.0 .or. typind.eq.3 ) then +c + if ( nbvnoe.eq.0 ) then + iaux = 0 + else + iaux = nbnoto + endif + call gmalot ( ntrano, 'entier ', iaux, adnoin, codre1 ) +c + if ( nbvare.eq.0 ) then + iaux = 0 + else + iaux = nbarto + endif + call gmalot ( ntraar, 'entier ', iaux, adarin, codre2 ) +c + if ( nbvtri.eq.0 ) then + iaux = 0 + else + iaux = nbtrto + endif + call gmalot ( ntratr, 'entier ', iaux, adtrin, codre3 ) +c + if ( nbvqua.eq.0 ) then + iaux = 0 + else + iaux = nbquto + endif + call gmalot ( ntraqu, 'entier ', iaux, adquin, codre4 ) +c + if ( nbvtet.eq.0 ) then + iaux = 0 + else + iaux = nbteto + endif + call gmalot ( ntrate, 'entier ', iaux, adtein, codre5 ) +c + if ( nbvpyr.eq.0 ) then + iaux = 0 + else + iaux = nbpyto + endif + call gmalot ( ntrapy, 'entier ', iaux, adpyin, codre6 ) +c + if ( nbvhex.eq.0 ) then + iaux = 0 + else + iaux = nbheto + endif + call gmalot ( ntrahe, 'entier ', iaux, adhein, codre7 ) +c + if ( nbvpen.eq.0 ) then + iaux = 0 + else + iaux = nbpeto + endif + call gmalot ( ntrape, 'entier ', iaux, adpein, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + endif +c + endif +c +c==== +c 5. Remplissage des tableaux entiers +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. remplissage ; codret', codret +#endif +c + if ( pilraf.gt.0 .or. pilder.gt.0 ) then +c +c 5.1. ==> Cas du raffinement ou deraffinement par des zones +c geometriques : on convertit en un indicateur entier sur +c les aretes +c + if ( nbzord.ne.0 ) then +c +c 5.1.1. ==> Recuperation de la structure +c + if ( codret.eq.0 ) then +c + ncazor = taopts(19) +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncazor ) +#endif +c + call gmadoj ( ncazor, adzord, iaux, codre1 ) + call gmalot ( ntrav1, 'entier ', nbnoto, adnosu, codre2 ) + call gmalot ( ntrav2, 'entier ', nbarto, adarsu, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 5.1.2. ==> Deploiement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINZR', nompro +#endif + call deinzr ( nbzord, rmem(adzord), + > rmem(pcoono), dimcst, rmem(adcocs), + > somare, hetare, + > imem(adnosu), imem(adarsu), imem(adarin), + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> Cas du raffinement ou deraffinement par un indicateur reel : +c on convertit en un indicateur entier +c + else +c + if ( typind.eq.3 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINRI', nompro +#endif + call deinri + > ( pilraf, pilder, + > typseh, typseb, seuilh, seuilb, nbsoci, + > usacmp, + > nbvpen, nbvpyr, nbvhex, nbvtet, + > nbvqua, nbvtri, nbvare, nbvnoe, + > imem(adnosu), rmem(adnorn), imem(adnoin), + > imem(adarsu), rmem(adarrn), imem(adarin), + > imem(adtrsu), rmem(adtrrn), imem(adtrin), + > imem(adqusu), rmem(adqurn), imem(adquin), + > imem(adtesu), rmem(adtern), imem(adtein), + > imem(adhesu), rmem(adhern), imem(adhein), + > imem(adpysu), rmem(adpyrn), imem(adpyin), + > imem(adpesu), rmem(adpern), imem(adpein), + > ulsort, langue, codret) +c + endif +c + endif +c + endif +c + endif +c +c==== +c 6. Elaboration des decisions sur les faces et les aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Elaboration ; codret', codret +#endif +c +c 6.1. ==> Cas du raffinement/deraffinement uniforme +c + if ( pilraf.eq.-1 .or. pilder.eq.-1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINUN', nompro +#endif + call deinun ( pilraf, pilder, nivmax, nivmin, + > decfac, decare, + > hetare, + > hettri, + > hetqua, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> Zone ou indicateur +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINII', nompro +#endif + call deinii + > ( pilraf, pilder, nivmax, nivmin, iniada, + > decare, decfac, + > somare, hetare, filare, merare, np2are, + > posifa, facare, + > aretri, hettri, filtri, pertri, nivtri, + > arequa, hetqua, filqua, perqua, nivqua, + > tritet, hettet, filtet, + > quahex, hethex, filhex, + > facpyr, hetpyr, + > facpen, hetpen, filpen, + > nbvpen, nbvpyr, nbvhex, nbvtet, + > nbvqua, nbvtri, nbvare, nbvnoe, + > imem(adnosu), imem(adnoin), + > imem(adarsu), imem(adarin), + > imem(adtrsu), imem(adtrin), + > imem(adqusu), imem(adquin), + > imem(adtesu), imem(adtein), + > imem(adhesu), imem(adhein), + > imem(adpysu), imem(adpyin), + > imem(adpesu), imem(adpein), + > ulsort, langue, codret) +c + endif +c + endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 2 + call delist ( nomail, 'DEINII', iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 7. Filtrages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Filtrages ; codret', codret +#endif +cgn write(*,*)'decare' +cgn write(*,91030)(decare(iaux),iaux=1,nbarto) +cgn write(*,*)'decfac quad' +cgn write(*,91030)(decfac(iaux),iaux=-nbquto,-1) +cgn write(*,*)'decfac tria' +cgn write(*,91030)(decfac(iaux),iaux=1,nbtrto) +c + if ( filada.ne.0 .or. diammi.gt.0.d0 ) then +c +c 7.1. ==> Tableaux de travail +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav3, 'entier ', nbarto, adtra3, codre1 ) + iaux = nbquto + 1 + nbtrto + call gmalot ( ntrav4, 'entier ', iaux, adtra4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +cgn write(*,91030)(decare(iaux),iaux=1,nbarto) +cgn write(*,91030)(decfac(iaux),iaux=1,nbtrto) +c +c 7.2. ==> Applications du ou des filtrages +c 7.2.1. ==> Filtrage par les groupes +c + if ( filada.ne.0 ) then +c +c 7.2.1.1. ==> Filtrage effectif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,6)) +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINFI-groupes', nompro +#endif + call deinfi ( iaux, obfigr, + > decare, decfac, iniada, + > imem(adtra3), imem(adtra4), + > povoso, voisom, + > noempo, + > somare, + > aretri, + > arequa, + > tritet, + > quahex, + > facpyr, + > facpen, + > ulsort, langue, codret ) +cgn call gmprsx ( nompro, ntrav3 ) +cgn call gmprsx ( nompro, ntrav4 ) +cgn write(*,91030)(decare(iaux),iaux=1,nbarto) +cgn write(*,91030)(decfac(iaux),iaux=1,nbtrto) +c + endif +c +c 7.2.1.2. ==> Affichage final +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPTE', nompro +#endif + call decpte ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, + > tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 7.2.2. ==> Filtrage par le diametre minimal +c + if ( diammi.gt.0.d0 ) then +c +c 7.2.2.1. ==> Filtrage effectif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,7)) +c + iaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINFI-diametre', nompro +#endif + call deinfi ( iaux, obfidm, + > decare, decfac, iniada, + > imem(adtra3), imem(adtra4), + > povoso, voisom, + > noempo, + > somare, + > aretri, + > arequa, + > tritet, + > quahex, + > facpyr, + > facpen, + > ulsort, langue, codret ) +cgn write(*,*)'decare' +cgn write(*,91030)(decare(iaux),iaux=1,nbarto) +cgn write(*,*)'decfac quad' +cgn write(*,91030)(decfac(iaux),iaux=-nbquto,-1) +cgn write(*,*)'decfac tria' +cgn write(*,91030)(decfac(iaux),iaux=1,nbtrto) +cgn call gmprsx ( nompro, ntrav3 ) +cgn call gmprsx ( nompro, ntrav4 ) +c + endif +c +c 7.2.2.2. ==> Affichage final +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPTE', nompro +#endif + call decpte ( pilraf, pilder, + > decare, decfac, + > hettri, hetqua, + > tritet, hettet, + > quahex, hethex, + > facpyr, hetpyr, + > facpen, hetpen, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +cgn do 7777 , iaux = 1 , nbarto +cgn if ( decare(iaux).ne.0 ) then +cgn write (ulsort,90001) '.. arete e/d', iaux, +cgn > hetare(iaux), decare(iaux), somare(1,iaux), somare(2,iaux) +cgn endif +cgn 7777 continue +c +c==== +c 8. Corrections selon le mode de conformite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. correction ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI4', nompro +#endif + call deini4 ( tyconf, + > decare, decfac, + > hetare, filare, + > aretri, hettri, filtri, + > voltri, pypetr, + > arequa, hetqua, + > volqua, + > tritet, quahex, facpen, facpyr, + > tabaux, + > ulsort, langue, codret) +cgn write(*,*)'decare' +cgn write(*,91030)(decare(iaux),iaux=1,nbarto) +cgn write(*,*)'decfac quad' +cgn write(*,91030)(decfac(iaux),iaux=-nbquto,-1) +cgn write(*,*)'decfac tria' +cgn write(*,91030)(decfac(iaux),iaux=1,nbtrto) +c +cgn do 8888 , iaux = 1 , nbarto +cgn if ( decare(iaux).ne.0 ) then +cgn write (ulsort,90001) '.. arete e/d', iaux, +cgn > hetare(iaux), decare(iaux), somare(1,iaux), somare(2,iaux) +cgn endif +cgn 8888 continue + endif +c +c==== +c 9. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 9.1. ==> Zones +c + if ( ( pilraf.gt.0 .or. pilder.gt.0 ) .and. + > nbzord.ne.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 9.2. ==> Filtrage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.2. Filtrage ; codret', codret +#endif +c + if ( filada.ne.0 .or. diammi.gt.0.d0 ) then +c + call gmlboj ( ntrav3, codre1 ) + call gmlboj ( ntrav4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 9.3. ==> Temporaires +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9.3. Temporaire ; codret', codret +#endif +c + if ( typind.eq.0 .or. typind.eq.3 ) then +c + call gmlboj ( ntrano, codre1 ) + call gmlboj ( ntraar, codre2 ) + call gmlboj ( ntratr, codre3 ) + call gmlboj ( ntraqu, codre4 ) + call gmlboj ( ntrate, codre5 ) + call gmlboj ( ntrapy, codre6 ) + call gmlboj ( ntrahe, codre7 ) + call gmlboj ( ntrape, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + endif +c + endif +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinod.F b/src/tool/Decision/deinod.F new file mode 100644 index 00000000..d7d77b63 --- /dev/null +++ b/src/tool/Decision/deinod.F @@ -0,0 +1,282 @@ + subroutine deinod ( nivmin, + > decare, decfac, + > somare, hetare, filare, + > np2are, posifa, facare, + > aretri, hettri, nivtri, + > arequa, hetqua, nivqua, + > nosupp, noindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des NOeuds - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . e . nbnoto . valeurs entieres pour les noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINOD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer somare(2,nbarto), hetare(nbarto), filare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer np2are(nbarto), posifa(0:nbarto), facare(nbfaar) + integer nosupp(nbnoto), noindi(nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer somdec, etat + integer larete, letria, lequad + integer fille1, fille2 + integer iaux, jaux, kaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +cgn print *,decare +cgn print *,decfac +cgn do 1999 , iaux = 1, nbnoto +cgn if ( nosupp(iaux).ne.0 ) then +cgn write (ulsort,*) iaux,noindi(iaux) +cgn endif +cgn 1999 continue +c +c==== +c 3. traitement des indicateurs portant sur les noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,-1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + if ( degre.eq.1 ) then +c + do 311 , larete = 1, nbarto +cgn write(ulsort,*) 'Arete', larete, ', etat',hetare(larete) + etat = mod(hetare(larete),10) + if ( etat.ge.2 ) then + fille1 = filare(larete) + fille2 = fille1 + 1 + if ( nosupp(somare(1,fille1)).ne.0 .and. + > nosupp(somare(2,fille1)).ne.0 .and. + > nosupp(somare(1,fille2)).ne.0 ) then + if ( noindi(somare(1,fille1)).eq.-1 .and. + > noindi(somare(2,fille1)).eq.-1 .and. + > noindi(somare(1,fille2)).eq.-1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.lt.nivmin ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then +cgn write(ulsort,*) 'Arete', larete, ' a reactiver' +cgn >, somare(1,fille1),somare(2,fille1),somare(1,fille2) + decare(larete) = -1 + else + iaux = iaux + 1 + endif + endif + endif + endif + 311 continue +c + else +c + do 312 , larete = 1, nbarto + etat = mod(hetare(larete),10) + if ( etat.ge.2 ) then + fille1 = filare(larete) + fille2 = fille1 + 1 + if ( nosupp(somare(1,fille1)).ne.0 .and. + > nosupp(somare(2,fille1)).ne.0 .and. + > nosupp(somare(1,fille2)).ne.0 .and. + > nosupp(np2are(fille1)) .ne.0 .and. + > nosupp(np2are(fille2)) .ne.0 ) then + if ( noindi(somare(1,fille1)).eq.-1 .and. + > noindi(somare(2,fille1)).eq.-1 .and. + > noindi(somare(1,fille2)).eq.-1 .and. + > noindi(np2are(fille1)) .eq.-1 .and. + > noindi(np2are(fille2)) .eq.-1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.lt.nivmin ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then +cgn write(ulsort,*) 'Arete', larete, ' a reactiver' +cgn >, somare(1,fille1),somare(2,fille1),somare(1,fille2) + decare(larete) = -1 + else + iaux = iaux + 1 + endif + endif + endif + endif + 312 continue +c + endif +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,-1) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c + do 313 , letria = 1, nbtrto + etat = mod(hettri(letria),10) + if ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 .or. + > etat.eq.9 ) then + somdec = decare(aretri(letria,1)) + > + decare(aretri(letria,2)) + > + decare(aretri(letria,3)) + if (somdec.eq.-3) then +cgn write(ulsort,*) 'Triangle', letria, ' a reactiver' + decfac(letria) = -1 + endif + endif + 313 continue +c + do 314 , lequad = 1, nbquto + etat = mod(hetqua(lequad),100) + if ( etat.eq.4 .or. + > etat.eq.99 ) then + somdec = decare(arequa(lequad,1)) + > + decare(arequa(lequad,2)) + > + decare(arequa(lequad,3)) + > + decare(arequa(lequad,4)) + if (somdec.eq.-4) then +cgn write(ulsort,*) 'Quadrangle', lequad, ' a reactiver' + decfac(-lequad) = -1 + endif + endif + 314 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinoi.F b/src/tool/Decision/deinoi.F new file mode 100644 index 00000000..a350a26c --- /dev/null +++ b/src/tool/Decision/deinoi.F @@ -0,0 +1,224 @@ + subroutine deinoi ( decare, decfac, + > somare, merare, + > np2are, posifa, facare, + > nosupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur entier +c -- -- +c - cas des NOeuds - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . merare . e . nbarto . mere des aretes . +c . nosupp . e . nbnoto . support pour les noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINOI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer somare(2,nbarto), merare(nbarto) + integer np2are(nbarto), posifa(0:nbarto), facare(nbfaar) + integer nosupp(nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete, lamere + integer iaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,-1) +#endif +c +c 2.1. ==> Degre 1 +c + if ( degre.eq.1 ) then +c + do 21 , larete = 1, nbarto +c + if ( nosupp(somare(1,larete)).ne.0 .and. + > nosupp(somare(2,larete)).ne.0 ) then +cgn write(ulsort,*) 'Arete', larete, ' a garder' +c +c 2.1.1. ==> Inhibition du raffinement par defaut : on garde l'arete +c entre les noeuds +c + decare(larete) = 0 + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + do 211 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux), ' a garder' + decfac(facare(iaux)) = 0 + 211 continue +c +c 2.1.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de l'arete entre les noeuds si elle existe +c + lamere = merare(larete) +c + if ( lamere.gt.0 ) then +c + decare(lamere) = 0 +cgn write(ulsort,*) 'Arete', lamere, ' a garder' + ideb = posifa(lamere-1)+1 + ifin = posifa(lamere) + do 212 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux), ' a garder' + decfac(facare(iaux)) = 0 + 212 continue +c + endif +c + endif +c + 21 continue +c +c 2.2. ==> Degre 2 +c + else +c + do 22 , larete = 1, nbarto +c + if ( nosupp(somare(1,larete)).ne.0 .and. + > nosupp(somare(2,larete)).ne.0 .and. + > nosupp(np2are(larete)).ne.0 ) then +c +c 2.2.1. ==> Inhibition du raffinement par defaut : on garde l'arete +c contenant les noeuds +c +cgn write(ulsort,*) 'Arete', larete, ' a garder' +c + decare(larete) = 0 + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + do 221 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux, ' a garder' + decfac(facare(iaux)) = 0 + 221 continue +c +c 2.2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de l'arete contenant les noeuds si elle existe +c + lamere = merare(larete) +c + if ( lamere.gt.0 ) then +c + decare(lamere) = 0 +cgn write(ulsort,*) 'Arete', lamere, ' a garder' + ideb = posifa(lamere-1)+1 + ifin = posifa(lamere) + do 222 , iaux = ideb, ifin +cgn write(ulsort,*) 'face', facare(iaux), ' a garder' + decfac(facare(iaux)) = 0 + 222 continue +c + endif +c + endif +c + 22 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinor.F b/src/tool/Decision/deinor.F new file mode 100644 index 00000000..2c6a53fa --- /dev/null +++ b/src/tool/Decision/deinor.F @@ -0,0 +1,234 @@ + subroutine deinor ( nivmax, + > decare, + > somare, hetare, + > np2are, posifa, facare, + > nivtri, + > nivqua, + > nosupp, noindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des NOeuds - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . nivtri . e . nbtrto . niveau des triangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . e . nbnoto . valeurs entieres pour les noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINOR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto) + integer somare(2,nbarto), hetare(nbarto) + integer nivtri(nbtrto) + integer nivqua(nbquto) + integer np2are(nbarto), posifa(0:nbarto), facare(nbfaar) + integer nosupp(nbnoto), noindi(nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete + integer iaux, jaux, kaux, ideb, ifin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr05.h" +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'degre', degre +#endif +c + codret = 0 +cgn print *,'decare :' +cgn print 91011,decare +cgn do 1999 , iaux = 1, nbnoto +cgn if ( nosupp(iaux).ne.0 ) then +cgn write (ulsort,90112) 'noindi',iaux,noindi(iaux) +cgn endif +cgn 1999 continue +c +c==== +c 3. traitement des indicateurs portant sur les noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,-1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + if ( degre.eq.1 ) then +c + do 321 , larete = 1, nbarto + if ( mod( hetare(larete) , 10 ).eq.0 ) then + if ( nosupp(somare(1,larete)).ne.0 .and. + > nosupp(somare(2,larete)).ne.0 ) then + if ( noindi(somare(1,larete)).eq.1 .and. + > noindi(somare(2,larete)).eq.1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb .and. nivmax.ge.0 ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.ge.nivmax ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then +cgn write(ulsort,90002) 'Raffinement de l''''arete', larete + decare(larete) = 2 + else + iaux = iaux + 1 + endif + endif + endif + endif + 321 continue +c + else +c + do 322 , larete = 1, nbarto + if ( mod( hetare(larete) , 10 ).eq.0 ) then + if ( nosupp(somare(1,larete)).ne.0 .and. + > nosupp(somare(2,larete)).ne.0 .and. + > nosupp(np2are(larete)).ne.0 ) then + if ( noindi(somare(1,larete)).eq.1 .and. + > noindi(somare(2,larete)).eq.1 .and. + > noindi(np2are(larete)) .eq.1 ) then + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + jaux = 0 + if ( ifin.ge.ideb .and. nivmax.ge.0 ) then + if ( facare(ideb).gt.0 ) then + kaux = nivtri(facare(ideb)) + else + kaux = nivqua(-facare(ideb)) + endif + if ( kaux.ge.nivmax ) then + jaux = 1 + endif + endif + if ( jaux.eq.0 ) then +cgn write(ulsort,90002) 'Raffinement de l''''arete', larete + decare(larete) = 2 + else + iaux = iaux + 1 + endif + endif + endif + endif + 322 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,-1) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinri.F b/src/tool/Decision/deinri.F new file mode 100644 index 00000000..2ef1f1b2 --- /dev/null +++ b/src/tool/Decision/deinri.F @@ -0,0 +1,662 @@ + subroutine deinri ( pilraf, pilder, + > typseh, typseb, seuilh, seuilb, nbsoci, + > usacmp, + > nbvpen, nbvpyr, nbvhex, nbvtet, + > nbvqua, nbvtri, nbvare, nbvnoe, + > nosupp, noindr, noindi, + > arsupp, arindr, arindi, + > trsupp, trindr, trindi, + > qusupp, quindr, quindi, + > tesupp, teindr, teindi, + > hesupp, heindr, heindi, + > pysupp, pyindr, pyindi, + > pesupp, peindr, peindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur +c -- -- +c passage de Reel a entIer +c - - +c ______________________________________________________________________ +c +c remarque : il faut filtrer par les supports pour les endroits ou +c la valeur de l'indicateur est indefinie. mettre une +c valeur "moyenne" ne permet pas de passer certains cas +c biscornus a cause des .le. ou .lt. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . . . . -1 : deraffinement uniforme . +c . typseh . e . 1 . type de seuil haut . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne + nh*ecart-type . +c . . . . 5 : cible en nombre de noeuds . +c . typseb . e . 1 . type de seuil bas . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne - nb*ecart-type . +c . seuilh . es . 1 . borne superieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nh) . +c . seuilb . e . 1 . borne inferieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nb) . +c . nbsoci . e . 1 . cible en nombre de sommets (-1 si non) . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nbvpen . e . 1 . nombre de valeurs par pentaedres . +c . nbvpyr . e . 1 . nombre de valeurs par pyramides . +c . nbvhex . e . 1 . nombre de valeurs par hexaedres . +c . nbvtet . e . 1 . nombre de valeurs par tetraedres . +c . nbvqua . e . 1 . nombre de valeurs par quadrangles . +c . nbvtri . e . 1 . nombre de valeurs par triangles . +c . nbvare . e . 1 . nombre de valeurs par aretes . +c . nbvnoe . e . 1 . nombre de valeurs par noeuds . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindr . e . nbnoto . valeurs reelles pour les noeuds . +c . noindi . s . nbnoto . valeurs entieres pour les noeuds . +c . arsupp . e . nbarto . support pour les aretes . +c . arindr . es . nbarto . valeurs reelles pour les aretes . +c . arindi . s . nbarto . valeurs entieres pour les aretes . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindr . es . nbtrto . valeurs reelles pour les triangles . +c . trindi . s . nbtrto . valeurs entieres pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindr . es . nbquto . valeurs reelles pour les quadrangles . +c . quindi . s . nbquto . valeurs entieres pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindr . es . nbteto . valeurs reelles pour les tetraedres . +c . teindi . s . nbteto . valeurs entieres pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindr . es . nbheto . valeurs reelles pour les hexaedres . +c . heindi . s . nbheto . valeurs entieres pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindr . es . nbpyto . valeurs reelles pour les pyramides . +c . pyindi . s . nbpyto . valeurs entieres pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindr . es . nbpeto . valeurs reelles pour les pentaedres . +c . peindi . s . nbpeto . valeurs entieres pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINRI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer pilraf, pilder + integer typseh, typseb + integer nbsoci + integer usacmp + integer nbvpen, nbvpyr, nbvhex, nbvtet + integer nbvqua, nbvtri, nbvare, nbvnoe +c + integer nosupp(nbnoto), noindi(nbnoto) + integer arsupp(nbarto), arindi(nbarto) + integer trsupp(nbtrto), trindi(nbtrto) + integer qusupp(nbquto), quindi(nbquto) + integer tesupp(nbteto), teindi(nbteto) + integer hesupp(nbheto), heindi(nbheto) + integer pysupp(nbpyto), pyindi(nbpyto) + integer pesupp(nbpeto), peindi(nbpeto) +c + integer ulsort, langue, codret +c + double precision seuilb, seuilh + double precision noindr(nbnoto) + double precision arindr(nbarto) + double precision trindr(nbtrto) + double precision quindr(nbquto) + double precision teindr(nbteto) + double precision heindr(nbheto) + double precision pyindr(nbpyto) + double precision peindr(nbpeto) +c +c 0.4. ==> variables locales +c + integer iaux + integer indtab + integer typenh, typen0 + integer ptrav1 + integer codre0 +c + double precision seuihe, seuibe +c + character*8 ntrav1 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. allocation de tableaux temporaires +c==== +c + iaux = 0 + if ( nbvnoe.ne.0 ) then + iaux = iaux + nbnoto + endif + if ( nbvare.ne.0 ) then + iaux = iaux + nbarto + endif + if ( nbvtri.ne.0 ) then + iaux = iaux + nbtrto + endif + if ( nbvqua.ne.0 ) then + iaux = iaux + nbquto + endif + if ( nbvtet.ne.0 ) then + iaux = iaux + nbteto + endif + if ( nbvpyr.ne.0 ) then + iaux = iaux + nbpyto + endif + if ( nbvhex.ne.0 ) then + iaux = iaux + nbheto + endif + if ( nbvpen.ne.0 ) then + iaux = iaux + nbpeto + endif +c + call gmalot ( ntrav1, 'reel ', iaux, ptrav1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c +c==== +c 3. traitement des indicateurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. traitement indicateurs ; codret', codret +#endif +c + indtab = 0 + typen0 = -2 +c +c 3.1. ==> noeuds +c + if ( nbvnoe.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_no', nompro +#endif + typenh = -1 + call deinti ( typenh, + > usacmp, nbnoto, nosupp, noindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + typen0 = typenh +c + endif +c + endif +c +c 3.2. ==> aretes +c + if ( nbvare.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_ar', nompro +#endif + typenh = 1 + call deinti ( typenh, + > usacmp, nbarto, arsupp, arindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.3. ==> triangles +c + if ( nbvtri.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_tr', nompro +#endif + typenh = 2 + call deinti ( typenh, + > usacmp, nbtrto, trsupp, trindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.4. ==> quadrangles +c + if ( nbvqua.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_qu', nompro +#endif + typenh = 4 + call deinti ( typenh, + > usacmp, nbquto, qusupp, quindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + elseif ( typen0.eq.2 ) then + typen0 = 8 + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.5. ==> tetraedres +c + if ( nbvtet.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_te', nompro +#endif + typenh = 3 + call deinti ( typenh, + > usacmp, nbteto, tesupp, teindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.6. ==> pyramides +c + if ( nbvpyr.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_py', nompro +#endif + typenh = 5 + call deinti ( typenh, + > usacmp, nbpyto, pysupp, pyindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + elseif ( typen0.eq.3 ) then + typen0 = 9 + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.7. ==> hexaedres +c + if ( nbvhex.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_he', nompro +#endif + typenh = 6 + call deinti ( typenh, + > usacmp, nbheto, hesupp, heindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + elseif ( typen0.eq.3 .or. typen0.eq.5 .or. typen0.eq.9 ) then + typen0 = 9 + else + typen0 = 10 + endif +c + endif +c + endif +c +c 3.8. ==> pentaedres +c + if ( nbvpen.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINTI_pe', nompro +#endif + typenh = 7 + call deinti ( typenh, + > usacmp, nbpeto, pesupp, peindr, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) + if ( typen0.eq.-2 ) then + typen0 = typenh + elseif ( typen0.eq.3 .or. typen0.eq.5 .or. + > typen0.eq.6 .or. typen0.eq.9 ) then + typen0 = 9 + else + typen0 = 10 + endif +c + endif +c + endif +c +c==== +c 4. determination du seuil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. determination du seuil ; codret', codret +#endif +cgn call gmprsx (nompro, ntrav1 ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINSE', nompro +#endif +c + call deinse ( typen0, + > seuihe, seuibe, + > pilraf, pilder, + > typseh, typseb, seuilh, seuilb, nbsoci, + > indtab, rmem(ptrav1), + > ulsort, langue, codret) +c + endif +c +c==== +c 5. transfert de reel a entier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. transfert reel/entier ; codret', codret +#endif +c 5.1. ==> noeuds +c + if ( nbvnoe.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_no', nompro +#endif + typenh = -1 + call deinst ( typenh, + > seuihe, seuibe, + > nbnoto, nosupp, noindr, noindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.2. ==> aretes +c + if ( nbvare.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_ar', nompro +#endif + typenh = 1 + call deinst ( typenh, + > seuihe, seuibe, + > nbarto, arsupp, arindr, arindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.3. ==> triangles +c + if ( nbvtri.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_tr', nompro +#endif + typenh = 2 + call deinst ( typenh, + > seuihe, seuibe, + > nbtrto, trsupp, trindr, trindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.4. ==> quadrangles +c + if ( nbvqua.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_qu', nompro +#endif + typenh = 4 + call deinst ( typenh, + > seuihe, seuibe, + > nbquto, qusupp, quindr, quindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.5. ==> tetraedres +c + if ( nbvtet.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_te', nompro +#endif + typenh = 3 + call deinst ( typenh, + > seuihe, seuibe, + > nbteto, tesupp, teindr, teindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.6. ==> pyramides +c + if ( nbvpyr.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_py', nompro +#endif + typenh = 5 + call deinst ( typenh, + > seuihe, seuibe, + > nbpyto, pysupp, pyindr, pyindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.7. ==> hexaedres +c + if ( nbvhex.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_he', nompro +#endif + typenh = 6 + call deinst ( typenh, + > seuihe, seuibe, + > nbheto, hesupp, heindr, heindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.8. ==> pentaedres +c + if ( nbvpen.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINST_pe', nompro +#endif + typenh = 7 + call deinst ( typenh, + > seuihe, seuibe, + > nbpeto, pesupp, peindr, peindi, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 6. liberation des tableaux temporaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. liberation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + seuilh = seuihe +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinse.F b/src/tool/Decision/deinse.F new file mode 100644 index 00000000..6b8afe01 --- /dev/null +++ b/src/tool/Decision/deinse.F @@ -0,0 +1,748 @@ + subroutine deinse ( typenh, + > seuihe, seuibe, + > pilraf, pilder, + > typseh, typseb, seuilh, seuilb, nbsoci, + > indtab, tabind, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation des SEuils +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites concernees . +c . . . . -1 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . seuihe . s . 1 . borne superieure absolue de l'erreur entite. +c . seuibe . s . 1 . borne inferieure absolue de l'erreur entite. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . . . . -1 : deraffinement uniforme . +c . typseh . e . 1 . type de seuil haut . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne + nh*ecart-type . +c . . . . 5 : cible en nombre de noeuds . +c . typseb . e . 1 . type de seuil bas . +c . . . . 1 : absolu . +c . . . . 2 : relatif . +c . . . . 3 : pourcentage d'entites . +c . . . . 4 : moyenne - nb*ecart-type . +c . seuilh . e . 1 . borne superieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nh) . +c . seuilb . e . 1 . borne inferieure de l'erreur (absolue, . +c . . . . relatif, pourcentage d'entites ou nb) . +c . nbsoci . e . 1 . cible en nombre de sommets (-1 si non) . +c . indtab . e . 1 . dernier indice affecte dans tabind . +c . tabind . e . indtab . tableau de l'indicateur . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 4 : nombres d'entites incoherents . +c . . . . 2 : probleme dans le traitement . +c . . . . 3 : les seuils sont mal definis . +c . . . . 5 : mauvaise cible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINSE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +c +#include "gmenti.h" +#include "infini.h" +#include "precis.h" +#include "impr02.h" +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer typenh + integer pilraf, pilder + integer typseh, typseb + integer nbsoci + integer indtab +c + integer ulsort, langue, codret +c + double precision seuibe, seuihe + double precision seuilb, seuilh + double precision tabind(indtab) +c +c 0.4. ==> variables locales +c + integer iaux +cgn integer jaux + integer ptrav1 + integer codre0 +c + double precision vmin, vmax + double precision vmoy, sigma + double precision daux +c + character*8 ntrav1 +cgn character*8 saux08 +cgn character*80 repere +c + logical lgaux1, lgaux2, lgaux3 +c + integer nbmess + parameter (nbmess = 16 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +cgn write (ulsort,90002) 'typenh', typenh +cgn write (ulsort,90002) 'pilraf', pilraf +cgn write (ulsort,90002) 'pilder', pilder +cgn write (ulsort,90002) 'typseh', typseh +cgn write (ulsort,90004) 'seuilh', seuilh +cgn write (ulsort,90002) 'typseb', typseb +cgn write (ulsort,90004) 'seuilb', seuilb +cgn 1400 format(5(i5,' : ',i11,' |')) +cgn 1401 format(5(i5,' : ',g11.4,' |')) +c + texte(1,4) = '(''Le seuil haut n''''est pas defini.'')' + texte(1,5) = '(''Le seuil bas n''''est pas defini.'')' + texte(1,6) = '(''Entite '',i10)' + texte(1,7) = '(''. Nombre d''''entites actives :'',i10)' + texte(1,8) = + >'(''. Nombre d''''entites designees par le support :'',i10)' + texte(1,9) = '(5x,a14,'' : seuil haut ='',g13.5,/)' + texte(1,10) = '(5x,a14,'' : seuil bas ='',g13.5,/)' + texte(1,11) = '(''Recherche des seuils pour les '',a))' + texte(1,12) = '(''On prend la valeur brute de l''''indicateur.'')' + texte(1,13) = + > '(''On prend la valeur absolue de l''''indicateur.'')' + texte(1,14) = '(''Nombre de sommets actuel :'',i10)' + texte(1,15) = '(''Nombre de sommets voulu :'',i10)' + texte(1,16) = '(''Impossible'')' +c + texte(2,4) = '(''Upper threshold is not defined.'')' + texte(2,5) = '(''Lower threshold is not defined.'')' + texte(2,6) = '(''Entity '',i10)' + texte(2,7) = '(''. Number of active entities :'',i10)' + texte(2,8) = + >'(''. Number of entities declared by support of error :'',i10)' + texte(2,9) = '(5x,a14,'': Upper threshold ='',g13.5,/)' + texte(2,10) = '(5x,a14,'': Lower threshold ='',g13.5,/)' + texte(2,11) = '(''Thresholds for the '',a))' + texte(2,12) = '(''Inlet value for indicator is taken.'')' + texte(2,13) = '(''Absolute value for indicator is taken.'')' + texte(2,14) = '(''Number of vertices :'',i10)' + texte(2,15) = '(''Targetted number of vertices:'',i10)' + texte(2,16) = '(''Impossible'')' +c +c==== +c 2. Prealables +c==== +c 2.1. ==> Controles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typseh', typseh + write (ulsort,90002) 'typseb', typseb +#endif +c + if ( pilraf.gt.0 .and. typseh.eq.0 .and. nbsoci.le.0 ) then + write (ulsort,texte(langue,4)) + codret = 3 + endif +c + if ( nbiter.gt.0 ) then +c + if ( pilder.gt.0 .and. typseb.eq.0 ) then + write (ulsort,texte(langue,5)) + codret = 3 + endif +c + endif +c 2.2. ==> Par defaut, on prend des valeurs extremes inhibant toute +c adaptation +c + seuihe = vinfpo + seuibe = vinfne +c +c 2.3. ==> Pour une cible, on va estimer un pourcentage de mailles +c 2.3.1. ==> Au premier passage, on va estimer un pourcentage de mailles +c + if ( typseh.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,14)) nbnop1 + write (ulsort,texte(langue,15)) nbsoci +#endif +c + if ( nbsoci.lt.nbnop1 ) then + write (ulsort,texte(langue,14)) nbnop1 + write (ulsort,texte(langue,15)) nbsoci + write (ulsort,texte(langue,16)) + codret = 5 + endif +c + if ( codret.eq.0 ) then +c + daux = dble(nbsoci)/dble(nbnop1) +cgn write (ulsort,90004) 'nbsoci/nbnop1', daux +c + daux = daux - 1.d0 + if ( mdim.eq.1 ) then + daux = daux + elseif ( mdim.eq.2 ) then + daux = daux/2.d0 + else + daux = daux/4.d0 + endif +cgn write (ulsort,90004) 'daux', daux + seuilh = 100.d0 * daux + seuilh = min(seuilh, 100.d0) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'seuilh', seuilh +#endif +c + endif +c + endif +c +c 2.3.2. ==> Ensuite, on transfere +c + if ( codret.eq.0 ) then +c + if ( ( typseh.eq.0 ) .and. (nbsoci.gt.0 ) ) then +c + seuihe = seuilh +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,3,typenh) +#endif +c +c==== +c 3. si les seuils sont definis par des valeurs absolues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. seuils en valeur absolue ; codret',codret +#endif +c + if ( codret.eq.0 ) then +c + if ( pilraf.gt.0 .and. typseh.eq.1 ) then + seuihe = seuilh + endif +c + if ( pilder.gt.0 .and. typseb.eq.1 ) then + seuibe = seuilb + endif +c + endif +c +c==== +c 4. determination des seuils si : +c . un des seuils est fourni en relatif +c . un des seuils est fourni en pourcentage d'entites +c . un des seuils est fourni en mu+n.sigma +c . un nombre de noeuds cibles est recherche +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. determination des seuils ; codret',codret +#endif +c + if ( ( pilraf.gt.0 .and. typseh.ge.2 .and. typseh.le.5 ) .or. + > ( pilder.gt.0 .and. typseb.ge.2 .and. typseb.le.4 ) ) then +c +c 4.1. ==> allocation du tableau de travail pour uttris +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Allocation pour', + > indtab, ' '//mess14(langue,3,typenh) +#endif +c + call gmalot ( ntrav1, 'entier ', indtab, ptrav1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 4.2. ==> tri +c On a besoin de la valeur max dans les cas suivants : +c - raffinement ou deraffinement libre, seuil exprime +c en relatif et valant plus de 0% +c - raffinement libre, seuil exprime en pourcentage +c d'elements et valant moins de 0% +c - deraffinement libre, seuil exprime en pourcentage +c d'elements et valant plus de 100% +c On a besoin de la valeur min dans les cas suivants : +c - raffinement ou deraffinement libre, seuil exprime +c en relatif et valant moins de 100% +c - raffinement libre, seuil exprime en pourcentage +c d'elements et valant plus de 100% +c - deraffinement libre, seuil exprime en pourcentage +c d'elements et valant moins de 0% +c On a besoin de la valeur moy et de l'ecart-type dans les +c cas suivants : +c - raffinement ou deraffinement libre, seuil exprime +c en moyenne + coeff*(ecart-type) +c +c lgaux1 = calcul de la valeur minimale +c lgaux2 = calcul de la valeur maximale +c lgaux3 = calcul de la valeur moyenne et de l'ecart-type +c + if ( codret.eq.0 ) then +c + lgaux1 = .false. + lgaux2 = .false. + lgaux3 = .false. +c +c 4.2.1. ==> examen du raffinement +c + if ( pilraf.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.2.1. Examen du raffinement' +#endif +c relatif + if ( typseh.eq.2 ) then + if ( abs(seuilh).le.epsima ) then + lgaux1 = .true. + elseif ( abs(seuilh-100.d0).le.epsima ) then + lgaux2 = .true. + else + lgaux1 = .true. + lgaux2 = .true. + endif +c pourcentage d'entites + elseif ( typseh.eq.3 .or. typseh.eq.5 ) then + if ( abs(seuilh).le.epsima ) then + lgaux2 = .true. + elseif ( abs(seuilh-100.d0).le.epsima ) then + lgaux1 = .true. + else + lgaux1 = .true. + lgaux2 = .true. + endif + elseif ( typseh.eq.4 ) then + lgaux3 = .true. + endif +c + endif +c +c 4.2.2. ==> examen du deraffinement +c + if ( pilder.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.2.2. Examen du deraffinement' +#endif +c relatif + if ( typseb.eq.2 ) then + if ( abs(seuilb).le.epsima ) then + lgaux1 = .true. + elseif ( abs(seuilb-100.d0).le.epsima ) then + lgaux2 = .true. + else + lgaux1 = .true. + lgaux2 = .true. + endif +c pourcentage d'entites + elseif ( typseb.eq.3 ) then + if ( abs(seuilb).le.epsima ) then + lgaux1 = .true. + elseif ( abs(seuilb-100.d0).le.epsima ) then + lgaux2 = .true. + else + lgaux1 = .true. + lgaux2 = .true. + endif + elseif ( typseb.eq.4 ) then + lgaux3 = .true. + endif +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'lgaux1', lgaux1 + write (ulsort,99001) 'lgaux2', lgaux2 + write (ulsort,99001) 'lgaux3', lgaux3 +#endif +c + endif +c +c 4.3. ==> Calcul +c + if ( codret.eq.0 ) then +c +c 4.3.1. ==> Mini/maxi +c + if ( lgaux1 .or. lgaux2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.3.1. Mini/maxi' +#endif +c + vmin = vinfpo + vmax = vinfne + if ( lgaux1 .and. lgaux2 ) then + do 4311 , iaux = 1, indtab + vmin = min(vmin,tabind(iaux)) + vmax = max(vmax,tabind(iaux)) + 4311 continue + elseif ( lgaux2 ) then + do 4312 , iaux = 1, indtab + vmax = max(vmax,tabind(iaux)) + 4312 continue + else + do 4313 , iaux = 1, indtab + vmin = min(vmin,tabind(iaux)) + 4313 continue + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'vmin', vmin + write (ulsort,90004) 'vmax', vmax +#endif +c +c 4.3.2. ==> Moyenne et ecart-type +c + elseif ( lgaux3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.3.2. Moyenne et ecart-type' +#endif +c + vmoy = 0.d0 + daux = 0.d0 + do 432 , iaux = 1, indtab + vmoy = vmoy + tabind(iaux) + daux = daux + tabind(iaux)**2 + 432 continue + vmoy = vmoy/dble(indtab) + daux = daux/dble(indtab) + sigma = sqrt(daux - vmoy**2) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90004) 'vmoy ', vmoy + write(ulsort,90004) 'sigma', sigma +#endif +c + endif +c + endif +c +c 4.4. ==> Deduction des seuils si exprime en pourcentage d'entites +c 4.4.1. ==> si le seuil haut est exprime en pourcentage d'entites, +c strictement compris entre 0 et 100, on repere la valeur +c de seuil +c + if ( codret.eq.0 ) then +c + if ( pilraf.gt.0 .and. + > ( typseh.eq.3 .or. typseh.eq.5 ) ) then +c + if ( abs(seuilh).gt.epsima .and. + > abs(seuilh-100.d0).gt.epsima ) then +c +cgn write (ulsort,1401)(iaux,tabind(iaux),iaux=1,indtab) + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTRIS', nompro +#endif + call uttris ( seuihe, + > iaux, imem(ptrav1), + > seuilh, indtab, tabind, + > ulsort, langue, codret ) +c +cgn codre0 = nint(seuilh*dble(indtab)/100.d0) +cgn if ( indtab.ge.2 ) codre0 = min(codre0+1,indtab) +cgn write (ulsort,*) '================== ptrav1 =========' +cgn write (ulsort,1400) (iaux,imem(ptrav1+iaux-1),iaux=1,codre0) +cgn write (ulsort,*) '==================' +cgn write (ulsort,*) '=========== ptrav1 trie pour haut ========' +cgn write (ulsort,1401) +cgn >(iaux,tabind(imem(ptrav1+iaux-1)),iaux=1,codre0) +cgn write (ulsort,90004) '==> seuihe',seuihe + endif +c + endif +c + endif +c +c 4.4.2. ==> si le seuil bas est exprime en pourcentage d'entites, +c strictement compris entre 0 et 100, on repere la valeur +c de seuil +c + if ( codret.eq.0 ) then +c + if ( pilder.gt.0 .and. typseh.eq.3 ) then +c + if ( abs(seuilh).gt.epsima .and. + > abs(seuilh-100.d0).gt.epsima ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTRIS', nompro +#endif + call uttris ( seuibe, + > iaux, imem(ptrav1), + > seuilb, indtab , tabind, + > ulsort, langue, codret ) +c +cgn codre0 = nint(seuilb*dble(indtab)/100.d0) +cgn if ( indtab.ge.2 ) codre0 = min(codre0+1,indtab) +cgn write (ulsort,*) '================== ptrav1 =========' +cgn write (ulsort,1400) (iaux,imem(ptrav1+iaux-1),iaux=1,codre0) +cgn write (ulsort,*) '==================' +cgn write (ulsort,*) '=========== ptrav1 trie pour bas ========' +cgn write (ulsort,1401) +cgn >(iaux,tabind(imem(ptrav1+iaux-1)),iaux=1,codre0) +cgn write (ulsort,90004) '==> seuibe',seuibe + endif +c + endif +c + endif +c +c 4.5. ==> Les seuils definitifs +c + if ( codret.eq.0 ) then +c +c 4.5.1. ==> en raffinement +c + if ( pilraf.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.5.1. Seuil en raffinement' +#endif +c +c relatif + if ( typseh.eq.2 ) then + if ( abs(vmax-vmin).le.epsima ) then + seuihe = vmax + epsima + elseif ( abs(seuilh).le.epsima ) then + seuihe = 0.999d0*vmin + elseif ( abs(seuilh-100.d0).le.epsima ) then + seuihe = 1.5d0*vmax + else + seuihe = vmin + seuilh*(vmax-vmin)/100.d0 + endif +c pourcentage d'entites + elseif ( typseh.eq.3 .or. typseh.eq.5 ) then + if ( abs(vmax-vmin).le.epsima ) then + seuihe = vmax + epsima + elseif ( abs(seuilh).le.epsima ) then + seuihe = 1.5d0*vmax + elseif ( abs(seuilh-100.d0).le.epsima ) then + seuihe = 0.999d0*vmin + endif +c moyenne et ecart-type + elseif ( typseh.eq.4 ) then + if ( abs(sigma).le.epsima ) then + seuihe = vmoy + epsima + else + seuihe = vmoy + seuilh*sigma + endif + endif +c + endif +c +c 4.5.2. ==> en deraffinement +c + if ( pilder.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93030) '4.5.2. Seuil en deraffinement' +#endif +c +c relatif + if ( typseb.eq.2 ) then + if ( abs(vmax-vmin).le.epsima ) then + seuibe = vmin - epsima + elseif ( abs(seuilb).le.epsima ) then + seuibe = 0.999d0*vmin + elseif ( abs(seuilb-100.d0).le.epsima ) then + seuibe = 1.5d0*vmax + else + seuibe = vmin + seuilb*(vmax-vmin)/100.d0 + endif +c pourcentage d'entites + elseif ( typseb.eq.3 ) then + if ( abs(vmax-vmin).le.epsima ) then + seuibe = vmin - epsima + elseif ( abs(seuilb).le.epsima ) then + seuibe = 0.999d0*vmin + elseif ( abs(seuilb-100.d0).le.epsima ) then + seuibe = 1.5d0*vmax + endif +c moyenne et ecart-type + elseif ( typseh.eq.4 ) then + if ( abs(sigma).le.epsima ) then + seuibe = vmoy - epsima + else + seuibe = vmoy - seuilb*sigma + endif + endif +c + endif +c + endif +c +c 4.6. ==> liberation des tableaux temporaires +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c==== +c 5. Ecriture sur la sortie standard et sur le fichier recapitulatif +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Ecriture standard ; codret',codret +#endif +c + if ( pilraf.gt.0 .and. + > ( ( typseh.ge.1 .and. typseh.le.5 ) .or. + > ( typseh.eq.0 .and. nbsoci.gt.0 ) ) ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,9)) mess14(langue,4,typenh), seuihe +c +cgn iaux = 2 +cgn jaux = 25 +cgnc 12345678901 +cgn repere(1:jaux) = 'Seuil haut '//mess14(langue,4,typenh) +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'UTSYNT', nompro +cgn#endif +cgn call utsynt ( repere, jaux, +cgn > iaux, jaux, seuihe, saux08, jaux, +cgn > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbiter.gt.0 ) then +c + if ( pilder.gt.0 .and. typseb.ge.1 .and. typseb.le.4 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,10)) mess14(langue,4,typenh), seuibe +c +cgn iaux = 2 +cgn jaux = 24 +cgnc 1234567890 +cgn repere(1:jaux) = 'Seuil bas '//mess14(langue,4,typenh) +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'UTSYNT', nompro +cgn#endif +cgn call utsynt ( repere, jaux, +cgn > iaux, jaux, seuibe, saux08, jaux, +cgn > ulsort, langue, codret ) +c + endif +c + endif +c + endif + if ( typseh.eq.5 ) then + typseh = 0 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) '==> seuihe', seuihe + write (ulsort,90004) '==> seuibe', seuibe +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinst.F b/src/tool/Decision/deinst.F new file mode 100644 index 00000000..e9aa7067 --- /dev/null +++ b/src/tool/Decision/deinst.F @@ -0,0 +1,161 @@ + subroutine deinst ( typenh, + > seuihe, seuibe, + > nbenti, suppor, indire, indien, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation des Seuils - Tri +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites concernees . +c . . . . 0 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . seuihe . e . 1 . borne superieure absolue de l'erreur entite. +c . seuibe . e . 1 . borne inferieure absolue de l'erreur entite. +c . nbenti . e . 1 . nombre d'entites pour les entites . +c . suppor . e . nbenti . support pour les entites . +c . indire . e . nbenti . valeurs reelles pour les entites . +c . indien . s . nbenti . valeurs entieres filtrees pour les entites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINST' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nbenti + integer suppor(nbenti), indien(nbenti) +c + double precision seuibe, seuihe + double precision indire(nbenti) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Transfert de reel a entier pour les '',a))' + texte(1,5) = '(''Seuil haut = '',g13.5)' + texte(1,6) = '(''Seuil bas = '',g13.5)' +c + texte(2,4) = '(''Transfert de reel a entier pour les '',a))' + texte(2,5) = '(''High threshold = '',g13.5)' + texte(2,6) = '(''Low threshold = '',g13.5)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) seuihe + write (ulsort,texte(langue,6)) seuibe +#endif +c +#include "impr03.h" +c +c==== +c 2. transfert de reel a entier +c==== +c + do 21 , iaux = 1, nbenti +cgn write (ulsort,90012) 'support pour', iaux, suppor(iaux) +c + if ( suppor(iaux).ne.0 ) then +cgn write (ulsort,90024) 'indire pour', iaux, indire(iaux) +c + if ( indire(iaux).le.seuibe ) then + indien(iaux) = -1 + elseif ( indire(iaux).ge.seuihe ) then + indien(iaux) = 1 + else + indien(iaux) = 0 + endif +cgn write (ulsort,90012) '==> indien pour', iaux, indien(iaux) +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinti.F b/src/tool/Decision/deinti.F new file mode 100644 index 00000000..e7b06393 --- /dev/null +++ b/src/tool/Decision/deinti.F @@ -0,0 +1,208 @@ + subroutine deinti ( typenh, + > usacmp, nbenti, suppor, indica, + > indtab, tabind, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation - Tableau des Indicateurs +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . type d'entites concernees . +c . . . . 0 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nbenti . e . 1 . nombre d'entites pour les entites . +c . suppor . e . nbenti . support pour les entites . +c . indica . e . nbenti . valeurs pour les entites . +c . indtab . es . 1 . dernier indice affecte dans tabind . +c . tabind . es . * . tableau de l'indicateur . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c . . . . 3 : les seuils sont mal definis . +c . . . . 4 : nombres d'entites incoherents . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINTI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer usacmp + integer nbenti + integer suppor(nbenti) + integer indtab +c + double precision indica(nbenti) + double precision tabind(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter (nbmess = 11 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Prise en compte des valeurs pour les '',a))' + texte(1,5) = + >'(''. Nombre d''''entites designees par le support :'',i10)' + texte(1,9) = '(''. Norme L2 des composantes.'')' + texte(1,10) = '(''. Norme infinie des composantes.'')' + texte(1,11) = '(''. Valeur relative de la composante.'')' +c + texte(2,4) = '(''Values for the '',a))' + texte(2,5) = + >'(''. Number of entities declared by support of error :'',i10)' + texte(2,9) = '(''. L2 norm of components.'')' + texte(2,10) = '(''. Infinite norm of components.'')' + texte(2,11) = '(''. Relative value for the component.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c==== +c 2. si on s'interesse a la valeur absolue de l'indicateur d'erreur, +c on remplace sa valeur +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9+usacmp)) +#endif +c + if ( usacmp.ne.2 ) then +c + do 21 , iaux = 1, nbenti + if ( suppor(iaux).ne.0 ) then + indica(iaux) = abs(indica(iaux)) + endif + 21 continue +c + endif +c +c==== +c 3. compactage +c le tableau d'indicateur peut comporter des trous. Le tableau +c suppor indique pour chaque entite si elle comporte un +c indicateur d'erreur, 1, ou si c'est sans objet, 0. +c on tasse alors le tableau d'indicateur de indica vers ntrav1 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. compactage, codret = ',codret +#endif +c +c Exemple : +c numero entite : 1 2 3 4 5 6 ==> nbenti = 6 +c indica : NaN 3.8 4.2 NaN NaN 2.3 +c apres compactage : +c ntrav1 : 3.8 4.2 2.3 NaN NaN NaN +c ntrav2 : 2 3 6 NaN NaN NaN ==> iaux = 3 +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1, nbenti + if ( suppor(iaux).ne.0 ) then + indtab = indtab + 1 + tabind(indtab) = indica(iaux) + endif + 31 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) indtab +#endif +cgn write (ulsort, * )'================== indica =========' +cgn write (ulsort, 1401 )(iaux,indica(iaux),iaux=1,nbenti) +cgn write (ulsort, * )'================== suppor =========' +cgn write (ulsort, 1400 )(iaux,suppor(iaux),iaux=1,nbenti) +cgn print * ,'================== ptrav1 =========' +cgn print 1401 ,(iaux,tabind(iaux),iaux=1,indtab) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinun.F b/src/tool/Decision/deinun.F new file mode 100644 index 00000000..6f7f61f7 --- /dev/null +++ b/src/tool/Decision/deinun.F @@ -0,0 +1,230 @@ + subroutine deinun ( pilraf, pilder, nivmax, nivmin, + > decfac, decare, + > hetare, + > hettri, + > hetqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation si UNiforme +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . pilraf . e . 1 . pilotage du raffinement . +c . . . . -1 : raffinement uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : raffinement libre . +c . . . . 2 : raff. libre homogene en type d'element. +c . pilder . e . 1 . pilotage du deraffinement . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : deraffinement libre . +c . . . . -1 : deraffinement uniforme . +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . decare . s .0:nbarto. decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : impossible de raffiner . +c . . . . 5 : impossible de deraffiner . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINUN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer pilraf, pilder, nivmax, nivmin + integer decfac(-nbquto:nbtrto) + integer decare(0:nbarto) + integer hetare(nbarto) + integer hettri(nbtrto) + integer hetqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer larete, letria, lequad + integer etat +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,5x,''Niveau '',a7,'' dans le maillage :'',i6)' + texte(1,5) = '(/,5x,''Niveau '',a7,'' voulu :'',i6)' + texte(1,6) = '(5x,''Raffinement uniforme'')' + texte(1,7) = '(5x,''Deraffinement uniforme'')' + texte(1,10) = '(/,5x,''--> Traitement impossible.'')' +c + texte(2,4) = '(/,5x,a7,''level in the mesh :'',i6)' + texte(2,5) = '(/,5x,a7,''level wanted :'',i6)' + texte(2,6) = '(5x,''Uniform refinement'')' + texte(2,7) = '(5x,''Uniform unrefinement'')' + texte(2,10) = '(/,5x,''--> Treatment cannot be done.'')' +c +c 1.2. ==> Controle des niveaux extremes du maillage courant +c + if ( pilraf.eq.-1 .and. nivmax.ge.0 ) then + if ( nivsup.ge.nivmax ) then + write (ulsort,texte(langue,4)) 'maximum', nivsup + write (ulsort,texte(langue,5)) 'maximum', nivmax + write (ulsort,texte(langue,10)) + codret = 1 + endif + endif +c + if ( pilder.eq.-1 .and. nivmin.ge.0 ) then + if ( nivinf.le.nivmin ) then + write (ulsort,texte(langue,4)) 'minimum', nivinf + write (ulsort,texte(langue,5)) 'minimum', nivmin + write (ulsort,texte(langue,10)) + codret = 5 + endif + endif +c +c==== +c 2. Decisions de raffinement uniforme sur aretes et faces actives +c==== +c + if ( pilraf.eq.-1 ) then +c + write(ulsort,texte(langue,6)) +c + do 21 , larete = 1, nbarto + if ( mod(hetare(larete),10).eq.0 ) then + decare (larete) = 2 + endif + 21 continue +c + do 22 , letria = 1, nbtrto + if ( mod(hettri(letria),10).eq.0 ) then + decfac (letria) = 4 + endif + 22 continue +c + do 23 , lequad = 1, nbquto + if ( mod(hetqua(lequad),100).eq.0 ) then + decfac (-lequad) = 4 + endif + 23 continue +c + endif +c +c==== +c 3. deraffinement uniforme +c==== +c + if ( pilder.eq.-1 ) then +c + write(ulsort,texte(langue,7)) +c + do 31 , larete = 1, nbarto + if ( mod(hetare(larete),10).eq.2 ) then + decare (larete) = -1 + endif + 31 continue +c + do 32 , letria = 1, nbtrto + etat = mod(hettri(letria),10) + if ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then + decfac (letria) = -1 + endif + 32 continue +c + do 33 , lequad = 1, nbquto + if ( mod(hetqua(lequad),100).eq.4 ) then + decfac (-lequad) = -1 + endif + 33 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +cgn letria = 824 +cgn write (ulsort,*) 'tri', letria, hettri(letria), decfac(letria) +cgn larete = 17736 +cgn write (ulsort,*) 'are', larete, hetare(larete), decare(larete) +#endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinz0.F b/src/tool/Decision/deinz0.F new file mode 100644 index 00000000..2a2e87a1 --- /dev/null +++ b/src/tool/Decision/deinz0.F @@ -0,0 +1,269 @@ + subroutine deinz0 ( option, + > xmin, xmax, + > ymin, ymax, + > zmin, zmax, + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur +c -- -- +c defini par des Zones de raffinement +c - +c phase 0 : boite parallelepipedique +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : raffinement, -1 : deraffinement . +c .xmin/max. e . 1 . caracteristiques du parallelepipede . +c .ymin/max. . . . +c .zmin/max. . . . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . nozone . aux . nbnoto . auxiliaire pour le transfert zone/noeud . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINZ0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer option + integer dimcst + integer nozone(nbnoto) +c + double precision xmin, xmax, ymin, ymax, zmin, zmax + double precision coonoe(nbnoto,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + double precision daux + double precision xminlo, xmaxlo, yminlo, ymaxlo, zminlo, zmaxlo +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +#ifdef _DEBUG_HOMARD_ + character*1 saux01(3) + data saux01 / 'X', 'Y', 'Z' / +#endif +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Zone parellepipedique'')' + texte(1,5) = '(''Prise en compte du noeud '',i10,3g15.7)' +c + texte(2,4) = '(''Zone as a brick'')' + texte(2,5) = '(''OK for node # '',i10,3g15.7)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90034) 'Xmin', xmin, 'Xmax', xmax + write (ulsort,90034) 'Ymin', ymin, 'Ymax', ymax + write (ulsort,90034) 'Zmin', zmin, 'Zmax', zmax + write (ulsort,90002) 'sdim', sdim + write (ulsort,90002) 'dimcst', dimcst + if ( dimcst.ne.0 ) then + write (ulsort,90004) saux01(dimcst)//' constant', coocst(dimcst+1) + endif + write (ulsort,90002) 'maextr', maextr +#endif +c +c==== +c 2. Du vrai 3D +c==== +c + if ( sdim.eq.3 ) then +c + do 21 , iaux = 1, nbnoto +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90004) 'X', coonoe(iaux,1), xmin, xmax + write(ulsort,90004) 'Y', coonoe(iaux,2), ymin, ymax + write(ulsort,90004) 'Z', coonoe(iaux,3), zmin, zmax +#endif + if ( coonoe(iaux,1).lt.xmin ) then + goto 21 + elseif ( coonoe(iaux,1).gt.xmax ) then + goto 21 + elseif ( coonoe(iaux,2).lt.ymin ) then + goto 21 + elseif ( coonoe(iaux,2).gt.ymax ) then + goto 21 + elseif ( coonoe(iaux,3).lt.zmin ) then + goto 21 + elseif ( coonoe(iaux,3).gt.zmax ) then + goto 21 + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) iaux, + > coonoe(iaux,1), coonoe(iaux,2), coonoe(iaux,3) +#endif + nozone(iaux) = option +c + 21 continue +c +c==== +c 3. Du vrai 2D ou du 2D defini dans un espace 3D +c . Avec du vrai 2D, on part du principe que Z est nul +c . Avec du 2D immerge, on repere +c . On verifie que la coordonnee constante est compatible, +c avec une certaine tolerance +c==== +c + else +c + if ( ( dimcst.eq.0 .or. dimcst.eq.3 ) .and. + > ( maextr.eq.0 .or. maextr.eq.3 ) ) then + xminlo = xmin + xmaxlo = xmax + yminlo = ymin + ymaxlo = ymax + zminlo = zmin + zmaxlo = zmax + jaux = 4 + daux = max(coocst(8), coocst(9)) + elseif ( dimcst.eq.1 .or. maextr.eq.1 ) then + xminlo = ymin + xmaxlo = ymax + yminlo = zmin + ymaxlo = zmax + zminlo = xmin + zmaxlo = xmax + jaux = 2 + daux = max(coocst(9), coocst(10)) + elseif ( dimcst.eq.2 .or. maextr.eq.2 ) then + xminlo = xmin + xmaxlo = xmax + yminlo = zmin + ymaxlo = zmax + zminlo = ymin + zmaxlo = ymax + jaux = 3 + daux = max(coocst(10), coocst(8)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90034) 'Xminlo', xminlo, 'Xmaxlo', xmaxlo + write (ulsort,90034) 'Yminlo', yminlo, 'Ymaxlo', ymaxlo + write (ulsort,90034) 'Zminlo', zminlo, 'Zmaxlo', zmaxlo +#endif +c + daux = 1.d-4*daux + if ( zminlo.gt.coocst(jaux)+daux .or. + > zmaxlo.lt.coocst(jaux)-daux ) then + goto 310 + endif +c + do 31 , iaux = 1, nbnoto +c + if ( coonoe(iaux,1).lt.xminlo ) then + goto 31 + elseif ( coonoe(iaux,1).gt.xmaxlo ) then + goto 31 + elseif ( coonoe(iaux,2).lt.yminlo ) then + goto 31 + elseif ( coonoe(iaux,2).gt.ymaxlo ) then + goto 31 + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) iaux, + > coonoe(iaux,1), coonoe(iaux,2) +#endif + nozone(iaux) = option +c + 31 continue +c + 310 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinz1.F b/src/tool/Decision/deinz1.F new file mode 100644 index 00000000..c09211d8 --- /dev/null +++ b/src/tool/Decision/deinz1.F @@ -0,0 +1,241 @@ + subroutine deinz1 ( option, + > rayon, + > xcen, ycen, zcen, + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur +c -- -- +c defini par des Zones de raffinement +c - +c phase 1 : sphere +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : raffinement, -1 : deraffinement . +c . rayon . e . 1 . caracteristiques de la sphere . +c . xcen . . . . +c . ycen . . . . +c . zcen . . . . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . nozone . aux . nbnoto . auxiliaire pour le transfert zone/noeud . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINZ1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer option + integer dimcst + integer nozone(nbnoto) +c + double precision rayon, xcen, ycen, zcen + double precision coonoe(nbnoto,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + double precision daux + double precision rext2 + double precision xcenlo, ycenlo, zcenlo +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +#ifdef _DEBUG_HOMARD_ + character*1 saux01(3) + data saux01 / 'X', 'Y', 'Z' / +#endif +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Zone spherique'')' + texte(1,8) = '(''Prise en compte du noeud '',i10,3g15.7)' +c + texte(2,4) = '(''Spherical zone'')' + texte(2,8) = '(''OK for node # '',i10,3g15.7)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90004) 'Rayon', rayon + write (ulsort,90004) 'X centre', xcen + write (ulsort,90004) 'Y centre', ycen + write (ulsort,90004) 'Z centre', zcen + write (ulsort,*) 'sdim =',sdim,', dimcst =',dimcst + if ( dimcst.ne.0 ) then + write (ulsort,90004) saux01(dimcst)//' constant', coocst(dimcst+1) + endif +#endif +c +c 1.2 ==> Carre du rayon +c + rext2 = rayon*rayon +cgn write (ulsort,90004) '==> rext2', rext2 +c +c==== +c 2. Du vrai 3D +c==== +c + if ( sdim.eq.3 ) then +c + do 21 , iaux = 1, nbnoto +c + daux = ( coonoe(iaux,1)-xcen ) * ( coonoe(iaux,1)-xcen ) + > + ( coonoe(iaux,2)-ycen ) * ( coonoe(iaux,2)-ycen ) + > + ( coonoe(iaux,3)-zcen ) * ( coonoe(iaux,3)-zcen ) +c + if ( daux.le.rext2 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,8)) iaux, + > coonoe(iaux,1), coonoe(iaux,2), coonoe(iaux,3) +#endif + nozone(iaux) = option + endif +c + 21 continue +c +c==== +c 3. Du vrai 2D ou du 2D defini dans un espace 3D +c . Avec du vrai 2D, on part du principe que Z est nul +c . Avec du 2D immerge, on repere +c . On verifie que la coordonnee constante est compatible, +c avec une certaine tolerance +c==== +c + else +c + if ( ( dimcst.eq.0 .or. dimcst.eq.3 ) .and. + > ( maextr.eq.0 .or. maextr.eq.3 ) ) then + xcenlo = xcen + ycenlo = ycen + zcenlo = zcen + jaux = 4 + elseif ( dimcst.eq.1 .or. maextr.eq.1 ) then + xcenlo = ycen + ycenlo = zcen + zcenlo = xcen + jaux = 2 + elseif ( dimcst.eq.2 .or. maextr.eq.2 ) then + xcenlo = xcen + ycenlo = zcen + zcenlo = ycen + jaux = 3 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90004) 'xcenlo', xcenlo + write (ulsort,90004) 'ycenlo', ycenlo + write (ulsort,90004) 'zcenlo', zcenlo +#endif +c + do 31 , iaux = 1, nbnoto +c + daux = ( coonoe(iaux,1)-xcenlo ) * ( coonoe(iaux,1)-xcenlo ) + > + ( coonoe(iaux,2)-ycenlo ) * ( coonoe(iaux,2)-ycenlo ) + > + ( coocst(jaux)-zcenlo ) * ( coocst(jaux)-zcenlo ) +c + if ( daux.le.rext2 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,8)) iaux, + > coonoe(iaux,1), coonoe(iaux,2) +#endif + nozone(iaux) = option + endif +c + 31 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinz2.F b/src/tool/Decision/deinz2.F new file mode 100644 index 00000000..6126f69c --- /dev/null +++ b/src/tool/Decision/deinz2.F @@ -0,0 +1,272 @@ + subroutine deinz2 ( option, + > rext, rint, + > haut, + > xaxe, yaxe, zaxe, + > xbas, ybas, zbas, + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur +c -- -- +c defini par des Zones de raffinement +c - +c phase 2 : boite cylindrique/tuyau +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : raffinement, -1 : deraffinement . +c . rext . e . 1 . caracteristiques du cylindre/tuyau . +c . rint . . . Si <0 : cylindre . +c . haut . . . . +c .x,y,zaxe. . . . +c .x,y,zbas. . . . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . nozone . aux . nbnoto . auxiliaire pour le transfert zone/noeud . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINZ2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombno.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + integer option + integer dimcst + integer nozone(nbnoto) +c + double precision rext, rint + double precision haut + double precision xaxe, yaxe, zaxe + double precision xbas, ybas, zbas + double precision coonoe(nbnoto,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision epsid2 + double precision daux + double precision vect1(3), vect2(3) + double precision rint2, rext2 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +#ifdef _DEBUG_HOMARD_ + character*1 saux01(3) + data saux01 / 'X', 'Y', 'Z' / +#endif +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Zone cylindrique'')' + texte(1,5) = '(''Zone tuyau'')' + texte(1,8) = '(''Prise en compte du noeud '',i10,3g15.7)' + texte(1,9) = '(''La definition de l''''axe est invalide.'')' +c + texte(2,4) = '(''Cylindrical zonek'')' + texte(2,5) = '(''Zone as a brick'')' + texte(2,8) = '(''OK for node # '',i10,3g15.7)' + texte(2,9) = '(''The definition of the axis is not valid.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( rint.lt.0 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) + write (ulsort,90004) 'Rint', rint + endif + write (ulsort,90004) 'Rext', rext + write (ulsort,90004) 'Hauteur', haut + write (ulsort,90004) 'Xaxe', xaxe + write (ulsort,90004) 'Yaxe', yaxe + write (ulsort,90004) 'Zaxe', zaxe + write (ulsort,90004) 'Xbas', xbas + write (ulsort,90004) 'Ybas', ybas + write (ulsort,90004) 'Zbas', zbas +cgn write (ulsort,*) 'sdim =',sdim,', dimcst =',dimcst + if ( dimcst.ne.0 ) then + write (ulsort,90004) saux01(dimcst)//' constant', coocst(dimcst+1) + endif +#endif +c +c 1.2 ==> Carre des rayons +c + rext2 = rext*rext +cgn write (ulsort,90004) '==> rext2', rext2 + if ( rint.ge.0 ) then + rint2 = rint*rint +cgn write (ulsort,90004) '==> rint2', rint2 + endif +c +c==== +c 2. Normalisation du vecteur de l'axe +c==== +c + daux = xaxe*xaxe + yaxe*yaxe + zaxe*zaxe +c + epsid2 = max(1.d-14,epsima) + if ( daux.le.epsid2 ) then + write (ulsort,texte(langue,9)) + codret = 2 + else + daux = 1.d0 / sqrt( daux ) + vect1(1) = xaxe * daux + vect1(2) = yaxe * daux + vect1(3) = zaxe * daux + endif +c +c==== +c 3. Du vrai 3D +c==== +c + if ( sdim.eq.3 ) then +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1, nbnoto +c +c controle du positionnement sur l'axe : +c la distance a la base est egale au produit +c scalaire (base-M)xVecteur-axe +c + daux = ( coonoe(iaux,1)-xbas ) * vect1(1) + > + ( coonoe(iaux,2)-ybas ) * vect1(2) + > + ( coonoe(iaux,3)-zbas ) * vect1(3) +c + if ( daux.lt.0.d0 .or. daux.gt.haut ) then + goto 31 + endif +c +c controle du rayon : +c la distance a l'axe est egale a la norme du +c produit vectoriel (base-M)xVecteur-axe +c + vect2(1) = (coonoe(iaux,2)-ybas)*vect1(3) + > - (coonoe(iaux,3)-zbas)*vect1(2) + vect2(2) = (coonoe(iaux,3)-zbas)*vect1(1) + > - (coonoe(iaux,1)-xbas)*vect1(3) + vect2(3) = (coonoe(iaux,1)-xbas)*vect1(2) + > - (coonoe(iaux,2)-ybas)*vect1(1) + daux = vect2(1)*vect2(1) + > + vect2(2)*vect2(2) + > + vect2(3)*vect2(3) +c + if ( daux.lt.rint2 .or. daux.gt.rext2 ) then + goto 31 + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,8)) iaux, + > coonoe(iaux,1), coonoe(iaux,2), coonoe(iaux,3) +#endif + nozone(iaux) = option +c + 31 continue +c + endif +c +c==== +c 4. Du vrai 2D ou du 2D defini dans un espace 3D +c . Avec du vrai 2D, on part du principe que Z est nul +c . Avec du 2D immerge, on repere +c . On verifie que la coordonnee constante est compatible, +c avec une certaine tolerance +c==== +c + else +c + codret = 40 +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deinzr.F b/src/tool/Decision/deinzr.F new file mode 100644 index 00000000..4f6a2241 --- /dev/null +++ b/src/tool/Decision/deinzr.F @@ -0,0 +1,586 @@ + subroutine deinzr ( nbzord, cazord, + > coonoe, dimcst, coocst, + > somare, hetare, + > nozone, arsupp, arindi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - INitialisation de l'indicateur +c -- -- +c defini par des Zones de Raffinement +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbzord . e . 1 . nombre de zones a raffiner/deraffiner . +c . cazord . e . 20 * . caracteristiques zone a raffiner/deraffiner. +c . . . nbzord . 1 : >0 si a raffiner, <0 si a deraffiner . +c . . . . . si rectangle : . +c . . . . 1 : +-1 . +c . . . . de 2 a 5 : xmin, xmax, ymin, ymax . +c . . . . . si parallelepipede : . +c . . . . 1 : +-2 . +c . . . . de 2 a 7 : xmin, xmax, ymin, ymax . +c . . . . zmin, zmax . +c . . . . . si disque : . +c . . . . 1 : +-3 . +c . . . . de 8 a 10 : rayon, xcentr, ycentr . +c . . . . . si sphere : . +c . . . . 1 : +-4 . +c . . . . de 8 a 11 : rayon, xcentr, ycentr, zcentr . +c . . . . . si cylindre : . +c . . . . 1 : +-5 . +c . . . . 8 : rayon . +c . . . . de 12 a 14 : xaxe, yaxe, zaxe . +c . . . . de 15 a 17 : xbase, ybase, zbase . +c . . . . 18 : hauteur . +c . . . . . si disque perce : . +c . . . . 1 : +-6 . +c . . . . de 9 a 10 : xcentr, ycentr . +c . . . . 19 : rayon interieur . +c . . . . 20 : rayon exterieur . +c . . . . . si tuyau : . +c . . . . 1 : +-7 . +c . . . . de 12 a 14 : xaxe, yaxe, zaxe . +c . . . . de 15 a 17 : xbase, ybase, zbase . +c . . . . 18 : hauteur . +c . . . . 19 : rayon interieur . +c . . . . 20 : rayon exterieur . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . nozone . aux . nbnoto . auxiliaire pour le transfert zone/noeud . +c . arsupp . s . nbarto . support pour les aretes . +c . arindi . s . nbarto . valeurs entieres pour les aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEINZR' ) +c +#include "nblang.h" +c + integer nbmcle + parameter ( nbmcle = 20 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbzord + integer somare(2,nbarto), hetare(nbarto) + integer dimcst + integer nozone(nbnoto) + integer arsupp(nbarto), arindi(nbarto) +c + double precision cazord(nbmcle,nbzord) + double precision coonoe(nbnoto,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer nrzord, tyzord, tyzosg +c + character*8 saux08(nbmcle) +c + double precision daux + double precision rext2, rint2 +c + logical afaire + logical mccod2(nbmcle) +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c + character*13 messag(nblang,8) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + character*1 saux01(3) + data saux01 / 'X', 'Y', 'Z' / +#endif +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de zones a raffiner :'',i8)' + texte(1,5) = '(/,7x,''Zone de raffinement numero'',i3)' + texte(1,6) = '(/,7x,''Zone de deraffinement numero'',i3)' + texte(1,7) = '(10x,''Type de la zone : '',a)' + texte(1,8) = '(10x,''Forme de zone inconnue :'',g15.7)' + texte(1,9) = '(''Prise en compte du noeud '',i10,3g15.7)' +c + texte(2,4) = '(''Number of zones to refine :'',i8)' + texte(2,5) = '(/,7x,''Refinement zone #'',i3)' + texte(2,6) = '(/,7x,''Unrefinement zone #'',i3)' + texte(2,7) = '(10x,''Type of zone : '',a)' + texte(2,8) = '(10x,''Unknown zone shape :'',g15.7)' + texte(2,9) = '(''OK for node # '',i10,3g15.7)' +c +c 1234567890123 + messag(1,1) = 'Rectangle ' + messag(1,2) = 'Parallepipede' + messag(1,3) = 'Disque ' + messag(1,4) = 'Sphere ' + messag(1,5) = 'Cylindre ' + messag(1,6) = 'Disque perce ' + messag(1,7) = 'Tuyau ' +c + messag(2,1) = 'Rectangle ' + messag(2,2) = 'Parallepiped ' + messag(2,3) = 'Disk ' + messag(2,4) = 'Sphere ' + messag(2,5) = 'Cylindre ' + messag(2,6) = 'Disk ' + messag(2,7) = 'Pipe ' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbzord + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'sdim ', sdim + write (ulsort,90002) 'dimcst', dimcst + if ( dimcst.ne.0 ) then + write (ulsort,90104) saux01(dimcst)//' constant', coocst(dimcst+1) + endif +#endif +c +#include "impr03.h" +c +c==== +c 2. les zones +c==== +c 2.1. ==> verifications +c + codret = 0 +c + if ( codret.eq.0 ) then +c + do 21 , nrzord = 1 , nbzord + if ( cazord(1,nrzord).gt.0.d0 ) then + tyzosg = 1 + else + tyzosg = -1 + endif + tyzord = nint(abs(cazord(1,nrzord))) + if ( tyzord.lt.1 .or. tyzord.gt.7 ) then + write (ulsort,texte(langue,5+(1-tyzosg)/2)) nrzord + write (ulsort,texte(langue,8)) cazord(1,nrzord) + codret = codret + 1 + endif + 21 continue +c + endif +c +c 2.2. ==> impressions +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. impressions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + saux08( 2) = 'X min ' + saux08( 3) = 'X max ' + saux08( 4) = 'Y min ' + saux08( 5) = 'Y max ' + saux08( 6) = 'Z min ' + saux08( 7) = 'Z max ' + saux08( 8) = 'Rayon ' + saux08( 9) = 'X centre' + saux08(10) = 'Y centre' + saux08(11) = 'Z centre' + saux08(12) = 'X axe ' + saux08(13) = 'Y axe ' + saux08(14) = 'Z axe ' + saux08(15) = 'X base ' + saux08(16) = 'Y base ' + saux08(17) = 'Z base ' + saux08(18) = 'Hauteur ' + saux08(19) = 'Rayon In' + saux08(20) = 'Rayon Ex' +c + do 22 , nrzord = 1 , nbzord +c + if ( cazord(1,nrzord).gt.0.d0 ) then + tyzosg = 1 + else + tyzosg = -1 + endif + tyzord = nint(abs(cazord(1,nrzord))) + write (ulsort,texte(langue,5+(1-tyzosg)/2)) nrzord + write (ulsort,texte(langue,7)) messag(langue,tyzord) +c + do 221 , iaux = 1 , nbmcle + mccod2(iaux) = .false. + 221 continue +c + if ( tyzord.eq.1 ) then + do 2211 , iaux = 2 , 5 + mccod2(iaux) = .true. + 2211 continue + elseif ( tyzord.eq.2 ) then + do 2212 , iaux = 2 , 7 + mccod2(iaux) = .true. + 2212 continue + elseif ( tyzord.eq.3 ) then + do 2213 , iaux = 8 , 10 + mccod2(iaux) = .true. + 2213 continue + elseif ( tyzord.eq.4 ) then + do 2214 , iaux = 8 , 11 + mccod2(iaux) = .true. + 2214 continue + elseif ( tyzord.eq.5 ) then + mccod2(8) = .true. + do 2215 , iaux = 12 , 18 + mccod2(iaux) = .true. + 2215 continue + elseif ( tyzord.eq.6 ) then + mccod2(9) = .true. + mccod2(10) = .true. + mccod2(19) = .true. + mccod2(20) = .true. + else + do 2217 , iaux = 12 , 20 + mccod2(iaux) = .true. + 2217 continue + endif +c + do 222 , iaux = 2 , nbmcle + if ( mccod2(iaux) ) then + write (ulsort,90104) ' '//saux08(iaux), + > cazord(iaux,nrzord) + endif + 222 continue +c + 22 continue +c + endif +c +c==== +c 3. Creation d'un indicateur portant sur les aretes : une arete est a +c decouper si et seulement si ses deux extremites sont dans la meme +c zone. +c On parcourt toutes les zones et on marque les noeuds qui sont +c a l'interieur de la zone. Puis on note les aretes dont les noeuds +c sont dans la zone. +c Remarque : cet algorithme de decodage n'est pas hyper performant +c si on a plusieurs zones. Mais c'est une maniere simple de gerer +c les recouvrements de zones. +c Remarque : attention a ne marquer que les aretes actives, comme si +c on avait produit un veritable indicateur d'erreur +c +c Exemple 1 : +c | | | +c | ooo|oooo | +c ....|.............o..|...o........|... +c . | o | o | . +c ------A-------------o--B---o--------C----- +c . | o | o | . +c . | o | o | . +c ....|.............o..|...o........|... +c | o | o | +c | o | o | +c ------D-------------o--E---o--------F----- +c | o | o | +c | ooo|oooo | +c | | | +c La zone . contient les noeuds A, B et C : +c ==> les aretes AB et BC sont a couper +c La zone o contient les noeuds B et E : +c ==> l'arete BE est a couper +c +c Exemple 2 : +c | | | +c | | | +c ....|................|............|... +c . | | | . +c ------A----------------B------------C----- +c . | | | . +c . | ooo|oooo | . +c ....|.............o..|...o........|... +c | o | o | +c | o | o | +c ------D-------------o--E---o--------F----- +c | o | o | +c | ooo|oooo | +c | | | +c La zone . contient les noeuds A, B et C : +c ==> les aretes AB et BC sont a couper +c La zone o contient le noeud E : +c ==> aucune arete n'est a couper +c +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. creation indicateur ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +cgn print 1789,0,0.,cazord(2,2),cazord(3,2),cazord(4,2) +c +c 3.1. ==> A priori, on suppose qu'aucune arete n'est concernee +c + do 31 , iaux = 1, nbarto +c + arsupp(iaux) = 0 + arindi(iaux) = 0 +c + 31 continue +c +c 3.2. ==> Exploration des differentes zones +c Quand la zone a ete declaree 3D mais que l'espace est 2D, +c on change de categorie +c + do 32 , nrzord = 1 , nbzord +c + if ( cazord(1,nrzord).gt.0.d0 ) then + tyzosg = 1 + else + tyzosg = -1 + endif + tyzord = nint(abs(cazord(1,nrzord))) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5+(1-tyzosg)/2)) nrzord + write (ulsort,texte(langue,7)) messag(langue,tyzord) +#endif +c +c 3.2.0. ==> A priori, aucun noeud n'est concerne +c + do 320 , iaux = 1, nbnoto + nozone(iaux) = 0 + 320 continue +c +c 3.2.1. ==> Filtrage sur une boite rectangulaire +c + if ( tyzord.eq.1 ) then +c + do 321 , iaux = 1, nbnoto +c +cgn write(ulsort,90104) 'X', +cgn > coonoe(iaux,1), cazord(2,nrzord),cazord(3,nrzord) +cgn write(ulsort,90104) 'Y', +cgn > coonoe(iaux,2), cazord(4,nrzord),cazord(5,nrzord) +cgn write (ulsort,90014)iaux, (coonoe(iaux,jaux),jaux=1,sdim) + afaire = .true. + if ( coonoe(iaux,1).lt.cazord(2,nrzord) ) then + afaire = .false. + elseif ( coonoe(iaux,1).gt.cazord(3,nrzord) ) then + afaire = .false. + endif + if ( afaire .and. sdim.ge.2 ) then + if ( coonoe(iaux,2).lt.cazord(4,nrzord) ) then + afaire = .false. + elseif ( coonoe(iaux,2).gt.cazord(5,nrzord) ) then + afaire = .false. + endif + endif + if ( afaire ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,9)) iaux, + > (coonoe(iaux,jaux),jaux=1,sdim) +#endif + nozone(iaux) = tyzosg + endif +c + 321 continue +c +c 3.2.2. ==> Filtrage sur une boite parallelepipedique +c + elseif ( tyzord.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINZ0', nompro +#endif + call deinz0 ( tyzosg, + > cazord(2,nrzord), cazord(3,nrzord), + > cazord(4,nrzord), cazord(5,nrzord), + > cazord(6,nrzord), cazord(7,nrzord), + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c +c 3.2.3. ==> Filtrage sur une boite circulaire / circulaire percee +c + elseif ( tyzord.eq.3 .or. tyzord.eq.6 ) then +c + if ( tyzord.eq.3 ) then + rint2 = -1.d0 + rext2 = cazord(8,nrzord)*cazord(8,nrzord) + else + rint2 = cazord(19,nrzord)*cazord(19,nrzord) + rext2 = cazord(20,nrzord)*cazord(20,nrzord) + endif +cgn write (ulsort,90004) 'rext2', rext2 +cgn write (ulsort,90004) 'rint2', rint2 +cgn write (ulsort,90004) 'centre', cazord( 9,nrzord),cazord(10,nrzord) +c + do 323 , iaux = 1, nbnoto +c + daux = ( coonoe(iaux,1)-cazord( 9,nrzord) ) + > * ( coonoe(iaux,1)-cazord( 9,nrzord) ) + if ( sdim.ge.2 ) then + daux = daux + > + ( coonoe(iaux,2)-cazord(10,nrzord) ) + > * ( coonoe(iaux,2)-cazord(10,nrzord) ) + endif +cgn write (ulsort,90014)iaux,(coonoe(iaux,jaux),jaux=1,sdim) +c + if ( daux.ge.rint2 .and. daux.le.rext2 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,9)) iaux, + > (coonoe(iaux,jaux),jaux=1,sdim) +#endif + nozone(iaux) = tyzosg + endif +c + 323 continue +c +c 3.2.4. ==> Filtrage sur une boite spherique +c + elseif ( tyzord.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINZ1', nompro +#endif + call deinz1 ( tyzosg, + > cazord(8,nrzord), + > cazord(9,nrzord), cazord(10,nrzord), + > cazord(11,nrzord), + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c +c 3.2.5. ==> Filtrage sur une boite cylindrique/tuyau +c + elseif ( tyzord.eq.5 .or. tyzord.eq.7 ) then +c + if ( tyzord.eq.5 ) then + iaux = 8 + daux = -1.d0 + else + iaux = 20 + daux = cazord(19,nrzord) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINZ2', nompro +#endif + call deinz2 ( tyzosg, + > cazord(iaux,nrzord), daux, + > cazord(18,nrzord), + > cazord(12,nrzord), cazord(13,nrzord), + > cazord(14,nrzord), + > cazord(15,nrzord), cazord(16,nrzord), + > cazord(17,nrzord), + > coonoe, dimcst, coocst, + > nozone, + > ulsort, langue, codret ) +c + endif +c +c 3.2.9. ==> Transfert aux aretes +c +cgn write(ulsort,4000) (iaux, nozone(iaux) , iaux = 1, nbnoto) + do 329 , iaux = 1, nbarto +c + if ( nozone(somare(1,iaux)).eq.tyzosg .and. + > nozone(somare(2,iaux)).eq.tyzosg ) then +cgn write (ulsort,*) 'arete ',iaux, +cgn > ' de ',somare(1,iaux),' a ',somare(2,iaux) + if ( mod(hetare(iaux),10).eq.0 ) then + arsupp(iaux) = 1 + arindi(iaux) = tyzosg + endif + endif +c + 329 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'fin de 32 ; codret', codret +#endif +c + 32 continue +c + endif +c +c==== +c 4. la fin +c==== +c +cgn write(ulsort,4000) (iaux, arindi(iaux) , iaux = 1, nbarto) +cgn 4000 format(5(i4,' :',i2)) + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiped.F b/src/tool/Decision/deiped.F new file mode 100644 index 00000000..849a165b --- /dev/null +++ b/src/tool/Decision/deiped.F @@ -0,0 +1,208 @@ + subroutine deiped ( nivmin, + > decare, decfac, + > aretri, nivtri, + > arequa, + > facpen, hetpen, filpen, + > pesupp, peindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PEntaedres - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . e . nbpeto . valeurs entieres pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPED' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), nivtri(nbtrto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), hetpen(nbpeto), filpen(nbpeto) + integer pesupp(nbpeto), peindi(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc, etat + integer lepent + integer iaux, jaux + integer letria, lequad, fils1 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pentaedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un pentaedre est identifie a celui de n'importe lequel +c de ses faces. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,7) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , lepent = 1, nbpeto +c + etat = mod( hetpen(lepent) , 100 ) + if ( etat.eq.80 ) then + fils1 = filpen(lepent) + if ( pesupp(fils1) .ne. 0 .and. + > pesupp(fils1+1) .ne. 0 .and. + > pesupp(fils1+2) .ne. 0 .and. + > pesupp(fils1+3) .ne. 0 .and. + > pesupp(fils1+4) .ne. 0 .and. + > pesupp(fils1+5) .ne. 0 .and. + > pesupp(fils1+6) .ne. 0 .and. + > pesupp(fils1+7) .ne. 0 ) then + if ( peindi(fils1) .eq. -1 .and. + > peindi(fils1+1) .eq. -1 .and. + > peindi(fils1+2) .eq. -1 .and. + > peindi(fils1+3) .eq. -1 .and. + > peindi(fils1+4) .eq. -1 .and. + > peindi(fils1+5) .eq. -1 .and. + > peindi(fils1+6) .eq. -1 .and. + > peindi(fils1+7) .eq. -1 ) then + jaux = facpen(lepent,1) + if ( nivtri(jaux).lt.nivmin ) then + iaux = iaux + 8 + else + do 22 , facloc = 1, 2 + letria = facpen(lepent,facloc) + decfac(letria) = -1 + do 23 , areloc = 1, 3 + decare(aretri(letria,areloc)) = -1 +cgn write(ulsort,*) 'reactivation de arete', aretri(letria,areloc) + 23 continue + 22 continue + do 24 , facloc = 3, 5 + lequad = facpen(lepent,facloc) + decfac(-lequad) = -1 + do 25 , areloc = 1, 4 + decare(arequa(lequad,areloc)) = -1 +cgn write(ulsort,*) 'reactivation de arete', arequa(lequad,areloc) + 25 continue + 24 continue + endif + endif + endif + endif + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,7) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deipei.F b/src/tool/Decision/deipei.F new file mode 100644 index 00000000..bfa5d598 --- /dev/null +++ b/src/tool/Decision/deipei.F @@ -0,0 +1,207 @@ + subroutine deipei ( decare, decfac, + > aretri, pertri, + > arequa, perqua, + > facpen, + > pesupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PEntaedres - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPEI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), pertri(nbtrto) + integer arequa(nbquto,4), perqua(nbquto) + integer facpen(nbpecf,5) + integer pesupp(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer laface, lepent, lamere + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,7) +#endif +c + do 21 , lepent = 1, nbpeto +c + if ( pesupp(lepent).ne.0 ) then +c + do 210 , facloc = 1, 5 +c + laface = facpen(lepent,facloc) +c +c 2.1. ==> Face triangulaire +c + if ( facloc.le.2 ) then +c +c 2.1.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(laface) = 0 + do 211 , areloc = 1, 3 + decare(aretri(laface,areloc)) = 0 + 211 continue +c +c 2.1.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lamere = pertri(laface) +c + if ( lamere.gt.0 ) then +c + decfac(lamere) = 0 + do 212 , areloc = 1, 3 + decare(aretri(lamere,areloc)) = 0 + 212 continue +c + endif +c +c 2.2. ==> Face quadrangulaire +c + else +c +c 2.2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(-laface) = 0 + do 221 , areloc = 1, 4 + decare(arequa(laface,areloc)) = 0 + 221 continue +c +c 2.2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lamere = perqua(laface) +c + if ( lamere.gt.0 ) then +c + decfac(-lamere) = 0 + do 222 , areloc = 1, 4 + decare(arequa(lamere,areloc)) = 0 + 222 continue +c + endif +c + endif +c + 210 continue +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiper.F b/src/tool/Decision/deiper.F new file mode 100644 index 00000000..accb0c34 --- /dev/null +++ b/src/tool/Decision/deiper.F @@ -0,0 +1,209 @@ + subroutine deiper ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > arequa, hetqua, + > facpen, + > pesupp, peindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PEntaedres - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . e . nbpeto . valeurs entieres pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPER' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer facpen(nbpecf,5) + integer pesupp(nbpeto), peindi(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer laface, lepent + integer iaux, jaux, kaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pentaedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un pentaedre est identifie a celui de n'importe lequel +c de ses faces. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,7) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , lepent = 1, nbpeto +cgn print *,lepent,pesupp(lepent),peindi(lepent) + if ( pesupp(lepent).ne.0 ) then + if ( peindi(lepent).eq.1 ) then + jaux = facpen(lepent,1) + if ( nivmax.ge.0 .and. nivtri(jaux).ge.nivmax ) then + iaux = iaux + 1 + else + do 22 , facloc = 1, 5 + laface = facpen(lepent,facloc) + if ( facloc.le.2 ) then + if ( mod(hettri(laface),10).eq.0 ) then + decfac(laface) = 4 + endif + do 23 , areloc = 1, 3 + kaux = aretri(laface,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then +cgn write(ulsort,*) 'raffinement de arete', kaux + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).eq.2 ) then +cgn write(ulsort,*) 'maintien de arete', kaux + decare(kaux) = 0 + endif + 23 continue + else + if ( mod(hetqua(laface),100).eq.0 ) then + decfac(-laface) = 4 + endif + do 24 , areloc = 1, 4 + kaux = arequa(laface,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 +cgn write(ulsort,*) 'raffinement de arete', kaux + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 +cgn write(ulsort,*) 'maintien de arete', kaux + endif + 24 continue + endif + 22 continue + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,6) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deipyd.F b/src/tool/Decision/deipyd.F new file mode 100644 index 00000000..d4b830cc --- /dev/null +++ b/src/tool/Decision/deipyd.F @@ -0,0 +1,148 @@ + subroutine deipyd ( nivmin, + > hetpyr, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PYramides - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPYD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer hetpyr(nbpyto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer etat + integer lapyra + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pyramides +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'une pyramide est identifie a celui de n'importe lequel +c de ses faces. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,5) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , lapyra = 1, nbpyto +c + etat = mod( hetpyr(lapyra) , 100 ) + if ( etat.eq.80 ) then + codret = 12 + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,5) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deipyi.F b/src/tool/Decision/deipyi.F new file mode 100644 index 00000000..2cc2bc47 --- /dev/null +++ b/src/tool/Decision/deipyi.F @@ -0,0 +1,207 @@ + subroutine deipyi ( decare, decfac, + > aretri, pertri, + > arequa, perqua, + > facpyr, + > pysupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PYramides - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . pysupp . e . nbpyto . support pour les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPYI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), pertri(nbtrto) + integer arequa(nbquto,4), perqua(nbquto) + integer facpyr(nbpycf,5) + integer pysupp(nbpyto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer laface, lapyra, lamere + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,5) +#endif +c + do 21 , lapyra = 1, nbpyto +c + if ( pysupp(lapyra).ne.0 ) then +c + do 210 , facloc = 1, 5 +c + laface = facpyr(lapyra,facloc) +c +c 2.1. ==> Face triangulaire +c + if ( facloc.le.4 ) then +c +c 2.1.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(laface) = 0 + do 211 , areloc = 1, 3 + decare(aretri(laface,areloc)) = 0 + 211 continue +c +c 2.1.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lamere = pertri(laface) +c + if ( lamere.gt.0 ) then +c + decfac(lamere) = 0 + do 212 , areloc = 1, 3 + decare(aretri(lamere,areloc)) = 0 + 212 continue +c + endif +c +c 2.2. ==> Face quadrangulaire +c + else +c +c 2.2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(-laface) = 0 + do 221 , areloc = 1, 4 + decare(arequa(laface,areloc)) = 0 + 221 continue +c +c 2.2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lamere = perqua(laface) +c + if ( lamere.gt.0 ) then +c + decfac(-lamere) = 0 + do 222 , areloc = 1, 4 + decare(arequa(lamere,areloc)) = 0 + 222 continue +c + endif +c + endif +c + 210 continue +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deipyr.F b/src/tool/Decision/deipyr.F new file mode 100644 index 00000000..680a9786 --- /dev/null +++ b/src/tool/Decision/deipyr.F @@ -0,0 +1,210 @@ + subroutine deipyr ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > arequa, hetqua, + > facpyr, + > pysupp, pyindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des PYramides - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . e . nbpyto . valeurs entieres pour les pyramides . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIPYR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer facpyr(nbpycf,5) + integer pysupp(nbpyto), pyindi(nbpyto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer laface, lapyra + integer iaux, jaux, kaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les pyramides +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'une pyramide est identifie a celui de n'importe lequel +c de ses faces. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,5) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , lapyra = 1, nbpyto +c +cgn print *,lapyra,pysupp(lapyra),pyindi(lapyra) + if ( pysupp(lapyra).ne.0 ) then + if ( pyindi(lapyra).eq.1 ) then + jaux = facpyr(lapyra,1) + if ( nivmax.ge.0 .and. nivtri(jaux).ge.nivmax ) then + iaux = iaux + 1 + else + do 22 , facloc = 1, 5 + laface = facpyr(lapyra,facloc) + if ( facloc.le.4 ) then + if ( mod(hettri(laface),10).eq.0 ) then + decfac(laface) = 4 + endif + if ( laface.le.nbtrpe ) then + do 23 , areloc = 1, 3 + kaux = aretri(laface,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 + endif + 23 continue + endif + else + if ( mod(hetqua(laface),100).eq.0 ) then + decfac(-laface) = 4 + endif + if ( laface.le.nbqupe ) then + do 24 , areloc = 1, 4 + kaux = arequa(laface,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 + endif + 24 continue + endif + endif + 22 continue + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,5) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiqud.F b/src/tool/Decision/deiqud.F new file mode 100644 index 00000000..398cab8a --- /dev/null +++ b/src/tool/Decision/deiqud.F @@ -0,0 +1,212 @@ + subroutine deiqud ( nivmin, + > decare, decfac, + > arequa, hetqua, filqua, nivqua, + > qusupp, quindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des QUadrangles - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . e . nbquto . valeurs entieres pour les quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIQUD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), filqua(nbquto) + integer nivqua(nbquto) + integer qusupp(nbquto), quindi(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, etat + integer lequad + integer fille1 + integer iaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,4) +cgn write (ulsort,*) 'quadrangle 7' +cgn write (ulsort,*) 'decfac(q7) =',decfac(-7) +cgn write (ulsort,*) arequa(7,1),arequa(7,2), +cgn >arequa(7,3),arequa(7,4) +cgn write (ulsort,*) decare(arequa(7,1)),decare(arequa(7,2)), +cgn >decare(arequa(7,3)),decare(arequa(7,4)) +cgn write (ulsort,*) hetare(arequa(7,1)),hetare(arequa(7,2)), +cgn >hetare(arequa(7,3)),hetare(arequa(7,4)) +cgn write (ulsort,*) ' ' +#endif +cgn write(ulsort,*)'quindi :' +cgn write(ulsort,1789)(lequad, quindi(lequad),lequad = 1, nbquto) +cgn 1789 format(5(i3,' : ',i4,', ')) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , lequad = 1, nbquto + etat = mod(hetqua(lequad),100) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'quad ',lequad,', etat = ',etat +#endif + if ( etat.eq.4 ) then + fille1 = filqua(lequad) + if ( qusupp(fille1) .ne. 0 .and. + > qusupp(fille1+1) .ne. 0 .and. + > qusupp(fille1+2) .ne. 0 .and. + > qusupp(fille1+3) .ne. 0 ) then + if ( quindi(fille1) .eq. -1 .and. + > quindi(fille1+1) .eq. -1 .and. + > quindi(fille1+2) .eq. -1 .and. + > quindi(fille1+3) .eq. -1 ) then + if ( nivqua(lequad).lt.nivmin ) then + iaux = iaux + 4 + else + decfac(-lequad) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', + >-lequad,decfac(-lequad),' ' +#endif + do 22 , areloc = 1, 4 + decare(arequa(lequad,areloc)) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',arequa(lequad,areloc), + > decare(arequa(lequad,areloc)),' (une de ses aretes)' +#endif + 22 continue + endif + endif + endif + endif + 21 continue +cgn write (ulsort,*) 'apres 312' +cgn write (ulsort,*) 'quadrangle 7' +cgn write (ulsort,*) 'decfac(q7) =',decfac(-7) +cgn write (ulsort,*) arequa(7,1),arequa(7,2), +cgn >arequa(7,3),arequa(7,4) +cgn write (ulsort,*) decare(arequa(7,1)),decare(arequa(7,2)), +cgn >decare(arequa(7,3)),decare(arequa(7,4)) +cgn write (ulsort,*) hetare(arequa(7,1)),hetare(arequa(7,2)), +cgn >hetare(arequa(7,3)),hetare(arequa(7,4)) +cgn write (ulsort,*) ' ' +cgn print 1789,(lequad, decfac(lequad),lequad = -nbquto,0) +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,2) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiqui.F b/src/tool/Decision/deiqui.F new file mode 100644 index 00000000..10e47e36 --- /dev/null +++ b/src/tool/Decision/deiqui.F @@ -0,0 +1,162 @@ + subroutine deiqui ( decare, decfac, + > arequa, perqua, + > qusupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des QUadrangles - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIQUI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer arequa(nbquto,4), perqua(nbquto) + integer qusupp(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc + integer lequad, lepere + integer iaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,4) +#endif +c + do 21 , lequad = 1, nbquto +c + if ( qusupp(lequad).ne.0 ) then +c +c 2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(-lequad) = 0 + do 211 , areloc = 1, 4 + decare(arequa(lequad,areloc)) = 0 + 211 continue +c +c 2.2. ==> Inhibition du deraffinement par defaut : on garde le pere +c de la face designee s'il existe +c + lepere = perqua(lequad) +c + if ( lepere.gt.0 ) then +c + decfac(-lepere) = 0 + do 212 , areloc = 1, 4 + decare(arequa(lepere,areloc)) = 0 + 212 continue +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiqur.F b/src/tool/Decision/deiqur.F new file mode 100644 index 00000000..d86e7bc2 --- /dev/null +++ b/src/tool/Decision/deiqur.F @@ -0,0 +1,212 @@ + subroutine deiqur ( nivmax, + > decare, decfac, + > hetare, + > arequa, hetqua, nivqua, + > qusupp, quindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des QUadrangles - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . e . nbquto . valeurs entieres pour les quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIQUR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer arequa(nbquto,4), hetqua(nbquto) + integer nivqua(nbquto) + integer qusupp(nbquto), quindi(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc + integer lequad + integer iaux, kaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,4) +cgn write (ulsort,*) 'quadrangle 7' +cgn write (ulsort,*) 'decfac(q7) =',decfac(-7) +cgn write (ulsort,*) arequa(7,1),arequa(7,2), +cgn >arequa(7,3),arequa(7,4) +cgn write (ulsort,*) decare(arequa(7,1)),decare(arequa(7,2)), +cgn >decare(arequa(7,3)),decare(arequa(7,4)) +cgn write (ulsort,*) hetare(arequa(7,1)),hetare(arequa(7,2)), +cgn >hetare(arequa(7,3)),hetare(arequa(7,4)) +cgn write (ulsort,*) ' ' +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , lequad = 1, nbquto +c +cgn write (ulsort,90112) 'qusupp/quindi', +cgn > lequad,qusupp(lequad),quindi(lequad) + if ( qusupp(lequad).ne.0 ) then + if ( quindi(lequad).eq.1 ) then + if ( mod(hetqua(lequad),100).eq.0 ) then + if ( nivmax.gt.0 .and. nivqua(lequad).ge.nivmax ) then + iaux = iaux + 1 + else + decfac(-lequad) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', + >-lequad,decfac(-lequad),' ' +#endif + do 22 , areloc = 1, 4 + kaux = arequa(lequad,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',kaux, + > decare(kaux),' (une de ses aretes)' +#endif + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',kaux, + > decare(kaux),' (une de ses aretes)' +#endif + endif + 22 continue + endif + endif + endif + endif +c + 21 continue +cgn write (ulsort,*) 'apres 322' +cgn write (ulsort,*) 'quadrangle 7' +cgn write (ulsort,*) 'decfac(q7) =',decfac(-7) +cgn write (ulsort,*) arequa(7,1),arequa(7,2), +cgn >arequa(7,3),arequa(7,4) +cgn write (ulsort,*) decare(arequa(7,1)),decare(arequa(7,2)), +cgn >decare(arequa(7,3)),decare(arequa(7,4)) +cgn write (ulsort,*) hetare(arequa(7,1)),hetare(arequa(7,2)), +cgn >hetare(arequa(7,3)),hetare(arequa(7,4)) +cgn write (ulsort,*) ' ' +cgn print 1789,(lequad, decfac(lequad),lequad = -nbquto,0) +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,2) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisa1.F b/src/tool/Decision/deisa1.F new file mode 100644 index 00000000..dcb7a443 --- /dev/null +++ b/src/tool/Decision/deisa1.F @@ -0,0 +1,475 @@ + subroutine deisa1 ( nbvent, ncmpin, usacmp, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, + > hesupp, heindi, + > pysupp, pyindi, + > pesupp, peindi, + > nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nomail, nhvois, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - SAut - etape 1 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type . +c . . . . d'element au sens HOMARD avec indicateur . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . es . nbnoto . valeurs reelles pour les noeuds . +c . arsupp . s . nbarto . support pour les aretes . +c . arindi . s . nbarto . valeurs reelles pour les aretes . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . s . nbtrto . valeurs pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . s . nbquto . valeurs pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . s . nbteto . valeurs pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . s . nbheto . valeurs pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . s . nbpyto . valeurs pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . s . nbpeto . valeurs pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISA1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmreel.h" +#include "gmenti.h" +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbvent(-1:7), ncmpin + integer usacmp + integer nosupp(nbnoto) + integer arsupp(nbarto) + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + integer ulsort, langue, codret +c + double precision noindi(nbnoto,ncmpin) + double precision arindi(nbarto,ncmpin) + double precision trindi(nbtrto,ncmpin) + double precision quindi(nbquto,ncmpin) + double precision teindi(nbteto,ncmpin) + double precision heindi(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin) + double precision peindi(nbpeto,ncmpin) +c + character*8 nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nomail, nhvois +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer codre0 +c + integer phetar, psomar, pfilar, pmerar + integer ppovos, pvoiso + integer pposif, pfacar + integer phettr, paretr, pfiltr, ppertr + integer phetqu, parequ, pfilqu, pperqu + integer phette, ptrite, pfilte, pperte, adtes2 + integer phethe, pquahe, pfilhe, pperhe, adhes2 + integer phetpy, pfacpy, pperpy, adpys2 + integer phetpe, pfacpe, pperpe + integer adtra1, adtra2 + integer adtrte, adtrhe, adtrpy, adtrpe + integer advotr, adpptr + integer advoqu, adppqu +c + character*8 ntrav1, ntrav2 + character*8 ntrate, ntrahe, ntrapy, ntrape +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. les tableaux +c==== +c +c 2.1. ==> les tableaux de travail +c + if ( codret.eq.0 ) then +c + iaux = max(4*(nbquto+nbtrto), nbarto) + call gmalot ( ntrav1, 'entier ', iaux, adtra1, codre1 ) + iaux = max(2*(nbquto+nbtrto), nbarto, nbnoto) + iaux = iaux * ncmpin + call gmalot ( ntrav2, 'reel ', iaux, adtra2, codre2 ) + iaux = nbteto * ncmpin + call gmalot ( ntrate, 'reel ', iaux, adtrte, codre3 ) + iaux = nbheto * ncmpin + call gmalot ( ntrahe, 'reel ', iaux, adtrhe, codre4 ) + iaux = nbpyto * ncmpin + call gmalot ( ntrapy, 'reel ', iaux, adtrpy, codre5 ) + iaux = nbpeto * ncmpin + call gmalot ( ntrape, 'reel ', iaux, adtrpe, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c +c 2.2. ==> les tableaux du maillage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. les tableaux ; codret', codret +#endif +c + if ( nbvent(-1).ne.0 .or. nbvent(1).ne.0 .or. + > nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 30 + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(2).ne.0 .or. nbvent(3).ne.0 .or. + > ( nbtrto.gt.0 .and. nbvent(4).ne.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 30 + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(4).ne.0 .or. nbvent(6).ne.0 .or. + > ( nbquto.gt.0 .and. nbvent(2).ne.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 30 + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(3).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2*3 + if ( nbteca.gt.0 ) then + iaux = iaux*5*17 + endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, pperte, + > jaux, jaux, jaux, + > jaux, jaux, adtes2, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(5).ne.0 .or. + > ( nbpyto.gt.0 .and. nbvent(3).ne.0 ) .or. + > ( nbpyto.gt.0 .and. nbvent(6).ne.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 2 + if ( nbpyca.gt.0 ) then + iaux = iaux*5*17 + endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , pperpy, + > jaux, jaux, jaux, + > jaux, jaux, adpys2, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(6).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2*3 + if ( nbheco.gt.0 ) then + iaux = iaux*5*17 + endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, pperhe, + > jaux, jaux, jaux, + > jaux, jaux, adhes2, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbvent(7).ne.0 .or. + > ( nbpeto.gt.0 .and. nbvent(3).ne.0 ) .or. + > ( nbpeto.gt.0 .and. nbvent(6).ne.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 2 + if ( nbpeca.gt.0 ) then + iaux = iaux*5 + endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , pperpe, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> Voisinages +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. ==> Voisinages ; codret', codret +#endif +c + if ( nbvent(-1).ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > iaux, jaux, jaux, jaux, + > ppovos, pvoiso, + > kaux, kaux, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 1 + if ( nbvent(-1).ne.0 ) then + iaux = iaux*2 + endif + if ( nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then + iaux = iaux*3 + endif + if ( nbvent(3).ne.0 ) then + iaux = iaux*5 + if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then + iaux = iaux*13 + endif + endif + if ( nbvent(6).ne.0 ) then + iaux = iaux*7 + if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then + iaux = iaux*17 + endif + endif + call utad04 ( iaux, nhvois, + > ppovos, pvoiso, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Operation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. operation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISA2', nompro +#endif + call deisa2 ( nbvent, ncmpin, usacmp, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, rmem(adtrte), + > hesupp, heindi, rmem(adtrhe), + > pysupp, pyindi, rmem(adtrpy), + > pesupp, peindi, rmem(adtrpe), + > imem(phetar), imem(psomar), + > imem(pfilar), imem(pmerar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), + > imem(phette), imem(ptrite), + > imem(pperte), imem(adtes2), + > imem(phethe), imem(pquahe), + > imem(pfilhe), imem(pperhe), imem(adhes2), + > imem(pfacpy), + > imem(pfacpe), + > imem(pposif), imem(pfacar), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > imem(adtra1), rmem(adtra2), + > ulsort, langue, codret) +c + endif +c +c==== +c 4. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrate, codre3 ) + call gmlboj ( ntrahe, codre4 ) + call gmlboj ( ntrapy, codre5 ) + call gmlboj ( ntrape, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisa2.F b/src/tool/Decision/deisa2.F new file mode 100644 index 00000000..ff03a0b0 --- /dev/null +++ b/src/tool/Decision/deisa2.F @@ -0,0 +1,457 @@ + subroutine deisa2 ( nbvent, ncmpin, usacmp, + > nosupp, noindi, + > arsupp, arindi, + > trsupp, trindi, + > qusupp, quindi, + > tesupp, teindi, teinin, + > hesupp, heindi, heinin, + > pysupp, pyindi, pyinin, + > pesupp, peindi, peinin, + > hetare, somare, filare, merare, + > hettri, aretri, filtri, pertri, + > hetqua, arequa, filqua, perqua, + > hettet, tritet, pertet, pthepe, + > hethex, quahex, filhex, perhex, fhpyte, + > facpyr, + > facpen, + > posifa, facare, + > voltri, pypetr, + > volqua, pypequ, + > tabent, tabree, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - SAut - etape 2 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type . +c . . . . d'element au sens HOMARD avec indicateur . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . es . nbnoto . valeurs reelles pour les noeuds . +c . arsupp . s . nbarto . support pour les aretes . +c . arindi . s . nbarto . valeurs reelles pour les aretes . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . s . nbtrto . valeurs pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . s . nbquto . valeurs pour les quadrangles . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . es . nbteto . valeurs pour les tetraedres . +c . teinin . a . nbteto . valeurs initiales pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . es . nbheto . valeurs pour les hexaedres . +c . heinin . a . nbheto . valeurs initiales pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . es . nbpyto . valeurs pour les pyramides . +c . pyinin . a . nbpyto . valeurs initiales pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . es . nbpeto . valeurs pour les pentaedres . +c . peinin . a . nbpeto . valeurs initiales pour les pentaedres . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . fils des aretes . +c . merare . e . nbarto . pere des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . tabent . aux . * . tableau auxiliaire entier . +c . tabree . aux . * . tableau auxiliaire reel . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISA2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nbvent(-1:7), ncmpin + integer usacmp + integer nosupp(nbnoto) + integer arsupp(nbarto) + integer trsupp(nbtrto) + integer qusupp(nbquto) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) + integer hetare(nbarto), somare(2,nbarto) + integer filare(nbarto), merare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer hettet(nbteto), tritet(nbtecf,4) + integer pertet(nbteto), pthepe(*) + integer hethex(nbheto), quahex(nbhecf,6) + integer filhex(nbheto), perhex(nbheto) + integer fhpyte(2,nbheco) + integer facpyr(nbpycf,5) + integer facpen(nbpecf,5) + integer posifa(0:nbarto), facare(nbfaar) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer tabent(2,*) +c + integer ulsort, langue, codret +c + double precision noindi(nbnoto,ncmpin) + double precision arindi(nbarto,ncmpin) + double precision trindi(nbtrto,ncmpin) + double precision quindi(nbquto,ncmpin) + double precision teindi(nbteto,ncmpin), teinin(nbteto,ncmpin) + double precision heindi(nbheto,ncmpin), heinin(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin), pyinin(nbpyto,ncmpin) + double precision peindi(nbpeto,ncmpin), peinin(nbpeto,ncmpin) + double precision tabree(ncmpin,*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Indicateur defini sur les '',i10,1x,a)' + texte(1,5) = '(''. Saut de l''''indicateur le long des '',a)' + texte(1,6) = + > '(''. Saut de l''''indicateur a la traversee des '',a)' +c + texte(2,4) = '(''. Indicator defined over the '',i10,1x,a)' + texte(2,5) = '(''. Jump of error indicator along the '',a)' + texte(2,6) = '(''. Jump of error indicator through the '',a)' +c +#include "impr03.h" +c +c==== +c 2. Au moins un indicateur est exprime sur les noeuds +c==== +c + if ( codret.eq.0 ) then +c + iaux = -1 + if ( nbvent(iaux).gt.0 ) then +c + write (ulsort,texte(langue,4)) nbnoto, mess14(langue,3,iaux) + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISNO', nompro +#endif + call deisno ( ncmpin, nosupp, noindi, + > arsupp, arindi, jaux, + > hetare, somare, + > ulsort, langue, codret ) +c + nbvent(1) = jaux +c + endif +c + endif +c +c==== +c 3. Au moins un indicateur est exprime sur les aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + if ( nbvent(iaux).gt.0 .and. nbvent(iaux).eq.0 ) then +c + write (ulsort,texte(langue,4)) nbarto, mess14(langue,3,iaux) + write(ulsort,*) 'A Programmer' + write(ulsort,*) 'To Do ...' + codret = 12 +c + endif +c + endif +c +c==== +c 4. Au moins un indicateur est exprime sur les faces +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. faces ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvent(2).gt.0 .or. nbvent(4).gt.0 ) then +c + if ( nbvent(2).eq.0 ) then + iaux = 4 + jaux = nbvent(4) + elseif ( nbvent(4).eq.0 ) then + iaux = 2 + jaux = nbvent(2) + else + iaux = 8 + jaux = nbvent(2) + nbvent(4) + endif + write (ulsort,texte(langue,4)) jaux, mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) mess14(langue,3,1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISFA', nompro +#endif + call deisfa ( ncmpin, usacmp, + > trsupp, trindi, qusupp, quindi, + > hetare, filare, merare, + > posifa, facare, + > hettri, aretri, hetqua, arequa, + > tabent, tabree, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. Au moins un indicateur est exprime sur les volumes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. volumes ; codret', codret +#endif +c + if ( nbvent(3).gt.0 .or. nbvent(5).gt.0 .or. + > nbvent(6).gt.0 .or. nbvent(7).gt.0 ) then +c +c 5.1. ==> sauvegardes des valeurs initiales +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV0', nompro +#endif + call deisv0 ( ncmpin, nbvent, + > tesupp, teindi, teinin, + > hesupp, heindi, heinin, + > pysupp, pyindi, pyinin, + > pesupp, peindi, peinin, + > ulsort, langue, codret ) +c + endif +c +c 5.2. ==> Saut entre entites +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. saut ; codret', codret +#endif +c +c 5.2.1. ==> L'indicateur est exprime exclusivement sur les tetraedres +c + if ( nbvent(3).gt.0 .and. nbvent(5).eq.0 .and. + > nbvent(6).eq.0 .and. nbvent(7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 3 + write (ulsort,texte(langue,4)) nbteto, mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) mess14(langue,3,2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV1_te', nompro +#endif + call deisv1 ( ncmpin, usacmp, nbteto, iaux, + > tesupp, teindi, + > hettri, filtri, pertri, + > hetqua, filqua, perqua, + > hettet, tritet, + > voltri, volqua, + > tabent, teinin, + > ulsort, langue, codret ) +c + endif +c +c 5.2.2. ==> L'indicateur est exprime exclusivement sur les hexaedres +c + elseif ( nbvent(3).eq.0 .and. nbvent(5).eq.0 .and. + > nbvent(6).gt.0 .and. nbvent(7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 6 + write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) mess14(langue,3,4) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV1_he', nompro +#endif + call deisv1 ( ncmpin, usacmp, nbheto, iaux, + > hesupp, heindi, + > hettri, filtri, pertri, + > hetqua, filqua, perqua, + > hethex, quahex, + > voltri, volqua, + > tabent, heinin, + > ulsort, langue, codret ) +c + endif +c +c 5.2.3. ==> L'indicateur est reparti sur plusieurs types de volumes +c + else +c + if ( codret.eq.0 ) then +c + jaux = nbvent(3) + nbvent(5)+ nbvent(6)+ nbvent(7) + iaux = 9 + write (ulsort,texte(langue,4)) jaux, mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) mess14(langue,3,8) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV2', nompro +#endif + call deisv2 ( ncmpin, usacmp, + > tesupp, teindi, teinin, + > hesupp, heindi, heinin, + > pysupp, pyindi, pyinin, + > pesupp, peindi, peinin, + > hettri, pertri, + > hetqua, filqua, perqua, + > tritet, pertet, pthepe, + > quahex, hethex, filhex, perhex, fhpyte, + > facpyr, + > facpen, + > voltri, pypetr, + > volqua, pypequ, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisau.F b/src/tool/Decision/deisau.F new file mode 100644 index 00000000..86e14b07 --- /dev/null +++ b/src/tool/Decision/deisau.F @@ -0,0 +1,374 @@ + subroutine deisau ( nomail, nohind, + > lgopti, taopti, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - SAUt +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISAU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombar.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nohind +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + integer adnoin, adnorn, adnosu + integer adarin, adarrn, adarsu + integer adtrin, adtrrn, adtrsu + integer adquin, adqurn, adqusu + integer adtein, adtern, adtesu + integer adhein, adhern, adhesu + integer adpyin, adpyrn, adpysu + integer adpein, adpern, adpesu + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen +c + integer typind, ncmpin + integer nbvent(-1:7) +c + character*6 saux + character*8 motaux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*14 saux14 +c +#ifdef _DEBUG_HOMARD_ + character*7 saux07(nblang,2) +#endif +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data motaux / 'ValeursR' / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = + > '(/,a6,'' CALCUL DES SAUTS'')' + texte(1,5) = '(23(''=''),/)' + texte(1,6) = '(''Le champ d''''indicateur est '',a)' + texte(1,7) = '(''Nombre de composantes :'',i3)' + texte(1,8) = '(''Nombre de valeurs pour les '',a,'':'',i10)' +c + texte(2,4) = + > '(/,a6,'' CALCULATIONS OF THE JUMPS'')' + texte(2,5) = '(32(''=''),/)' + texte(2,6) = '(''The type of the indicator is '',a)' + texte(2,7) = '(''Number of components:'',i3)' + texte(2,8) = '(''Number of values for the '',a,'':'',i10)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. gestion des tableaux +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> structure generale de l'indicateur +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI0', nompro +#endif + call deini0 ( nohind, typind, ncmpin, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > adnoin, adnorn, adnosu, + > adarin, adarrn, adarsu, + > adtrin, adtrrn, adtrsu, + > adquin, adqurn, adqusu, + > adtein, adtern, adtesu, + > adhein, adhern, adhesu, + > adpyin, adpyrn, adpysu, + > adpein, adpern, adpesu, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbvent(-1) = nbvnoe + nbvent(0) = 0 + nbvent(1) = nbvare + nbvent(2) = nbvtri + nbvent(4) = nbvqua + nbvent(3) = nbvtet + nbvent(5) = nbvpyr + nbvent(6) = nbvhex + nbvent(7) = nbvpen +c + afaire = .false. + do 21 , iaux= -1, 7 + if ( nbvent(iaux).gt.0 ) then + afaire = .true. + endif + 21 continue +c +#ifdef _DEBUG_HOMARD_ + saux07(1,1) = 'entier ' + saux07(1,2) = 'reel ' + saux07(2,1) = 'integer' + saux07(2,2) = 'real ' + write (ulsort,texte(langue,6)) saux07(langue,typind-1) + write (ulsort,texte(langue,7)) ncmpin + do 222 , iaux= -1, 7 + write (ulsort,texte(langue,8)) mess14(langue,3,iaux), nbvent(iaux) + 222 continue +#endif +c + endif +c +c==== +c 3. Si l'indicateur est fourni par noeud, on alloue la branche +c par arete ... sauf si elle existe, ce qui ne devrait pas arriver ! +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. allocation ; codret', codret +#endif +c + if ( nbvent(-1).gt.0 ) then +c + if ( codret.eq.0 ) then +c + if ( nbvent(1).gt.0 ) then +c + codret = 31 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALIH_ar', nompro +#endif + iaux = 1 + call utalih ( nohind, iaux, nbarto, ncmpin, motaux, + > adarrn, adarsu, + > ulsort, langue, codret) + nbvent(iaux) = nbarac +c + endif +c + endif +c + endif +c +c==== +c 4. calcul des sauts +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. calcul des sauts ; codret', codret +#endif +c + if ( afaire ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISA1', nompro +#endif + call deisa1 ( nbvent, ncmpin, taopti( 8), + > imem(adnosu), rmem(adnorn), + > imem(adarsu), rmem(adarrn), + > imem(adtrsu), rmem(adtrrn), + > imem(adqusu), rmem(adqurn), + > imem(adtesu), rmem(adtern), + > imem(adhesu), rmem(adhern), + > imem(adpysu), rmem(adpyrn), + > imem(adpesu), rmem(adpern), + > nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nomail, nhvois, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 5. Si l'indicateur est fourni par noeud, menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbvent(-1).gt.0 ) then +c + saux14 = nohind//'.'//suffix(1,-1)(1:5) + call gmsgoj ( saux14 , codret ) + nbvent(-1) = 0 +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c +c 6.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 6.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/deisfa.F b/src/tool/Decision/deisfa.F new file mode 100644 index 00000000..766f7bda --- /dev/null +++ b/src/tool/Decision/deisfa.F @@ -0,0 +1,469 @@ + subroutine deisfa ( ncmpin, usacmp, + > trsupp, trindi, qusupp, quindi, + > hetare, filare, merare, + > posifa, facare, + > hettri, aretri, hetqua, arequa, + > tabent, tabree, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - FAces +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . es . nbtrto . valeurs reelles pour les triangles . +c . qusupp . e . nbquto . support pour les quadrangles . +c . quindi . es . nbquto . valeurs reelles pour les quadrangles . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . fils des aretes . +c . merare . e . nbarto . pere des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tabent . aux . * . tableau auxiliaire entier . +c . tabree . aux . * . tableau auxiliaire reel . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "infini.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer usacmp + integer trsupp(nbtrto), qusupp(nbquto) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer tabent(*) +c + integer ulsort, langue, codret +c + double precision trindi(nbtrto,ncmpin), quindi(nbquto,ncmpin) + double precision tabree(-nbquto:nbtrto,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer lgpile, nupile + integer laface, larefa, larete + integer merear + integer nbarfa + integer nrcomp +cgn integer glop +c + double precision daux1, daux2 + integer lgdaux + parameter( lgdaux = 100 ) + double precision daux(lgdaux), vect(lgdaux) +c + logical afaire + logical calcul +c + integer nbmess + parameter (nbmess = 11 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Saut a la traversee des '',a)' + texte(1,5) = + > '(''On veut'',i6,'' composantes, mais taille de daux ='',i6)' + texte(1,9) = '(''. Norme L2 des composantes.'')' + texte(1,10) = '(''. Norme infinie des composantes.'')' + texte(1,11) = '(''. Valeur relative de la composante.'')' +c + texte(2,4) = '(''. Jump through the '',a)' + texte(2,5) = + > '(i6,''components are requested, but size of daux equals'',i6)' + texte(2,9) = '(''. L2 norm of components.'')' + texte(2,10) = '(''. Infinite norm of components.'')' + texte(2,11) = '(''. Relative value for the component.'')' +cgn print *, hettri +cgn print *, aretri +cgn print *, hetqua +cgn print *, arequa +c +#include "impr03.h" +c + codret = 0 +c +c 1.2. ==> controle +c + if ( ncmpin.gt.lgdaux ) then + write (ulsort,texte(langue,5)) ncmpin, lgdaux + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9+usacmp)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) +#endif +c +c==== +c 2. sauvegarde de l'indicateur +c==== +c + if ( codret.eq.0 ) then +c + do 211 , iaux = 1 , nbtrto + if ( trsupp(iaux).ne.0 ) then + do 2110 , nrcomp = 1 , ncmpin + tabree(iaux,nrcomp) = trindi(iaux,nrcomp) + 2110 continue + endif + 211 continue +c + do 212 , iaux = 1 , nbquto + if ( qusupp(iaux).ne.0 ) then + do 2120 , nrcomp = 1 , ncmpin + tabree(-iaux,nrcomp) = quindi(iaux,nrcomp) + 2120 continue + endif + 212 continue +c +c==== +c 3. traitement des indicateurs portant sur les faces +c==== +c + do 3 , laface = -nbquto , nbtrto +c +cgn glop=0 +c +c 3.0. ==> On y va ? +c + afaire = .false. + if ( laface.lt.0 ) then + if ( qusupp(-laface).ne.0 ) then + afaire = .true. + nbarfa = 4 + endif + elseif ( laface.gt.0 ) then + if ( trsupp(laface).ne.0 ) then + afaire = .true. + nbarfa = 3 + endif + endif +c + if ( afaire ) then +c +cgn if ( laface.ge.-42 .and. laface.le.49 ) then +cgn glop = 1 +cgn endif +cgn if ( glop.eq.1) then +cgn print *,'===========================' +cgn print *,'FACE = ',laface,', d''indic ', +cgn > (tabree(laface,nrcomp),nrcomp=1,ncmpin) +cgn endif +c + daux1 = vinfne +c + do 31 , iaux = 1 , nbarfa +c +c 3.1. ==> pour une des aretes de la face, on stocke les numeros +c des faces voisines, en descendant les parentes. +c ensuite, on stocke la premiere arete mere dont une des +c faces voisines est active +c +c + if ( laface.gt.0 ) then + larefa = aretri(laface,iaux) + else + larefa = arequa(-laface,iaux) + endif +cgn if ( glop.eq.1) then +cgn print *,'.', iaux,'-ieme arete de la face : ',larefa +cgn endif + lgpile = 1 + tabent(lgpile) = larefa + nupile = 1 +c + 310 continue +c + larete = tabent(nupile) + if ( mod(hetare(larete),10).ne.0 ) then +cgn if ( glop.eq.1) then +cgn print *,'.. des filles' +cgn endif + lgpile = lgpile + 1 + tabent(lgpile) = filare(larete) + lgpile = lgpile + 1 + tabent(lgpile) = filare(larete) + 1 +cgn if ( glop.eq.1) then +cgn print *,'.... ajout de ',tabent(lgpile), ' a la pile' +cgn endif + endif +c + nupile = nupile + 1 + if ( nupile.le.lgpile ) then + goto 310 + endif +c +c 3.2. ==> pour chaque arete de la pile : si elle est active, on +c cherche le max de l'ecart entre la valeur de l'indicateur +c sur la face voisine et celle sur la face courante +c + do 32 , nupile = 1 , lgpile + larete = tabent(nupile) + if ( mod(hetare(larete),10).eq.0 ) then +cgn if ( glop.eq.1) then +cgn print *,'...... Examen de la pile, arete : ',larete +cgn endif + jdeb = posifa(larete-1)+1 + jfin = posifa(larete) + do 321 , jaux = jdeb, jfin + kaux = facare(jaux) + if ( kaux.ne.laface ) then +cgn if ( glop.eq.1) then +cgn print *,'........ ==> face ', kaux,' : ', +cgn > (tabree(kaux,nrcomp),nrcomp=1,ncmpin) +cgn endif + calcul = .false. + if ( kaux.gt.0 ) then + if ( trsupp(kaux).ne.0 ) then + calcul = .true. + do 3211 , nrcomp = 1 , ncmpin + daux(nrcomp) = tabree(kaux,nrcomp) + > - tabree(laface,nrcomp) + 3211 continue + endif + elseif ( kaux.lt.0 ) then + if ( qusupp(-kaux).ne.0 ) then + calcul = .true. + do 3212 , nrcomp = 1 , ncmpin + daux(nrcomp) = tabree(kaux,nrcomp) + > - tabree(laface,nrcomp) + 3212 continue + endif + endif + if ( calcul ) then +c calcul de la norme de l'ecart +c si on a passe le max, on stocke + if ( usacmp.eq.0 ) then + daux2 = daux(1)**2 + do 32111 , nrcomp = 2 , ncmpin + daux2 = daux2 + daux(nrcomp)**2 +32111 continue + elseif ( usacmp.eq.1 ) then + daux2 = abs(daux(1)) + do 32112 , nrcomp = 2 , ncmpin + daux2 = max(daux2,abs(daux(nrcomp))) +32112 continue + else + daux2 = daux(1) + endif + if ( daux2.gt.daux1 ) then + daux1 = daux2 + do 3213 , nrcomp = 1 , ncmpin + vect(nrcomp) = daux(nrcomp) + 3213 continue + endif + endif +cgn if ( glop.eq.1) then +cgn print *,'........ daux1 ', daux1 +cgn endif + endif + 321 continue +cgn if ( glop.eq.1) then +cgn print *,'...... ==> valeur finale =', daux1 +cgn endif + endif + 32 continue +c +c 3.3. ==> on remonte la parente pour pieger les non-conformites +c + larete = larefa +c + 33 continue +c + merear = merare(larete) + if ( merear.gt.0 ) then +cgn if ( glop.eq.1) then +cgn print *,'......', larete,' a une mere : ',merear +cgn endif + jdeb = posifa(merear-1)+1 + jfin = posifa(merear) + if ( jdeb.gt.jfin ) then + larete = merear + goto 33 + else + do 331 , jaux = jdeb, jfin + kaux = facare(jaux) + if ( kaux.ne.laface ) then +cgn if ( glop.eq.1) then +cgn print *,'.......... ==> face ', kaux,' : ', +cgn > (tabree(kaux,nrcomp),nrcomp=1,ncmpin) +cgn endif + calcul = .false. + if ( kaux.gt.0 ) then + if ( mod(hettri(kaux),10).eq.0 ) then + if ( trsupp(kaux).ne.0 ) then + calcul = .true. + do 3311 , nrcomp = 1 , ncmpin + daux(nrcomp) = tabree(kaux,nrcomp) + > - tabree(laface,nrcomp) + 3311 continue + endif + endif + elseif ( kaux.lt.0 ) then + if ( mod(hetqua(-kaux),100).eq.0 ) then + if ( qusupp(-kaux).ne.0 ) then + calcul = .true. + do 3312 , nrcomp = 1 , ncmpin + daux(nrcomp) = tabree(kaux,nrcomp) + > - tabree(laface,nrcomp) + 3312 continue + endif + endif + endif + if ( calcul ) then + if ( usacmp.eq.0 ) then + daux2 = daux(1)**2 + do 33111 , nrcomp = 2 , ncmpin + daux2 = daux2 + daux(nrcomp)**2 +33111 continue + elseif ( usacmp.eq.1 ) then + daux2 = abs(daux(1)) + do 33112 , nrcomp = 2 , ncmpin + daux2 = max(daux2,abs(daux(nrcomp))) +33112 continue + else + daux2 = daux(1) + endif + if ( daux2.gt.daux1 ) then + daux1 = daux2 + do 3313 , nrcomp = 1 , ncmpin + vect(nrcomp) = daux(nrcomp) + 3313 continue + endif + endif +cgn if ( glop.eq.1) then +cgn print *,'.......... daux1 ', daux1 +cgn endif + endif + 331 continue +cgn if ( glop.eq.1) then +cgn print *,'........ ==> valeur finale =', daux1 +cgn endif + endif + endif +c + 31 continue +c +c 3.4. ==> stockage +c +cgn if ( glop.eq.1) then +cgn write(ulsort,20000) 'Final '// +cgn > 'face', laface,' : ', +cgn > mess14(langue,1,typenh), laface,' : ', +cgn > (vect(nrcomp),nrcomp=1,ncmpin) +cgn endif + if ( laface.gt.0 ) then + do 341 , nrcomp = 1 , ncmpin + trindi(laface,nrcomp) = vect(nrcomp) + 341 continue + else + do 342 , nrcomp = 1 , ncmpin + quindi(-laface,nrcomp) = vect(nrcomp) + 342 continue + endif +c + endif +c + 3 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,1) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisno.F b/src/tool/Decision/deisno.F new file mode 100644 index 00000000..39a9f22f --- /dev/null +++ b/src/tool/Decision/deisno.F @@ -0,0 +1,192 @@ + subroutine deisno ( ncmpin, nosupp, noindi, + > arsupp, arindi, nbval, + > hetare, somare, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - NOeuds +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . nosupp . e . nbnoto . support pour les noeuds . +c . noindi . e . nbnoto . valeurs reelles pour les noeuds . +c . arsupp . s . nbarto . support pour les aretes . +c . arindi . s . nbarto . valeurs reelles pour les aretes . +c . nbval . s . 1 . nombres de valeurs pour les aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISNO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer nosupp(nbnoto) + integer arsupp(nbarto) + integer nbval + integer hetare(nbarto), somare(2,nbarto) +c + integer ulsort, langue, codret +c + double precision noindi(nbnoto,ncmpin) + double precision arindi(nbarto,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux + integer noeud1, noeud2 + integer typenh + integer nrcomp +cgn integer glop +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) =' (''. Saut entre '',a)' +c + texte(2,4) = '(''. Jump between '',a)' +c + codret = 0 +c + typenh = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c==== +c 2. On affecte a chaque arete l'ecart du champ entre ses deux noeuds +c extremites. On ne tient pas compte du noeud milieu en degre 2. +c Attention : il ne faut s'interesser qu'aux aretes actives, sinon +c on cree des sauts artificiels ! +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> A priori, aucune arete n'est concernee +c + do 21 , iaux = 1 , nbarto + arsupp(iaux) = 0 + 21 continue + nbval = 0 +c + do 20 , iaux = 1, nbarto +c + if ( mod(hetare(iaux),10).eq.0 ) then +c +cgn glop=0 +cgn if ( iaux.le.-42 ) then +cgn glop = 1 +cgn endif +c + noeud1 = somare(1,iaux) + noeud2 = somare(2,iaux) + if ( nosupp(noeud1).ne.0 .and. nosupp(noeud2).ne.0 ) then +c + nbval = nbval + 1 + arsupp(iaux) = 1 + do 200 , nrcomp = 1 , ncmpin + arindi(iaux,nrcomp) = abs ( noindi(noeud1,nrcomp) - + > noindi(noeud2,nrcomp) ) + 200 continue +cgn if ( glop.eq.1) then +cgn write(ulsort,*)'===========================' +cgn write(ulsort,*)'ARETE = ',iaux +cgn write(ulsort,*)' Noeud 1 = ',noeud1,', d''indic ' +cgn write(ulsort,*)(noindi(noeud1,nrcomp), nrcomp = 1 , ncmpin) +cgn write(ulsort,*)' Noeud 2 = ',noeud2,', d''indic ' +cgn write(ulsort,*)(noindi(noeud2,nrcomp), nrcomp = 1 , ncmpin) +cgn write(ulsort,*)' ==> champ ', +cgn > (arindi(iaux,nrcomp),nrcomp=1 , ncmpin) +cgn endif +c + endif +c + endif +c + 20 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,5)) typenh +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv0.F b/src/tool/Decision/deisv0.F new file mode 100644 index 00000000..eb043116 --- /dev/null +++ b/src/tool/Decision/deisv0.F @@ -0,0 +1,219 @@ + subroutine deisv0 ( ncmpin, nbvent, + > tesupp, teindi, teinin, + > hesupp, heindi, heinin, + > pysupp, pyindi, pyinin, + > pesupp, peindi, peinin, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 0 +c -- - - - - +c +c Sauvegarde des valeurs initiales +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . nbvent . e . -1:7 . nombre d'entites actives pour chaque type . +c . . . . d'element au sens HOMARD avec indicateur . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . e . nbteto . valeurs pour les tetraedres . +c . teinin . s . nbteto . valeurs initiales pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . e . nbheto . valeurs pour les hexaedres . +c . heinin . s . nbheto . valeurs initiales pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . e . nbpyto . valeurs pour les pyramides . +c . pyinin . s . nbpyto . valeurs initiales pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . e . nbpeto . valeurs pour les pentaedres . +c . peinin . s . nbpeto . valeurs initiales pour les pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer nbvent(-1:7) + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + double precision teindi(nbteto,ncmpin), teinin(nbteto,ncmpin) + double precision heindi(nbheto,ncmpin), heinin(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin), pyinin(nbpyto,ncmpin) + double precision peindi(nbpeto,ncmpin), peinin(nbpeto,ncmpin) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) =' (''Sauvegardes des indicateurs sur les '',i10,1x,a)' +c + texte(2,4) = '(''Saving of indicator over '',i10,1x,a)' +c + codret = 0 +c +c==== +c 2. Sauvegardes des indicateurs +c==== +c 2.1. ==> Sur les tetraedres +c + if ( nbvent(3).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbteto, mess14(langue,3,3) +#endif +c + do 21 , iaux = 1 , nbteto + if ( tesupp(iaux).ne.0 ) then + do 211 , nrcomp = 1 , ncmpin + teinin(iaux,nrcomp) = teindi(iaux,nrcomp) + 211 continue + endif + 21 continue +c + endif +c +c 2.2. ==> Sur les hexaedres +c + if ( nbvent(6).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,6) +#endif +c + do 22 , iaux = 1 , nbheto + if ( hesupp(iaux).ne.0 ) then + do 221 , nrcomp = 1 , ncmpin + heinin(iaux,nrcomp) = heindi(iaux,nrcomp) + 221 continue + endif + 22 continue +c + endif +c +c 2.3. ==> Sur les pyramides +c + if ( nbvent(5).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpyto, mess14(langue,3,5) +#endif +c + do 23 , iaux = 1 , nbpyto + if ( pysupp(iaux).ne.0 ) then + do 231 , nrcomp = 1 , ncmpin + pyinin(iaux,nrcomp) = pyindi(iaux,nrcomp) + 231 continue + endif + 23 continue +c + endif +c +c 2.4. ==> Sur les pentaedres +c + if ( nbvent(7).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpeto, mess14(langue,3,7) +#endif +c + do 24 , iaux = 1 , nbpeto + if ( pesupp(iaux).ne.0 ) then + do 241 , nrcomp = 1 , ncmpin + peinin(iaux,nrcomp) = peindi(iaux,nrcomp) + 241 continue + endif + 24 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv1.F b/src/tool/Decision/deisv1.F new file mode 100644 index 00000000..986b5ec3 --- /dev/null +++ b/src/tool/Decision/deisv1.F @@ -0,0 +1,466 @@ + subroutine deisv1 ( ncmpin, usacmp, nbvoto, typenh, + > vosupp, voindi, + > hettri, filtri, pertri, + > hetqua, filqua, perqua, + > hetvol, facvol, + > voltri, volqua, + > tabent, voinin, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 1 +c -- - - - - +c +c On traite ici uniquement les sauts entre volumes pour les cas ou +c il n'y a que des tetraedres ou que des hexaedres concernes par +c un indicateur d'erreur. +c Quand l'indicateur est reparti sur des entites de nature +c differente, on gerera le saut dans deisv2. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nbvoto . e . 1 . nombre de volumes total . +c . typenh . e . 1 . 3 : tetraedres . +c . . . . 6 : hexaedres . +c . vosupp . e . nbvoto . support pour les volumes . +c . voindi . s . nbvoto . valeurs reelles pour les volumes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . hetvol . e . nbvoto . historique de l'etat des volumes . +c . facvol . e .nbvoto*n. numeros des n faces des volumes . +c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . tabent . aux . * . tableau auxiliaire entier . +c . voinin . aux . * . sauvegarde des valeurs des indicateurs . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvais typenh . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "infini.h" +#include "impr02.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer usacmp + integer nbvoto, typenh +c + integer vosupp(nbvoto) + integer hettri(nbtrto), filtri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), filqua(nbquto), perqua(nbquto) + integer voltri(2,nbtrto) + integer volqua(2,nbquto) + integer hetvol(nbvoto), facvol(nbvoto,*) + integer tabent(2,*) +c + integer ulsort, langue, codret +c + double precision voindi(nbvoto,ncmpin) + double precision voinin(nbvoto,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lgpile, nupile + integer levolu + integer lafavo, laface, tyface, typfac + integer etat + integer merefa + integer nbfavo + integer nrcomp +cgn integer glop +c + double precision daux1, daux2 + integer lgdaux + parameter( lgdaux = 100 ) + double precision daux(lgdaux), vect(lgdaux) +c + logical calcul +c + integer nbmess + parameter (nbmess = 11 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Saut a la traversee des '',a)' + texte(1,5) = + > '(''On veut'',i6,'' composantes, mais taille de daux ='',i6)' + texte(1,6) = ' (''Type d''''entite incorrect :'',i10)' + texte(1,9) = '(''. Norme L2 des composantes.'')' + texte(1,10) = '(''. Norme infinie des composantes.'')' + texte(1,11) = '(''. Valeur relative de la composante.'')' +c + texte(2,4) = '(''. Jump through the '',a)' + texte(2,5) = + > '(i6,''components are requested, but size of daux equals'',i6)' + texte(2,6) = ' (''Uncorrect type of entity: :'',i10)' + texte(2,9) = '(''. L2 norm of components.'')' + texte(2,10) = '(''. Infinite norm of components.'')' + texte(2,11) = '(''. Relative value for the component.'')' +c +#include "impr03.h" +c + codret = 0 +c +c 1.2. ==> controle +c + if ( ncmpin.gt.lgdaux ) then + write (ulsort,texte(langue,5)) ncmpin, lgdaux + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9+usacmp)) +#endif +c +c 1.3. ==> Les types de faces : triangle (2) ou quadrangle (4) +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.3 ) then + nbfavo = 4 + typfac = 2 + elseif ( typenh.eq.6 ) then + nbfavo = 6 + typfac = 4 + else + codret = 1 + write (ulsort,texte(langue,6)) typenh + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typfac) +#endif +c + endif +c +c==== +c 2. On parcourt tous les volumes. +c On calcule l'ecart entre la valeur de l'indicateur sur le volume +c courant et sur les voisins. +c On garde le max au sens de la norme voulue +c levolu = numero local dans la categorie +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. parcours des volumes ; codret', codret +#endif +c + do 2 , levolu = 1 , nbvoto +c + if ( codret.eq.0 ) then +c + if ( vosupp(levolu).ne.0 ) then +c +c 2.1. ==> Exploration de toutes les faces du volume +c + daux1 = vinfne +c + do 21 , iaux = 1 , nbfavo +c +c 2.1.1. ==> pour chaque face du volume, on stocke les numeros +c des faces voisines, en descendant les parentes. +c Au final, on stocke la premiere face mere active +c + lafavo = facvol(levolu,iaux) + tyface = typfac +cgn if ( glop.eq.1) then +cgn write(ulsort,90002) '. face de rang',iaux +cgn endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV3', nompro +#endif + call deisv3 ( lafavo, tyface, + > hettri, filtri, + > hetqua, filqua, + > lgpile, tabent, + > ulsort, langue, codret ) +c +c 2.1.2. ==> pour chaque face de la pile : si elle est active, on +c cherche le max de l'ecart entre la valeur de l'indicateur +c sur le volume voisin et celle sur le volume courant +c on sait que les faces sont toutes de meme type +c + do 212 , nupile = 1 , lgpile +c + laface = tabent(1,nupile) +c +c 2.1.2.1. ==> reperage selon la face +c + if ( typfac.eq.2 ) then + etat = mod(hettri(laface),10) + else + etat = mod(hetqua(laface),100) + endif +c +c 2.1.2.2. ==> traitement +c + if ( etat.eq.0 ) then +cgn if ( glop.eq.1) then +cgn write(ulsort,90002)'.. Voisinage par le '// +cgn > mess14(langue,1,typfac),laface +cgn endif + do 2122 , jaux = 1 , 2 +c + calcul = .false. +c + if ( typfac.eq.2 ) then + kaux = voltri(jaux,laface) + else + kaux = volqua(jaux,laface) + endif +c + if ( kaux.gt.0 ) then +c + if ( vosupp(kaux).ne.0 ) then +c + if ( kaux.ne.levolu ) then + calcul = .true. + do 21221 , nrcomp = 1 , ncmpin + daux(nrcomp) = voinin(kaux,nrcomp) + > - voinin(levolu,nrcomp) +21221 continue +cgn if ( glop.eq.1) then +cgn write(ulsort,90054)'...... ==> ecart avec ', kaux,' : ', +cgn > (daux(nrcomp),nrcomp=1,ncmpin) +cgn endif +c + endif +c + endif +c + elseif ( kaux.lt.0 ) then +cgn if ( glop.eq.1) then +cgn write(ulsort,*)'.... Autre type de volume voisin.' +cgn endif + codret = codret + 1 + endif +c +c calcul de la norme de l'ecart +c si on a passe le max, on stocke +c + if ( calcul ) then +c + if ( usacmp.eq.0 ) then + daux2 = daux(1)**2 + do 21222 , nrcomp = 2 , ncmpin + daux2 = daux2 + daux(nrcomp)**2 +21222 continue + elseif ( usacmp.eq.1 ) then + daux2 = abs(daux(1)) + do 21223 , nrcomp = 2 , ncmpin + daux2 = max(daux2,abs(daux(nrcomp))) +21223 continue + else + daux2 = daux(1) + endif + if ( daux2.gt.daux1 ) then + daux1 = daux2 + do 21224 , nrcomp = 1 , ncmpin + vect(nrcomp) = daux(nrcomp) +21224 continue + endif +c + endif +c + 2122 continue +c + endif +c + 212 continue +c +c 2.3. ==> on remonte la parente pour pieger les non-conformites +c + laface = lafavo +c + 231 continue +c +cgn if ( glop.eq.1) then +cgn write(ulsort,90002)'.... Parente du '// +cgn > mess14(langue,1,typfac),laface +cgn endif + if ( typfac.eq.2 ) then + merefa = pertri(laface) + else + merefa = perqua(laface) + endif +c + if ( merefa.gt.0 ) then +cgn if ( glop.eq.1) then +cgn write(ulsort,90006)'.... le '// +cgn > mess14(langue,1,typfac), laface,' a une mere : ',merefa +cgn endif +c + if ( typfac.eq.2 ) then + kaux = voltri(2,merefa) + else + kaux = volqua(2,merefa) + endif +c + calcul = .false. + if ( kaux.eq.0 ) then + laface = merefa + goto 231 + elseif ( kaux.gt.0 ) then + do 232 , jaux = 1 , 2 + if ( typfac.eq.2 ) then + kaux = voltri(jaux,merefa) + else + kaux = volqua(jaux,merefa) + endif + if ( kaux.gt.0 ) then + if ( mod(hetvol(kaux),100).eq.0 ) then + calcul = .true. + do 2311 , nrcomp = 1 , ncmpin + daux(nrcomp) = voinin(kaux,nrcomp) + > - voinin(levolu,nrcomp) + 2311 continue +cgn if ( glop.eq.1) then +cgn write(ulsort,90054)'...... ==> ecart avec ', kaux,' : ', +cgn > (daux(nrcomp),nrcomp=1,ncmpin) +cgn endif + endif + elseif ( kaux.lt.0 ) then + codret = codret + 1 + endif + 232 continue + elseif ( kaux.lt.0 ) then + codret = codret + 1 + endif + if ( calcul ) then + if ( usacmp.eq.0 ) then + daux2 = daux(1)**2 + do 23111 , nrcomp = 2 , ncmpin + daux2 = daux2 + daux(nrcomp)**2 +23111 continue + elseif ( usacmp.eq.1 ) then + daux2 = abs(daux(1)) + do 23112 , nrcomp = 2 , ncmpin + daux2 = max(daux2,abs(daux(nrcomp))) +23112 continue + else + daux2 = daux(1) + endif + if ( daux2.gt.daux1 ) then + daux1 = daux2 + do 2312 , nrcomp = 1 , ncmpin + vect(nrcomp) = daux(nrcomp) + 2312 continue + endif + endif +c + endif +c + 21 continue +c +c 2.4. ==> stockage +c +cgn if ( glop.eq.1 ) then +cgn write(ulsort,90054) 'Final '// +cgn > mess14(langue,1,typenh), levolu, ' : ', +cgn > (vect(nrcomp),nrcomp=1,ncmpin) +cgn endif +c + do 241 , nrcomp = 1 , ncmpin + voindi(levolu,nrcomp) = vect(nrcomp) + 241 continue +c + endif +c + endif +c + 2 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ne.1 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv2.F b/src/tool/Decision/deisv2.F new file mode 100644 index 00000000..d5bfc0d2 --- /dev/null +++ b/src/tool/Decision/deisv2.F @@ -0,0 +1,706 @@ + subroutine deisv2 ( ncmpin, usacmp, + > tesupp, teindi, teinin, + > hesupp, heindi, heinin, + > pysupp, pyindi, pyinin, + > pesupp, peindi, peinin, + > hettri, pertri, + > hetqua, filqua, perqua, + > tritet, pertet, pthepe, + > quahex, hethex, filhex, perhex, fhpyte, + > facpyr, + > facpen, + > voltri, pypetr, + > volqua, pypequ, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 2 +c -- - - - - +c attention : on ne traite pas les cas non-conformes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . es . nbteto . valeurs pour les tetraedres . +c . teinin . e . nbteto . valeurs initiales pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heindi . es . nbheto . valeurs pour les hexaedres . +c . heinin . e . nbheto . valeurs initiales pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyindi . es . nbpyto . valeurs pour les pyramides . +c . pyinin . e . nbpyto . valeurs initiales pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peindi . es . nbpeto . valeurs pour les pentaedres . +c . peinin . e . nbpeto . valeurs initiales pour les pentaedres . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pyramides . +c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV2' ) +c +#include "nblang.h" +c + integer lgdaux + parameter( lgdaux = 500 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer usacmp + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) + integer hettri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), filqua(nbquto), perqua(nbquto) + integer tritet(nbtecf,4) + integer pertet(nbteto), pthepe(*) + integer quahex(nbhecf,6) + integer hethex(nbheto), filhex(nbheto), perhex(nbheto) + integer fhpyte(2,nbheco) + integer facpyr(nbpycf,5) + integer facpen(nbpecf,5) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) +c + integer ulsort, langue, codret +c + double precision teindi(nbteto,ncmpin), teinin(nbteto,ncmpin) + double precision heindi(nbheto,ncmpin), heinin(nbheto,ncmpin) + double precision pyindi(nbpyto,ncmpin), pyinin(nbpyto,ncmpin) + double precision peindi(nbpeto,ncmpin), peinin(nbpeto,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer laface, typfac + integer lamail, typenh +c + double precision valaux(lgdaux) +c + integer nbfite, nbvote, voiste(lgdaux) + integer nbfihe, nbvohe, voishe(lgdaux) + integer nbfipy, nbvopy, voispy(lgdaux) + integer nbfipe, nbvope, voispe(lgdaux) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Saut a la traversee des faces'')' + texte(1,5) = + > '(''On veut'',i6,'' composantes, mais taille de daux ='',i6)' + texte(1,6) = '(''. Examen du '',a,i10)' +c + texte(2,4) = '(''. Jump through the faces'')' + texte(2,5) = + > '(i6,''components are requested, but size of daux equals'',i6)' + texte(2,6) = '(''. Examen du '',a,i10)' +c +#include "impr03.h" +20000 format(a,i10,a,20g16.8) +20001 format(2(a,i10)) +c + codret = 0 +c +c 1.2. ==> controle +c + if ( ncmpin.gt.lgdaux ) then + write (ulsort,texte(langue,5)) ncmpin, lgdaux + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Calcul du saut entre chaque tetraedre et ses voisins +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. parcours tetraedre ; codret = ', codret + write (ulsort,90002) 'nbtecf', nbtecf +#endif +c + typfac = 2 + typenh = 3 + do 21 , iaux = 1 , nbtecf +c + if ( tesupp(iaux).gt.0 ) then +c + lamail = iaux +cgn write (ulsort,*) 'lamail = ', lamail +c +c 2.1.1. ==> Recherche des voisins par chacune des faces +c + nbvote = 0 + nbvohe = 0 + nbvopy = 0 + nbvope = 0 +c + do 211 , kaux = 1 , 4 +c + if ( codret.eq.0 ) then +c + laface = tritet(iaux,kaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV6 / tetr', nompro +#endif + call deisv6 ( laface, typfac, lamail, typenh, + > hettri, pertri, + > hetqua, perqua, + > pertet, + > hethex, filhex, perhex, fhpyte, + > voltri, pypetr, + > volqua, pypequ, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > ulsort, langue, codret ) +c + endif +c + 211 continue +c +c 2.1.2. ==> Retrait de la maille courante de la liste des voisins +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV7 / tetr', nompro +#endif +cc call deisv7 ( lamail, nbvote, voiste, +cc > ulsort, langue, codret ) +c + endif +c +c 2.1.3. ==> Calcul des sauts +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV5 / tetr', nompro +#endif + call deisv5 ( lamail, ncmpin, usacmp, + > nbteto, teindi, teinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. Calcul du saut entre chaque hexaedre et ses voisins +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. parcours hexaedre ; codret = ', codret + write (ulsort,90002) 'nbhecf', nbhecf +#endif +c + typfac = 4 + typenh = 6 + do 31 , iaux = 1 , nbhecf +c + if ( hesupp(iaux).gt.0 ) then +c + lamail = iaux +cgn write (ulsort,*) 'lamail = ', lamail +c +c 3.1.1. ==> Recherche des voisins par chacune des faces +c + nbvote = 0 + nbvohe = 0 + nbvopy = 0 + nbvope = 0 +c + do 311 , kaux = 1 , 6 +c + if ( codret.eq.0 ) then +c + laface = quahex(iaux,kaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV6 / hexa', nompro +#endif + call deisv6 ( laface, typfac, lamail, typenh, + > hettri, pertri, + > hetqua, perqua, + > pertet, + > hethex, filhex, perhex, fhpyte, + > voltri, pypetr, + > volqua, pypequ, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'apres la face', kaux + write (ulsort,90002) 'nbvote', nbvote + write (ulsort,90002) 'nbvohe', nbvohe + write (ulsort,90002) 'nbvopy', nbvopy + write (ulsort,90002) 'nbvope', nbvope +#endif +c + endif +c + 311 continue +c +c 3.1.2. ==> Retrait de la maille courante de la liste des voisins +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV7 / hexa', nompro +#endif +cc call deisv7 ( lamail, nbvohe, voishe, +cc > ulsort, langue, codret ) +c + endif +c +c 3.1.3. ==> Calcul des sauts +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV5 / hexa', nompro +#endif + call deisv5 ( lamail, ncmpin, usacmp, + > nbheto, heindi, heinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) +c + endif +c + endif +c + 31 continue +c +c==== +c 4. Calcul du saut entre chaque pyramide et ses voisins +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. parcours pyramide ; codret = ', codret + write (ulsort,90002) 'nbpycf', nbpycf +#endif +c + typenh = 5 + do 41 , iaux = 1 , nbpycf +c + if ( pysupp(iaux).gt.0 ) then +c + lamail = iaux +cgn write (ulsort,*) 'lamail = ', lamail +c +c 4.1.1. ==> Recherche des voisins par chacune des faces +c + nbvote = 0 + nbvohe = 0 + nbvopy = 0 + nbvope = 0 +c + do 411 , kaux = 1 , 5 +c + if ( codret.eq.0 ) then +c + laface = facpyr(iaux,kaux) + if ( kaux.le.4 ) then + typfac = 2 + else + typfac = 4 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV6 / pyra', nompro +#endif + call deisv6 ( laface, typfac, lamail, typenh, + > hettri, pertri, + > hetqua, perqua, + > pertet, + > hethex, filhex, perhex, fhpyte, + > voltri, pypetr, + > volqua, pypequ, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > ulsort, langue, codret ) +c + endif +c + 411 continue +c +c 4.1.2. ==> Retrait de la maille courante de la liste des voisins +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV7 / pyra', nompro +#endif +cc call deisv7 ( lamail, nbvopy, voispy, +cc > ulsort, langue, codret ) +c + endif +c +c 4.1.3. ==> Calcul des sauts +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV5 / pyra', nompro +#endif + call deisv5 ( lamail, ncmpin, usacmp, + > nbpyto, pyindi, pyinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) +c + endif +c + endif +c + 41 continue +c +c==== +c 5. Calcul du saut entre chaque pentaedre et ses voisins +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. parcours pentaedre ; codret = ', codret + write (ulsort,90002) 'nbpecf', nbpecf +#endif +c + typenh = 7 + do 51 , iaux = 1 , nbpecf +c + if ( pesupp(iaux).gt.0 ) then +c + lamail = iaux +c +c 5.1.1. ==> Recherche des voisins par chacune des faces +c + nbvote = 0 + nbvohe = 0 + nbvopy = 0 + nbvope = 0 +c + do 511 , kaux = 1 , 5 +c + if ( codret.eq.0 ) then +c + laface = facpen(iaux,kaux) + if ( kaux.le.2 ) then + typfac = 2 + else + typfac = 4 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV6 / pent', nompro +#endif + call deisv6 ( laface, typfac, lamail, typenh, + > hettri, pertri, + > hetqua, perqua, + > pertet, + > hethex, filhex, perhex, fhpyte, + > voltri, pypetr, + > volqua, pypequ, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > ulsort, langue, codret ) +c + endif +c + 511 continue +c +c 5.1.2. ==> Retrait de la maille courante de la liste des voisins +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV7 / pent', nompro +#endif + call deisv7 ( lamail, nbvope, voispe, + > ulsort, langue, codret ) +c + endif +c +c 5.1.3. ==> Calcul des sauts +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV5 / pent', nompro +#endif + call deisv5 ( lamail, ncmpin, usacmp, + > nbpeto, peindi, peinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) +c + endif +c + endif +c + 51 continue +c +c==== +c 6. Calcul des sauts pour les fils des hexaedres coupes par conformite +c s'ils sont decrits par aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. fils des hexaedres ; codret = ', codret +#endif +c + if ( nbteca.gt.0 .or. nbheca.gt.0 .or. nbpyca.gt.0 ) then +c + do 61 , jaux = 1 , nbhecf +c + iaux = jaux +c + if ( mod(hethex(iaux),1000).ge.11 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,6), iaux +#endif +c +c 6.1. ==> Recherche des mailles a considerer +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV8', nompro +#endif + call deisv8 ( iaux, + > filqua, + > hethex, quahex, + > filhex, fhpyte, + > volqua, + > nbfite, nbvote, voiste, + > nbfihe, nbvohe, voishe, + > nbfipy, nbvopy, voispy, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> Calcul des sauts entre chaque fils de l'hexaedre et les +c voisins contenus dans la liste +c + if ( codret.eq.0 ) then +c + do 621 , kaux = 1 , nbfite +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) '. DEISV5 / tetr', nompro +#endif + call deisv5 ( voiste(kaux), ncmpin, usacmp, + > nbteto, teindi, teinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) + 621 continue +c + do 622 , kaux = 1 , nbfihe +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) '. DEISV5 / hexa', nompro +#endif + call deisv5 ( voishe(kaux), ncmpin, usacmp, + > nbheto, heindi, heinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) + 622 continue +c + do 623 , kaux = 1 , nbfipy +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) '. DEISV5 / pyra', nompro +#endif + call deisv5 ( voispy(kaux), ncmpin, usacmp, + > nbpyto, pyindi, pyinin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) + 623 continue +c + endif +c + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv3.F b/src/tool/Decision/deisv3.F new file mode 100644 index 00000000..529e626b --- /dev/null +++ b/src/tool/Decision/deisv3.F @@ -0,0 +1,203 @@ + subroutine deisv3 ( laface, tyface, + > hettri, filtri, + > hetqua, filqua, + > lgpile, tabent, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 1 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . laface . e . 1 . numero de la face a traiter . +c . tyface . e . 1 . type de la face a traiter . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . lgpile . s . 1 . longueur de la pile . +c . tabent . s . (2,*) . tabent(1,i) = numero de la i-eme face . +c . . . . tabent(2,i) = type de la i-eme face . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvais typenh . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer laface, tyface +c + integer hettri(nbtrto), filtri(nbtrto) + integer hetqua(nbquto), filqua(nbquto) + integer lgpile + integer tabent(2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer etat, fils + integer nupile +cgn integer glop +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > ' (''Reperage des faces actives liees a la face'',i10)' +c + texte(2,4) = + > '(''List of the active faces linked to the face #'',i10)' +c + 1000 format ( 'Faces :',10i10) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) laface +#endif +c + codret = 0 +c +c==== +c 2. On stocke les numeros des faces, en descendant les parentes. +c Au final, on stocke la premiere face mere active +c==== +c +cgn glop = 0 + lgpile = 1 + tabent(1,lgpile) = laface + tabent(2,lgpile) = tyface + nupile = 1 +c + 2 continue +c + laface = tabent(1,nupile) + tyface = tabent(2,nupile) +c +cgn if ( glop.eq.10) then +cgn write(ulsort,*)'..laface = ',laface +cgn endif +c +c 2.1. ==> reperage du fils selon la face +c + fils = 0 + if ( tyface.eq.2 ) then + etat = mod(hettri(laface),10) + if ( etat.ne.0 ) then + fils = filtri(laface) + endif + else + etat = mod(hetqua(laface),100) + if ( etat.ne.0 ) then + fils = filqua(laface) + endif + endif +c +c 2.2. ==> complement dans la pile +c + if ( fils.ne.0 ) then +c +cgn if ( glop.eq.1) then +cgn write(ulsort,*)'.. des fils' +cgn endif + do 22 , iaux = 0, 3 + lgpile = lgpile + 1 + tabent(1,lgpile) = fils + iaux + tabent(2,lgpile) = tyface +cgn if ( glop.eq.1) then +cgn write(ulsort,*)'.... ajout de ',tabent(1,lgpile), +cgn > ' a la pile' +cgn endif + 22 continue +c + endif +c +c 2.3. ==> suite de l'exploration de la pile +c + nupile = nupile + 1 + if ( nupile.le.lgpile ) then + goto 2 + endif +#ifdef _DEBUG_HOMARD_ +cgn if ( glop.eq.1) then +cgn write (ulsort,1000) (tabent(1,iaux),iaux=1,lgpile) +cgn endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv4.F b/src/tool/Decision/deisv4.F new file mode 100644 index 00000000..3f524935 --- /dev/null +++ b/src/tool/Decision/deisv4.F @@ -0,0 +1,213 @@ + subroutine deisv4 ( ncmpin, usacmp, vasmax, + > lamail, nbvolu, lesvol, + > nbenti, enindi, eninin, + > nbenvo, vosupp, voinin, + > valaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 4 +c -- - - - - +c Exploration de la pile des voisins d'une maille +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . vasmax . es . 1 . valeur max du saut de l'indicateur . +c . lamail . e . 1 . la maille en cours d'examen . +c . nbvolu . e . 1 . nombre de volumes a examiner . +c . lesvol . e . nbvolu . les volumes a examiner . +c . nbenti . e . 1 . nombre d'entites courantes . +c . eninin . e . ncmpin . valeur brute de l'indicateur sur la maille . +c . enindi . es . ncmpin . valeur du saut de l'indicateur . +c . nbenvo . e . 1 . nombre d'entites du type des voisines . +c . vosupp . e . nbenvo . support pour les entites voisines . +c . voinin . e . nbenvo . valeurs initiales pour les entites voisines. +c . valaux . a . ncmpin . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer ncmpin + integer usacmp + integer lamail + integer nbvolu, lesvol(nbvolu) + integer nbenti + integer nbenvo, vosupp(nbenvo) +c + integer ulsort, langue, codret +c + double precision vasmax + double precision eninin(nbenti,ncmpin), enindi(nbenti,ncmpin) + double precision voinin(nbenvo,ncmpin) + double precision valaux(ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux + integer nuvolu, levolu +c + double precision daux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Norme L2 des composantes.'')' + texte(1,5) = '(''. Norme infinie des composantes.'')' + texte(1,6) = '(''. Valeur relative de la composante.'')' + texte(1,7) = '(''. Saut avec '',i10,'' mailles'')' +c + texte(2,4) = '(''. L2 norm of components.'')' + texte(2,5) = '(''. Infinite norm of components.'')' + texte(2,6) = '(''. Relative value for the component.'')' + texte(2,7) = '(''. Jump with the '',i10,'' meshes'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4+usacmp)) + write (ulsort,texte(langue,7)) nbvolu +#endif +c +c==== +c 2. On parcourt tous les volumes de la pile : +c on cherche le max de l'ecart entre la valeur de l'indicateur +c sur ce volume voisin et celle sur le volume courant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. parcours volumes pile ; codret = ', codret +#endif +c + do 2 , nuvolu = 1 , nbvolu +c + levolu = lesvol(nuvolu) +c + if ( vosupp(levolu).ne.0 ) then +c +c 2.1. ==> Calcul de l'ecart entre la valeur sur la maille en cours +c de test et le volume a examiner +c + do 21 , iaux = 1 , ncmpin + valaux(iaux) = voinin(levolu,iaux) - eninin(lamail,iaux) + 21 continue +c +c 2.2. ==> Calcul de la norme ; si on a passe le max, on stocke +c 2.2.1. ==> Calcul de la norme +c + if ( usacmp.eq.0 ) then +c + daux = valaux(1)**2 + do 2211 , iaux = 2 , ncmpin + daux = daux + valaux(iaux)**2 + 2211 continue +c + elseif ( usacmp.eq.1 ) then +c + daux = abs(valaux(1)) + do 2212 , iaux = 2 , ncmpin + daux = max(daux,abs(valaux(iaux))) + 2212 continue +c + else +c + daux = valaux(1) +c + endif +c +c 2.2.2. ==> On a passe le max : on stocke +c + if ( daux.gt.vasmax ) then + vasmax = daux + do 222 , iaux = 1 , ncmpin + enindi(lamail,iaux) = valaux(iaux) + 222 continue + endif +c + endif +c + 2 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv5.F b/src/tool/Decision/deisv5.F new file mode 100644 index 00000000..1fbec723 --- /dev/null +++ b/src/tool/Decision/deisv5.F @@ -0,0 +1,296 @@ + subroutine deisv5 ( lamail, ncmpin, usacmp, + > nbenti, enindi, eninin, + > tesupp, teinin, + > hesupp, heinin, + > pysupp, pyinin, + > pesupp, peinin, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > valaux, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 5 +c -- - - - - +c Calcul des sauts sur tous les voisins +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lamail . e . 1 . la maille en cours d'examen . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . nbenti . e . 1 . nombre d'entites courantes . +c . eninin . e . ncmpin . valeur brute de l'indicateur sur la maille . +c . enindi . es . ncmpin . valeur du saut de l'indicateur . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teinin . e . nbteto . valeurs initiales pour les tetraedres . +c . hesupp . e . nbheto . support pour les hexaedres . +c . heinin . e . nbheto . valeurs initiales pour les hexaedres . +c . pysupp . e . nbpyto . support pour les pyramides . +c . pyinin . e . nbpyto . valeurs initiales pour les pyramides . +c . pesupp . e . nbpeto . support pour les pentaedres . +c . peinin . e . nbpeto . valeurs initiales pour les pentaedres . +c . nbvote . e . 1 . nombre de voisins de type tetraedre . +c . voiste . e . nbvote . les voisins de type tetraedre . +c . nbvohe . e . 1 . nombre de voisins de type hexaedre . +c . voishe . e . nbvohe . les voisins de type hexaedre . +c . nbvopy . e . 1 . nombre de voisins de type pyramide . +c . voispy . e . nbvopy . les voisins de type pyramide . +c . nbvope . e . 1 . nombre de voisins de type pentaedre . +c . voispe . e . nbvope . les voisins de type pentaedre . +c . valaux . a . ncmpin . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "infini.h" +#include "impr02.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lamail + integer ncmpin + integer usacmp + integer nbenti + integer tesupp(nbteto) + integer hesupp(nbheto) + integer pysupp(nbpyto) + integer pesupp(nbpeto) +c + integer nbvote, voiste(*) + integer nbvohe, voishe(*) + integer nbvopy, voispy(*) + integer nbvope, voispe(*) +c + integer ulsort, langue, codret +c + double precision eninin(nbenti,ncmpin), enindi(nbenti,ncmpin) + double precision teinin(nbteto,ncmpin) + double precision heinin(nbheto,ncmpin) + double precision pyinin(nbpyto,ncmpin) + double precision peinin(nbpeto,ncmpin) + double precision valaux(ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision vasmax +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Saut avec les '',i10,1x,a)' +c + texte(2,4) = '(''. Jump with the '',i10,1x,a)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbvote', nbvote + write (ulsort,90002) 'nbvohe', nbvohe + write (ulsort,90002) 'nbvopy', nbvopy + write (ulsort,90002) 'nbvope', nbvope +#endif +c + vasmax = vinfne +c +c==== +c 2. Saut avec des voisins tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Saut avec tetraedres ; codret = ', codret +#endif +c + if ( nbvote.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbvote, mess14(langue,3,3) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV4 / tetr', nompro +#endif + call deisv4 ( ncmpin, usacmp, vasmax, + > lamail, nbvote, voiste, + > nbenti, enindi, eninin, + > nbteto, tesupp, teinin, + > valaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Saut avec des voisins hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Saut avec hexaedres ; codret = ', codret +#endif +c + if ( nbvohe.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbvohe, mess14(langue,3,6) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV4 / hexa', nompro +#endif + call deisv4 ( ncmpin, usacmp, vasmax, + > lamail, nbvohe, voishe, + > nbenti, enindi, eninin, + > nbheto, hesupp, heinin, + > valaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Saut avec des voisins pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Saut avec pyramides ; codret = ', codret +#endif +c + if ( nbvopy.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbvopy, mess14(langue,3,5) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV4 / pyra', nompro +#endif + call deisv4 ( ncmpin, usacmp, vasmax, + > lamail, nbvopy, voispy, + > nbenti, enindi, eninin, + > nbpyto, pysupp, pyinin, + > valaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. Saut avec des voisins pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Saut avec pentaedres ; codret = ', codret +#endif +c + if ( nbvope.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbvope, mess14(langue,3,7) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISV4 / pent', nompro +#endif + call deisv4 ( ncmpin, usacmp, vasmax, + > lamail, nbvope, voispe, + > nbenti, enindi, eninin, + > nbpeto, pesupp, peinin, + > valaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv6.F b/src/tool/Decision/deisv6.F new file mode 100644 index 00000000..7c75b69a --- /dev/null +++ b/src/tool/Decision/deisv6.F @@ -0,0 +1,353 @@ + subroutine deisv6 ( laface, typfac, lamail, typenh, + > hettri, pertri, + > hetqua, perqua, + > pertet, + > hethex, filhex, perhex, fhpyte, + > voltri, pypetr, + > volqua, pypequ, + > nbvote, voiste, + > nbvohe, voishe, + > nbvopy, voispy, + > nbvope, voispe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 6 +c -- - - - - +c Recherche des voisins d'une maille decrite par ses faces +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . laface . e . 1 . la face en cours d'examen . +c . typfac . e . 1 . type de la face . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . lamail . e . 1 . la maille en cours d'examen . +c . typenh . e . 1 . type de la maille . +c . . . . 3 : tetraedres . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . voltri . es .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbvote . es . 1 . nombre de voisins de type tetraedre . +c . voiste . es . nbvote . les voisins de type tetraedre . +c . nbvohe . es . 1 . nombre de voisins de type hexaedre . +c . voishe . es . nbvohe . les voisins de type hexaedre . +c . nbvopy . es . 1 . nombre de voisins de type pyramide . +c . voispy . es . nbvopy . les voisins de type pyramide . +c . nbvope . es . 1 . nombre de voisins de type pentaedre . +c . voispe . es . nbvope . les voisins de type pentaedre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer laface, typfac + integer lamail, typenh + integer hettri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), perqua(nbquto) + integer pertet(nbteto) + integer hethex(nbheto), filhex(nbheto), perhex(nbheto) + integer fhpyte(2,nbheco) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) +c + integer nbvote, voiste(*) + integer nbvohe, voishe(*) + integer nbvopy, voispy(*) + integer nbvope, voispe(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer etat, bindec, lamere, lepere, levois + integer nbfipy, filspy + integer nbfite, filste + integer nbfihe, filshe +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Voisins de la maille'',i10,'' ('',a,'')'')' +c + texte(2,4) = + > '(''. Neighbourgs of the mesh #'',i10,'' ('',a,'')'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lamail, mess14(langue,1,typenh) +#endif +c +c==== +c 2. On parcourt tous les voisins de la face +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. parcours voisins face ; codret = ', codret +#endif +c +c 2.1. ==> L'etat de la face +c + if ( typfac.eq.2 ) then + etat = mod(hettri(laface),10) + else + etat = mod(hetqua(laface),100) + endif +cgn write (ulsort,90002) '.. etat', etat +c +c 2.2. ==> traitement pour une face non coupee +c + if ( etat.eq.0 ) then +c + do 221 , iaux = 1 , 2 +cgn write (ulsort,90002) '.... voisin de rang', iaux +c +c 2.2.1. ==> Cas de la face triangulaire +c + if ( typfac.eq.2 ) then +c + jaux = voltri(iaux,laface) +c +c 2.2.1.1. ==> Il existe un voisin tetraedre + if ( jaux.gt.0 ) then + nbvote = nbvote + 1 + voiste(nbvote) = jaux +c 2.2.1.2. ==> Il existe un voisin pyramide ou pentaedre + elseif ( jaux.lt.0 ) then + jaux = -jaux + if ( pypetr(1,jaux).ne.0 ) then + nbvopy = nbvopy + 1 + voispy(nbvopy) = pypetr(1,jaux) + endif + if ( pypetr(2,jaux).ne.0 ) then + nbvope = nbvope + 1 + voispe(nbvope) = pypetr(2,jaux) + endif +c 2.2.1.3. ==> Il n'existe pas de voisin + else + lamere = pertri(laface) + if ( lamere.gt.0 ) then + if ( voltri(2,lamere).ne.0 ) then + do 2211 , kaux = 1 , 2 + levois = voltri(kaux,lamere) + if ( levois.ne.pertet(lamail) ) then +c + write(ulsort,*) 'A PROGRAMMER quand on aura' + write(ulsort,*) 'la conformite des pentaedres' + codret = 2211 +c + endif + 2211 continue + endif + elseif ( lamere.lt.0 ) then + if ( volqua(2,-lamere).ne.0 ) then + do 2212 , kaux = 1 , 2 + levois = volqua(kaux,-lamere) + if ( levois.ne.pertet(lamail) ) then +c + write(ulsort,*) 'A PROGRAMMER quand on aura' + write(ulsort,*) 'la conformite des pentaedres' + codret = 2212 +c + endif + 2212 continue + endif + endif + endif +c +c 2.2.2. ==> Cas de la face quadrangulaire +c + else +c + jaux = volqua(iaux,laface) +cgn write (ulsort,90002) '.... jaux', jaux +c 2.2.2.1. ==> Il existe un voisin hexaedre + if ( jaux.gt.0 ) then + nbvohe = nbvohe + 1 + voishe(nbvohe) = jaux +c 2.2.2.2. ==> Il existe un voisin pyramide ou pentaedre + elseif ( jaux.lt.0 ) then + jaux = -jaux + if ( pypequ(1,jaux).ne.0 ) then + nbvopy = nbvopy + 1 + voispy(nbvopy) = pypequ(1,jaux) + endif + if ( pypequ(2,jaux).ne.0 ) then + nbvope = nbvope + 1 + voispe(nbvope) = pypequ(2,jaux) + endif +c 2.2.2.3. ==> Il n'existe pas de voisin +c Soit c'est un bord et il n'y a rien a faire. +c Soit c'est que la maille du niveau precedent a ete +c coupee par conformite et les fils sont decrites par +c aretes : le voisinage n'est pas reconstitue. Dans ce +c cas, on stocke tous les fils. +c Remarque : la face mere ne peut avoir 2 voisins que +c dans le cas d'hexaedres voisins. A completer quand +c on aura programme le raffinement conforme complet +c des pentaedres + else + lamere = perqua(laface) +cgn write (ulsort,90002) 'lamere', lamere + if ( lamere.gt.0 ) then + if ( volqua(2,lamere).ne.0 ) then + do 2221 , kaux = 1 , 2 + if ( volqua(kaux,lamere).ne.perhex(lamail) ) then +c + lepere = volqua(kaux,lamere) + etat = mod(hethex(lepere),1000) + bindec = chbiet(etat) + nbfihe = chnhe(bindec) + nbfipy = chnpy(bindec) + nbfite = chnte(bindec) + filshe = filhex(lepere) + if ( nbfihe.gt.0 ) then + do 22211 , laux = 0 , nbfihe-1 + nbvohe = nbvohe + 1 + voishe(nbvohe) = filshe + iaux +22211 continue + endif + if ( nbfipy.gt.0 ) then + filspy = fhpyte(1,-filshe) + do 22212 , laux = 0 , nbfipy-1 + nbvopy = nbvopy + 1 + voispy(nbvopy) = filspy + iaux +22212 continue + endif + if ( nbfite.gt.0 ) then + filste = fhpyte(2,-filshe) + do 22213 , laux = 0 , nbfite-1 + nbvote = nbvote + 1 + voiste(nbvote) = filste + iaux +22213 continue + endif +c + endif + 2221 continue + endif + endif + endif +c + endif +c + 221 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv7.F b/src/tool/Decision/deisv7.F new file mode 100644 index 00000000..0b3998a8 --- /dev/null +++ b/src/tool/Decision/deisv7.F @@ -0,0 +1,130 @@ + subroutine deisv7 ( lamail, nbvoen, voisen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 7 +c -- - - - - +c Retrait de la maille courante de la liste des voisins +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lamail . e . 1 . la maille en cours d'examen . +c . nbvoen . es . 1 . nombre de voisins de type courant . +c . voisen . es . nbvoen . les voisins de type courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV7' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lamail + integer nbvoen, voisen(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. On parcourt tous les voisins de la face +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. parcours voisins face ; codret = ', codret +#endif +c + do 21 , iaux = 1 , nbvoen + if ( voisen(iaux).eq.lamail ) then + jaux = iaux + goto 22 + endif + 21 continue + goto 24 +c + 22 continue +c + nbvoen = nbvoen - 1 + do 23 , iaux = jaux , nbvoen + voisen(iaux) = voisen(iaux+1) + 23 continue +c + 24 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deisv8.F b/src/tool/Decision/deisv8.F new file mode 100644 index 00000000..33d72733 --- /dev/null +++ b/src/tool/Decision/deisv8.F @@ -0,0 +1,310 @@ + subroutine deisv8 ( lehexa, + > filqua, + > hethex, quahex, + > filhex, fhpyte, + > volqua, + > nbfite, nbvote, voiste, + > nbfihe, nbvohe, voishe, + > nbfipy, nbvopy, voispy, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - par Saut - Volumes - 8 +c -- - - - - +c Pour un hexaedre coupe par conformite et dont les fils sont decrits +c par aretes : +c - etablissement de la liste des fils par type de maille +c - ajout des fils des voisins de l'hexaedre +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . l'hexaedre en cours d'examen . +c . filqua . e . nbquto . fils des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . nbfite . s . 1 . nombre de fils de type tetraedre . +c . nbvote . s . 1 . nombre de voisins de type tetraedre . +c . voiste . s . nbvote . les voisins de type tetraedre . +c . nbfihe . s . 1 . nombre de fils de type hexaedre . +c . nbvohe . s . 1 . nombre de voisins de type hexaedre . +c . voishe . s . nbvohe . les voisins de type hexaedre . +c . nbfipy . s . 1 . nombre de fils de type pyramide . +c . nbvopy . s . 1 . nombre de voisins de type pyramide . +c . voispy . s . nbvopy . les voisins de type pyramide . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEISV8' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer filqua(nbquto) + integer hethex(nbheto), filhex(nbheto) + integer quahex(nbhecf,6) + integer fhpyte(2,nbheco) + integer volqua(2,nbquto) +c + integer nbfite, nbvote, voiste(*) + integer nbfihe, nbvohe, voishe(*) + integer nbfipy, nbvopy, voispy(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer etat + integer laface, levois + integer lafafi, levofi + integer filste + integer filshe + integer filspy + integer nbfitf, filstf + integer nbfihf, filshf + integer nbfipf, filspf +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Voisins de l''''hexaedre'',i10,'')' + texte(1,5) = '(''... Face '',i10,'')' +c + texte(2,4) = '(''. Neighbourgs of the mesh #'',i10,'')' + texte(2,5) = '(''... Face '',i10,'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lehexa +#endif +c +c==== +c 2. Recuperation des fils +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. parcours voisins face ; codret = ', codret +#endif +c + call utfihe ( lehexa, + > hethex, filhex, fhpyte, + > nbfite, filste, + > nbfihe, filshe, + > nbfipy, filspy ) +c + nbvote = nbfite + do 21 , iaux = 1 , nbfite + voiste(iaux) = filste + iaux - 1 + 21 continue +c + nbvohe = nbfihe + do 22 , iaux = 1 , nbfihe + voishe(iaux) = filshe + iaux - 1 + 22 continue +c + nbvopy = nbfipy + do 23 , iaux = 1 , nbfipy + voispy(iaux) = filspy + iaux - 1 + 23 continue +c +c==== +c 3. On passe en revue les voisins par face de l'hexaedre +c==== +c + do 30 , iaux = 1 , 6 +c + laface = quahex(lehexa,iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) laface +#endif +c + do 31 , jaux = 1 , 2 +c + levois = volqua(jaux,laface) +c +c 3.1. ==> Le jaux-eme est un hexaedre +c + if ( levois.gt.0 ) then +c + if ( levois.ne.lehexa ) then +c + etat = mod(hethex(levois),1000) +c 3.1.1. ==> Le voisin est actif : on le stocke + if ( etat.eq.0 ) then + nbvohe = nbvohe + 1 + voishe(nbvohe) = levois +c 3.1.2. ==> Le voisin est coupe en 8 avec eventuellement des +c petits-fils : +c On parcourt les 4 filles de laface : elles n'ont qu'un +c voisin qui est un hexaedre fils de levois. +c . Si ce fils est actif, on le stocke +c . Sinon, c'est qu'il est coupe par conformite et +c on stocke ses enfants. + elseif ( etat.eq.8 .or. etat.eq.9 ) then + lafafi = filqua(laface) + do 312 , kaux = 1 , 4 + levofi = volqua(1,lafafi+kaux-1) + if ( mod(hethex(levofi),1000).eq.0 ) then + nbvohe = nbvohe + 1 + voishe(nbvohe) = levofi + else + call utfihe ( levofi, + > hethex, filhex, fhpyte, + > nbfitf, filstf, + > nbfihf, filshf, + > nbfipf, filspf ) + do 3121 , laux = 1 , nbfitf + nbvote = nbvote + 1 + voiste(nbvote) = filstf + laux - 1 + 3121 continue + do 3122 , laux = 1 , nbfihf + nbvohe = nbvohe + 1 + voishe(nbvohe) = filshf + laux - 1 + 3122 continue + do 3123 , laux = 1 , nbfipf + nbvopy = nbvopy + 1 + voispy(nbvopy) = filspf + laux - 1 + 3123 continue + endif + 312 continue +c +c 3.1.3. ==> Le voisin est coupepar conformite : +c on stocke ses enfants. + else + call utfihe ( levois, + > hethex, filhex, fhpyte, + > nbfitf, filstf, + > nbfihf, filshf, + > nbfipf, filspf ) + do 3131 , laux = 1 , nbfitf + nbvote = nbvote + 1 + voiste(nbvote) = filstf + laux - 1 + 3131 continue + do 3132 , laux = 1 , nbfihf + nbvohe = nbvohe + 1 + voishe(nbvohe) = filshf + laux - 1 + 3132 continue + do 3133 , laux = 1 , nbfipf + nbvopy = nbvopy + 1 + voispy(nbvopy) = filspf + laux - 1 + 3133 continue +c + endif +c + endif +c +c 3.2. ==> Le jaux-eme est un pentaedre ou une pyramide : pas encore +c + elseif ( levois.lt.0 ) then + codret = 3829 + endif +c + 31 continue +c + 30 continue +c +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'hexaedre', lehexa + write (ulsort,90002) 'fils/voisins tetr', nbfite, nbvote + if ( nbvote.gt.0 ) then + write (ulsort,91010) (voiste(iaux),iaux=1,nbvote) + endif + write (ulsort,90002) 'fils/voisins hexa', nbfihe, nbvohe + if ( nbvohe.gt.0 ) then + write (ulsort,91010) (voishe(iaux),iaux=1,nbvohe) + endif + write (ulsort,90002) 'fils/voisins pyra', nbfipy, nbvopy + if ( nbvopy.gt.0 ) then + write (ulsort,91010) (voispy(iaux),iaux=1,nbvopy) + endif +#endif +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deited.F b/src/tool/Decision/deited.F new file mode 100644 index 00000000..d95ba528 --- /dev/null +++ b/src/tool/Decision/deited.F @@ -0,0 +1,206 @@ + subroutine deited ( nivmin, + > decare, decfac, + > aretri, nivtri, + > tritet, hettet, filtet, + > tesupp, teindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TEtraedres - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . e . nbteto . valeurs entieres pour les tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITED' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), nivtri(nbtrto) + integer tritet(nbtecf,4), hettet(nbteto), filtet(nbteto) + integer tesupp(nbteto), teindi(nbteto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc, etat + integer letria, letetr + integer fils1 + integer iaux, jaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les tetraedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un tetraedre est identifie a celui de l'une quelconque +c de ses triangles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,3) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , letetr = 1, nbteto +c + etat = mod( hettet(letetr) , 100 ) + if ( etat.ge.85 .and. etat.le.87 ) then + fils1 = filtet(letetr) + if ( tesupp(fils1) .ne. 0 .and. + > tesupp(fils1+1) .ne. 0 .and. + > tesupp(fils1+2) .ne. 0 .and. + > tesupp(fils1+3) .ne. 0 .and. + > tesupp(fils1+4) .ne. 0 .and. + > tesupp(fils1+5) .ne. 0 .and. + > tesupp(fils1+6) .ne. 0 .and. + > tesupp(fils1+7) .ne. 0 ) then + if ( teindi(fils1) .eq. -1 .and. + > teindi(fils1+1) .eq. -1 .and. + > teindi(fils1+2) .eq. -1 .and. + > teindi(fils1+3) .eq. -1 .and. + > teindi(fils1+4) .eq. -1 .and. + > teindi(fils1+5) .eq. -1 .and. + > teindi(fils1+6) .eq. -1 .and. + > teindi(fils1+7) .eq. -1 ) then + jaux = tritet(letetr,1) + if ( nivtri(jaux).lt.nivmin ) then + iaux = iaux + 8 + else + do 22 , facloc = 1, 4 + letria = tritet(letetr,facloc) + decfac(letria) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', + >letria,decfac(letria),' ' +#endif + do 23 , areloc = 1, 3 + decare(aretri(letria,areloc)) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',aretri(letria,areloc), + > decare(aretri(letria,areloc)),' (une de ses aretes)' +#endif + 23 continue + 22 continue + endif + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,3) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deitei.F b/src/tool/Decision/deitei.F new file mode 100644 index 00000000..4049957e --- /dev/null +++ b/src/tool/Decision/deitei.F @@ -0,0 +1,174 @@ + subroutine deitei ( decare, decfac, + > aretri, pertri, + > tritet, + > tesupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TEtraedres - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . tesupp . e . nbteto . support pour les tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITEI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), pertri(nbtrto) + integer tritet(nbtecf,4) + integer tesupp(nbteto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer letria, letetr, lepere + integer iaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,3) +#endif +c + iaux = 0 +c + do 21 , letetr = 1, nbteto +c + if ( tesupp(letetr).ne.0 ) then +c + do 22 , facloc = 1, 4 +c + letria = tritet(letetr,facloc) +c +c 2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(letria) = 0 + do 221 , areloc = 1, 3 + decare(aretri(letria,areloc)) = 0 + 221 continue +c +c 2.2. ==> Inhibition du deraffinement par defaut : on garde la mere +c de la face designee s'il existe +c + lepere = pertri(letria) +c + if ( lepere.gt.0 ) then +c + decfac(lepere) = 0 + do 222 , areloc = 1, 3 + decare(aretri(lepere,areloc)) = 0 + 222 continue +c + endif +c + 22 continue +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiter.F b/src/tool/Decision/deiter.F new file mode 100644 index 00000000..fb3cf760 --- /dev/null +++ b/src/tool/Decision/deiter.F @@ -0,0 +1,190 @@ + subroutine deiter ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > tritet, + > tesupp, teindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TEtraedres - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmax . e . 1 . niveau max a ne pas depasser en raffinement. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . tesupp . e . nbteto . support pour les tetraedres . +c . teindi . e . nbteto . valeurs entieres pour les tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITER' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer tritet(nbtecf,4) + integer tesupp(nbteto), teindi(nbteto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, facloc + integer letria, letetr + integer iaux, jaux, kaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les tetraedres +c pour le filtrage sur les niveaux, on tient compte du fait que +c le niveau d'un tetraedre est identifie a celui de l'une quelconque +c de ses triangles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,3) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , letetr = 1, nbteto +c + if ( tesupp(letetr).ne.0 ) then + if ( teindi(letetr).eq.1 ) then +cgn write (ulsort,*) '--> tetra ',letetr + jaux = tritet(letetr,1) + if ( nivmax.ge.0 .and. nivtri(jaux).ge.nivmax ) then + iaux = iaux + 1 + else + do 22 , facloc = 1, 4 + letria = tritet(letetr,facloc) +cgn write (ulsort,*) '----> tria ',letria + if ( mod(hettri(letria),10).eq.0 ) then + decfac(letria) = 4 + endif + do 23 , areloc = 1, 3 + kaux = aretri(letria,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 + endif + 23 continue + 22 continue + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,3) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deitrd.F b/src/tool/Decision/deitrd.F new file mode 100644 index 00000000..ea0aaa35 --- /dev/null +++ b/src/tool/Decision/deitrd.F @@ -0,0 +1,199 @@ + subroutine deitrd ( nivmin, + > decare, decfac, + > aretri, hettri, filtri, nivtri, + > trsupp, trindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TRiangles - Deraffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . e . nbtrto . valeurs entieres pour les triangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITRD' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmin + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), hettri(nbtrto), filtri(nbtrto) + integer nivtri(nbtrto) + integer trsupp(nbtrto), trindi(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc, etat + integer letria + integer fille1 + integer iaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,2) +#endif +cgn write(ulsort,*)'trindi :' +cgn write(ulsort,1789)(letria, trindi(letria),letria = 1, nbtrto) +cgn 1789 format(5(i3,' : ',i4,', ')) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) +#endif +c + iaux = 0 +c + do 21 , letria = 1, nbtrto +c + etat = mod(hettri(letria),10) + if ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'tria ',letria,', etat = ',etat +#endif + fille1 = filtri(letria) + if ( trsupp(fille1) .ne.0 .and. + > trsupp(fille1+1).ne.0 .and. + > trsupp(fille1+2).ne.0 .and. + > trsupp(fille1+3).ne.0 ) then + if ( trindi(fille1) .eq.-1 .and. + > trindi(fille1+1).eq.-1 .and. + > trindi(fille1+2).eq.-1 .and. + > trindi(fille1+3).eq.-1 ) then + if ( nivtri(letria).lt.nivmin ) then + iaux = iaux + 4 + else + decfac(letria) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', + >letria,decfac(letria),' ' +#endif + do 22 , areloc = 1, 3 + decare(aretri(letria,areloc)) = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',aretri(letria,areloc), + > decare(aretri(letria,areloc)),' (une de ses aretes)' +#endif + 22 continue + endif + endif + endif + endif +c + 21 continue +c +cgn write(ulsort,*)'a la fin de 3.1' +cgn write(ulsort,*)'decfac :' +cgn write(ulsort,1789)(letria, decfac(letria),letria = 1, nbtrto) +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,2) + write(ulsort,texte(langue,8)) nivmin + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deitri.F b/src/tool/Decision/deitri.F new file mode 100644 index 00000000..d0233f0a --- /dev/null +++ b/src/tool/Decision/deitri.F @@ -0,0 +1,162 @@ + subroutine deitri ( decare, decfac, + > aretri, pertri, + > trsupp, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TRiangles - Initialisation +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . trsupp . e . nbtrto . support pour les triangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITRI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer aretri(nbtrto,3), pertri(nbtrto) + integer trsupp(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc + integer letria, lepere + integer iaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,2) +#endif +c + do 21 , letria = 1, nbtrto +c + if ( trsupp(letria).ne.0 ) then +c +c 2.1. ==> Inhibition du raffinement par defaut : on garde la face +c designee +c + decfac(letria) = 0 + do 211 , areloc = 1, 3 + decare(aretri(letria,areloc)) = 0 + 211 continue +c +c 2.2. ==> Inhibition du deraffinement par defaut : on garde le pere +c de la face designee s'il existe +c + lepere = pertri(letria) +c + if ( lepere.gt.0 ) then +c + decfac(lepere) = 0 + do 212 , areloc = 1, 3 + decare(aretri(lepere,areloc)) = 0 + 212 continue +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deitrr.F b/src/tool/Decision/deitrr.F new file mode 100644 index 00000000..96f6abeb --- /dev/null +++ b/src/tool/Decision/deitrr.F @@ -0,0 +1,193 @@ + subroutine deitrr ( nivmax, + > decare, decfac, + > hetare, + > aretri, hettri, nivtri, + > trsupp, trindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisation de l'indicateur entier +c -- - +c - cas des TRiangles - Raffinement +c -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nivmin . e . 1 . niveau min a ne pas depasser en deraffinemt. +c . decare . s .0:nbarto. decisions des aretes . +c . decfac . s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . trsupp . e . nbtrto . support pour les triangles . +c . trindi . e . nbtrto . valeurs entieres pour les triangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEITRR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nivmax + integer decare(0:nbarto), decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto) + integer nivtri(nbtrto) + integer trsupp(nbtrto), trindi(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer areloc + integer letria + integer iaux, kaux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr05.h" +#include "derco1.h" +c + codret = 0 +c +c==== +c 2. traitement des indicateurs portant sur les triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,2) +#endif +cgn write(ulsort,*)'trindi :' +cgn write(ulsort,1789)(letria, trindi(letria),letria = 1, nbtrto) +cgn 1789 format(5(i3,' : ',i4,', ')) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) +#endif +c + iaux = 0 +c + do 21 , letria = 1, nbtrto +c + if ( trsupp(letria).ne.0 ) then + if ( trindi(letria).eq.1 ) then + if ( mod(hettri(letria),10).eq.0 ) then + if ( nivmax.gt.0 .and. nivtri(letria).ge.nivmax ) then + iaux = iaux + 1 + else + decfac(letria) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', + >letria,decfac(letria),' ' +#endif + do 22 , areloc = 1, 3 + kaux = aretri(letria,areloc) + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',kaux, + > decare(kaux),' (une de ses aretes)' +#endif + elseif ( mod(hetare(kaux),10).eq.2 ) then + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decare',kaux, + > decare(kaux),' (une de ses aretes)' +#endif + endif + 22 continue + endif + endif + endif + endif +c + 21 continue +c + if ( iaux.ne.0 ) then + write(ulsort,texte(langue,10)) + write(ulsort,texte(langue,4)) mess14(langue,3,2) + write(ulsort,texte(langue,7)) nivmax + write(ulsort,texte(langue,9)) iaux + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiuc0.F b/src/tool/Decision/deiuc0.F new file mode 100644 index 00000000..13e5d641 --- /dev/null +++ b/src/tool/Decision/deiuc0.F @@ -0,0 +1,178 @@ + subroutine deiuc0 ( nbval, ncmpin, usacmp, + > ensupp, enindi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - Usage des CoMposantes - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbval . e . 1 . nombres de valeurs . +c . ncmpin . e . 1 . nombre de composantes de l'indicateur . +c . usacmp . e . 1 . usage des composantes de l'indicateur . +c . . . . 0 : norme L2 . +c . . . . 1 : norme infinie -max des valeurs absolues. +c . . . . 2 : valeur relative si une seule composante. +c . ensupp . e . nbval . support pour les entites . +c . enindi . es . nbval . valeurs reelles pour les entites . +c . . .*ncmpin . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans le traitement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIUC0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbval, ncmpin + integer usacmp + integer ensupp(nbval) +c + integer ulsort, langue, codret +c + double precision enindi(nbval,ncmpin) +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp +c + double precision daux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) =' (''. Saut entre '',a)' +c + texte(2,4) = '(''. Jump between '',a)' +c + codret = 0 +c +c==== +c 2. Traitement +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> norme L2 +c + if ( usacmp.eq.0 ) then +c + do 21 , iaux = 1 , nbval +c + if ( ensupp(iaux).ne.0 ) then +c + daux = 0.d0 + do 211 , nrcomp = 1 , ncmpin + daux = daux + enindi(iaux,nrcomp)**2 + 211 continue + enindi(iaux,1) = sqrt(daux) +c + endif +c + 21 continue +c +c 2.2. ==> norme infinie +c + elseif ( usacmp.eq.1 ) then +c + do 22 , iaux = 1 , nbval +c + if ( ensupp(iaux).ne.0 ) then +c + daux = 0.d0 + do 221 , nrcomp = 1 , ncmpin + daux = max ( daux, abs(enindi(iaux,nrcomp)) ) + 221 continue + enindi(iaux,1) = daux +c + endif +c + 22 continue +c +c 2.3. ==> probleme +c + else +c + codret = 23 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deiucm.F b/src/tool/Decision/deiucm.F new file mode 100644 index 00000000..ae89f431 --- /dev/null +++ b/src/tool/Decision/deiucm.F @@ -0,0 +1,339 @@ + subroutine deiucm ( nohind, + > lgopti, taopti, lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Initialisations - Usage des CoMposantes +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DEIUCM' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nohind +c + integer lgopti + integer taopti(lgopti) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + integer adnoin, adnorn, adnosu + integer adarin, adarrn, adarsu + integer adtrin, adtrrn, adtrsu + integer adquin, adqurn, adqusu + integer adtein, adtern, adtesu + integer adhein, adhern, adhesu + integer adpyin, adpyrn, adpysu + integer adpein, adpern, adpesu + integer nbvnoe, nbvare + integer nbvtri, nbvqua + integer nbvtet, nbvhex, nbvpyr, nbvpen +c + integer usacmp + integer typind, ncmpin + integer nbvent(-1:7) + integer adsupp(-1:7) + integer advale(-1:7) +c + character*6 saux +c +#ifdef _DEBUG_HOMARD_ + character*7 saux07(nblang,2) +#endif +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = + > '(/,a6,'' USAGE DES COMPOSANTES'')' + texte(1,5) = '(28(''=''),/)' + texte(1,6) = '(''Le champ d''''indicateur est '',a)' + texte(1,7) = '(''Nombre de composantes :'',i3)' + texte(1,8) = '(''Nombre de valeurs pour les '',a,'':'',i10)' + texte(1,9) = '(''. Norme L2 des composantes.'')' + texte(1,10) = '(''. Norme infinie des composantes.'')' + texte(1,11) = '(''. Valeur relative de la composante.'')' +c + texte(2,4) = + > '(/,a6,'' USE OF THE COMPONENTS'')' + texte(2,5) = '(28(''=''),/)' + texte(2,6) = '(''The type of the indicator is '',a)' + texte(2,7) = '(''Number of components:'',i3)' + texte(2,8) = '(''Number of values for the '',a,'':'',i10)' + texte(2,9) = '(''. L2 norm of components.'')' + texte(2,10) = '(''. Infinite norm of components.'')' + texte(2,11) = '(''. Relative value for the component.'')' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. gestion des tableaux +c==== +c +c 2.1. ==> structure generale de l'indicateur +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINI0', nompro +#endif + call deini0 ( nohind, typind, ncmpin, + > nbvnoe, nbvare, + > nbvtri, nbvqua, + > nbvtet, nbvhex, nbvpyr, nbvpen, + > adnoin, adnorn, adnosu, + > adarin, adarrn, adarsu, + > adtrin, adtrrn, adtrsu, + > adquin, adqurn, adqusu, + > adtein, adtern, adtesu, + > adhein, adhern, adhesu, + > adpyin, adpyrn, adpysu, + > adpein, adpern, adpesu, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbvent(-1) = nbvnoe + nbvent(0) = 0 + nbvent(1) = nbvare + nbvent(2) = nbvtri + nbvent(4) = nbvqua + nbvent(3) = nbvtet + nbvent(5) = nbvpyr + nbvent(6) = nbvhex + nbvent(7) = nbvpen +c + adsupp(-1) = adnosu + adsupp(1) = adarsu + adsupp(2) = adtrsu + adsupp(4) = adqusu + adsupp(3) = adtesu + adsupp(5) = adpysu + adsupp(6) = adhesu + adsupp(7) = adpesu +c + advale(-1) = adnorn + advale(1) = adarrn + advale(2) = adtrrn + advale(4) = adqurn + advale(3) = adtern + advale(5) = adpyrn + advale(6) = adhern + advale(7) = adpern +c +#ifdef _DEBUG_HOMARD_ + saux07(1,1) = 'entier ' + saux07(1,2) = 'reel ' + saux07(2,1) = 'integer' + saux07(2,2) = 'real ' + write (ulsort,texte(langue,6)) saux07(langue,typind-1) + write (ulsort,texte(langue,7)) ncmpin + do 222 , iaux= -1, 7 + write (ulsort,texte(langue,8)) mess14(langue,3,iaux), nbvent(iaux) + 222 continue +#endif +c + endif +c +c==== +c 3. Calcul par type d'entite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Calcul par type entite ; codret = ', codret +#endif +c +c 3.1. ==> Si une seule composante et si valeur relative, rien n'est +c a faire, sinon traitement +c + usacmp = taopti(8) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9+usacmp)) +#endif + if ( usacmp.eq.2 .and. ncmpin.eq.1 ) then + goto 39 + endif +c +c 3.2. ==> traitement +cgn call gmprsx(nompro,nohind//'.Arete.ValeursR') +c + do 30 , iaux = -1, 7 +c + if ( nbvent(iaux).gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIUC0', nompro +#endif + call deiuc0 ( nbvent(iaux), ncmpin, usacmp, + > imem(adsupp(iaux)), rmem(advale(iaux)), + > ulsort, langue, codret) +c + endif +c + endif +c + 30 continue +c + 39 continue +cgn call gmprsx(nompro,nohind//'.Arete.ValeursR') +c +c==== +c 4. Bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Bilan ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIUC0', nompro +#endif + call deinbi ( nbvent, ncmpin, + > imem(adnosu), rmem(adnorn), + > imem(adarsu), rmem(adarrn), + > imem(adtrsu), rmem(adtrrn), + > imem(adqusu), rmem(adqurn), + > imem(adtesu), rmem(adtern), + > imem(adhesu), rmem(adhern), + > imem(adpysu), rmem(adpyrn), + > imem(adpesu), rmem(adpern), + > ulsort, langue, codret) +c + endif +c +c==== +c 5. la fin +c==== +c +c 5.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 5.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/delis1.F b/src/tool/Decision/delis1.F new file mode 100644 index 00000000..452f2fbc --- /dev/null +++ b/src/tool/Decision/delis1.F @@ -0,0 +1,396 @@ + subroutine delis1 ( option, + > decare, decfac, + > posifa, facare, hetare, merare, + > hettri, nivtri, + > hetqua, nivqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - LISte des decisions - 1 +c -- --- - +c On utilise ce programme de debogage en modifiant le +c contenu des tableaux lisare et listri. +c Remarque : Les appels ont lieu seulement en mode DEBUG +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . x2 : affichage total . +c . . . . x3 : les mailles a raffiner . +c . . . . x5 : les mailles a reactiver . +c . decare . e . nbarto . decisions des aretes . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . merare . e . nbarto . mere des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon, probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DELIS1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer option + integer decfac(-nbquto:nbtrto) + integer decare(0:nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetare(nbarto), merare(nbarto) + integer hettri(nbtrto), nivtri(nbtrto) + integer hetqua(nbquto), nivqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbrqua, nbrtri, nbrare +c + integer nbrq, nbrt, nbra + parameter ( nbrq = 1 ) + parameter ( nbrt = 1 ) + parameter ( nbra = 1 ) +c + integer lisqua(nbrt) + integer listri(nbrt) + integer lisare(nbra) +c + logical toutqu, touttr, toutar +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data lisqua / + > 1 + >/ +c + data listri / + > 1 + >/ +c + data lisare / + > 1 + >/ +c + data toutqu / .true. / + data touttr / .true. / + data toutar / .true. / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'option', option +#endif +c + codret = 0 +c +c 1.2. ==> On fait une fausse utilisation des variables pour +c eviter des messages de ftnchek +c + iaux = posifa(0) + iaux = max(iaux,facare(1)) + iaux = max(iaux,hetare(1)) + iaux = max(iaux,abs(merare(1))) +c +c==== +c 2. les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,99001) 'touttr', touttr + write(ulsort,90002) 'nbtrto', nbtrto + write(ulsort,90002) 'nbrt ', nbrt +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( touttr ) then + nbrtri = nbtrto + else + nbrtri = min(nbrt,nbtrto) + endif +c + if ( mod(option,2).eq.0 ) then +c +20000 format ( + > //,'decisions sur les triangles',/, + > ' Triangle! Dec ! Etat ! Niv.') +21000 format (i10,' ! ',i3,' ! ',i4,' ! ',i2) +c + write (ulsort,20000) +c +cc do 21 , iaux = 1 , nbrtri +cc listri(iaux) = iaux +cc 21 continue +c + do 221 , iaux = 1 , nbrtri + if ( touttr ) then + jaux = iaux + else + jaux = listri(iaux) + endif + write (ulsort,21000) jaux, decfac(jaux), + > hettri(jaux), nivtri(jaux) + 221 continue +c + endif +c + if ( mod(option,3).eq.0 ) then +c + do 222 , iaux = 1 , nbrtri + if ( touttr ) then + jaux = iaux + else + jaux = listri(iaux) + endif + if ( decfac(jaux).eq.2 ) then + write(ulsort,90015) 'Triangle', jaux, ' a decouper' + endif + 222 continue +c + endif +c + if ( mod(option,5).eq.0 ) then +c + do 223 , iaux = 1 , nbrtri + if ( touttr ) then + jaux = iaux + else + jaux = listri(iaux) + endif + if ( decfac(jaux).eq.-1 ) then + write(ulsort,90015) 'Triangle', jaux, ' a reactiver' + endif + 223 continue +c + endif +c + endif +c +c==== +c 3. les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,99001) 'toutqu', toutqu + write(ulsort,90002) 'nbquto', nbquto + write(ulsort,90002) 'nbrq ', nbrq +#endif +c + if ( nbquto.ne.0 ) then +c + if ( toutqu ) then + nbrqua = nbquto + else + nbrqua = min(nbrq,nbquto) + endif +c + if ( mod(option,2).eq.0 ) then +c +30000 format ( + > //,'decisions sur les quadrangles',/, + > ' quadrangle! Dec ! Etat ! Niv.') +31000 format (i10,' ! ',i3,' ! ',i4,' ! ',i2) + + write (ulsort,30000) +c +cc do 31 , iaux = 1 , nbrqua +cc lisqua(iaux) = iaux +cc 31 continue +c + do 321 , iaux = 1 , nbrqua + if ( toutqu ) then + jaux = iaux + else + jaux = lisqua(iaux) + endif + write (ulsort,31000) jaux, decfac(-jaux), + > hetqua(jaux), nivqua(jaux) + 321 continue +c + endif +c + if ( mod(option,3).eq.0 ) then +c + do 322 , iaux = 1 , nbrqua + if ( toutqu ) then + jaux = iaux + else + jaux = lisqua(iaux) + endif + if ( decfac(-jaux).eq.2 ) then + write(ulsort,90015) 'Quadrangle', jaux, + > ' a decouper, de niveau', nivqua(jaux) + endif + 322 continue +c + endif +c + if ( mod(option,5).eq.0 ) then +c + do 323 , iaux = 1 , nbrqua + if ( toutqu ) then + jaux = iaux + else + jaux = lisqua(iaux) + endif + if ( decfac(-jaux).eq.-1 ) then + write(ulsort,90015) 'Quadrangle', jaux, + > ' a reactiver, de niveau', nivqua(jaux) + endif + 323 continue +c + endif +c + endif +c +c==== +c 4. Les aretes +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,99001) 'toutar', toutar + write(ulsort,90002) 'nbarto', nbarto + write(ulsort,90002) 'nbra ', nbra +#endif +c + if ( toutar ) then + nbrare = nbarto + else + nbrare = min(nbra,nbarto) + endif +c + if ( mod(option,2).eq.0 ) then +c +40000 format (//,'decisions sur les aretes',/, + > ' Arete ! Dec ! Etat ') +41000 format (i8,' ! ',i3,' ! ',i4) +c + write (ulsort,40000) +c +cc do 41 , iaux = 1 , nbrare +cc lisare(iaux) = iaux +cc 41 continue +c + do 42 , iaux = 1 , nbrare + if ( toutar ) then + jaux = iaux + else + jaux = lisare(iaux) + endif + write (ulsort,41000) jaux, decare(jaux), + > hetare(jaux) + 42 continue +c + endif +c + if ( mod(option,3).eq.0 ) then +c + do 422 , iaux = 1 , nbrare + if ( toutar ) then + jaux = iaux + else + jaux = lisare(iaux) + endif + if ( decare(jaux).eq.2 ) then + write(ulsort,90015) 'Arete', jaux, ' a decouper' + endif + 422 continue +c + endif +c + if ( mod(option,5).eq.0 ) then +c + do 423 , iaux = 1 , nbrare + if ( toutar ) then + jaux = iaux + else + jaux = lisare(iaux) + endif + if ( decare(jaux).eq.-1 ) then + write(ulsort,90015) 'Arete', jaux, ' a reactiver' + endif + 423 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/delist.F b/src/tool/Decision/delist.F new file mode 100644 index 00000000..ea0b0237 --- /dev/null +++ b/src/tool/Decision/delist.F @@ -0,0 +1,305 @@ + subroutine delist ( nomail, nmprde, avappr, + > lgopts, taopts, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - LISTe des decisions +c -- ---- +c Remarque : Les appels ont lieu seulement en mode DEBUG +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nmprde . e . ch8 . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprde" . +c . . . . 2 : impression apres l'appel a "nmprde" . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgoptc . tableau des options caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon, probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DELIST' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + character*6 nmprde +c + integer avappr +c + integer lgopts + character*8 taopts(lgopts) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer pdecfa, pdecar + integer phetar, pmerar + integer phettr, paretr, pnivtr + integer phetqu, parequ, pnivqu + integer phethe, pquahe + integer pposif, pfacar + integer adhoar, adhotr, adhoqu +c + integer codre0, codre1, codre2 +c + character*8 ntrav1, ntrav2 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Avant appel a '',a6,'' :'',/)' + texte(1,5) = '(/,''Apres appel a '',a6,'' :'',/)' + texte(1,10) = '(/,''Mauvais code pour '',a6,'' : '',i8,/)' +c + texte(2,4) = '(/,''Before calling '',a6,'':'',/)' + texte(2,5) = '(/,''After calling '',a6,'':'',/)' + texte(2,10) = '(/,''Bad code for '',a6,'': '',i8,/)' +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + iaux = 10 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, jaux , jaux , pmerar, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 22 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux , jaux, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 22 + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux , jaux, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + ntrav1 = taopts(11) + call gmadoj ( ntrav1, pdecar, iaux, codre1 ) + ntrav2 = taopts(12) + call gmadoj ( ntrav2, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. impressions vraies +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. impressions vraies ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( avappr.eq.1 .or. avappr.eq.2 ) then + write (ulsort,texte(langue,3+avappr)) nmprde + else + write (ulsort,texte(langue,10)) nmprde, avappr + endif +c + iaux = 3*5 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DELIS1', nompro +#endif + call delis1 + > ( iaux, + > imem(pdecar), imem(pdecfa), + > imem(pposif), imem(pfacar), imem(phetar), imem(pmerar), + > imem(phettr), imem(pnivtr), + > imem(phetqu), imem(pnivqu), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/deraff.F b/src/tool/Decision/deraff.F new file mode 100644 index 00000000..83999e82 --- /dev/null +++ b/src/tool/Decision/deraff.F @@ -0,0 +1,382 @@ + subroutine deraff ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - RAFFinement +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERAFF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + integer phetar, psomar, pfilar, pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer phette, ptrite + integer phethe, pquahe, pcoquh + integer phetpy, pfacpy, pcofay + integer phetpe, pfacpe, pcofap + integer pposif, pfacar + integer advotr, advoqu, adpptr, adppqu + integer pdecfa, pdecar + integer adhoar, adhotr, adhoqu + integer ptrav3 +c + character*6 saux + character*8 ntrav3 +c + logical prem +c +#ifdef _DEBUG_HOMARD_ + character*6 nompra +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + if ( prem ) then + nrosec = taetco(4) + endif + call gtdems (nrosec) +c +c 1.3. ==> les messages +c + texte(1,4) = '(/,a6,'' DECISIONS POUR LE RAFFINEMENT'')' + texte(1,5) = '(36(''=''),/)' +c + texte(2,4) = '(/,a6,'' REFINEMENT DECISIONS'')' + texte(2,5) = '(27(''=''),/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEARD0', nompro +#endif + call deard0 ( nomail, taopts(11), taopts(12), ntrav3, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, + > phethe, pquahe, pcoquh, + > phetpy, pfacpy, pcofay, + > phetpe, pfacpe, pcofap, + > pposif, pfacar, + > advotr, advoqu, adpptr, adppqu, + > pdecfa, pdecar, + > adhoar, adhotr, adhoqu, + > ptrav3, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. contamination des decisions pour le raffinement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. contamination ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST dercon', nompro + nompra = 'dercon' + iaux = 1 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCON', nompro +#endif + call dercon + > ( taopti(30), homolo, maconf, + > imem(pdecar), imem(pdecfa), + > imem(phetar), imem(pfilar), imem(pmerar), imem(adhoar), + > imem(pposif), imem(pfacar), + > imem(phettr), imem(paretr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), imem(adhotr), + > imem(advotr), imem(adpptr), + > imem(phetqu), imem(parequ), + > imem(pfilqu), imem(pperqu), imem(pnivqu), imem(adhoqu), + > imem(advoqu), imem(adppqu), + > imem(phette), imem(ptrite), + > imem(phethe), imem(pquahe), imem(pcoquh), + > imem(phetpy), imem(pfacpy), imem(pcofay), + > imem(phetpe), imem(pfacpe), imem(pcofap), + > imem(ptrav3), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST apres dercon', nompro + nompra = 'dercon' + iaux = 2 + call delist ( nomail, nompra, iaux, + > lgopts, taopts, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 4. decompte des decisions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. decompte decisions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECPTE', nompro +#endif + call decpte ( taopti(31), taopti(32), + > imem(pdecar), imem(pdecfa), + > imem(phettr), imem(phetqu), + > imem(ptrite), imem(phette), + > imem(pquahe), imem(phethe), + > imem(pfacpy), imem(phetpy), + > imem(pfacpe), imem(phetpe), + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. desallocations des tableaux de travail +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. desallocations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav3 , codret ) +c + endif +c +c==== +c 6. verification des decisions s'il existe des homologues +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. verif. homologue ; codret', codret +#endif +c +c 6.1. ==> sur les aretes +c + if ( homolo.ge.2 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVA', nompro +#endif + call dehova ( imem(adhoar), imem(pdecar), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 6.2. ==> sur les triangles +c + if ( homolo.ge.3 .and. nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 2 + call dehovf ( iaux, + > nbtrto, imem(adhotr), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 6.3. ==> sur les quadrangles +c + if ( homolo.ge.3 .and. nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOVF', nompro +#endif + iaux = 4 + call dehovf ( iaux, + > nbquto, imem(adhoqu), imem(pdecfa), + > nompro, 1, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + prem = .false. +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Decision/derco1.F b/src/tool/Decision/derco1.F new file mode 100644 index 00000000..025548dc --- /dev/null +++ b/src/tool/Decision/derco1.F @@ -0,0 +1,473 @@ + subroutine derco1 ( tyconf, + > niveau, + > decare, decfac, + > hetare, + > posifa, facare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 1 +c -- - -- - +c Application de la regle des deux voisins dans les cas : +c tyconf = 0 ; conforme +c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees +c tyconf = -1 ; conforme avec boites +c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer niveau + integer decare(0:nbarto) + integer hetare(nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer facact, laface, nbfali + integer ipos + integer iaux, ideb, ifin, ifacli + integer nbaret, nbar00, anodec(4) + integer iarelo, iarete, iface + integer etatar, etatfa + integer nbare1, liare1(4) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ + ideb = 0 + do 1105 , iaux = 1 , nbquto + if ( decfac(-iaux).eq.4 ) ideb = ideb+1 +cgn write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1105 continue + write (ulsort,90002) 'quadrangles a decision 4', ideb + ideb = 0 + do 11051 , iaux = 1 , nbarto + if ( decare(iaux).eq.2 ) ideb = ideb+1 +11051 continue + write (ulsort,90002) 'aretes a decision 2', ideb +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,38) + write (ulsort,90112) 'nivqua', iaux, nivqua(iaux) + write (ulsort,90112) 'decfac', -iaux, decfac(-iaux) + write (ulsort,90001) 'aretes du quadrangle ', iaux, + >arequa(iaux,1), arequa(iaux,2), + >arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,10) + write (ulsort,90001) 'aretes du quadrangle ', iaux, + >arequa(iaux,1), arequa(iaux,2), + >arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + iaux = min(nbquto,19) + write (ulsort,90001) 'aretes du quadrangle ', iaux, + >arequa(iaux,1), arequa(iaux,2), + >arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +c + codret = 0 +c +c initialisation vide de la liste de faces a examiner +c + nbfali = 0 +c +c initialisation du nombre d'aretes decoupees possibles +c pour un quadrangle dans le cas de l'adaptation conforme +c + if ( tyconf.ge.0 ) then + nbar00 = -2 + else + nbar00 = 2 + endif +c +c==== +c 2. Application de la regle des deux voisins +c==== +c + do 2 , laface = -nbquto , nbtrto +c +c on regarde toutes les faces actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c + if ( etatfa.eq.0 ) then +c + facact = laface +cgn write (ulsort,90001) 'face', facact +c +c debut du traitement de la face courante +c *************************************** +c +c -------- + 20 continue +c -------- +c on ne regarde que les faces "a garder" +c + if ( decfac(facact).eq.0 ) then +c +c 2.1. ==> on compte les aretes actives a garder et les aretes +c inactives a reactiver +c + if ( facact.gt.0 ) then + nbare1 = 3 + do 211 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(facact,iarelo) + 211 continue + else + nbare1 = 4 + iaux = -facact + do 212 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 212 continue + endif +c + nbaret = 0 + do 213 , iarelo = 1 , nbare1 + iarete = liare1(iarelo) + if ( decare(iarete).eq.0 ) then + etatar = mod( hetare(iarete) , 10 ) + if ( etatar.eq.0 ) then + nbaret = nbaret + 1 + anodec(nbaret) = iarete + endif + elseif ( decare(iarete).eq.-1 ) then + nbaret = nbaret + 1 + anodec(nbaret) = iarete + endif + 213 continue +c +c 2.2. ==> aucune arete n'est ni "active a garder" ni "a reactiver" +c -------------------------------------------------------- +c ==> on declare la face "a couper" +c + if ( nbaret.eq.0 ) then +c + decfac(facact) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif +c +c 2.3. ==> une seule arete est une "active a garder" ou "a reactiver" +c ---------------------------------------------------------- +c ==> on declare la face "a couper" +c . si l'arete est active, on la declare "a couper" +c . si l'arete est inactive, on la declare "a garder" +c + elseif ( nbaret.eq.1 ) then +c + decfac(facact) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' +#endif + if ( mod(hetare(anodec(1)),10).eq.0 ) then + decare(anodec(1)) = 2 + else + decare(anodec(1)) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives "a garder" +c + ideb = posifa(anodec(1)-1)+1 + ifin = posifa(anodec(1)) +c + do 23 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 231 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 232 + endif + 231 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 232 continue + endif + endif + 23 continue +c +c 2.4. ==> pour un quadrangle, deux aretes sont +c ------------------------------------ +c des "actives a garder" ou "a reactiver" si on veut des boites +c ------------------------------------------------------------- +c + elseif ( facact.lt.0 ) then +c + if ( nbaret.eq.nbar00 ) then +c +c on declare la face "a couper" +c + decfac(facact) = 4 +#ifdef _DEBUG_HOMARD_ + if ( facact.eq.0 ) then + write (ulsort,texte(langue,30))'decfac', facact,decfac(facact),' ' + endif +#endif +c + do 241 , iaux = 1 , 2 +c +c . si l'arete est active, on la declare "a couper" +c . si l'arete est inactive, on la declare "a garder" +c + if ( mod(hetare(anodec(iaux)),10).eq.0 ) then + decare(anodec(iaux)) = 2 + else + decare(anodec(iaux)) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives "a garder" +c + ideb = posifa(anodec(iaux)-1)+1 + ifin = posifa(anodec(iaux)) +c + do 242 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 243 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 244 + endif + 243 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 244 continue + endif + endif + 242 continue +c + 241 continue +c + endif +c + endif +c + endif +c +c 2.5. ==> on passe a la face suivante de la liste +c --------------------------------------- +c + if ( nbfali .gt. 0 ) then +c + facact = listfa(nbfali) + nbfali = nbfali - 1 + goto 20 +c + endif +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 11060 , iaux = 1 , nbarto + if ( iaux.eq.-17735 .or. iaux.eq.-877 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +11060 continue +#endif +#ifdef _DEBUG_HOMARD_ + ideb = 0 + do 1106 , iaux = 1 , nbquto + if ( decfac(-iaux).eq.4 ) ideb = ideb+1 +cgn write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue + write (ulsort,90002) 'quadrangle a decision 4', ideb + ideb = 0 + do 11061 , iaux = 1 , nbarto + if ( decare(iaux).eq.2 ) ideb = ideb+1 +11061 continue + write (ulsort,90002) 'arete a decision 2', ideb + if ( nbquto.lt.0 ) then + iaux = min(nbquto,12) + write (ulsort,90112) 'decfac', -iaux, decfac(-iaux) + write (ulsort,90001) 'decare pour aretes quadrangle', iaux, + >decare(arequa(iaux,1)), decare(arequa(iaux,2)), + >decare(arequa(iaux,3)), decare(arequa(iaux,4)) +cgn iaux = min(nbquto,10) +cgn write (ulsort,90001) 'decare pour aretes quadrangle', iaux, +cgn >decare(arequa(iaux,1)), decare(arequa(iaux,2)), +cgn >decare(arequa(iaux,3)), decare(arequa(iaux,4)) +cgn iaux = min(nbquto,19) +cgn write (ulsort,90001) 'decare pour aretes quadrangle', iaux, +cgn >decare(arequa(iaux,1)), decare(arequa(iaux,2)), +cgn >decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco2.F b/src/tool/Decision/derco2.F new file mode 100644 index 00000000..9bf3d233 --- /dev/null +++ b/src/tool/Decision/derco2.F @@ -0,0 +1,743 @@ + subroutine derco2 ( tyconf, niveau, + > decare, decfac, + > hetare, filare, + > hettri, aretri, filtri, nivtri, + > voltri, pypetr, + > hetqua, arequa, filqua, nivqua, + > volqua, pypequ, + > tritet, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 2 +c -- - -- - +c Application de la regle des ecarts de niveau, tout type de raffinement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hetare(nbarto), filare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer nivtri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer nivqua(nbquto) + integer volqua(2,nbquto), pypequ(2,*) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) + integer facpen(nbpecf,5), cofape(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer iarelo + integer laface, lafac2 + integer larete + integer etat + integer nbaret, listar(12), nbface, listfa(12) + integer nbvolu, listvo(2), typevo(2) + integer nbvotr, nbvoqu, nbvoto +c + integer choix +c + logical afaire +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'entree de ',nompro + do 1105 , iaux = 1 , -nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1105 continue +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,38) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,10) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,19) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c +c nombre maximum de volumes par triangle ou quadrangle +c + if ( nbteto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + nbvotr = 0 + else + nbvotr = 2 + endif +c + if ( nbheto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + nbvoqu = 0 + else + nbvoqu = 2 + endif +c +c==== +c 2. Application de la regle des ecarts de niveau aux faces +c==== +c + do 2 , laface = -nbquto , nbtrto +cgn print *,'debut boucle 2 : decfac(',laface,') :',decfac(laface) +c +c 2.1. ==> On s'interesse aux faces du niveau courant : +c . actives a garder +c ou . inactives a garder et bord de volume +c ou . inactives a reactiver +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etat = mod( hettri(laface) , 10 ) +cgn write (ulsort,texte(langue,29))'Triangle', laface, +cgn > nivtri(laface), hettri(laface), decfac(laface) + else + goto 2 + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etat = mod( hetqua(iaux) , 100 ) +cgn write (ulsort,texte(langue,29))'Quadrangle', -laface, +cgn > nivqua(-laface), hetqua(-laface), decfac(laface) + else + goto 2 + endif +c + else +c + goto 2 +c + endif +c + choix = 0 + if ( etat.eq.0 ) then + if ( decfac(laface).eq.0 ) then + choix = 1 + endif + elseif ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then + if ( decfac(laface).eq.0 .and. nbvoto.gt.0 ) then + choix = 3 + elseif ( decfac(laface).eq.-1 ) then + if ( nbvoto.eq.0 ) then + choix = 2 + else + choix = 4 + endif + endif + endif +cgn write (ulsort,*) 'Face', laface, ', choix = ', choix +c +c 2.2. ==> Liste des aretes de la face +c + if ( choix.gt.0 ) then +c + if ( laface.gt.0 ) then + nbaret = 3 + do 221 , iarelo = 1 , nbaret + listar(iarelo) = aretri(laface,iarelo) + 221 continue + else + nbaret = 4 + iaux = -laface + do 222 , iarelo = 1 , nbaret + listar(iarelo) = arequa(iaux,iarelo) + 222 continue + endif +c +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,15)) +#endif + endif +c +c 2.3. ==> Cas du raffinement a propager par voisinage +c + if ( choix.eq.1 ) then +c +c 2.3.1. ==> Decompte des aretes coupees en 2 avec une fille a couper : +c . celles d'etat > 0 +c . et avec une fille de decision > 0 +c S'il n'y en a pas, rien n'est a faire +c + afaire = .False. + do 231, iaux = 1 , nbaret + larete = listar(iaux) +cgn if ( larete.eq.1661 ) then +cgn write(ulsort,90002) '.... arete possible', larete +cgn endif + if ( mod(hetare(larete),10).gt.0 ) then + jaux = filare(larete) + if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then + afaire = .True. + goto 2310 + endif + endif + 231 continue + 2310 continue +c +c 2.3.2. ==> Propagation du raffinement sur la face et ses +c aretes actives +c + if ( afaire ) then +c + decfac(laface) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + do 232 , iaux = 1 , nbaret + larete = listar(iaux) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.1661 ) then + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' + endif +#endif + endif + endif + 232 continue +c + endif +c + endif +c +c 2.4. ==> Cas du deraffinement a inhiber par voisinage +c + if ( choix.eq.2 .or. choix.eq.4 ) then +c +c 2.4.1. ==> Existe-t-il des aretes coupees en 2 avec une fille coupee +c qui doit etre coupee ? +c + afaire = .False. + do 241, iaux = 1 , nbaret + larete = listar(iaux) +cgn write (ulsort,*) larete, decare(larete) + jaux = filare(larete) + if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then + afaire = .True. + goto 2410 + endif + 241 continue + 2410 continue +c +c 2.4.2. ==> Inhibition du raffinement sur la face et ses aretes +c + if ( afaire ) then +c + decfac(laface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + do 242 , iaux = 1 , nbaret + larete = listar(iaux) + if ( decare(larete).eq.-1 ) then + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif + endif + 242 continue +c + endif +c + endif +c +c 2.5. ==> Cas du raffinement a propager ou du deraffinement a inhiber +c par l'interieur de volumes +c + if ( choix.ge.3 ) then +c +c 2.5.1. ==> Pour chaque face, on regarde si une arete tracee sur +c la face est coupee ou va etre coupee. +c . Pour un triangle, ces aretes sont celles qui definissent +c la fille face centrale (cf. cmrdtr) +c . Pour un quadrangle, ces aretes sont la 2eme et le 3eme +c du premier et du troisieme fils (cf. cmrdqu) +c S'il n'y en a pas, rien n'est a faire +c + if ( laface.gt.0 ) then + jaux = filtri(laface) + nbaret = 3 + do 2511 , iarelo = 1 , nbaret + listar(iarelo) = aretri(jaux,iarelo) + 2511 continue + else + jaux = filqua(-laface) + nbaret = 4 + listar(1) = arequa(jaux ,2) + listar(2) = arequa(jaux ,3) + listar(3) = arequa(jaux+2,2) + listar(4) = arequa(jaux+2,3) + endif +c + afaire = .False. + do 2513 , iarelo = 1 , nbaret +cgn write (ulsort,*) 'hetare, decare(',listar(iarelo),') =', +cgn >hetare(listar(iarelo)), decare(listar(iarelo)) + if ( decare(listar(iarelo)).gt.0 .or. + > mod(hetare(listar(iarelo)),10).eq.2 ) then + afaire = .True. + goto 2510 + endif + 2513 continue + 2510 continue +cgn write (ulsort,99001) 'afaire', afaire +c +c 2.5.2. ==> La face retenue borde-t-elle un volume ? +c + nbvolu = 0 +c + if ( afaire ) then +c + if ( laface.gt.0 ) then +c + do 2521, iaux = 1 , nbvotr + jaux = voltri(iaux,laface) + if ( jaux.gt.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = jaux + typevo(nbvolu) = 3 + elseif ( jaux.lt.0 ) then + if ( pypetr(1,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypetr(1,-jaux) + typevo(nbvolu) = 5 + endif + if ( pypetr(2,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypetr(2,-jaux) + typevo(nbvolu) = 7 + endif + endif + 2521 continue +c + else +c + do 2522, iaux = 1 , nbvoqu + jaux = volqua(iaux,-laface) + if ( jaux.gt.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = jaux + typevo(nbvolu) = 6 + elseif ( jaux.lt.0 ) then + if ( pypequ(1,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypequ(1,-jaux) + typevo(nbvolu) = 5 + endif + if ( pypequ(2,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypequ(2,-jaux) + typevo(nbvolu) = 7 + endif + endif + 2522 continue +c + endif +cgn write (ulsort,*)nbvolu,'volumes', (listvo(iaux),iaux=1,nbvolu) +cgn write (ulsort,*)nbvolu,'types ', (typevo(iaux),iaux=1,nbvolu) +c + endif +c +c 2.5.3. ==> Une des aretes tracees sur laface sera coupee. Il faut que +c le ou les volumes s'appuyant sur laface soient coupes +c + if ( nbvolu.gt.0 ) then +c +c 2.5.3. ==> Recherche des faces concernees +c + nbface = 0 + do 2531 , iaux = 1 , nbvolu + jaux = listvo(iaux) +cgn write (ulsort,*)'Volume', jaux,' de type',typevo(iaux) + if ( typevo(iaux).eq.3 ) then + do 25311 , kaux = 1 , 4 + nbface = nbface + 1 + listfa(nbface) = tritet(jaux,kaux) +25311 continue + elseif ( typevo(iaux).eq.5 ) then + listfa(1) = facpyr(jaux,1) + listfa(2) = facpyr(jaux,2) + listfa(3) = facpyr(jaux,3) + listfa(4) = facpyr(jaux,4) + listfa(5) = -facpyr(jaux,5) + nbface = 5 + elseif ( typevo(iaux).eq.6 ) then + do 25313 , kaux = 1 , 6 + nbface = nbface + 1 + listfa(nbface) = -quahex(jaux,kaux) +25313 continue + elseif ( typevo(iaux).eq.7 ) then + listfa(1) = facpen(jaux,1) + listfa(2) = facpen(jaux,2) + listfa(3) = -facpen(jaux,3) + listfa(4) = -facpen(jaux,4) + listfa(5) = -facpen(jaux,5) + nbface = 5 + endif + 2531 continue +cgn write (ulsort,1000)nbface,' faces :', +cgn > (listfa(iaux),iaux=1,nbface) +cgn 1000 format(i2,a,12i5) +c + do 2532 , iaux = 1 , nbface +c + lafac2 = listfa(iaux) +cgn if ( lafac2.gt.0 ) then +cgn write (ulsort,texte(langue,29))'Triangle', lafac2, +cgn > nivtri(lafac2), hettri(lafac2), decfac(lafac2) +cgn else +cgn write (ulsort,texte(langue,29))'Quadrangle', -lafac2, +cgn > nivqua(-lafac2), hetqua(-lafac2), decfac(lafac2) +cgn endif + if ( decfac(lafac2).eq.-1 ) then + decfac(lafac2) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + elseif ( decfac(lafac2).eq.0 ) then + if ( lafac2.gt.0 ) then + if ( mod(hettri(lafac2),10).eq.0 ) then + decfac(lafac2) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + endif + else + if ( mod(hetqua(-lafac2),100).eq.0 ) then + decfac(lafac2) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + endif + endif + endif +c + if ( lafac2.gt.0 ) then + nbaret = 3 + do 2533 , iarelo = 1 , nbaret + listar(iarelo) = aretri(lafac2,iarelo) + 2533 continue + else + nbaret = 4 + do 2534 , iarelo = 1 , nbaret + listar(iarelo) = arequa(-lafac2,iarelo) + 2534 continue + endif +c + do 2535 , jaux = 1 , nbaret + larete = listar(jaux) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.1661)then + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' + endif +#endif + endif + elseif ( decare(larete).eq.-1 ) then + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif + endif + 2535 continue +c + 2532 continue +c + endif +c + endif +c + 2 continue +c +c==== +c 3. Transfert via les volumes ayant des quadrangles comme faces +c Si une fille de l'une de ses aretes est a couper, le volume +c doit l'etre entierement : on le declare par ses aretes. +c 1/12/16 : c'est trop. Le decoupage est assure par l'etape 2.3. +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. Transfert ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,38) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +c + if ( tyconf.eq.1789 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,*) 'ATTENTION' + write (ulsort,texte(langue,3)) 'DERCO9', nompro + call derco9 ( niveau, + > decare, + > hetare, filare, + > aretri, nivtri, + > arequa, nivqua, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 11060 , iaux = 1 , nbarto + if ( iaux.eq.-17735 .or. iaux.le.-877 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +11060 continue +#endif +#ifdef _DEBUG_HOMARD_ + do 1106 , iaux = 1 , nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,12) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,10) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,19) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( nbquto.gt.0 ) then + iaux = min(nbquto,38) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco3.F b/src/tool/Decision/derco3.F new file mode 100644 index 00000000..7775ad8b --- /dev/null +++ b/src/tool/Decision/derco3.F @@ -0,0 +1,362 @@ + subroutine derco3 ( niveau, + > decare, decfac, + > merare, + > posifa, facare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > tritet, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 3 +c -- - -- - +c Complement sur la regle des ecarts de niveau pour du non-conforme +c a 1 noeud pendant par arete +c Remarque : cela ne peut concerner que des niveaux au moins egal a 2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . merare . e . nbarto . mere des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer merare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer pertri(nbtrto), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer perqua(nbquto), nivqua(nbquto) + integer tritet(nbtecf,4) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, tetrae, nbtetr + integer ipos + integer iaux, ideb, ifin + integer iarelo, jarelo, ifalo, iarete, jarete, iface, itetra + integer etatfa, merear, merefa, grdmfa + integer nbare1, nbare2, liare1(4), liare2(4) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" +#endif +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c + codret = 0 +c +c nombre maximum de tetraedres par triangle +c + if ( nbteto.eq.0 ) then + nbtetr = 0 + else + nbtetr = 2 + endif +c +c==== +c 2. Complements sur la regle des ecarts de niveau +c==== +c + do 2 , laface = -nbquto , nbtrto +cgn print *,'entree de ',nompro,', ',laface,' :',decfac(laface) +c +c 2.1. ==> on s'interesse aux faces : +c . du niveau courant +c . actives +c . qui ont une mere qui ne reapparait pas +c . qui ont une grand-mere +c + grdmfa = 0 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + if ( etatfa.eq.0 ) then + merefa = pertri(laface) + if ( merefa.gt.0 ) then + if ( decfac(merefa).eq.0 ) then + grdmfa = pertri(merefa) + endif + endif + endif + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + if ( etatfa.eq.0 ) then + merefa = perqua(iaux) + if ( merefa.gt.0 ) then + if ( decfac(-merefa).eq.0 ) then + grdmfa = perqua(merefa) + endif + endif + endif + endif +c + endif +c +c 2.2. ==> on regarde les aretes de la face mere +c + if ( grdmfa.gt.0 ) then +c +c 2.2.1. ==> liste de ces aretes +c + if ( laface.gt.0 ) then +c + nbare2 = 3 + do 2211 , iarelo = 1 , nbare2 + liare2(iarelo) = aretri(merefa,iarelo) + 2211 continue +c + else +c + nbare2 = 4 + do 2212 , iarelo = 1 , nbare2 + liare2(iarelo) = arequa(merefa,iarelo) + 2212 continue +c + endif +c + nbare1 = 0 + do 2213 , iaux = 1 , nbare2 + if ( decare(liare2(iaux)).eq.0 ) then + nbare1 = nbare1 + 1 + liare1(nbare1) = liare2(iaux) + endif + 2213 continue +c +c on parcourt les aretes retenues +c + do 220 , iarelo = 1 , nbare1 +c + iarete = liare1(iarelo) +c + merear = merare(iarete) +c + if ( merear.ne.0 ) then +c +c 2.2.2. ==> l'arete iarete est sur le bord de la face grdmfa +c ------------------------------------------------ +c ==> pour toutes les faces qui s'appuient sur merear, +c mere de cette arete iarete : +c . si elles sont a reactiver, on les garde +c + ideb = posifa(merear-1)+1 + ifin = posifa(merear) +c + do 2221 , ipos = ideb , ifin +c + iface = facare(ipos) +c + if ( decfac(iface).eq.-1 ) then +c + decfac(iface) = 0 + if ( iface.gt.0 ) then + do 2222 , jarelo = 1 , 3 + jarete = aretri(iface,jarelo) + decare(jarete) = 0 + 2222 continue + else + iaux = -iface + do 2223 , jarelo = 1 , 4 + jarete = arequa(iaux,jarelo) + decare(jarete) = 0 + 2223 continue + endif +c + endif +c + 2221 continue +c + else +c +c 2.2.3. ==> l'arete iarete est interieure a la face grdmfa +c ---------------------------------------------- +c ==> pour toutes les faces des tetraedres qui +c s'appuient sur le triangle pere grdmfa : +c . si elles sont a reactiver, on les garde +c + if ( laface.gt.0 ) then +c + do 2231 , itetra = 1 , nbtetr +c +c attention : on ne traite que les volumes traditionnels +c tetra ou hexa, d'ou le codret=12 + if ( voltri(itetra,grdmfa).lt.0 ) then + codret = 12 + goto 33 + endif + tetrae = voltri(itetra,grdmfa) + if ( tetrae.ne.0 ) then +c + do 2232 , ifalo = 1 , 4 +c + iface = tritet(tetrae,ifalo) +c + if ( decfac(iface).eq.-1 ) then +c + decfac(iface) = 0 + do 2233 , jarelo = 1 , 3 + jarete = aretri(iface,jarelo) + decare(jarete) = 0 + 2233 continue +c + endif +c + 2232 continue +c + endif +c + 2231 continue +c + endif +c + endif +c + 220 continue +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 1106 , iaux = 1 , nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue + if ( nbquto.gt.0 ) then + iaux = min(nbquto,5) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + iaux = min(nbquto,8) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +c +c==== +c 3. la fin +c==== +c + 33 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco4.F b/src/tool/Decision/derco4.F new file mode 100644 index 00000000..88296d72 --- /dev/null +++ b/src/tool/Decision/derco4.F @@ -0,0 +1,473 @@ + subroutine derco4 ( tyconf, + > niveau, + > decare, decfac, + > hetare, arehom, + > posifa, facare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 4 +c -- - -- - +c Application de la regle des deux voisins : +c pilraf = 1 ou 2. libre +c pilraf = 3. non-conforme avec 1 arete decoupee unique par element +c en presence d'aretes et/ou de faces homologues : +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer niveau + integer decare(0:nbarto) + integer hetare(nbarto) + integer decfac(-nbquto:nbtrto) + integer posifa(0:nbarto), facare(nbfaar) + integer arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer facact, laface, nbfali + integer ipos + integer iaux, ideb, ifin, ifacli + integer nbaret, nbar00, anodec(4) + integer kaux + integer iarelo, iarete, iface + integer etatar, etatfa + integer nbare1, liare1(4) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c + codret = 0 +c +c initialisation vide de la liste de faces a examiner +c + nbfali = 0 +c +c initialisation du nombre d'aretes autorisees pour un quadrangle +c + if ( tyconf.eq.0 ) then + nbar00 = -2 + else + nbar00 = 2 + endif +c +c==== +c 2. Application de la regle des deux voisins +c==== +c + do 2 , laface = -nbquto , nbtrto +c +c on regarde toutes les faces actives du niveau courant +c + etatfa = -1 + if ( laface.gt.0 ) then + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + endif + elseif ( laface.lt.0 ) then + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + endif + endif +c + if ( etatfa.eq.0 ) then +c + facact = laface +c +c debut du traitement de la face courante +c *************************************** +c +c -------- + 20 continue +c -------- +c on ne regarde que les faces "a garder" +c + if ( decfac(facact).eq.0 ) then +c +c 2.1. ==> on compte les aretes actives a garder et les aretes +c inactives a reactiver +c + if ( facact.gt.0 ) then + nbare1 = 3 + do 211 , iarelo = 1 , nbare1 + liare1(iarelo) = aretri(facact,iarelo) + 211 continue + else + nbare1 = 4 + iaux = -facact + do 212 , iarelo = 1 , nbare1 + liare1(iarelo) = arequa(iaux,iarelo) + 212 continue + endif +c + nbaret = 0 + do 213 , iarelo = 1 , nbare1 + iarete = liare1(iarelo) + if ( decare(iarete).eq.0 ) then + etatar = mod( hetare(iarete) , 10 ) + if ( etatar.eq.0 ) then + nbaret = nbaret + 1 + anodec(nbaret) = iarete + endif + elseif ( decare(iarete).eq.-1 ) then + nbaret = nbaret + 1 + anodec(nbaret) = iarete + endif + 213 continue +c +c 2.2. ==> aucune arete n'est une active a garder +c ------------------------------------ +c ==> on declare la face "a couper" +c + if ( nbaret.eq.0 ) then +c + decfac(facact) = 4 +c +c 2.3. ==> une seule arete est une active a garder +c --------------------------------------- +c + elseif ( nbaret.eq.1 ) then +c +c 2.3.1. ==> on declare la face "a couper" +c . si l'arete est active, on la declare "a couper" +c . si l'arete est inactive, on la declare "a garder" +c + decfac(facact) = 4 + if ( mod(hetare(anodec(1)),10).eq.0 ) then + decare(anodec(1)) = 2 + else + decare(anodec(1)) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives "a garder" +c + ideb = posifa(anodec(1)-1)+1 + ifin = posifa(anodec(1)) +c + do 231 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 2311 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2312 + endif + 2311 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2312 continue + endif + endif + 231 continue +c +c 2.3.2. ==> on regarde si l'arete a une homologue +c + if ( arehom(anodec(1)) .ne. 0 ) then +c + kaux = abs( arehom(anodec(1)) ) +c +c . si l'arete homologue est active, on la declare "a couper" +c . si l'arete homologue est inactive, on la declare "a garder" +c + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + else + decare(kaux) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives a "garder" +c + ideb = posifa(kaux-1) + 1 + ifin = posifa(kaux) +c + do 232, ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 2321 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2322 + endif + 2321 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2322 continue + endif + endif + 232 continue +c + endif +c +c 2.4. ==> pour un quadrangle, deux aretes sont +c ------------------------------------ +c des actives a garder si on veut des boites +c ------------------------------------------ +c + elseif ( facact.lt.0 ) then +c + if ( nbaret.eq.nbar00 ) then +c +c on declare la face "a couper" +c + decfac(facact) = 4 +c + do 24 , iaux = 1 , 2 +c +c 2.4.1. ==> . si l'arete est active, on la declare "a couper" +c . si l'arete est inactive, on la declare "a garder" +c + if ( mod(hetare(anodec(iaux)),10).eq.0 ) then + decare(anodec(iaux)) = 2 + else + decare(anodec(iaux)) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives "a garder" +c + ideb = posifa(anodec(iaux)-1)+1 + ifin = posifa(anodec(iaux)) +c + do 241 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 2412 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2413 + endif + 2412 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2413 continue + endif + endif + 241 continue +c +c 2.4.2. ==> . si l'arete a une homolgue +c + if ( arehom(anodec(iaux)) .ne. 0 ) then +c + kaux = abs( arehom(anodec(iaux)) ) +c +c . si l'arete homologue est active, on la declare "a couper" +c . si l'arete homologue est inactive, on la declare "a garder" +c + if ( mod(hetare(kaux),10).eq.0 ) then + decare(kaux) = 2 + else + decare(kaux) = 0 + endif +c +c on regarde toutes les faces qui s'appuient sur cette +c arete, on memorise celles qui sont actives a "garder" +c + ideb = posifa(kaux-1) + 1 + ifin = posifa(kaux) +c + do 242, ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface).eq.0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa.eq.0 ) then + do 2421 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2422 + endif + 2421 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2422 continue + endif + endif + 242 continue +c + endif +c + 24 continue +c + endif +c + endif +c + endif +c +c 2.5. ==> on passe a la face suivante de la liste +c --------------------------------------- +c + if ( nbfali .gt. 0 ) then +c + facact = listfa(nbfali) + nbfali = nbfali - 1 + goto 20 +c + endif +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ +c==== +c 3. verification +c==== +c + if ( codret.eq.0 ) then +c + call dehova ( arehom, decare, + > nompro, 1, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco5.F b/src/tool/Decision/derco5.F new file mode 100644 index 00000000..852e0f30 --- /dev/null +++ b/src/tool/Decision/derco5.F @@ -0,0 +1,727 @@ + subroutine derco5 ( tyconf, niveau, + > decare, decfac, + > hetare, filare, arehom, + > hettri, aretri, filtri, nivtri, homtri, + > voltri, pypetr, + > hetqua, arequa, filqua, nivqua, quahom, + > volqua, pypequ, + > tritet, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 2 +c -- - -- - +c Application de la regle des ecarts de niveau, tout type de raffinement +c en presence d'aretes et/ou de faces homologues +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . homtri . e . nbtrto . ensemble des triangles homologues . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hetare(nbarto), filare(nbarto) + integer arehom(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer nivtri(nbtrto), homtri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer nivqua(nbquto), quahom(nbquto) + integer volqua(2,nbquto), pypequ(2,*) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) + integer facpen(nbpecf,5), cofape(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer iarelo + integer laface, lafac2 + integer larete + integer etat + integer nbaret, listar(12), nbface, listfa(12) +cgn integer nbareh, listah(4) + integer nbvolu, listvo(2), typevo(2) + integer nbvotr, nbvoqu, nbvoto +c + integer afaire +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'entree de ',nompro + do 1105 , iaux = 1 , -nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1105 continue + if ( nbquto.gt.0 ) then + iaux = min(nbquto,12) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,10) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,19) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c +c nombre maximum de volumes par triangle ou quadrangle +c + if ( nbteto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + nbvotr = 0 + else + nbvotr = 2 + endif +c + if ( nbheto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + nbvoqu = 0 + else + nbvoqu = 2 + endif +c +c==== +c 2. Application de la regle des ecarts de niveau aux faces +c==== +c + do 2 , laface = -nbquto , nbtrto +cgn print *,'debut boucle 2 : decfac(',laface,') :',decfac(laface) +c +c 2.1. ==> On s'interesse aux faces du niveau courant : +c . actives a garder +c ou . inactives a garder et bord de volume +c ou . inactives a reactiver +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etat = mod( hettri(laface) , 10 ) +cgn write (ulsort,texte(langue,29))'Triangle', laface, +cgn > nivtri(laface), hettri(laface), decfac(laface) + else + goto 2 + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etat = mod( hetqua(iaux) , 100 ) +cgn write (ulsort,texte(langue,29))'Quadrangle', -laface, +cgn > nivqua(-laface), hetqua(-laface), decfac(laface) + else + goto 2 + endif +c + else +c + goto 2 +c + endif +c + afaire = 0 + if ( etat.eq.0 ) then + if ( decfac(laface).eq.0 ) then + afaire = 1 + endif + elseif ( etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 ) then + if ( decfac(laface).eq.0 .and. nbvoto.gt.0 ) then + afaire = 3 + elseif ( decfac(laface).eq.-1 ) then + if ( nbvoto.eq.0 ) then + afaire = 2 + else + afaire = 4 + endif + endif + endif +cgn write (ulsort,*) 'Face', laface, ', afaire = ', afaire +c +c 2.2. ==> Liste des aretes de la face +c + if ( afaire.gt.0 ) then +c + if ( laface.gt.0 ) then + nbaret = 3 + do 221 , iarelo = 1 , nbaret + listar(iarelo) = aretri(laface,iarelo) + 221 continue + else + nbaret = 4 + iaux = -laface + do 222 , iarelo = 1 , nbaret + listar(iarelo) = arequa(iaux,iarelo) + 222 continue + endif +c +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,15)) +#endif + endif +c +c 2.3. ==> Cas du raffinement a propager par voisinage +c + if ( afaire.eq.1 ) then +c +c 2.3.1. ==> Decompte des aretes coupees en 2 avec une fille a couper : +c . celles d'etat > 0 +c . et avec une fille de decision > 0 +c S'il n'y en a pas, rien n'est a faire +c + kaux = 0 + do 231, iaux = 1 , nbaret + larete = listar(iaux) +cgn print *,'.... arete possible', larete + if ( mod(hetare(larete),10).gt.0 ) then + jaux = filare(larete) + if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then + kaux = kaux + 1 + endif + endif + 231 continue +c +c 2.3.2. ==> Propagation du raffinement sur la face et ses +c aretes actives +c + if ( kaux.gt.0 ) then +c +cgn nbareh = 0 +c + decfac(laface) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + do 232 , iaux = 1 , nbaret + larete = listar(iaux) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif +cgn if ( arehom(larete).ne.0 ) then +cgn nbareh = nbareh + 1 +cgn listah(nbareh) = abs( arehom(larete) ) +cgn endif + endif + endif + 232 continue +cgn write (ulsort,1000) nbareh,' aretes :', +cgn > (listah(iaux),iaux=1,nbareh) +cgn 1000 format(i2,a,12i5) +c + endif +c + endif +c +c 2.4. ==> Cas du deraffinement a inhiber par voisinage +c + if ( afaire.eq.2 .or. afaire.eq.4 ) then +c +c 2.4.1. ==> Decompte des aretes coupees en 2 avec une fille coupee +c qui ne reapparait pas +c S'il n'y en a pas, rien n'est a faire +c + kaux = 0 + do 241, iaux = 1 , nbaret + larete = listar(iaux) +cgn write (ulsort,*) larete, decare(larete) + jaux = filare(larete) + if ( decare(jaux).gt.0 .or. decare(jaux+1).gt.0 ) then + kaux = kaux + 1 + endif + 241 continue +c +c 2.4.2. ==> Inhibition du raffinement sur la face et ses aretes +c + if ( kaux.gt.0 ) then +c +cgn nbareh = 0 +c + decfac(laface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' ' +#endif + do 242 , iaux = 1 , nbaret + larete = listar(iaux) + if ( decare(larete).eq.-1 ) then + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif +cgn if ( arehom(larete).ne.0 ) then +cgn nbareh = nbareh + 1 +cgn listah(nbareh) = abs( arehom(larete) ) +cgn endif + endif + 242 continue +cgn write (ulsort,1000) nbareh,' aretes :', +cgn > (listah(iaux),iaux=1,nbareh) +c + endif +c + endif +c +c 2.5. ==> Cas du raffinement a propager ou du deraffinement a inhiber +c par l'interieur de volumes +c + if ( afaire.ge.3 ) then +c +c 2.5.1. ==> Pour chaque face, on regarde si une arete tracee sur +c la face va etre coupee. +c . Pour un triangle, ces aretes sont celles qui definissent +c la fille face centrale (cf. cmrdtr) +c . Pour un quadrangle, ces aretes sont la 2eme et le 3eme +c du premier et du troisieme fils (cf. cmrdqu) +c S'il n'y en a pas, rien n'est a faire +c + kaux = 0 +c + if ( laface.gt.0 ) then + jaux = filtri(laface) + nbaret = 3 + do 2511 , iarelo = 1 , nbaret + listar(iarelo) = aretri(jaux,iarelo) + 2511 continue + else + jaux = filqua(-laface) + nbaret = 4 + listar(1) = arequa(jaux ,2) + listar(2) = arequa(jaux ,3) + listar(3) = arequa(jaux+2,2) + listar(4) = arequa(jaux+2,3) + endif +c + do 2513 , iarelo = 1 , nbaret +cgn write (ulsort,*) 'hetare, decare(',listar(iarelo),') =', +cgn >hetare(listar(iarelo)), decare(listar(iarelo)) + if ( decare(listar(iarelo)).gt.0 ) then + kaux = kaux + 1 + endif + 2513 continue +cgn write (ulsort,*)' kaux', kaux +c +c 2.5.2. ==> La face retenue borde-t-elle un volume ? +c + nbvolu = 0 +c + if ( kaux.gt.0 ) then +c + if ( laface.gt.0 ) then +c + do 2521, iaux = 1 , nbvotr + jaux = voltri(iaux,laface) + if ( jaux.gt.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = jaux + typevo(nbvolu) = 3 + elseif ( jaux.lt.0 ) then + if ( pypetr(1,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypetr(1,-jaux) + typevo(nbvolu) = 5 + endif + if ( pypetr(2,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypetr(2,-jaux) + typevo(nbvolu) = 7 + endif + endif + 2521 continue +c + else +c + do 2522, iaux = 1 , nbvoqu + jaux = volqua(iaux,-laface) + if ( jaux.gt.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = jaux + typevo(nbvolu) = 6 + elseif ( jaux.lt.0 ) then + if ( pypequ(1,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypequ(1,-jaux) + typevo(nbvolu) = 5 + endif + if ( pypequ(2,-jaux).ne.0 ) then + nbvolu = nbvolu + 1 + listvo(nbvolu) = pypequ(2,-jaux) + typevo(nbvolu) = 7 + endif + endif + 2522 continue +c + endif +cgn write (ulsort,*)nbvolu,'volumes', (listvo(iaux),iaux=1,nbvolu) +cgn write (ulsort,*)nbvolu,'types ', (typevo(iaux),iaux=1,nbvolu) +c + endif +c +c 2.5.3. ==> Une des aretes tracees sur laface sera coupee. Il faut que +c le ou les volumes s'appuyant sur laface soient coupes +c + if ( nbvolu.gt.0 ) then +c +c 2.5.3. ==> Recherche des faces concernees +c + nbface = 0 + do 2531 , iaux = 1 , nbvolu + jaux = listvo(iaux) +cgn write (ulsort,*)'Volume', jaux,' de type',typevo(iaux) + if ( typevo(iaux).eq.3 ) then + do 25311 , kaux = 1 , 4 + nbface = nbface + 1 + listfa(nbface) = tritet(jaux,kaux) +25311 continue + elseif ( typevo(iaux).eq.5 ) then + listfa(1) = facpyr(jaux,1) + listfa(2) = facpyr(jaux,2) + listfa(3) = facpyr(jaux,3) + listfa(4) = facpyr(jaux,4) + listfa(5) = -facpyr(jaux,5) + nbface = 5 + elseif ( typevo(iaux).eq.6 ) then + do 25313 , kaux = 1 , 6 + nbface = nbface + 1 + listfa(nbface) = -quahex(jaux,kaux) +25313 continue + elseif ( typevo(iaux).eq.7 ) then + listfa(1) = facpen(jaux,1) + listfa(2) = facpen(jaux,2) + listfa(3) = -facpen(jaux,3) + listfa(4) = -facpen(jaux,4) + listfa(5) = -facpen(jaux,5) + nbface = 5 + endif + 2531 continue +cgn write (ulsort,1000)nbface,' faces :', +cgn > (listfa(iaux),iaux=1,nbface) +cgn 1000 format(i2,a,12i5) +c + do 2532 , iaux = 1 , nbface +c + lafac2 = listfa(iaux) +cgn if ( lafac2.gt.0 ) then +cgn write (ulsort,texte(langue,29))'Triangle', lafac2, +cgn > nivtri(lafac2), hettri(lafac2), decfac(lafac2) +cgn else +cgn write (ulsort,texte(langue,29))'Quadrangle', -lafac2, +cgn > nivqua(-lafac2), hetqua(-lafac2), decfac(lafac2) +cgn endif + if ( decfac(lafac2).eq.-1 ) then + decfac(lafac2) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + elseif ( decfac(lafac2).eq.0 ) then + if ( lafac2.gt.0 ) then + if ( mod(hettri(lafac2),10).eq.0 ) then + decfac(lafac2) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + endif + else + if ( mod(hetqua(-lafac2),100).eq.0 ) then + decfac(lafac2) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', lafac2,decfac(lafac2),' ' +#endif + endif + endif + endif +c + if ( lafac2.gt.0 ) then + nbaret = 3 + do 2533 , iarelo = 1 , nbaret + listar(iarelo) = aretri(lafac2,iarelo) + 2533 continue + else + nbaret = 4 + do 2534 , iarelo = 1 , nbaret + listar(iarelo) = arequa(-lafac2,iarelo) + 2534 continue + endif +c + do 2535 , jaux = 1 , nbaret + larete = listar(jaux) + if ( decare(larete).eq.0 ) then + if ( mod(hetare(larete),10).eq.0 ) then + decare(larete) = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif + if ( arehom(larete).ne.0 ) then + decare(abs(arehom(larete))) = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare', + > abs(arehom(larete)),decare(abs(arehom(larete))),' ' +#endif + endif + endif + elseif ( decare(larete).eq.-1 ) then + decare(larete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',larete,decare(larete),' ' +#endif + if ( arehom(larete).ne.0 ) then + decare(abs(arehom(larete))) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare', + > abs(arehom(larete)),decare(abs(arehom(larete))),' ' +#endif + endif + endif + 2535 continue +c + 2532 continue +c + endif +c + endif +c + 2 continue +c +c==== +c 3. Transfert via les volumes ayant des quadrangles comme faces +c Si une fille de l'une de ses aretes est a couper, le volume +c doit l'etre entierement : on le declare par ses aretes. +c==== +c + if ( tyconf.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO9', nompro +#endif + call derco9 ( niveau, + > decare, + > hetare, filare, + > aretri, nivtri, + > arequa, nivqua, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 1106 , iaux = 1 , nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue + if ( nbquto.gt.0 ) then + iaux = min(nbquto,12) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,10) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + iaux = min(nbquto,19) + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)), decfac(-iaux) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco6.F b/src/tool/Decision/derco6.F new file mode 100644 index 00000000..6ab75f63 --- /dev/null +++ b/src/tool/Decision/derco6.F @@ -0,0 +1,473 @@ + subroutine derco6 ( niveau, + > decare, decfac, + > merare, arehom, + > posifa, facare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > tritet, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 6 +c -- - -- - +c Complement sur la regle des ecarts de niveau pour du non-conforme +c a 1 noeud pendant par arete +c en presence d'aretes et/ou de faces homologues +c Remarque : cela ne peut concerner que des niveaux au moins egal a 2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . merare . e . nbarto . mere des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer merare(nbarto), arehom(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer pertri(nbtrto), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer perqua(nbquto), nivqua(nbquto) + integer tritet(nbtecf,4) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, tetrae, nbtetr + integer ipos, ipos1 + integer ideb, ifin, ifacli, nbfali + integer iaux, jaux, kaux, jfin + integer iarelo, jarelo, ifalo, iarete, jarete, iface, itetra + integer etatfa, merear, merefa, grdmfa + integer nbare1, nbare2, liare1(4), liare2(4), liare3(2) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c + codret = 0 +c +c nombre maximum de tetraedres par triangle +c + if ( nbteto.eq.0 ) then + nbtetr = 0 + else + nbtetr = 2 + endif +c +c initialisation vide de la liste de faces a examiner +c + nbfali = 0 +c +c==== +c 2. Complements sur la regle des ecarts de niveau +c==== +c + do 2 , laface = -nbquto , nbtrto +cgn print *,'entree de ',nompro,', ',laface,' :',decfac(laface) +c +c 2.1. ==> on s'interesse aux faces : +c . du niveau courant +c . actives +c . qui ont une mere qui ne reapparait pas +c . qui ont une grand-mere +c + grdmfa = 0 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + etatfa = mod( hettri(laface) , 10 ) + if ( etatfa.eq.0 ) then + merefa = pertri(laface) + if ( merefa.gt.0 ) then + if ( decfac(merefa).eq.0 ) then + grdmfa = pertri(merefa) + endif + endif + endif + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + etatfa = mod( hetqua(iaux) , 100 ) + if ( etatfa.eq.0 ) then + merefa = perqua(iaux) + if ( merefa.gt.0 ) then + if ( decfac(-merefa).eq.0 ) then + grdmfa = perqua(merefa) + endif + endif + endif + endif +c + endif +c +c 2.2. ==> on regarde les aretes de la face mere +c + if ( grdmfa.gt.0 ) then +c +c 2.2.1. ==> liste de ces aretes +c + if ( laface.gt.0 ) then +c + nbare2 = 3 + do 2211 , iarelo = 1 , nbare2 + liare2(iarelo) = aretri(merefa,iarelo) + 2211 continue +c + else +c + nbare2 = 4 + do 2212 , iarelo = 1 , nbare2 + liare2(iarelo) = arequa(merefa,iarelo) + 2212 continue +c + endif +c + nbare1 = 0 + do 2213 , iaux = 1 , nbare2 + if ( decare(liare2(iaux)).eq.0 ) then + nbare1 = nbare1 + 1 + liare1(nbare1) = liare2(iaux) + endif + 2213 continue +c +c on parcourt les aretes retenues +c + do 220 , iarelo = 1 , nbare1 +c + iarete = liare1(iarelo) +c + merear = merare(iarete) +c + if ( merear.ne.0 ) then +c +c 2.2.2. ==> l'arete iarete est sur le bord de la face grdmfa +c ------------------------------------------------ +c on explore les faces qui s'enroulent autour de +c l'arete merear et celles qui s'enroulent autour +c de son eventuelle homologue +c +c ==> pour toutes les faces qui s'appuient sur merear, +c mere de cette arete iarete, ou son homologue : +c . si elles sont a reactiver, on les garde +c + liare3(1) = merear + if ( arehom(merear).eq.0 ) then + jfin = 1 + else + liare3(2) = abs(arehom(merear)) + jfin = 2 + endif +c + do 2220 , jaux = 1 , jfin +c + ideb = posifa(liare3(jaux)-1)+1 + ifin = posifa(liare3(jaux)) +c + do 2221 , ipos = ideb , ifin +c + iface = facare(ipos) +c + if ( decfac(iface).eq.-1 ) then +c + decfac(iface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', iface,decfac(iface),' ' +#endif + if ( iface.gt.0 ) then + nbare2 = 3 + do 22211 , jarelo = 1 , nbare2 + liare2(jarelo) = aretri(iface,jarelo) +22211 continue + else + nbare2 = 4 + iaux = -iface + do 22212 , jarelo = 1 , nbare2 + liare2(jarelo) = arequa(iaux,jarelo) +22212 continue + endif + do 22213 , jarelo = 1 , nbare2 + jarete = liare2(jarelo) + decare(jarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',jarete,decare(jarete),' ' +#endif +c +c on regarde si l'arete a une homologue +c + if ( arehom(jarete) .ne. 0 ) then +c + kaux = abs( arehom(jarete) ) + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',kaux,decare(kaux),' ' +#endif +c +c on regarde toutes les faces qui s'appuient sur +c cette arete, on memorise celles qui sont +c actives a "garder" +c + ideb = posifa(kaux-1)+1 + ifin = posifa(kaux) +c + do 22214, ipos1 = ideb, ifin + iface = facare(ipos1) + if ( decfac(iface) .eq. 0 ) then + if ( iface.gt.0 ) then + etatfa = mod( hettri(iface) , 10 ) + else + etatfa = mod( hetqua(-iface) , 100 ) + endif + if ( etatfa .eq. 0 ) then + do 22215, ifacli = 1, nbfali + if ( listfa(ifacli).eq.iface ) then + goto 22216 + endif +22215 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface +22216 continue + endif + endif +22214 continue + endif +22213 continue +c + endif +c + 2221 continue +c + 2220 continue +c + else +c +c 2.2.3. ==> l'arete iarete est interieure a la face grdmfa +c ---------------------------------------------- +c ==> pour toutes les faces des tetraedres qui +c s'appuient sur le triangle pere grdmfa : +c . si elles sont a reactiver, on les garde +c + if ( laface.gt.0 ) then +c + do 2231 , itetra = 1 , nbtetr +c attention : on ne traite que les volumes traditionnels +c tetra ou hexa, d'ou le codret=12 +c + if ( voltri(itetra,grdmfa).lt.0 ) then + codret = 12 + goto 33 + endif + tetrae = voltri(itetra,grdmfa) + if ( tetrae.ne.0 ) then +c + do 2232 , ifalo = 1 , 4 +c + iface = tritet(tetrae,ifalo) +c + if ( decfac(iface) .eq. -1 ) then +c + decfac(iface) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))'decfac', iface,decfac(iface),' ' +#endif +c + do 2233 , jarelo = 1 , 3 + jarete = aretri(iface,jarelo) + decare(jarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',jarete,decare(jarete),' ' +#endif +c +c on regarde si l'arete a une homologue +c --------- + if ( arehom(jarete).ne.0 ) then +c + kaux = abs( arehom(jarete) ) + decare(kaux) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',kaux,decare(kaux),' ' +#endif +c +c on regarde toutes les faces qui s'appuient sur +c cette arete, on memorise celles qui sont +c actives a "garder" +c + ideb = posifa(kaux-1)+1 + ifin = posifa(kaux) +c + do 2234 , ipos = ideb , ifin + iface = facare(ipos) + if ( decfac(iface) .eq. 0 ) then + etatfa = mod(hettri(iface),10) + if ( etatfa .eq. 0 ) then + do 2235 , ifacli = 1 , nbfali + if ( listfa(ifacli).eq.iface ) then + goto 2236 + endif + 2235 continue + nbfali = nbfali + 1 + listfa(nbfali) = iface + 2236 continue + endif + endif + 2234 continue +c + endif +c + 2233 continue +c + endif +c + 2232 continue +c + endif +c + 2231 continue +c + endif +c + endif +c + 220 continue +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ +c==== +c 3. verification +c==== +c + if ( codret.eq.0 ) then +c + call dehova ( arehom, decare, + > nompro, 1, + > ulsort, langue, codret ) +c + endif +#endif +c +cgn print *,'sortie de ',nompro,', ',laface,' :',decfac(laface) +c +c==== +c 4. la fin +c==== +c + 33 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco7.F b/src/tool/Decision/derco7.F new file mode 100644 index 00000000..5aa251b3 --- /dev/null +++ b/src/tool/Decision/derco7.F @@ -0,0 +1,296 @@ + subroutine derco7 ( niveau, + > decare, decfac, + > hetare, + > hettri, aretri, nivtri, + > voltri, + > hetqua, arequa, nivqua, + > volqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 7 +c -- - -- - +c Complement sur la regle des ecarts de niveau pour du non-conforme +c a 1 noeud pendant par arete +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO7' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer volqua(2,nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface + integer etatar + integer iaux + integer iarelo, iarete + integer etatfa + integer nbaret, liaret(4) +c + logical loaret, loface +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" +#endif +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c + codret = 0 +c +c==== +c 2. Complements sur la regle des ecarts de niveau +c on s'interesse aux faces : +c . du niveau courant +c . qui sont a decouper : leurs aretes qui seraient a faire +c reapparaitre sont declarees "a garder" +c . qui sont a garder : si toutes leurs aretes sont a couper, +c on coupera la face aussi +c . qui sont bidimensionnelles +c==== +c + do 2 , laface = -nbquto , nbtrto +cgn write (ulsort,90001) 'decision face', laface,decfac(laface) +c +c 2.1. ==> examen des faces +c + loaret = .false. + loface = .false. +c + nbaret = 0 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + if ( decfac(laface).eq.0 ) then + etatfa = mod( hettri(laface) , 10 ) + if ( etatfa.eq.0 ) then + loface = .true. + endif + elseif ( decfac(laface).eq.4 ) then + loaret = .true. + endif + if ( loface ) then + if ( nbteto.gt.0 ) then + if ( voltri(1,laface).gt.0 ) then + loface = .false. + endif + endif + endif + if ( loaret .or. loface ) then + nbaret = 3 + do 211 , iarelo = 1 , nbaret + liaret(iarelo) = aretri(laface,iarelo) + 211 continue + endif + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + if ( decfac(laface).eq.0 ) then + etatfa = mod( hetqua(iaux) , 100 ) + if ( etatfa.eq.0 ) then + loface = .true. + endif + elseif ( decfac(laface).eq.4 ) then + loaret = .true. + endif + if ( loface ) then + if ( nbheto.gt.0 ) then + if ( volqua(1,iaux).gt.0 ) then + loface = .false. + endif + endif + endif + if ( loaret .or. loface ) then + nbaret = 4 + do 212 , iarelo = 1 , nbaret + liaret(iarelo) = arequa(iaux,iarelo) + 212 continue + endif + endif +c + endif +c +c 2.2. ==> les aretes sont a garder +c + if ( loaret ) then +c + do 22 , iarelo = 1 , nbaret + iarete = liaret(iarelo) + if ( decare(iarete).eq.-1 ) then + decare(iarete) = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decare',iarete,decare(iarete),' ' +#endif + endif + 22 continue +c + endif +c +c 2.3. ==> la face est eventuellement a couper +c + if ( loface ) then +c + iaux = 0 + do 23 , iarelo = 1 , nbaret + iarete = liaret(iarelo) + etatar = mod( hetare(iarete) , 10 ) + if ( decare(iarete).eq.2 .or. etatar.eq.2 ) then + iaux = iaux + 1 + endif + 23 continue +c + if ( iaux.eq.nbaret ) then + decfac(laface) = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30))' decfac',laface,decfac(laface),' ' +#endif + endif +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 1106 , iaux = 1 , nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue + if ( nbquto.gt.0 ) then + iaux = min(nbquto,5) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + iaux = min(nbquto,8) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco8.F b/src/tool/Decision/derco8.F new file mode 100644 index 00000000..571bbcbc --- /dev/null +++ b/src/tool/Decision/derco8.F @@ -0,0 +1,374 @@ + subroutine derco8 ( niveau, + > decare, decfac, + > hetare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > volqua, + > hettet, tritet, + > hethex, quahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 8 +c -- - -- - +c Complement sur la regle des ecarts de niveau pour du non-conforme +c a 1 noeud pendant par arete +c Cas ou les non-conformites sur les faces sont uniquement dans un +c rapport de 1 a 4 +c Point de depart : un volume dont au moins une des faces est coupee, +c et au moins une ne l'est pas. On a donc une non conformite entre cet +c hexaedre et son voisin. +c Situation : une des faces filles de la face coupee est a couper, peu +c importe le reste. +c Il faut s'assurer que le volume sera coupe pour eviter que le rapport +c soit > 1/4. +c Methode : on repere le voisin de la mere de la fille a couper qui +c est actif (il y en a au plus 1). On impose a ce voisin que toutes +c ses faces soient decoupees. +c Attention : il faut sauter les faces du bord exterieur car le probleme +c de non conformite ne se pose pas +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . merare . e . nbarto . mere des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO8' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer niveau + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer pertri(nbtrto), nivtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer perqua(nbquto), nivqua(nbquto) + integer volqua(2,nbquto) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer laface, lehexa, letetr + integer facdeb, facfin + integer iaux, jaux + integer afaire + integer jarelo, jarete, iface + integer merefa +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ +#include "impr03.h" +#endif +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c + codret = 0 +c + if ( nbheto.gt.0 ) then + facdeb = -nbquto + else + facdeb = 0 + endif +c + if ( nbteto.gt.0 ) then + facfin = 0 + else + facfin = nbtrto + endif +cgn write (ulsort,*) facdeb, facfin +c +c==== +c 2. Complements sur la regle des ecarts de niveau +c==== +c + do 2 , laface = facdeb , facfin +cgn print *,'entree de ',nompro,', ',laface,' :',decfac(laface) +#ifdef _DEBUG_HOMARD_ + if ( laface.eq.-215996 .or. + > laface.eq.-215996 ) then + glop=1 + else + glop=0 + endif + if ( glop.eq.1 ) then + if ( nivqua(-laface).eq.niveau ) then + write (ulsort,*) ' ====================' + write (ulsort,*) ' quadrangle : ',-laface + write (ulsort,*) ' decfac : ',decfac(laface) + write (ulsort,*) ' etat : ',hetqua(-laface) + write (ulsort,*) ' niveau : ',nivqua(-laface) + if ( nbheto.gt.0 ) then + write (ulsort,*) ' volqua(*,laface) : ', + > volqua(1,-laface),volqua(2,-laface) + if ( volqua(1,-laface).gt.0 ) then + write (ulsort,*) ' etat du voisin 1 : ', + > hethex(volqua(1,-laface)) + endif + if ( volqua(2,-laface).gt.0 ) then + write (ulsort,*) ' etat du voisin 2 : ', + > hethex(volqua(2,-laface)) + endif + write(ulsort,*) ' perqua : ',perqua(-laface) + endif + endif + endif +#endif +c +c 2.1. ==> on s'interesse aux faces : +c . du niveau courant +c . a decouper +c . qui ne sont pas au bord du domaine +c + if ( decfac(laface).eq.4 ) then +c + afaire = 0 +c + if ( laface.gt.0 ) then +c + if ( nivtri(laface).eq.niveau ) then + afaire = 1 + endif +c + elseif ( laface.lt.0 ) then +c + iaux = -laface + if ( nivqua(iaux).eq.niveau ) then + afaire = 1 + endif +c + endif +c +c 2.2. ==> on regarde le voisin non decoupe de la face mere +c attention : on ne traite que les volumes traditionnels +c tetra ou hexa, d'ou le codret=12 +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) ' afaire : ',afaire + endif +#endif + if ( afaire.gt.0 ) then +c + if ( laface.gt.0 ) then +c + merefa = pertri(laface) + if ( merefa.gt.0 ) then + if ( voltri(1,merefa).lt.0 .or. voltri(2,merefa).lt.0 ) then + codret = 12 + goto 33 + endif +c + if ( voltri(1,merefa).gt.0 .and. + > voltri(2,merefa).gt.0 ) then +c + do 2211 , iaux = 1 , 2 + letetr = voltri(iaux,merefa) + if ( mod(hettet(letetr),100).eq.0 ) then + do 2212 , jaux = 1 , 4 + iface = tritet(letetr,jaux) + if ( mod(hettri(iface),10).eq.0 .and. + > decfac(iface).ne.4 ) then + decfac(iface) = 4 + do 2213 , jarelo = 1 , 3 + jarete = aretri(iface,jarelo) + if ( mod(hetare(jarete),10).eq.0 .and. + > decare(jarete).ne.2 ) then + decare(jarete) = 2 + endif + 2213 continue + endif + 2212 continue + endif + 2211 continue +c + endif +c + endif +c + else +c + merefa = perqua(-laface) + if ( merefa.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) ' perqua : ',merefa + endif +#endif + if ( volqua(1,merefa).gt.0 .and. + > volqua(2,merefa).gt.0 ) then +c + do 2214 , iaux = 1 , 2 + lehexa = volqua(iaux,merefa) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) '..... lehexa : ',lehexa + write (ulsort,*) '..... etat : ',hethex(lehexa) + endif +#endif + if ( mod(hethex(lehexa),1000).eq.0 ) then + do 2215 , jaux = 1 , 6 + iface = quahex(lehexa,jaux) + if ( mod(hetqua(iface),100).eq.0 .and. + > decfac(-iface).ne.4 ) then + decfac(-iface) = 4 + do 2216 , jarelo = 1 , 4 + jarete = arequa(iface,jarelo) + if ( mod(hetare(jarete),10).eq.0 .and. + > decare(jarete).ne.2 ) then + decare(jarete) = 2 + endif + 2216 continue + endif + 2215 continue + endif + 2214 continue +c + endif +c + endif +c + endif +c + endif +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'sortie de ',nompro + do 1106 , iaux = 1 , nbquto + write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) +cgn write (ulsort,90001) 'quadrangle', iaux, +cgn > arequa(iaux,1), arequa(iaux,2), +cgn > arequa(iaux,3), arequa(iaux,4) + 1106 continue + if ( nbquto.gt.0 ) then + iaux = min(nbquto,5) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + iaux = min(nbquto,8) + write (ulsort,90001) 'quadrangle', iaux, + > decare(arequa(iaux,1)), decare(arequa(iaux,2)), + > decare(arequa(iaux,3)), decare(arequa(iaux,4)) + endif +#endif +c +c==== +c 3. la fin +c==== +c + 33 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/derco9.F b/src/tool/Decision/derco9.F new file mode 100644 index 00000000..11724a55 --- /dev/null +++ b/src/tool/Decision/derco9.F @@ -0,0 +1,294 @@ + subroutine derco9 ( niveau, + > decare, + > hetare, filare, + > aretri, nivtri, + > arequa, nivqua, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : COntamination - option 9 +c -- - -- - +c Application de la regle des ecarts de niveau a travers les volumes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . niveau . e . 1 . niveau en cours d'examen . +c . decare . es . nbarto . decisions des aretes . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCO9' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer niveau + integer decare(0:nbarto) + integer hetare(nbarto), filare(nbarto) + integer aretri(nbtrto,3), nivtri(nbtrto) + integer arequa(nbquto,4), nivqua(nbquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) + integer facpen(nbpecf,5), cofape(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer larete, laret0 + integer lehexa, lepent, lapyra + integer listar(12) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + +#endif +c +#include "impr03.h" +c +#include "derco1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) niveau +#endif +c +c Transfert via les volumes ayant des quadrangles comme faces +c Si une fille de l'une de ses aretes est a couper, le volume +c doit l'etre entierement : on le declare par ses aretes. +c==== +c 3. Les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. Les hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 31 , lehexa = 1 , nbheto +c + jaux = nivqua(quahex(lehexa,1)) + 1 +c + if ( jaux.eq.niveau ) then +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + do 311 , iaux = 1 , 12 +c + larete = listar(iaux) + if ( mod(hetare(larete),10).eq.2 ) then + if ( decare(filare(larete) ).eq.2 .or. + > decare(filare(larete)+1).eq.2 ) then + do 3111 , jaux = 1 , 12 + laret0 = listar(jaux) + if ( mod(hetare(laret0),10).eq.2 ) then + if ( decare(laret0).eq.-1 ) then + decare(laret0) = 0 + endif + elseif ( mod(hetare(laret0),10).eq.0 ) then + decare(laret0) = 2 + endif + 3111 continue + goto 31 + endif + endif +c + 311 continue +c + endif +c + 31 continue +c + endif +c +c==== +c 4. Les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '4. Les pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 41 , lepent = 1 , nbpeto +c + jaux = nivqua(facpen(lepent,3)) + 1 +c + if ( jaux.eq.niveau ) then +c + call utarpe ( lepent, + > nbquto, nbpecf, + > arequa, facpen, cofape, + > listar ) +c + do 411 , iaux = 1 , 9 +c + larete = listar(iaux) + if ( mod(hetare(larete),10).eq.2 ) then + if ( decare(filare(larete) ).eq.2 .or. + > decare(filare(larete)+1).eq.2 ) then + do 4111 , jaux = 1 , 12 + laret0 = listar(jaux) + if ( mod(hetare(laret0),10).eq.2 ) then + if ( decare(laret0).eq.-1 ) then + decare(laret0) = 0 + endif + elseif ( mod(hetare(laret0),10).eq.0 ) then + decare(laret0) = 2 + endif + 4111 continue + goto 41 + endif + endif +c + 411 continue +c + endif +c + 41 continue +c + endif +c +c==== +c 5. Les pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5. Les pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 51 , lapyra = 1 , nbpyto +c + jaux = nivqua(facpyr(lapyra,5)) + 1 +c + if ( jaux.eq.niveau ) then +c + call utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) + + do 511 , iaux = 1 , 8 +c + larete = listar(iaux) + if ( mod(hetare(larete),10).eq.2 ) then + if ( decare(filare(larete) ).eq.2 .or. + > decare(filare(larete)+1).eq.2 ) then + do 5111 , jaux = 1 , 12 + laret0 = listar(jaux) + if ( mod(hetare(laret0),10).eq.2 ) then + if ( decare(laret0).eq.-1 ) then + decare(laret0) = 0 + endif + elseif ( mod(hetare(laret0),10).eq.0 ) then + decare(laret0) = 2 + endif + 5111 continue + goto 51 + endif + endif +c + 511 continue +c + endif +c + 51 continue +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/dercon.F b/src/tool/Decision/dercon.F new file mode 100644 index 00000000..4cf545b6 --- /dev/null +++ b/src/tool/Decision/dercon.F @@ -0,0 +1,682 @@ + subroutine dercon ( tyconf, homolo, maconf, + > decare, decfac, + > hetare, filare, merare, arehom, + > posifa, facare, + > hettri, aretri, + > filtri, pertri, nivtri, homtri, + > voltri, pypetr, + > hetqua, arequa, + > filqua, perqua, nivqua, quahom, + > volqua, pypequ, + > hettet, tritet, + > hethex, quahex, coquhe, + > hetpyr, facpyr, cofapy, + > hetpen, facpen, cofape, + > listfa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Raffinement : CONtamination +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . homolo . e . 1 . presence d'homologue . +c . . . . 0 : non . +c . . . . 1 : il existe des noeuds homologues . +c . . . . 2 : il existe des aretes homologues . +c . . . . 3 : il existe des faces homologues . +c . maconf . e . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . decare . es . nbarto . decisions des aretes . +c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . merare . e . nbarto . mere des aretes . +c . arehom . e . nbarto . ensemble des aretes homologues . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e . nbtrto . numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . homtri . e . nbtrto . ensemble des triangles homologues . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . listfa . t . * . liste de faces a considerer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DERCON' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer tyconf, homolo, maconf + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer arehom(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer homtri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer quahom(nbquto) + integer volqua(2,nbquto), pypequ(2,*) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6), coquhe(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5), cofapy(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5) + integer listfa(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nivdeb, nivfin + integer niveau + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux, kaux +#endif +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "derco1.h" +#include "impr03.h" +c + codret = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maconf', maconf + write (ulsort,90002) 'tyconf', tyconf +#endif +c +#ifdef _DEBUG_HOMARD_ + do 1103 , iaux = 1 , nbarto + if ( iaux.eq.-17735 .or. iaux.eq.-1207 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 1103 continue +#endif +#ifdef _DEBUG_HOMARD_ + do 1104 , iaux = 1 , nbtrto + if ( iaux.eq.-830 .or. iaux.eq.-800) then + write (ulsort,90001) '.triangle', iaux, + > aretri(iaux,1), aretri(iaux,2), + > aretri(iaux,3) + write (ulsort,90002) 'niveau et decision', + > nivtri(iaux), decfac(iaux) + do 11041 ,jaux=1,3 + write (ulsort,90001) 'arete e/d', aretri(iaux,jaux), + > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux)) +11041 continue + endif + 1104 continue + do 1105 , iaux = 1 , nbquto + if ( iaux.eq.-2311 ) then +cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or. +cgn > iaux.eq.333 .or. iaux.eq.1662.or. +cgn > iaux.eq.1658 .or. iaux.eq.1666 .or. +cgn > iaux.eq.729 .or. iaux.eq.721 ) then + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'niveau et decision', + > nivqua(iaux), decfac(-iaux) + do 11051 ,jaux=1,4 + write (ulsort,90001) 'arete e/d', arequa(iaux,jaux), + > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux)) +11051 continue + endif + 1105 continue +#endif +cgn print *,'entree de',nompro,'perqua : ',perqua +c +c==== +c 2. algorithme : on regarde tous les niveaux dans l'ordre decroissant +c +c tyconf = 1 : non-conforme avec au minimum 2 aretes non decoupees +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c +c -------X------- --------------- +c . . . . +c . . . . +c . . X . +c . . . . +c . . . . +c . . . . +c --------X------ --------X------ +c +c Cela correspond au raffinement libre, sans appliquer le raffinement +c de conformite final +c +c tyconf = 2 : non-conforme avec 1 noeud pendant unique par arete +c . --------------- +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c +c . --------------- +c . . . . +c . . . . +c X . X . +c . . . . +c . . . . +c . . . . +c ------X------ --------X------ +c +c -------X------- -------X------- +c . . . . +c . . . . +c . . X . +c . . . . +c . . . . +c . . . . +c --------X------ --------X------ +c Cela correspond a ignorer la regle des deux voisins, mais a +c appliquer la regle sur les differences de niveau +c==== +c + nivdeb = nivsup + nivfin = max(nivinf-1,0) + do 20 , niveau = nivdeb , nivfin , -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) + write (ulsort,texte(langue,12)) niveau +#endif +c + iaux = niveau +c +c 2.1. ==> cas sans entites homologues, sauf eventuellement des noeuds +c + if ( homolo.le.1 ) then +c +c 2.1.1. ==> regle des ecarts de niveau +c ========================== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO2', nompro +#endif +c + call derco2 ( tyconf, iaux, + > decare, decfac, + > hetare, filare, + > hettri, aretri, filtri, nivtri, + > voltri, pypetr, + > hetqua, arequa, filqua, nivqua, + > volqua, pypequ, + > tritet, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c + endif +c +c 2.1.2. ==> regle des deux voisins +c ====================== +c elle s'applique aux cas d'adaptation : +c tyconf = 0 ; conforme +c tyconf = 1 ; non-conforme avec au minimum 2 aretes non coupees +c tyconf = -1 ; conforme avec boites +c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee +c + if ( codret.eq.0 ) then +c + if ( tyconf.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO1', nompro +#endif +c + call derco1 ( tyconf, + > iaux, + > decare, decfac, + > hetare, + > posifa, facare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + do 2123 , iaux = 1 , nbarto + if ( iaux.eq.-4739 .or. iaux.eq.-1207 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 2123 continue + do 2125 , jaux = 1 , nbquto + if ( jaux.eq.-215996 .or. jaux.eq.-66980 ) then + write (ulsort,90001) 'quadrangle', jaux, + > arequa(jaux,1), arequa(jaux,2), + > arequa(jaux,3), arequa(jaux,4) + write (ulsort,90002) 'de decision', decfac(-jaux) + endif + 2125 continue +#endif +c + endif +c + endif +c +c 2.1.3. ==> ecarts de niveau, complements non conforme, 1 noeud pendant +c =========================================================== +c + if ( tyconf.eq.2 ) then +c + if ( niveau.gt.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO3', nompro +#endif +c + call derco3 ( iaux, + > decare, decfac, + > merare, + > posifa, facare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > tritet, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + do 2135 , jaux = 1 , nbquto + if ( jaux.eq.-94774 ) then + write (ulsort,90001) 'quadrangle', jaux, + > arequa(jaux,1), arequa(jaux,2), + > arequa(jaux,3), arequa(jaux,4) + write (ulsort,90002) 'de decision', decfac(-jaux) + endif + 2135 continue +#endif +c + endif +c + endif +c +c======================================================================= + if ( nbteto.gt.0 .or. nbheto.gt.0 .or. nbpeto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +c ATTENTION : c'est une verrue pour imposer un rapport 1/4 sur +c les recollements de non conformite +c a filtrer quand on aura ameliore le pilotage +c du non conforme +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO8', nompro +#endif +c + call derco8 ( iaux, + > decare, decfac, + > hetare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > volqua, + > hettet, tritet, + > hethex, quahex, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + do 21351 , jaux = 1 , nbquto + if ( jaux.eq.-94774 ) then + write (ulsort,90001) 'quadrangle', jaux, + > arequa(jaux,1), arequa(jaux,2), + > arequa(jaux,3), arequa(jaux,4) + write (ulsort,90002) 'de decision', decfac(-jaux) + endif +21351 continue +#endif +c + endif +c + endif +c======================================================================= +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO7', nompro +#endif +c + call derco7 ( iaux, + > decare, decfac, + > hetare, + > hettri, aretri, nivtri, + > voltri, + > hetqua, arequa, nivqua, + > volqua, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + do 21353 , iaux = 1 , nbarto + if ( iaux.eq.-4739 .or. iaux.eq.-1207 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif +21353 continue + do 21352 , jaux = 1 , nbquto + if ( jaux.eq.-94774 ) then + write (ulsort,90001) 'quadrangle', jaux, + > arequa(jaux,1), arequa(jaux,2), + > arequa(jaux,3), arequa(jaux,4) + write (ulsort,90002) 'de decision', decfac(-jaux) + endif +21352 continue +#endif + endif +c + endif +c +c 2.2. ==> cas avec homologues +c + else +c +c 2.2.1. ==> regle des ecarts de niveau +c ========================== +c + if ( codret.eq.0 ) then +c +c if ( niveau.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO5', nompro +#endif +c + call derco5 ( tyconf, iaux, + > decare, decfac, + > hetare, filare, arehom, + > hettri, aretri, filtri, nivtri, homtri, + > voltri, pypetr, + > hetqua, arequa, filqua, nivqua, quahom, + > volqua, pypequ, + > tritet, + > quahex, coquhe, + > facpyr, cofapy, + > facpen, cofape, + > ulsort, langue, codret ) +c +c endif +c + endif +c +c 2.2.2. ==> regle des deux voisins +c ====================== +c elle s'applique aux cas de raffinement : +c tyconf = 0 ; libre +c tyconf = 1 ; non-conforme avec au miximum 2 aretes non coupees +c tyconf = -1 ; libre avec boites +c tyconf = -2 ; non-conforme avec au maximum 1 arete coupee +c + if ( codret.eq.0 ) then +c + if ( tyconf.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO4', nompro +#endif +c + call derco4 ( tyconf, + > iaux, + > decare, decfac, + > hetare, arehom, + > posifa, facare, + > hettri, aretri, nivtri, + > hetqua, arequa, nivqua, + > listfa, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.3. ==> ecarts de niveau, complements non conforme, 1 noeud pendant +c =========================================================== +c + if ( tyconf.eq.2 ) then +c + if ( niveau.gt.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO6', nompro +#endif +c + call derco6 ( iaux, + > decare, decfac, + > merare, arehom, + > posifa, facare, + > hettri, aretri, pertri, nivtri, + > voltri, + > hetqua, arequa, perqua, nivqua, + > tritet, + > listfa, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERCO7', nompro +#endif +c + call derco7 ( iaux, + > decare, decfac, + > hetare, + > hettri, aretri, nivtri, + > voltri, + > hetqua, arequa, nivqua, + > volqua, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +cgn print *,'fin 20, n = ',niveau,', ',decfac(5), decfac(8) +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + do 2103 , iaux = 1 , nbarto + if ( iaux.eq.-17735 .or. iaux.eq.-1207 ) then + write (ulsort,90001) '.. arete e/d', iaux, + > hetare(iaux), decare(iaux) + endif + 2103 continue + do 2104 , iaux = 1 , nbtrto + if ( iaux.eq.-830 .or. iaux.eq.-833 .or. iaux.eq.-800) then + write (ulsort,90001) '.triangle', iaux, + > aretri(iaux,1), aretri(iaux,2), + > aretri(iaux,3) + write (ulsort,90002) '.. niveau et decision', + > nivtri(iaux), decfac(iaux) + do 21041 ,jaux=1,3 + write (ulsort,90001) '.. arete e/d', aretri(iaux,jaux), + > hetare(aretri(iaux,jaux)), decare(aretri(iaux,jaux)) +21041 continue + endif + 2104 continue + do 2105 , iaux = 1 , nbquto + if ( iaux.eq.-2311 ) then +cgn if ( iaux.eq.1160 .or. iaux.eq.1411 .or. +cgn > iaux.eq.333 .or. iaux.eq.1662 .or. +cgn > iaux.eq.1658 .or. iaux.eq.1666 .or. +cgn > iaux.eq.729 .or. iaux.eq.721 ) then + write (ulsort,90001) 'quadrangle', iaux, + > arequa(iaux,1), arequa(iaux,2), + > arequa(iaux,3), arequa(iaux,4) + write (ulsort,90002) 'de decision', decfac(-iaux) + do 21051 ,jaux=1,4 + write (ulsort,90001) 'arete e/d', arequa(iaux,jaux), + > hetare(arequa(iaux,jaux)), decare(arequa(iaux,jaux)) +21051 continue + endif + 2105 continue +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Decision/desmaj.F b/src/tool/Decision/desmaj.F new file mode 100644 index 00000000..2915f337 --- /dev/null +++ b/src/tool/Decision/desmaj.F @@ -0,0 +1,474 @@ + subroutine desmaj ( nhnoeu, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > afaire, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c traitement des DEcisions - Suppression - Mise A Jour +c -- - - - - +c ______________________________________________________________________ +c +c but : mises a jour des communs apres suppression des entites de mise +c en conformite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhtetr . e . char8 . nom de l'objet decrivant les hexaedres . +c . nhhexa . e . char8 . nom de l'objet decrivant les tetraedres . +c . nhpyra . e . char8 . nom de l'objet decrivant les pyramides . +c . nhpent . e . char8 . nom de l'objet decrivant les pentaedres . +c . afaire . s . logic . vrai, si la numerotation des noeuds doit . +c . . . . etre revue . +c . . . . faux, si un raccourcissement suffit . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DESMAJ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nhnoeu, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + logical afaire +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Nombre de '',a,'' : '',i10)' + texte(1,5) = '(5x,''Nombre de '',a,'' actifs : '',i10)' +c + texte(2,4) = '(5x,''Number of '',a,'' : '',i10)' + texte(2,5) = '(5x,''Number of active '',a,'' : '',i10)' +c +#include "impr03.h" +c +c==== +c 2. mise a jour des nombres d'entites du maillage +c==== +c remarques : +c - lorsqu'on supprime des entites provisoires, leur mere reapparait. +c - les nombres de paires d'homologues ne seront mis a jour qu'apres +c raffinement du maillage. il faut veiller a ne pas utiliser les +c tables ho1noe ... avant cela. +c +c 2.1. commun "nombno" --> noeuds +c remarque : voir utplco pour la coherence des chiffres +c Les noeuds a supprimer sont ceux qui sont : +c - au centre des quadrangles coupes selon 2 aretes adjacentes. +c - au centre des hexaedres coupes selon 2 ou 3 aretes. +c - au centre des pentaedres coupes selon 2 aretes de triangles +c ou 1 face triangulaire. +c . En degre 1 : +c Par construction, ces noeuds sont numerotes en dernier. Il suffit +c donc de raccourcir les tableaux des noeuds du nombre de +c quadrangles, d'hexaedres ou de pentaedres concernes. +c . En degre 2, les aretes de mise en conformite disparaissant, les +c noeuds P2 qu'elles portent doivent disparaitre. Par creation, ils +c sont numerotes en dernier. +c De plus, si on a supprime un noeud central, ce noeud a ete cree +c avant les nouveaux noeuds P2, Il faut donc remanier la +c numerotation des noeuds. +c +c nbnois = non modifie +c nbnoei = non modifie +c nbpnho = mis a jour dans cmhomo/uthonh - non utilise avant +c nbnoma = non modifie +c nbnop1 = non modifie +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'mailet', mailet + write (ulsort,90002) 'nbnoin', nbnoin + write (ulsort,*) ' ' + write (ulsort,90002) 'nbart2', nbart2 + write (ulsort,90002) 'nbarq2', nbarq2 + write (ulsort,90002) 'nbarq3', nbarq3 + write (ulsort,90002) 'nbarq5', nbarq5 + write (ulsort,90002) 'nbarin', nbarin + write (ulsort,*) ' ' + write (ulsort,90002) 'nbtrt2', nbtrt2 + write (ulsort,90002) 'nbtrq3', nbtrq3 + write (ulsort,*) ' ' + write (ulsort,90002) 'nbquq2', nbquq2 + write (ulsort,90002) 'nbquq5', nbquq5 + write (ulsort,*) ' ' + write (ulsort,90002) 'nbteh2', nbteh2 + write (ulsort,90002) 'nbteh3', nbteh3 + write (ulsort,90002) 'nbtedh', nbtedh + write (ulsort,90002) 'nbtep3', nbtep3 + write (ulsort,90002) 'nbtep5', nbtep5 + write (ulsort,90002) 'nbtedp', nbtedp + write (ulsort,90002) 'debut de '//nompro//' nbnoto', nbnoto + write (ulsort,90002) 'debut de '//nompro//' nbnop2', nbnop2 + write (ulsort,90002) 'debut de '//nompro//' nbnoim', nbnoim +#endif + afaire = .false. + iaux = nbquq5/3 + > + nbnoin +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nombre de noeuds P1 a supprimer', iaux +#endif + nbnoto = nbnoto - iaux + if ( degre.eq.2 ) then + iaux = nbart2 + > + nbarq2 + nbarq3 + nbarq5 + > + nbarin +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nombre de noeuds P2 a supprimer', iaux +#endif + nbnoto = nbnoto - iaux + nbnop2 = nbnop2 - iaux + if ( nbquq5.ne.0 .or. nbnoin.ne.0 ) then + afaire = .true. + endif + endif +c + if ( mod(mailet,2).eq.0 ) then +c + nbnoto = nbnoto - nbtrt2 + nbnoim = nbnoim - nbtrt2 +c + endif +c + if ( mod(mailet,3).eq.0 ) then +c + nbnoto = nbnoto - nbtrq3 + nbnoim = nbnoim - nbtrq3 +c + endif +c + if ( mod(mailet,5).eq.0 ) then +c + codret = 31 +c + endif +c + nbnoin = 0 +c +cgn write (ulsort,90002) '==> nouveau nbnoto', nbnoto +cgn write (ulsort,90002) '==> nouveau nbnop2', nbnop2 +cgn write (ulsort,90002) '==> nouveau nbnoim', nbnoim +cgn write (ulsort,99001) '==> afaire', afaire + +c 2.2. commun "nombar" --> aretes +c +cgn write(*,*) nbart2, nbarq3, nbarin + iaux = nbart2 + > + nbarq2 + nbarq3 + nbarq5 + nbarin +cgn write (ulsort,90002) 'nombre d''aretes a supprimer', iaux + nbarac = nbarac - iaux +c nbarde = non modifie + nbart2 = 0 + nbarq2 = 0 + nbarq3 = 0 + nbarq5 = 0 + nbarin = 0 +c nbarma = non modifie +c nbarpe = non modifie + nbarto = nbarpe +c nbfaar = modifie plus tard par utfaa1 +c nbpaho = mis a jour dans cmhomo/uthonh - non utilise avant +c +c 2.3. commun "nombqu" --> quadrangles +c remarque : a faire avant les triangles, sinon les nombres +c sont faux +c . un triplet de triangles issus d'un decoupage en 3 d'un +c quadrangle reactive 1 quadrangle et 0 triangle : nombre de +c triangles actifs = -3, nombre de quadrangles actifs = +1 +c . un doublet de quadrangles issus d'un decoupage en 2 d'un +c quadrangle reactive 1 quadrangle et en detruit 2 = -1 +c . un triplet de quadrangles issus d'un decoupage en 3 d'un +c quadrangle reactive 1 quadrangle et en detruit 3 = -2/3 +c + iaux = nbtrq3/3 - nbquq2 - 2*nbquq5/3 +cgn write (ulsort,90002) 'bilan sur les quadrangles', iaux + nbquac = nbquac + iaux +c nbqude = non modifie + nbquq2 = 0 + nbquq5 = 0 +c nbquma = non modifie +c nbqupe = non modifie + nbquto = nbqupe +c nbpqho = mis a jour dans cmhomo/uthonh - non utilise avant +c +c 2.4. commun "nombtr" --> triangles +c . une paire de triangles issus d'un decoupage en 2 d'un triangle +c reactive 1 triangle : nombre de triangles actifs = -2 +1 +c . un triplet de triangles issus d'un decoupage en 3 d'un +c quadrangle reactive 1 quadrangle et 0 triangle : nombre de +c triangles actifs = -3, nombre de quadrangles actifs = +1 +c . un ensemble de triangles issus d'un decoupage interne a un +c volume ne reactive aucun triangle : nombre de triangles +c actifs = -n +c + iaux = nbtrt2/2 + nbtrq3 + nbtrhc + nbtrpc + nbtrtc +cgn write (ulsort,90002) 'nombre de triangles a supprimer', iaux + nbtrac = nbtrac - iaux +c nbtrde = non modifie + nbtrt2 = 0 + nbtrq3 = 0 + nbtrhc = 0 + nbtrpc = 0 + nbtrtc = 0 +c nbtrma = non modifie +c nbtrpe = non modifie + nbtrto = nbtrpe +c nbptho = mis a jour dans cmhomo/uthonh - non utilise avant +c +c 2.5. commun "nombhe" --> hexaedres +c . chaque suppression de conformite des hexaedres supprime tous +c les hexaedres concernes et reactive les peres +c + iaux = nbhedh - nbheco +c + nbheac = nbheac - iaux + nbheco = 0 + nbhedh = 0 +c nbhede = non modifie +c nbhema = non modifie +c nbhepe = non modifie + nbheto = nbhepe + nbhecf = nbheto + nbheca = 0 +c +c 2.6. commun "nombte" --> tetraedres +c . une paire de tetraedres issus d'un decoupage en 2 d'un tetraedre +c reactive 1 tetraedre : nombre de tetraedres actifs = -2 +1 +c . un quadruplet de tetraedres issus d'un decoupage en 4 d'un +c tetraedre reactive 1 tetraedre : nombre de tetraedres +c actifs = -4 +1 +c . chaque suppression de conformite des hexaedres supprime tous +c les tetraedres concernes +c . chaque suppression de conformite des pentaedres supprime tous +c les tetraedres concernes +c + iaux = nbtea2/2 + 3*(nbtea4 + nbtef4)/4 + > + nbteh1 + nbteh2 + nbteh3 + nbteh4 + > + nbtep0 + nbtep1 + nbtep2 + nbtep3 + nbtep4 + nbtep5 + > + nbtedh + nbtedp +cgn write (ulsort,90002) 'nombre de tetraedres a supprimer', iaux + nbteac = nbteac - iaux + nbtea2 = 0 + nbtea4 = 0 + nbtef4 = 0 + nbteh1 = 0 + nbteh2 = 0 + nbteh3 = 0 + nbteh4 = 0 + nbtep0 = 0 + nbtep1 = 0 + nbtep2 = 0 + nbtep3 = 0 + nbtep4 = 0 + nbtep5 = 0 + nbtedh = 0 + nbtedp = 0 +c nbtede = non modifie +c nbtema = non modifie +c nbtepe = non modifie + nbteto = nbtepe + nbtecf = nbteto + nbteca = 0 +c +c 2.7. commun "nombpy" --> pyramides +c . chaque suppression de conformite des hexaedres supprime toutes +c les pyramides concernees +c . chaque suppression de conformite des pentaedres supprime toutes +c les pyramides concernees +c Autrement dit, nbpyto = nbpyac = 0 en sortie +c + iaux = nbpyh1 + nbpyh2 + nbpyh3 + nbpyh4 + > + nbpyp0 + nbpyp1 + nbpyp2 + nbpyp3 + nbpyp4 + nbpyp5 + > + nbpydh + nbpydp +cgn write (ulsort,90002) 'nombre de pyramides a supprimer', iaux + nbpyac = nbpyac - iaux + nbpyh1 = 0 + nbpyh2 = 0 + nbpyh3 = 0 + nbpyh4 = 0 + nbpyp0 = 0 + nbpyp1 = 0 + nbpyp2 = 0 + nbpyp3 = 0 + nbpyp4 = 0 + nbpyp5 = 0 + nbpydh = 0 + nbpydp = 0 +c nbpyma = non modifie +c nbpype = non modifie + nbpyto = nbpype + nbpycf = nbpyto + nbpyca = 0 +c +c 2.8. commun "nombpe" --> pentaedres +c + iaux = nbpedp - nbpeco +c + nbpeac = nbpeac - iaux + nbpeco = 0 + nbpedp = 0 +c nbpede = non modifie +c nbpema = non modifie +c nbpepe = non modifie + nbpeto = nbpepe + nbpecf = nbpeto + nbpeca = 0 +c +c==== +c 3. impressions +c==== +c + write(ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto + write(ulsort,texte(langue,5)) mess14(langue,3,1), nbarac + if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,2), nbtrac + endif + if ( nbquto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,4), nbquac + endif + if ( nbteto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,3), nbteac + endif + if ( nbheto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,6), nbheac + endif + if ( nbpeto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,7), nbpeac + endif + if ( nbpyto.ne.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,5), nbpyac + endif + write(ulsort,*) ' ' +c +c==== +c 4. stockage dans l'objet maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. stockage ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhnoeu, 1, nbnoto, codre1 ) + call gmecat ( nharet, 1, nbarto, codre2 ) + call gmecat ( nhtria, 1, nbtrto, codre3 ) + call gmecat ( nhquad, 1, nbquto, codre4 ) + call gmecat ( nhtetr, 1, nbteto, codre5 ) + call gmecat ( nhhexa, 1, nbheto, codre6 ) + call gmecat ( nhpyra, 1, nbpyto, codre7 ) + call gmecat ( nhpent, 1, nbpeto, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmecat ( nhtetr, 2, nbteca, codre1 ) + call gmecat ( nhhexa, 2, nbheca, codre2 ) + call gmecat ( nhpyra, 2, nbpyca, codre3 ) + call gmecat ( nhpent, 2, nbpeca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Dependance_Machine/CMakeLists.txt b/src/tool/Dependance_Machine/CMakeLists.txt new file mode 100644 index 00000000..b72f43ef --- /dev/null +++ b/src/tool/Dependance_Machine/CMakeLists.txt @@ -0,0 +1,66 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Dependance_Machine + +SET(Dependance_Machine_SOURCES + ./dmabor.F + ./dmalme.F + ./dmcpch.F + ./dmflsh.F + ./dmftmp.F + ./dmindf.F + ./dmjohe.F + ./dmlibe.F + ./dmloci.F + ./dmlocr.F + ./dmlocs.F + ./dmmach.F + ./dmnfcv.F + ./dmoubs.F + ./dmoufs.F + ./dmprma.F + ./dmralo.F + ./dmsepf.F + ./dmsize.F + ./dmtemp.F + ./dmunit.F + ./dmvaen.F + ./dmze10.F + ./dmzero.F + ./dmaboc.c + ./dmalmc.c + ./dmdate.c + ./dmflsc.c + ./dmlibc.c + ./dmloca.c + ./dmmacc.c + ./dmprmc.c + ./dmralc.c + ./dmsepc.c + ./dmsizc.c + ./dmtemc.c + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Dependance_Machine ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Dependance_Machine ${Dependance_Machine_SOURCES}) + +INSTALL(TARGETS Dependance_Machine EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Dependance_Machine/FC.h b/src/tool/Dependance_Machine/FC.h new file mode 120000 index 00000000..2132c5ae --- /dev/null +++ b/src/tool/Dependance_Machine/FC.h @@ -0,0 +1 @@ +../FC.h \ No newline at end of file diff --git a/src/tool/Dependance_Machine/dmaboc.c b/src/tool/Dependance_Machine/dmaboc.c new file mode 100644 index 00000000..7afa4665 --- /dev/null +++ b/src/tool/Dependance_Machine/dmaboc.c @@ -0,0 +1,51 @@ +/* __________________________________________________________________________ *. +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmaboc_(INTGR *codret) +#else +#ifdef extern_stdcall +extern void __stdcall DMABOC(INTGR *codret) +#else +void FortranCInterface_GLOBAL(dmaboc, DMABOC)(INTGR *codret) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX + *codret = 0 ; + abort() ; + +#else + *codret = 1 ; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +} + diff --git a/src/tool/Dependance_Machine/dmabor.F b/src/tool/Dependance_Machine/dmabor.F new file mode 100644 index 00000000..b2c6bdd6 --- /dev/null +++ b/src/tool/Dependance_Machine/dmabor.F @@ -0,0 +1,56 @@ + subroutine dmabor +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : ABORt +c - - ---- +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c + integer codret +c +c==== +c 1. vidage des buffers +c==== +c + call dmflsh ( codret ) +c +c==== +c 2. appel de la fonction C equivalente +c==== +c + call dmaboc ( codret ) +c + stop +c + end diff --git a/src/tool/Dependance_Machine/dmalmc.c b/src/tool/Dependance_Machine/dmalmc.c new file mode 100644 index 00000000..7c04f42a --- /dev/null +++ b/src/tool/Dependance_Machine/dmalmc.c @@ -0,0 +1,79 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 2014 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +// long est en général de la taille des adresses gérées par le processeur (taille des pointeurs). +// machines 64bits => long=64bits +// machines 32bits => long=32bits + +// 1) ad_mem est un pointeur (32/64 bits fonction de la machine) sur une variable fortran +// dont la taille doit être celle des pointeurs de la machine (car cette variable stocke un pointeur C) +// Le type long (C) est correct pour stocker les pointeurs sur machines 32/64 bits. Cependant il faut faire attention à ce que la taille de la variable fortran corresponde aux caractéristiques de la machine. +// En effet, sur machine 32bits certains fortrans sont capables de gérer des integer*8 en 64bits ce qui ne correspondrait pas à la taille d'un long sur machine 32 bits. (cf détection configuration autoconf med) +// 2) size est le nombre d'éléments de type INTGR (entiers 32/64 bits) que l'on veut allouer. +// size pourrait être de type int (C) / integer*4 (F) mais en général si l'on a besoin d'entier 64bits pour stoker des grandeurs on a aussi besoin de dénombrer un grand nombre d'éléments. +// C'est la raison pour laquelle on a le type INTGR (C) <=> INTEGER*4 ou INTEGER*8 <=> INTEGER avec option gfortran -fdefault-integer-8 (F) + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include +#include +#include + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmalmc_( long * const ad_mem, const INTGR * const size ) +#else +#ifdef extern_stdcall +extern void __stdcall DMALMC( long * const ad_mem, const INTGR * const size ) +#else +void FortranCInterface_GLOBAL(dmalmc, DMALMC)(long * const ad_mem, const INTGR * const size) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + + if ( *size == 0 ) + { printf(" demande d allocation d une taille nulle\n") ; } + + if ( *size >= 0 ) + { +#ifdef _DEBUG_HOMARD_ + printf ("demande de %d octets\n",*size*sizeof(int)); +#endif + + // p_intgr est un pointeur sur des entiers de taille sizeof(INTGR) + INTGR * p_intgr = malloc( *size * sizeof(INTGR) ) ; + // On renvoie la valeur de notre pointeur alloué dans la variable Fortran *ad_mem + (*ad_mem) = (long) p_intgr; + +#ifdef _DEBUG_HOMARD_ + printf ("==> ad_mem = %d\n",*ad_mem); +#endif + } + + else + { + printf(" demande d allocation d une taille negative\n") ; + *ad_mem = 0 ; + } + +} + diff --git a/src/tool/Dependance_Machine/dmalme.F b/src/tool/Dependance_Machine/dmalme.F new file mode 100644 index 00000000..06f3fb22 --- /dev/null +++ b/src/tool/Dependance_Machine/dmalme.F @@ -0,0 +1,65 @@ + subroutine dmalme ( adress, taille, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : ALlocation de MEmoire +c - - -- -- +c ______________________________________________________________________ +c +c but : alloue une place memoire de taille donnee +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . adress . s . 1 . adresse de depart de la zone allouee . +c . taille . e . 1 . taille voulue . +c . codret . s . 1 . code retour : 0 si tout va bien, 1 sinon . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer adress, taille, codret +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. appel de la fonction C equivalente +c==== +c + call dmalmc ( adress, taille ) +c + if ( adress.eq.0 ) then + codret = 1 + else + codret = 0 + endif +c + end diff --git a/src/tool/Dependance_Machine/dmcpch.F b/src/tool/Dependance_Machine/dmcpch.F new file mode 100644 index 00000000..70fb3d84 --- /dev/null +++ b/src/tool/Dependance_Machine/dmcpch.F @@ -0,0 +1,159 @@ + subroutine dmcpch ( chain1, long1, chain2, long2 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : CoPie de CHaine de caracteres +c - - - - -- +c ______________________________________________________________________ +c +c +c but : copie "prudente" de la chaine 1 dans la chaine 2 +c +c . les eventuels caracteres non imprimables sont remplaces . +c par des blancs ... sauf ceux en debut et fin de chaine, . +c qui sont elimines. . +c +c dependance machine : code ASCII +c ( blanc = 32, et +c non imprimable <==> code < 32 ... +c ... sauf que les TAB (code 9) sont remplaces +c par un blanc chacun ) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chain1 . e . char * . chaine "source" . +c . long1 . e . 1 . longueur utile de la chaine "source" . +c . chain2 . s . char * . chaine "cible" . +c . long2 . s . 1 . longueur utile de la chaine "cible" . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer long1, long2 + character*(*) chain1, chain2 +c +c 0.4. ==> variables locales +c + integer long, iaux, deb, fin, dern0, deb1, p0 +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. +c==== +c + long = 0 + deb = 0 + deb1 = 0 + dern0 = 0 + p0 = -1 +c + do 1 iaux = 1, min( len(chain1), long1 ) + if ( ichar(chain1(iaux:iaux)).gt.32 ) then + if ( deb.eq.0 ) then + deb = iaux + endif + fin = iaux + p0 = 0 + if ( long.lt.len(chain2) ) then + if ( deb1.eq.0 ) then + deb1 = iaux + endif + long = long + 1 + chain2(long:long) = chain1(iaux:iaux) + endif + else if ( ichar(chain1(iaux:iaux)).eq.32 .or. + > ichar(chain1(iaux:iaux)).eq.9 ) then + if ( deb.eq.0 ) then + deb = iaux + endif + if ( long.lt.len(chain2) ) then + long = long + 1 + chain2(long:long) = ' ' + endif + else +c +c non imprimables: +c + if ( deb.gt.0 .and. long.lt.len(chain2) ) then + long = long + 1 + chain2(long:long) = ' ' + endif + dern0 = iaux + if ( p0.eq.0 ) then + p0 = iaux + endif + endif + 1 continue +c +c On complete eventuellement avec des blancs : +c (mais qui ne seront pas comptes dans long2) +c + do 10 iaux = long+1, len(chain2) + chain2(iaux:iaux) = ' ' + 10 continue +c +c Bilan : +c + if ( deb1.gt.0 ) then +c +c Il y a au moins un caractere imprimable et non blanc, qui a pu +c etre copie de la chaine source chain1 vers la cible chain2 : +c (deb1 est le premier de ceux-ci dans chain1) +c + if ( dern0.lt.fin ) then + long2 = long + else +c +c Apres le dernier caractere imprimable et non blanc de chain1 (fin), +c on a trouve : des blancs eventuels, puis un premier caractere non +c imprimable (p0), puis eventuellement des blancs ou non impr. +c puis enfin un dernier caractere non impr. (dern0, >= p0), +c puis des blancs eventuels. +c +c deb pointe sur le premier caractere "utile" (blanc ou imprimable) +c de chaine1 (deb<=deb1<=fin) +c p0-1 serait le dernier caractere "utile" de chaine1 (fin<=p0-1) +c + long2 = min( max(0,len(chain2)) , p0-deb ) +c + endif +c + else +c +c chaine "source" vide, ou entierement blanche(+caracteres non impr.) : +c + long2 = 0 +c + endif +c + end diff --git a/src/tool/Dependance_Machine/dmdate.c b/src/tool/Dependance_Machine/dmdate.c new file mode 100644 index 00000000..7f691bda --- /dev/null +++ b/src/tool/Dependance_Machine/dmdate.c @@ -0,0 +1,54 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include +#include + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmdate_( char *ladate, LNSTRF bidon ) +#else +#ifdef extern_stdcall +extern void __stdcall DMDATE( char *ladate, LNSTRF bidon ) +#else +void FortranCInterface_GLOBAL(dmdate, DMDATE)(char *ladate, LNSTRF bidon) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +/* time renvoie le nombre de secondes écoulées depuis le 1er janvier 1970 à 0h */ +/* ctime convertit ce nombre en une chaine de 26 caractères */ +/* sous la forme 'day mon dd hh:mm:ss yyyy\n\0' */ +/* 123456789012345678901234 5 6 */ +/* ex : 'Thu Jul 19 9:42:23 1994' */ +/* On renvoie alors les 24 premiers caractères utiles. */ +{ + + char *c ; + time_t t ; + + t = time( (time_t *)0 ) ; + c = ctime(&t) ; + strncpy(ladate, c, (size_t)24 ) ; + +} + diff --git a/src/tool/Dependance_Machine/dmflsc.c b/src/tool/Dependance_Machine/dmflsc.c new file mode 100644 index 00000000..08e310b7 --- /dev/null +++ b/src/tool/Dependance_Machine/dmflsc.c @@ -0,0 +1,58 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Ce programme vide les buffers des entrees-sorties */ +/* . avec stdout comme argument, seul le buffer de la sortie standard (print fortran) est vide. */ +/* . avec 0 comme argument, les buffers de toutes les sorties sont vides. */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmflsc_(INTGR *codret) +#else +#ifdef extern_stdcall +extern void __stdcall DMFLSC(INTGR *codret) +#else +void FortranCInterface_GLOBAL(dmflsc, DMFLSC)(INTGR *codret) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ +/* fflush(stdout) ; */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX + *codret = fflush(0) ; + +#else + _flushall() ; + *codret = 0 ; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +} + diff --git a/src/tool/Dependance_Machine/dmflsh.F b/src/tool/Dependance_Machine/dmflsh.F new file mode 100644 index 00000000..f5377785 --- /dev/null +++ b/src/tool/Dependance_Machine/dmflsh.F @@ -0,0 +1,55 @@ + subroutine dmflsh ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : FLuSH des buffers +c - - ---- +c ______________________________________________________________________ +c +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c 0.5. ==> initialisations +c +c=== +c 1. appel de la fonction C equivalente +c=== +c + call dmflsc ( codret ) +c + end diff --git a/src/tool/Dependance_Machine/dmftmp.F b/src/tool/Dependance_Machine/dmftmp.F new file mode 100644 index 00000000..9c7ee326 --- /dev/null +++ b/src/tool/Dependance_Machine/dmftmp.F @@ -0,0 +1,138 @@ + subroutine dmftmp ( nomdep , lnomde , nomfic , lnomfi ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine - Fichier TeMPoraire +c - - - - -- +c ______________________________________________________________________ +c +c on determine un nom de fichier dont on est sur qu'il n'existe pas. +c Ce fichier doit se trouver dans le meme repertoire qu'un fichier +c de depart pour pouvoir faire du renommage par la suite. +c +c "renomme" un fichier (trouve un nouveau nom, nomfic, a partir +c du nom de depart nomdep) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomdep . e . ch . ancien nom du fichier . +c . lnomde . e . e . longueur de l'ancien nom du fichier . +c . nomfic . s . ch . nouveau nom du fichier . +c . lnomfi . s . e . . longueur du nouveau nom du fichier . +c . ulsort . e . 1 . unite logique de la liste standard . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nomdep, nomfic +c + integer lnomde, lnomfi +c +c 0.4. ==> variables locales +c + integer iaux, jaux, lnomd +c + character*4 fmt +c + logical old +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. on concatene une chaine de caracteres jusqu'a trouver un fichier +c qui n'existe pas. +c==== +c + lnomd = min( max(0,lnomde), max(0,len(nomdep)) ) + do 1 iaux = 1, len(nomfic) + nomfic(iaux:iaux) = ' ' + 1 continue +c + if ( lnomd.lt.len(nomfic) ) then + if ( lnomd.gt.0 ) then + nomfic(1:lnomd) = nomdep( 1 : lnomd ) + endif + jaux = lnomd + 1 + else + lnomfi = 0 + goto 12 + endif +c + do 11 , iaux = 1 , 999999 +c + if ( iaux.le.9 ) then + fmt = '(I1)' + lnomfi = lnomd + 1 + elseif ( iaux.le.99 ) then + fmt = '(I2)' + lnomfi = lnomd + 2 + elseif ( iaux.le.999 ) then + fmt = '(I3)' + lnomfi = lnomd + 3 + elseif ( iaux.le.9999 ) then + fmt = '(I4)' + lnomfi = lnomd + 4 + elseif ( iaux.le.99999 ) then + fmt = '(I5)' + lnomfi = lnomd + 5 + else + fmt = '(I6)' + lnomfi = lnomd + 6 + endif +c + if ( lnomfi.le.len(nomfic) ) then +c + write ( nomfic(jaux:lnomfi) , fmt ) iaux +c + inquire (file=nomfic(1:lnomfi),exist=old) +c + if ( .not.old ) then + goto 12 + endif +c + else + lnomfi = 0 + goto 12 + endif +c + 11 continue +c + lnomfi = 0 +c + 12 continue +c + end diff --git a/src/tool/Dependance_Machine/dmindf.F b/src/tool/Dependance_Machine/dmindf.F new file mode 100644 index 00000000..d7238e4c --- /dev/null +++ b/src/tool/Dependance_Machine/dmindf.F @@ -0,0 +1,66 @@ + subroutine dmindf ( iindef, rindef, sindef ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : valeurs INDeFinies +c - - --- - +c ______________________________________________________________________ +c +c affecte les valeurs indefinies +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . iindef . s . 1 . valeur indefinie entiere . +c . rindef . s . 1 . valeur indefinie double precision reelle . +c . sindef . s . c8 . valeur indefinie caractere . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer iindef +c + double precision rindef +c + character*8 sindef +c +c 0.4. ==> variables locales +c +c==== +c 1. On met une tres grande valeur, reconnaissble +c==== +c + iindef = 17891792 +c + rindef = 1848.1871d12 +c + sindef = 'INDEFINI' +c + end diff --git a/src/tool/Dependance_Machine/dminfc.h b/src/tool/Dependance_Machine/dminfc.h new file mode 100644 index 00000000..5c3b13a0 --- /dev/null +++ b/src/tool/Dependance_Machine/dminfc.h @@ -0,0 +1,23 @@ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Commentaires sur les dépendances aux machines */ +/* 1. Les programmes C ne sont appelés que par les programmes */ +/* fortran du répertoire Dependance_Machine */ +/* 2. Les programmes en dm...c sont appelés par dm.... */ +/* 3. Les dépendances des source_c pour les arguments : */ +/* _POSIX, extern_stdcall, autres */ +/* 4. Les autres dépendances des source_c sont : */ +/* . Le programme d'abort (dmaboc) */ +/* _POSIX, autres */ +/* . Le vidage des buffers (dmflsc) */ +/* _POSIX, autres */ +/* . Le vidage des buffers (dmflsc) */ +/* _POSIX, autres */ +/* . Les caractéristiques des machines (dmmacc) */ +/* _POSIX, autres */ +/* . La précision des machines (dmprmc) */ +/* _USE_64_BITS, autres */ +/* . Le caractère de séparation des répertoires (dmsepc) */ +/* _POSIX, autres */ +/* . Le temps système (dmtemc) */ +/* CLK_TCK, _POSIX */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ diff --git a/src/tool/Dependance_Machine/dmjohe.F b/src/tool/Dependance_Machine/dmjohe.F new file mode 100644 index 00000000..3979da6e --- /dev/null +++ b/src/tool/Dependance_Machine/dmjohe.F @@ -0,0 +1,270 @@ + subroutine dmjohe ( numann, nummoi, numjou, numjos, + > numheu, nummin, numsec ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : JOur et HEure +c - - -- -- +c ______________________________________________________________________ +c +c +c retourne la date et l'heure +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numann . s . 1 . numero de l'annee . +c . nummoi . s . 1 . numero du mois . +c . numjou . s . 1 . numero du jour (1-->31) . +c . numjos . s . 1 . numero du jour symbolique (0-->7) . +c . . . . 0 : rien n'est fourni par la machine . +c . . . . 1-->7 : numero du jour dans la semaine . +c . numheu . s . 1 . numero de l'heure . +c . nummin . s . 1 . numero des minutes . +c . numsec . s . 1 . numero des secondes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'DMJOHE' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numann, nummoi, numjou, numjos + integer numheu, nummin, numsec +c +c 0.4. ==> variables locales +c + integer iaux +c + character*24 tampon + character*8 chjour, heurus + character*4 nomann + character*3 tabday (7) + character*3 tabmon (12) + character*3 nomjou, nommoi +c +c==== +c 1. les constantes +c==== +c 1.1. ==> nom des jours +c + tabday (1) = 'Mon' + tabday (2) = 'Tue' + tabday (3) = 'Wed' + tabday (4) = 'Thu' + tabday (5) = 'Fri' + tabday (6) = 'Sat' + tabday (7) = 'Sun' +c +c 1.2. ==> nom des mois +c + tabmon (1) = 'Jan' + tabmon (2) = 'Feb' + tabmon (3) = 'Mar' + tabmon (4) = 'Apr' + tabmon (5) = 'May' + tabmon (6) = 'Jun' + tabmon (7) = 'Jul' + tabmon (8) = 'Aug' + tabmon (9) = 'Sep' + tabmon (10) = 'Oct' + tabmon (11) = 'Nov' + tabmon (12) = 'Dec' +c +c==== +c 2. determination de la date et de l'heure de passage du calcul +c==== +c + chjour = '07/19/94' + heurus = '09:42:23' + tampon = 'Thu Jul 19 9:42:23 1994' + nomann = '1994' +c +c sur machine UNIX ou WINDOWS de base +c 1234567890123456789012345678 +c 'day mon dd hh:mm:ss yyyy' +c ex : 'Thu Jul 19 9:42:23 1994' +c==== +c +c 2.1. ==> appel a la fonction machine +c + call dmdate ( tampon ) +c +c 2.2. ==> archivage sous forme standard +c + nomann = tampon(21:24) + nommoi = tampon(5:7) + nomjou = tampon(1:3) + chjour(4:5) = tampon(9:10) +c + heurus = tampon(12:19) +c +c==== +c 3. decodage commun a toutes les machines +c==== +c + if ( index('0123456789',nomann(3:3)).gt.0 .and. + > index('0123456789',nomann(4:4)).gt.0 ) then +c + read ( nomann(3:4) , fmt='(i2)' ) numann +c + if (nomann(1:2).eq.'19') then + numann = numann + 1900 + else + numann = numann + 2000 + endif + else + numann = 1970 + endif +c + if ( chjour(4:4).eq.' ' ) then + chjour(4:4) = '0' + endif + if ( index('0123',chjour(4:4)).gt.0 .and. + > index('0123456789',chjour(5:5)).gt.0 ) then +c + read ( chjour(4:5) , fmt='(i2)' ) numjou +c + if ( numjou.le.0 .or. numjou.gt.31 ) then + numjou = 1 + endif + else if ( chjour(5:5).eq.' ' .and. + > index('123456789',chjour(4:4)).gt.0 ) then +c + read ( chjour(4:4) , fmt='(i1)' ) numjou +c + else + numjou = 1 + endif +c +c apres la date, on s'occupe maintenant de l'heure : +c + if ( heurus(1:1).eq.' ' ) then + heurus(1:1) = '0' + endif + if ( index('012',heurus(1:1)).gt.0 .and. + > index('0123456789',heurus(2:2)).gt.0 ) then +c + read ( heurus(1:2),fmt='(i2)' ) numheu +c + if (numheu.gt.23) then + numheu = 0 + endif +c + else if ( heurus(2:2).eq.' ' .and. + > index('0123456789',heurus(1:1)).gt.0 ) then +c + read ( heurus(1:1),fmt='(i1)' ) numheu +c + else +c + numheu = 0 +c + endif +c + if ( index(' 012345',heurus(4:4)).gt.0 .and. + > index('0123456789',heurus(5:5)).gt.0 ) then +c + read ( heurus(4:5),fmt='(i2)' ) nummin +c + if (nummin.gt.59) then + nummin = 0 + endif +c + else if ( heurus(5:5).eq.' ' .and. + > index('0123456789',heurus(4:4)).gt.0 ) then +c + read ( heurus(4:4),fmt='(i1)' ) nummin +c + else +c + nummin = 0 +c + endif +c + if ( index(' 012345',heurus(7:7)).gt.0 .and. + > index('0123456789',heurus(8:8)).gt.0 ) then +c + read ( heurus(7:8),fmt='(i2)' ) numsec +c + if (numsec.gt.59) then + numsec = 0 + endif +c + else if ( heurus(8:8).eq.' ' .and. + > index('0123456789',heurus(7:7)).gt.0 ) then +c + read ( heurus(7:7),fmt='(i1)' ) numsec +c + else +c + numsec = 0 +c + endif +c +c==== +c 4. decodages specifiques +c . nummoi = numero du mois +c . numjos = numero du jour dans la semaine +c==== +c + nummoi = 0 + do 41 , iaux = 1 , 12 + if ( nommoi .eq. tabmon(iaux) ) then + nummoi = iaux + endif + 41 continue +c + numjos = 0 + do 42 , iaux = 1 , 7 + if ( nomjou .eq. tabday(iaux) ) then + numjos = iaux + endif + 42 continue +c + if (numjou.gt.28 .and. nummoi.gt.1) then + if (nummoi.eq.2 .and. mod(numann,4).ne.0) then + nummoi = 0 + else if (nummoi.eq.2 .and. mod(numann,4).eq.0) then + if (numjou.gt.29) then + nummoi = 0 + endif + else if (nummoi.eq.4 .or. nummoi.eq.6) then + if (numjou.gt.30) then + nummoi = 0 + endif + else if (nummoi.eq.9 .or. nummoi.eq.11) then + if (numjou.gt.30) then + nummoi = 0 + endif + endif + endif +c + end diff --git a/src/tool/Dependance_Machine/dmlibc.c b/src/tool/Dependance_Machine/dmlibc.c new file mode 100644 index 00000000..ad713ff7 --- /dev/null +++ b/src/tool/Dependance_Machine/dmlibc.c @@ -0,0 +1,45 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include +#include + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Libération de la mémoire associée à malloc */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmlibc_( long **iad_mem ) +#else +#ifdef extern_stdcall +extern void __stdcall DMLIBC( long **iad_mem ) +#else +void FortranCInterface_GLOBAL(dmlibc, DMLIBC)(long **iad_mem) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + free( *iad_mem ) ; +} + diff --git a/src/tool/Dependance_Machine/dmlibe.F b/src/tool/Dependance_Machine/dmlibe.F new file mode 100644 index 00000000..f381c4d1 --- /dev/null +++ b/src/tool/Dependance_Machine/dmlibe.F @@ -0,0 +1,60 @@ + subroutine dmlibe ( iad, err ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : LIBEration de place memoire +c - - ---- +c ______________________________________________________________________ +c +c +c but : libere une place memoire demarrant a iad +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . iad . e . 1 . adresse de depart de la zone allouee . +c . err . s . 1 . code d'erreur . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer iad,err +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. appel de la fonction C equivalente +c==== +c + call dmlibc ( iad ) + err = 0 +c + end diff --git a/src/tool/Dependance_Machine/dmloca.c b/src/tool/Dependance_Machine/dmloca.c new file mode 100644 index 00000000..c3fb2a39 --- /dev/null +++ b/src/tool/Dependance_Machine/dmloca.c @@ -0,0 +1,39 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmloca_( void *a, INTGR *iad ) +#else +#ifdef extern_stdcall +extern void __stdcall DMLOCA( void *a, INTGR *iad ) +#else +void FortranCInterface_GLOBAL(dmloca, DMLOCA)(void *a, INTGR *iad) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + *iad = (long) a ; +} + diff --git a/src/tool/Dependance_Machine/dmloci.F b/src/tool/Dependance_Machine/dmloci.F new file mode 100644 index 00000000..c9b45fd0 --- /dev/null +++ b/src/tool/Dependance_Machine/dmloci.F @@ -0,0 +1,63 @@ + subroutine dmloci (var,iad) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : LOCalisation en memoire - entIer +c - - --- - +c ______________________________________________________________________ +c +c Ce programme retourne l'adresse en machine ou est la variable var. +c Il utilise la fonction machine loc qui est une extension par +c rapport au fortran 77 ansi. +c Si cette extension n'est pas disponible, on reactivera la +c fonction C dmloca qui joue sur la facon de passer les arguments : +c par adresse / par valeur. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . iad . s . 1 . adresse de depart de la zone allouee . +c . var . e . 1 . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer var, iad +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. appel du programme ad-hoc +c==== +c + iad = loc(var) +c + end diff --git a/src/tool/Dependance_Machine/dmlocr.F b/src/tool/Dependance_Machine/dmlocr.F new file mode 100644 index 00000000..fa3882a8 --- /dev/null +++ b/src/tool/Dependance_Machine/dmlocr.F @@ -0,0 +1,64 @@ + subroutine dmlocr (var,iad) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : LOCalisation en memoire - Reel +c - - --- - +c ______________________________________________________________________ +c +c Ce programme retourne l'adresse en machine ou est la variable var. +c Il utilise la fonction machine loc qui est une extension par +c rapport au fortran 77 ansi. +c Si cette extension n'est pas disponible, on reactivera la +c fonction C dmloca qui joue sur la facon de passer les arguments : +c par adresse / par valeur. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . iad . s . 1 . adresse de depart de la zone allouee . +c . var . e . 1 . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision var + integer iad +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. appel du programme ad-hoc +c==== +c + iad = loc(var) +c + end diff --git a/src/tool/Dependance_Machine/dmlocs.F b/src/tool/Dependance_Machine/dmlocs.F new file mode 100644 index 00000000..ccb870a2 --- /dev/null +++ b/src/tool/Dependance_Machine/dmlocs.F @@ -0,0 +1,64 @@ + subroutine dmlocs (var,iad) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : LOCalisation en memoire - String +c - - --- - +c ______________________________________________________________________ +c +c Ce programme retourne l'adresse en machine ou est la variable var. +c Il utilise la fonction machine loc qui est une extension par +c rapport au fortran 77 ansi. +c Si cette extension n'est pas disponible, on reactivera la +c fonction C dmloca qui joue sur la facon de passer les arguments : +c par adresse / par valeur. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . iad . s . 1 . adresse de depart de la zone allouee . +c . var . e . 1 . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*8 var + integer iad +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c==== +c 1. appel du programme ad-hoc +c==== +c + iad = loc(var) +c + end diff --git a/src/tool/Dependance_Machine/dmmacc.c b/src/tool/Dependance_Machine/dmmacc.c new file mode 100644 index 00000000..edc103ae --- /dev/null +++ b/src/tool/Dependance_Machine/dmmacc.c @@ -0,0 +1,142 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Retourne le nom de la machine, son système, etc. */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +#include /* Pour le nom de la machine d'execution */ +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +#include + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ + +#ifdef _POSIX +void dmmacc_( char *nodeno, INTGR *nodelg, char *machno, INTGR *machlg, char *systno, INTGR *systlg, char *releno, INTGR *relelg, char *versno, INTGR *verslg, LNSTRF nodebi, LNSTRF machbi, LNSTRF systbi, LNSTRF relebi, LNSTRF versbi ) +#else +#ifdef extern_stdcall +extern void __stdcall DMMACC( char *nodeno, LNSTRF nodebi, INTGR *nodelg, char *machno, LNSTRF machbi, INTGR *machlg, char *systno, LNSTRF systbi, INTGR *systlg, char *releno, LNSTRF relebi, INTGR *relelg, char *versno, LNSTRF versbi, INTGR *verslg ) +#else +void FortranCInterface_GLOBAL(dmmacc, DMMACC)(char *nodeno, INTGR *nodelg, char *machno, INTGR *machlg, char *systno, INTGR *systlg, char *releno, INTGR *relelg, char *versno, INTGR *verslg) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + int lg ; + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX + + struct utsname myname ; + + lg = fflush(0) ; + + if ( uname ( &myname ) != -1 ) { + + lg = (int)strlen(myname.nodename) ; + if ( *nodelg > lg ) *nodelg = lg ; + strncpy (nodeno,myname.nodename, (size_t)*nodelg ) ; + + lg = (int)strlen(myname.machine) ; + if ( *machlg > lg ) *machlg = lg ; + strncpy (machno,myname.machine, (size_t)*machlg ) ; + + lg = (int)strlen(myname.sysname) ; + if ( *systlg > lg ) *systlg = lg ; + strncpy (systno,myname.sysname, (size_t)*systlg ) ; + + lg = (int)strlen(myname.release) ; + if ( *relelg > lg ) *relelg = lg ; + strncpy (releno,myname.release, (size_t)*relelg ) ; + + lg = (int)strlen(myname.version) ; + if ( *verslg > lg ) *verslg = lg ; + strncpy (versno,myname.version, (size_t)*verslg ) ; + + } + + else { + + if ( *nodelg > 7 ) *nodelg = 7 ; + strncpy (nodeno,"inconnu", (size_t)*nodelg ) ; + if ( *machlg > 1 ) *machlg = 1 ; + strncpy (machno," ", (size_t)*machlg ) ; + if ( *systlg > 4 ) *systlg = 4 ; + strncpy (systno,"Unix", (size_t)*systlg ) ; + if ( *relelg > 1 ) *relelg = 1 ; + strncpy (releno," ", (size_t)*relelg ) ; + if ( *verslg > 1 ) *verslg = 1 ; + strncpy (versno," ", (size_t)*verslg ) ; + } + +#else + + + char *nodename, *machine, *sysname, *release, *version; + + nodename=getenv("COMPUTERNAME"); + if ( nodename == NULL ) { + nodename="inconnu"; + } + lg = (int)strlen(nodename) ; + if ( *nodelg > lg ) *nodelg = lg ; + strncpy (nodeno,nodename, (size_t)*nodelg ) ; + + machine=getenv ("CPU"); + if ( machine == NULL ) { + machine="inconnu"; + } + lg = (int)strlen(machine) ; + if ( *machlg > lg ) *machlg = lg ; + strncpy (machno,machine, (size_t)*machlg ) ; + + sysname=getenv ("OS"); + if ( sysname == NULL ) { + sysname="inconnu"; + } + lg = (int)strlen(sysname) ; + if ( *systlg > lg ) *systlg = lg ; + strncpy (systno,sysname, (size_t)*systlg ) ; + + release="inconnu"; + lg = (int)strlen(release) ; + if ( *relelg > lg ) *relelg = lg ; + strncpy (releno,release, (size_t)*relelg ) ; + + version="inconnu"; + lg = (int)strlen(version) ; + if ( *verslg > lg ) *verslg = lg ; + strncpy (versno,version, (size_t)*verslg ) ; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + + +} + diff --git a/src/tool/Dependance_Machine/dmmach.F b/src/tool/Dependance_Machine/dmmach.F new file mode 100644 index 00000000..7ae51bb4 --- /dev/null +++ b/src/tool/Dependance_Machine/dmmach.F @@ -0,0 +1,204 @@ + subroutine dmmach ( nomare, nomais, typmac, + > noarch, systre, systve, + > lgcar ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : caracteristiques de la MACHine +c - - ---- +c ______________________________________________________________________ +c +c retourne le type de machine sur laquelle a lieu le calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomare . s . char* . nom reseau de la machine . +c . nomais . s . char* . nom de la machine isolee . +c . typmac . s . char* . type de la machine . +c . noarch . s . char* . nom de l'architecture systeme . +c . systre . s . char* . release du systeme . +c . systve . s . char* . version du systeme . +c . lgcar . s . 6 . longueurs de chacune des chaines de caract.. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + integer nbcar + parameter ( nbcar = 6 ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nomare + character*(*) nomais + character*(*) typmac + character*(*) noarch + character*(*) systre + character*(*) systve +c + integer lgcar(nbcar) +c +c 0.4. ==> variables locales +#ifdef _DEBUG_HOMARD_ + integer enstul, sostul +#endif +c + integer iaux, jaux + integer luname(nbcar) + integer lgcloc(nbcar) + character*255 uname(nbcar) +c +c 0.5. ==> initialisations +c +c=== +c 1. nom et numero de la machine +c=== +c +c 1.1. ==> on suppose que l'on ignore tout +c + lgcloc(1) = len(nomare) + lgcloc(2) = len(nomais) + lgcloc(3) = len(typmac) + lgcloc(4) = len(noarch) + lgcloc(5) = len(systre) + lgcloc(6) = len(systve) +c + nomare = ' ' + nomais = ' ' + typmac = ' ' + noarch = ' ' + systre = ' ' + systve = ' ' +c + do 11 , iaux = 1 , nbcar + lgcar(iaux) = 1 + 11 continue +c +c 1.2. ==> preparation de l'appel a dmmacc : on met la chaine a blanc +c jaux est la taille (nombre de caracteres) de chaque element +c du tableau uname. 256 semblerait etre une bonne valeur, +c preconisee sous unix, ... +c mais ftnchek rale au dela de 255 (portabilite). +c + jaux = len (uname(1)) +c + do 121 , iaux = 1, jaux + uname(1)(iaux:iaux) = ' ' + 121 continue + luname(1) = jaux +c + do 122 , iaux = 2, nbcar + uname(iaux) = uname(1) + luname(iaux) = luname(1) + 122 continue +c +c 1.3. ==> appel de la fonction C equivalente +c argument 1 = nomare +c argument 2 = typmac +c argument 3 = noarch +c argument 4 = systre +c argument 5 = systve +c + call dmmacc ( uname(1), luname(1), uname(2), luname(2), + > uname(3), luname(3), uname(4), luname(4), + > uname(5), luname(5) ) +c +c==== +c 2. transfert dans les bonnes variables +c==== +c 2.1. ==> nettoyage eventuel (caracteres non impr.) +c + do 21 , iaux = 1, nbcar + call dmcpch ( uname(iaux), luname(iaux), + > uname(iaux), luname(iaux) ) + 21 continue +c +c 2.2. ==> transfert +c 2.2.1. ==> argument 1 = nomare +c + if ( luname(1).gt.0 ) then + iaux = min(luname(1),lgcloc(1)) + nomare(1:iaux) = uname(1)(1:iaux) + lgcar(1) = iaux + endif + if ( luname(1).gt.0 ) then + do 22 , iaux = 1 , lgcar(1) + if ( nomare(iaux:iaux).eq.'.' ) then + lgcar(2) = iaux-1 + goto 221 + endif + nomais(iaux:iaux) = nomare(iaux:iaux) + 22 continue + lgcar(2) = lgcar(1) + 221 continue + endif +c +c 2.2.2. ==> argument 2 = typmac +c + if ( luname(2).gt.0 ) then + iaux = min(luname(2),lgcloc(2)) + typmac(1:iaux) = uname(2)(1:iaux) + lgcar(3) = iaux + endif +c +c 2.2.3. ==> argument 2 = noarch +c + if ( luname(3).gt.0 ) then + iaux = min(luname(3),lgcloc(3)) + noarch(1:iaux) = uname(3)(1:iaux) + lgcar(4) = iaux + endif +c +c 2.2.4. ==> argument 4 = systre +c + if ( luname(4).gt.0 ) then + iaux = min(luname(4),lgcloc(4)) + systre(1:iaux) = uname(4)(1:iaux) + lgcar(5) = iaux + endif +c +c 2.2.5. ==> argument 5 = systve +c + if ( luname(5).gt.0 ) then + iaux = min(luname(5),lgcloc(5)) + systve(1:iaux) = uname(5)(1:iaux) + lgcar(6) = iaux + endif +c +#ifdef _DEBUG_HOMARD_ + call dmunit ( enstul, sostul ) + write(sostul,*) 'Dans dmmach :' + write(sostul,*) 'nom reseau = ', nomare + write(sostul,*) 'nom isole = ', nomais + write(sostul,*) 'typmac = ', typmac + write(sostul,*) 'architecture = ', noarch + write(sostul,*) 'release = ', systre + write(sostul,*) 'version = ', systve +#endif +c + end diff --git a/src/tool/Dependance_Machine/dmnfcv.F b/src/tool/Dependance_Machine/dmnfcv.F new file mode 100644 index 00000000..848751a1 --- /dev/null +++ b/src/tool/Dependance_Machine/dmnfcv.F @@ -0,0 +1,89 @@ + subroutine dmnfcv ( nfichi, lfichi ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : Nom de Fichier ConVerti +c - - - - - - +c ______________________________________________________________________ +c +c REMARQUE : en fait on ne fait RIEN +c il faudrait traiter le probleme en C pour Windows +c +c but : convertit un nom de fichier UNIX en un nom de fichier +c acceptable par le systeme d'exploitation utilise. +c autrement dit, sous WINDOWS, change les / en \ , et . +c ailleurs (sous UNIX, en particulier), ne fait RIEN . +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfichi . es . char * . nom de fichier . +c . lfichi . e . 1 . longueur de ce nom . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi + character*(*) nfichi +c +c 0.4. ==> variables locales +c + integer iaux +c + character*1 slash +c + character*1 slashu + parameter ( slashu = '/' ) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Recherche du caractere de separation pour la machine courante +c==== +c + call dmsepf ( slash ) +c +c==== +c 2. Substitution le cas echeant +c==== +c + if ( slash.ne.slashu ) then +c + do 21 , iaux = 1 , lfichi + if ( nfichi(iaux:iaux).eq.slashu ) then + nfichi(iaux:iaux) = slash + endif + 21 continue +c + endif +c + end diff --git a/src/tool/Dependance_Machine/dmoubs.F b/src/tool/Dependance_Machine/dmoubs.F new file mode 100644 index 00000000..08fd50c6 --- /dev/null +++ b/src/tool/Dependance_Machine/dmoubs.F @@ -0,0 +1,80 @@ + subroutine dmoubs ( nuroul , nomfic, lnomfi, + > ulmess, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine - OUverture en Binaire Sequentiel +c - - -- - - +c ______________________________________________________________________ +c +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . e . 1 . numero de l'unite logique attribuee . +c . nomfic . e . ch<200 . nom du fichier a ouvrir . +c . lnomfi . e . 1 . longueur du nom du fichier a ouvrir . +c . ulmess . e . 1 . numero d'unite logique des messages . +c . codret . s . 1 . code de retour : 0 si c'est bon . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul, lnomfi, codret, ulmess +c + character*(*) nomfic +c +c 0.4. ==> variables locales +c +c 0.5. ==> initialisations +c +c=== +c 1. pas de differences entre les machines +c=== +c + open ( unit=nuroul, err=10, file=nomfic(1:lnomfi), + > access='SEQUENTIAL', form='UNFORMATTED', + > status='UNKNOWN', iostat=codret ) +c + goto 11 +c + 10 continue + if ( codret.eq.0 ) then + codret = -1 + endif +c + 11 continue +c + if ( codret.ne.0 ) then + write(ulmess,*) 'Ouverture du fichier :' + write(ulmess,*) nomfic(1:lnomfi) + write(ulmess,*) 'Code retour dans dmoubs : ',codret + endif +c + end diff --git a/src/tool/Dependance_Machine/dmoufs.F b/src/tool/Dependance_Machine/dmoufs.F new file mode 100644 index 00000000..4a05decb --- /dev/null +++ b/src/tool/Dependance_Machine/dmoufs.F @@ -0,0 +1,80 @@ + subroutine dmoufs ( nuroul , nomfic, lnomfi, + > ulmess, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine - OUverture en Formate Sequentiel +c - - -- - - +c ______________________________________________________________________ +c +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . e . 1 . numero de l'unite logique attribuee . +c . nomfic . e . ch<200 . nom du fichier a ouvrir . +c . lnomfi . e . 1 . longueur du nom du fichier a ouvrir . +c . ulmess . e . 1 . numero d'unite logique des messages . +c . codret . s . 1 . code de retour : 0 si c'est bon . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul, lnomfi, codret, ulmess +c + character*(*) nomfic +c +c 0.4. ==> variables locales +c +c 0.5. ==> initialisations +c +c=== +c 1. pas de differences entre les machines +c=== +c + open ( unit=nuroul, err=10, file=nomfic(1:lnomfi), + > access='SEQUENTIAL', form='FORMATTED', + > status='UNKNOWN', iostat=codret ) +c + goto 11 +c + 10 continue + if ( codret.eq.0 ) then + codret = -1 + endif +c + 11 continue +c + if ( codret.ne.0 ) then + write(ulmess,*) 'Ouverture du fichier :' + write(ulmess,*) nomfic(1:lnomfi) + write(ulmess,*) 'Code retour dans dmoufs : ',codret + endif +c + end diff --git a/src/tool/Dependance_Machine/dmport.h b/src/tool/Dependance_Machine/dmport.h new file mode 100644 index 00000000..ec18009f --- /dev/null +++ b/src/tool/Dependance_Machine/dmport.h @@ -0,0 +1,49 @@ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* include (langage C ou C++) pour portage des routines */ +/* "dependance_machine" */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +#ifndef dmport_h +#define dmport_h + +#if defined(__unix__) +#define _POSIX +#warning "-------- definition de _POSIX --------" +#endif + +#if defined __LP64__ || defined __MINGW64__ +#define _USE_64_BITS +#warning "-------- definition de _USE_64_BITS --------" +#endif + + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Correspondance entre les entiers fortran et les entiers C : */ +/* Utile par exemple sur machine DEC, quand les pointeurs sont sur */ +/* 64 bits et qu'on utilise une option du compilateur fortran qui */ +/* force tous les entiers fortran a 64 bits */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +#define DOUBLE double + +#ifdef _USE_64_BITS +#warning "-------- passage par ifdef _USE_64_BITS --------" + typedef long INTGR ; + #define INTEGER_NB_CHIFFRES_SIGNIFICATIFS 19 +#else +#warning "-------- passage par else de ifdef _USE_64_BITS --------" + typedef int INTGR ; + #define INTEGER_NB_CHIFFRES_SIGNIFICATIFS 9 +#endif + + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Longueur des chaines de caractères fortran (telles que passées */ +/* comme arguments cachés par les compilateurs fortran) */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +#ifdef _USE_64_BITS + typedef long LNSTRF ; +#else + typedef int LNSTRF ; +#endif +// +#endif diff --git a/src/tool/Dependance_Machine/dmprma.F b/src/tool/Dependance_Machine/dmprma.F new file mode 100644 index 00000000..884f499f --- /dev/null +++ b/src/tool/Dependance_Machine/dmprma.F @@ -0,0 +1,72 @@ + subroutine dmprma ( epsima, dmxent, nbchii ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : PRecision MAchine +c - - -- -- +c ______________________________________________________________________ +c +c retourne la precision machine +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . epsima . s . dp . la precision de la machine . +c . dmxent . s . dp . plus grand entier, exprime en double . +c . nbchii . s . i . nombre de chiffres significatifs des entier. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbchii +c + double precision epsima, dmxent +c +c 0.4. ==> variables locales +c +c 0.5. ==> initialisations +c +c==== +c 1. appel de la fonction generique +c==== +c + call dmprmc ( epsima, nbchii ) +cgn print *,epsima +cgn print *,nbchii +c +c==== +c 2. plus grand entier, exprime en double +c==== +c + dmxent = 10.d0**nbchii +cgn print *,dmxent +cgn print *,int(dmxent) +c + end diff --git a/src/tool/Dependance_Machine/dmprmc.c b/src/tool/Dependance_Machine/dmprmc.c new file mode 100644 index 00000000..2aa0b9f6 --- /dev/null +++ b/src/tool/Dependance_Machine/dmprmc.c @@ -0,0 +1,57 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Retourne la précision machine */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmprmc_( DOUBLE *epsima, INTGR *nbchii ) +#else +#ifdef extern_stdcall +extern void __stdcall DMPRMC( DOUBLE *epsima, INTGR *nbchii ) +#else +void FortranCInterface_GLOBAL(dmprmc, DMPRMC)(DOUBLE *epsima, INTGR *nbchii) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _USE_64_BITS + *epsima = 1.e-31; + +#else + *epsima = 1.e-15; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +/* printf (". INTEGER_NB_CHIFFRES_SIGNIFICATIFS : %d\n", INTEGER_NB_CHIFFRES_SIGNIFICATIFS); */ + *nbchii = INTEGER_NB_CHIFFRES_SIGNIFICATIFS ; + + +} + diff --git a/src/tool/Dependance_Machine/dmralc.c b/src/tool/Dependance_Machine/dmralc.c new file mode 100644 index 00000000..777e657f --- /dev/null +++ b/src/tool/Dependance_Machine/dmralc.c @@ -0,0 +1,53 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" +#include +#include + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmralc_( INTGR *iad_mem, INTGR *size ) +#else +#ifdef extern_stdcall +extern void __stdcall DMRALC( INTGR *iad_mem, INTGR *size ) +#else +void FortranCInterface_GLOBAL(dmralc, DMRALC)(INTGR *iad_mem, INTGR *size) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + void *adret ; + + adret = realloc( (void *) *iad_mem, (size_t) *size ) ; + + if ( adret != NULL ) + { + *iad_mem = (INTGR) adret ; + } + else + { + *iad_mem = 0 ; + } + +} + diff --git a/src/tool/Dependance_Machine/dmralo.F b/src/tool/Dependance_Machine/dmralo.F new file mode 100644 index 00000000..6b40cb00 --- /dev/null +++ b/src/tool/Dependance_Machine/dmralo.F @@ -0,0 +1,81 @@ + subroutine dmralo ( adress, taille, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : ReALlOcation +c - - - -- - +c ______________________________________________________________________ +c +c but : re-alloue une place memoire demarrant a adress, +c a la nouvelle taille +c Attention : l'adresse de depart peut etre MODIFIEE, meme si la +c nouvelle taille est plus petite que l'ancienne. +c Le contenu, lui, est conserve. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . adress . es . 1 . adresse de depart de la zone allouee . +c . taille . e . 1 . nouvelle taille de la zone allouee . +c . codret . s . 1 . code d'erreur ( 0 : tout va bien ) . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer adress, taille, codret +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c Precautions generales d'emploi: +c - la taille finale doit etre strictement positive +c (sinon, ce serait une desallocation complete: cf. dmlibe) +c - l'adresse de depart doit correspondre (en entree) a une +c adresse de depart d'une zone allouee (cf. dmalme) ou +c re-allouee... +c + if ( taille.gt.0 ) then +c + call dmralc ( adress, taille ) +c + if ( adress.eq.0 ) then + codret = 1 + else + codret = 0 + endif +c + else +c + codret = -1 +c + endif +c + end diff --git a/src/tool/Dependance_Machine/dmsepc.c b/src/tool/Dependance_Machine/dmsepc.c new file mode 100644 index 00000000..84cf8d06 --- /dev/null +++ b/src/tool/Dependance_Machine/dmsepc.c @@ -0,0 +1,53 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" + +/* but : retourne le caractère séparateur de répertoires */ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmsepc_( char *slash, LNSTRF bidon ) +#else +#ifdef extern_stdcall +extern void __stdcall DMSEPC( char *slash, LNSTRF bidon ) +#else +void FortranCInterface_GLOBAL(dmsepc, DMSEPC)(char *slash, LNSTRF bidon) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX + + slash[0] = '/' ; + +#else + + slash[0] = '\\' ; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +} + diff --git a/src/tool/Dependance_Machine/dmsepf.F b/src/tool/Dependance_Machine/dmsepf.F new file mode 100644 index 00000000..0ec2dfb0 --- /dev/null +++ b/src/tool/Dependance_Machine/dmsepf.F @@ -0,0 +1,55 @@ + subroutine dmsepf ( slash ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : SEParateur Fichiers +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . slash . s . char* . separateur des noms de fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) slash +c +c 0.4. ==> variables locales +c +c 0.5. ==> initialisations +c +c=== +c 1. appel de la fonction C equivalente +c=== +c + call dmsepc ( slash ) +c + end diff --git a/src/tool/Dependance_Machine/dmsizc.c b/src/tool/Dependance_Machine/dmsizc.c new file mode 100644 index 00000000..35594ea6 --- /dev/null +++ b/src/tool/Dependance_Machine/dmsizc.c @@ -0,0 +1,56 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmsizc_( INTGR *tentie, INTGR *treel, INTGR *tchain ) +#else +#ifdef extern_stdcall +extern void __stdcall DMSIZC( INTGR *tentie, INTGR *treel, INTGR *tchain ) +#else +void FortranCInterface_GLOBAL(dmsizc, DMSIZC)(INTGR *tentie, INTGR *treel, INTGR *tchain) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ +/* malloc fonctionne en octets */ + *tentie = sizeof(INTGR) ; + *treel = 8 ; + *tchain = 8 ; + +#ifdef _DEBUG_HOMARD_ + printf ("Dans dmsizc, tailles en octets :\n"); + printf (". Entiers : %d\n", *tentie); + printf (". Reels : %d\n", *treel); + printf (". Chaine : %d\n", *tchain); + printf (". taille de INTGR : %d\n", sizeof(INTGR)); + printf (". taille de int : %d\n", sizeof(int)); + printf (". taille de int* : %d\n", sizeof(int*)); + printf (". taille de long : %d\n", sizeof(long)); + printf (". taille de tentie : %d\n", sizeof(*tentie)); + +#endif + +} + diff --git a/src/tool/Dependance_Machine/dmsize.F b/src/tool/Dependance_Machine/dmsize.F new file mode 100644 index 00000000..335c4767 --- /dev/null +++ b/src/tool/Dependance_Machine/dmsize.F @@ -0,0 +1,72 @@ + subroutine dmsize ( tentie , treel, tchain ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : SIZE des variables selon leurs types +c - - ---- +c ______________________________________________________________________ +c +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tentie . s . 1 . tailles des entiers en octets . +c . treel . s . 1 . tailles des reels en octets . +c . tchain . s . 1 . tailles des chaines en octets . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'DMSIZE' ) +#endif +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer tentie , treel, tchain +c +c 0.4. ==> variables locales +c 0.5. ==> initialisations +c +c=== +c 1. appel de la fonction C equivalente +c=== +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de DMSIZC par ', nompro +#endif + call dmsizc ( tentie , treel, tchain ) +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Dans ', nompro,', apres dmsizc, tailles en octets :' + write (*,*) ' Entier : ', tentie + write (*,*) ' Reel : ', treel + write (*,*) ' Chaine : ', tchain +#endif +c + end diff --git a/src/tool/Dependance_Machine/dmtemc.c b/src/tool/Dependance_Machine/dmtemc.c new file mode 100644 index 00000000..42bba2f5 --- /dev/null +++ b/src/tool/Dependance_Machine/dmtemc.c @@ -0,0 +1,70 @@ +/* __________________________________________________________________________ */ +/* */ +/* H O M A R D */ +/* */ +/* Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D */ +/* */ +/* Version originale enregistrée le 18 juin 1996 sous le numéro 96036 auprès */ +/* des huissiers de justice Simart et Lavoir à Clamart */ +/* Version 11.2 enregistrée le 13 février 2015 sous le numéro 2015/014 auprès */ +/* des huissiers de justice Lavoir, Silinski & Cherqui-Abrahmi à Clamart */ +/* */ +/* HOMARD est une marque déposée d'Electricite de France */ +/* */ +/* Copyright EDF 1997 */ +/* Copyright EDF 1998 */ +/* Copyright EDF 1999 */ +/* Copyright EDF 2021 */ +/* __________________________________________________________________________ */ + +#include "dminfc.h" +#include "dmport.h" +#include "FC.h" + +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Retourne les temps user et système écoulés depuis le début */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ + +#ifdef _POSIX +#include +#include +#endif + +#include + +#ifdef CLK_TCK +#define CLOCKS_PER_SEC_VALUE CLK_TCK +#else +#define CLOCKS_PER_SEC_VALUE sysconf(_SC_CLK_TCK) +#endif + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX +void dmtemc_( DOUBLE *tuser, DOUBLE *tsyst ) +#else +#ifdef extern_stdcall +extern void __stdcall DMTEMC( DOUBLE *tuser, DOUBLE *tsyst ) +#else +void FortranCInterface_GLOBAL(dmtemc, DMTEMC)(DOUBLE *tuser, DOUBLE *tsyst) +#endif +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +{ + +/* %%%%%%%%%%%%%%%%% début de zone à préprocesser %%%%%%%%%%%%%%%%%% */ +#ifdef _POSIX + struct tms temps; + times (&temps); + *tuser=(DOUBLE)temps.tms_utime/(DOUBLE)CLOCKS_PER_SEC_VALUE; + *tsyst=(DOUBLE)temps.tms_stime/(DOUBLE)CLOCKS_PER_SEC_VALUE; + +#else + *tuser=(DOUBLE)clock()/CLOCKS_PER_SEC_VALUE; + *tsyst=(DOUBLE)0.; + +#endif +/* %%%%%%%%%%%%%%%%%% fin de zone à préprocesser %%%%%%%%%%%%%%%%%%% */ + +} + diff --git a/src/tool/Dependance_Machine/dmtemp.F b/src/tool/Dependance_Machine/dmtemp.F new file mode 100644 index 00000000..3226baf7 --- /dev/null +++ b/src/tool/Dependance_Machine/dmtemp.F @@ -0,0 +1,94 @@ + subroutine dmtemp ( tuser, tsyst ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : TEMPs de calcul +c - - ---- +c ______________________________________________________________________ +c +c +c retourne les temps user et systeme ecoules depuis le dernier appel +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tuser . s . 1 . temps user depuis le dernier appel . +c . tsyst . s . 1 . temps systeme .................... . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision tuser, tsyst +c +c 0.4. ==> variables locales +c + logical prem +c + double precision tuser0, tsyst0 + double precision tuser1, tsyst1 +c +c 0.5. ==> initialisations +c + data prem / .true. / +c +c=== +c 1. appel de la fonction C equivalente +c=== +c + call dmtemc ( tuser, tsyst ) +c +c 1.1 ==> Archivage du depart +c + if ( prem ) then +c + tuser0 = tuser + tsyst0 = tsyst +c + tuser = 0.d0 + tsyst = 0.0d0 +c + prem = .false. +c + else +c +c 1.2. ==> Difference +c + tuser1 = tuser + tsyst1 = tsyst +c + tuser = tuser - tuser0 + tsyst = tsyst - tsyst0 +c + tuser0 = tuser1 + tsyst0 = tsyst1 +c + endif +c + end diff --git a/src/tool/Dependance_Machine/dmunit.F b/src/tool/Dependance_Machine/dmunit.F new file mode 100644 index 00000000..41caeb24 --- /dev/null +++ b/src/tool/Dependance_Machine/dmunit.F @@ -0,0 +1,60 @@ + subroutine dmunit ( enstul, sostul ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : UNITes logiques d'entree et de sortie standard +c - - ---- +c ______________________________________________________________________ +c +c but : retourne les numeros d'entree et de sortie standard sur +c la machine concernee +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . enstul . s . 1 . entree standard : numero de l'unite logique. +c . sostul . s . 1 . sortie standard : numero de l'unite logique. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer enstul, sostul +c +c 0.4. ==> variables locales +c +c==== +c 1. affectation +c==== +c + enstul = 5 +c + sostul = 6 +c + end diff --git a/src/tool/Dependance_Machine/dmvaen.F b/src/tool/Dependance_Machine/dmvaen.F new file mode 100644 index 00000000..62d3047d --- /dev/null +++ b/src/tool/Dependance_Machine/dmvaen.F @@ -0,0 +1,182 @@ + subroutine dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine - decodage d'une VAriable d'ENvironnement +c - - -- -- +c ______________________________________________________________________ +c +c +c but : decode les variables d'environnement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomvar . e . char* . nom de la variable a decoder . +c . lgnova . e . i . longueur reelle de nomvar . +c . nomuti . s . char* . nom utilisable pour cette variable . +c . lgnout . s . i . longueur reelle de nomuti . +c . ulsort . e . 1 . unite logique de la liste standard . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : impossible de decoder la variable . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'DMVAEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nomvar, nomuti +c + integer lgnova, lgnout + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, lgmax +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + parameter ( lgmax = 200 ) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Variable d''''environnement :'')' + texte(1,5) = '(''Impossible de la decoder.'')' + texte(1,6) = '(''Valeur interpretee :'')' +c + texte(2,4) = '(''Environment variable :'')' + texte(2,5) = '(''It cannot be uncoded.'')' + texte(2,6) = '(''It is equal to :'')' +c +c==== +c 2. appel a la fonction machine +c==== +c + lgnout = 0 +c + do 2 iaux = 1 , len(nomuti) + nomuti(iaux:iaux) = ' ' + 2 continue +c +c 2.1. ==> attention a la taille maximale ... +c + if ( lgnova.le.0 .or. lgnova.gt.len(nomvar) ) then +c + codret = 1 +c + else +c +c 2.2. ==> appel a la fonction standard ailleurs et +c comptage du nombre de lettres effectives +c +c NB: sous WINDOWS + Visual Fortran 6.0, l'appel a getenv impose +c le rajout de la bibliotheque Dfport.lib +c pour que l'edition des liens se passe bien. +c + call getenv ( nomvar(1:lgnova) , nomuti ) +c + do 221 , iaux = 1 , min(lgmax,len(nomuti)) + if ( nomuti(iaux:iaux).eq.' ' ) then + codret = 0 + goto 222 + endif + lgnout = lgnout + 1 + 221 continue +c + codret = 1 +c + 222 continue +c +c nettoyage eventuel: +c + call dmcpch( nomuti, lgnout, nomuti, lgnout ) +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + iaux = -1 +#else + iaux = 0 +#endif +c + if ( codret.ne.iaux ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + if (min(lgnova,len(nomvar)).ge.1) then + write (ulsort,*) nomvar( 1 : min(lgnova,len(nomvar)) ) + else + write (ulsort,*) + endif + if ( codret.eq.1 ) then + write (ulsort,texte(langue,5)) + else + if ( iaux.eq.-1 ) then + write (ulsort,texte(langue,6)) + if (lgnout.ge.1) then + write (ulsort,*) nomuti(1:lgnout) + else + write (ulsort,*) + endif + endif + endif + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Dependance_Machine/dmze10.F b/src/tool/Dependance_Machine/dmze10.F new file mode 100644 index 00000000..8321b71b --- /dev/null +++ b/src/tool/Dependance_Machine/dmze10.F @@ -0,0 +1,77 @@ + subroutine dmze10 ( vinfpo, zero, pd10vi, pd10ze ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : ZEros en puissance de 10 +c - - -- -- +c ______________________________________________________________________ +c +c +c retourne la plus petite et la plus grande valeur possible +c et leurs puissances de 10 associees : x = 0.abc*10**n +c exemple : avec x = 1.e9, on a x = 0.1*10**10, donc n = 10 +c avec x = 1.e-40, on a x = 0.1*10**-39, donc n = -39 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . vinfpo . s . dp . plus grande valeur positive possible . +c . zero . s . dp . le zero de la machine . +c . pd10vi . s . i . la puissance de 10 associee a vinfpo . +c . pd10ze . s . i . la puissance de 10 associee a zero . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision vinfpo, zero + integer pd10vi, pd10ze +c +c 0.4. ==> variables locales +c +c 0.5. ==> initialisations +c +c==== +c 1. les valeurs extremes +c=== +c +c 1.1. ==> le maximum +c + vinfpo = 1.d29 + pd10vi = 30 +c +c 1.2. ==> le minimum : l'inverse du maximum +c + zero = 1.d0 / vinfpo +c +c 1.3. ==> les puissances de 10 associees +c + pd10ze = 2 - pd10vi +c + end diff --git a/src/tool/Dependance_Machine/dmzero.F b/src/tool/Dependance_Machine/dmzero.F new file mode 100644 index 00000000..36743232 --- /dev/null +++ b/src/tool/Dependance_Machine/dmzero.F @@ -0,0 +1,61 @@ + subroutine dmzero ( vinfpo, zero ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Dependance Machine : ZEROs machine +c - - ---- +c ______________________________________________________________________ +c +c retourne la plus petite et la plus grande valeur possible +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . vinfpo . s . dp . plus grande valeur positive possible . +c . zero . s . dp . le zero de la machine . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision vinfpo, zero +c +c 0.4. ==> variables locales +c + integer pd10vi, pd10ze +c +c 0.5. ==> initialisations +c +c==== +c 1. appel de la fonction generique +c==== +c + call dmze10 ( vinfpo, zero, pd10vi, pd10ze ) +c + end diff --git a/src/tool/ES_HOMARD/CMakeLists.txt b/src/tool/ES_HOMARD/CMakeLists.txt new file mode 100644 index 00000000..a87642aa --- /dev/null +++ b/src/tool/ES_HOMARD/CMakeLists.txt @@ -0,0 +1,69 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de ES_HOMARD + +SET(ES_HOMARD_SOURCES + ./esece0.F + ./esece1.F + ./esece2.F + ./esecen.F + ./esecf0.F + ./esecfd.F + ./esecfe.F + ./esecfs.F + ./esecig.F + ./esecn1.F + ./esecno.F + ./esecs1.F + ./esecs2.F + ./esecs3.F + ./esecs4.F + ./esecs5.F + ./esecsu.F + ./esemh0.F + ./esemh1.F + ./esemh2.F + ./esemho.F + ./esle01.F + ./esle02.F + ./esle03.F + ./eslee0.F + ./eslee1.F + ./eslee2.F + ./esleen.F + ./eslefe.F + ./eslen1.F + ./esleno.F + ./eslmh1.F + ./eslmh2.F + ./eslmh3.F + ./eslmh4.F + ./eslmh5.F + ./eslmh6.F + ./eslmh7.F + ./eslmho.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/ES_HOMARD ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (ES_HOMARD ${ES_HOMARD_SOURCES}) + +INSTALL(TARGETS ES_HOMARD EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/ES_HOMARD/esece0.F b/src/tool/ES_HOMARD/esece0.F new file mode 100644 index 00000000..1f5a6ad9 --- /dev/null +++ b/src/tool/ES_HOMARD/esece0.F @@ -0,0 +1,245 @@ + subroutine esece0 ( idfmed, nomamd, + > typenh, typgeo, typent, + > nbenti, nbencf, nbenca, nbrfma, + > somare, + > codeen, infosu, codear, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture d'une Entite - 0 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typent . e . 1 . type d'entite au sens MED . +c . nbenti . e . 1 . nombre d'entites . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . nbrfma . e . 1 . nbre noeuds par maille si connec. par noeud. +c . . . . nbre faces par maille si connectivite desce. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . codeen . e .nbencf**. connectivite descendante des mailles . +c . infosu . e .nbencf**. code des faces dans les mailles 3D . +c . codear . e .nbenca**. connectivite des mailles par aretes . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECE0' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typgeo, typent + integer nbenti, nbencf, nbenca, nbrfma + integer somare(2,*) + integer codeen(nbencf,*), infosu(nbencf,*), codear(nbenca,*) + integer numdt, numit + integer ltbiau, tbiaux(*) +c + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer listma(1) + integer dim1 + integer typcon +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des '',i10,1x,a)' +c + texte(2,4) = '(''... Writings of '',i10,1x,a)' +c +#include "esimpr.h" +c + texte(1,81) = '(''Longueur allouee pour tbiaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbiaux : '',i10)' +c + texte(2,81) = '(''Allocated length for tbiaux : '',i10)' + texte(2,82) = '(''Used length for tbiaux : '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbenti, mess14(langue,3,typenh) + write (ulsort,90002) 'nbencf', nbencf + write (ulsort,90002) 'nbenca', nbenca +#endif +c +c==== +c 2. Preparation des donnees +c==== +c 2.1. ==> Verification +c + if ( codret.eq.0 ) then +c + if ( nbenti*nbrfma.gt.ltbiau ) then + write (ulsort,texte(langue,81)) ltbiau + write (ulsort,texte(langue,82)) nbenti*nbrfma + codret = 7 + endif +c + endif +c +c 2.2. ==> Creation du tableau +c + if ( codret.eq.0 ) then +c + dim1 = nbenti +c +c 2.2.2. ==> Mailles-points +c + if ( typenh.eq.0 ) then +c + listma(1) = 0 + typcon = ednoda +c +c 2.2.1. ==> Segments +c + elseif ( typenh.eq.1 ) then +c + dim1 = 2 + listma(1) = -nbrfma + typcon = eddesc +c +c 2.2.4. ==> Autres : on cree directement le tableau a ecrire +c + else +c + listma(1) = 0 + typcon = eddesc +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECE2', nompro +#endif + call esece2 ( typenh, nbencf, nbenca, nbrfma, + > somare, codeen, infosu, codear, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Ecriture veritable +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMC', nompro +#endif + call esemmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbenti, nbrfma, nbenti, + > typcon, dim1, + > codeen, infosu, listma, + > numdt, numit, instan, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esece1.F b/src/tool/ES_HOMARD/esece1.F new file mode 100644 index 00000000..69a602d5 --- /dev/null +++ b/src/tool/ES_HOMARD/esece1.F @@ -0,0 +1,496 @@ + subroutine esece1 ( idfmed, nomamd, + > typenh, typgeo, typent, + > nbenti, nbencf, nbenca, + > adfami, adhist, + > adnivo, admere, + > adenho, + > adinsu, lginsu, + > adins2, lgins2, + > adnoim, + > addera, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture d'une Entite - 1 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typent . e . 1 . type d'entite au sens MED . +c . nbenti . e . 1 . nombre d'entites . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . adfami . e . 1 . famille . +c . adhist . e . 1 . historique de l'etat . +c . adnivo . e . 1 . niveau des entites . +c . admere . e . 1 . mere des entites . +c . adinsu . e . 1 . informations supplementaires . +c . lginsu . e . 1 . longueur des informations supplementaires . +c . adins2 . e . 1 . informations supplementaires numero 2 . +c . lgins2 . e . 1 . longueur des informations supplementaires 2. +c . adnoim . s . 1 . noeud interne a la maille . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECE1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "impr02.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typgeo, typent + integer nbenti, nbencf, nbenca + integer adfami, adhist + integer adnivo, admere + integer adenho + integer adinsu, lginsu + integer adins2, lgins2 + integer adnoim + integer addera + integer numdt, numit + integer ltbiau, tbiaux(*) +c + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbcmax + parameter ( nbcmax = 20 ) +c + integer iaux, jaux, kaux, laux + integer nbinsu + integer adress(nbcmax) + integer typcom(nbcmax) + integer nbcomp +c + character*16 dtunit + character*16 nomcmp(nbcmax), unicmp(nbcmax) + character*64 nomcha + character*64 noprof +c + logical prem +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''... Ecriture des complements pour les '',i10,1x,a)' +c + texte(2,4) = + > '(''... Writings of additional terms for the '',i10,1x,a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbenti, mess14(langue,3,typenh) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Creation du champ : '',a64)' + texte(1,5) = '(''Type du champ : '',i2)' + texte(1,6) = + > '(''Numero ! Composante ! Unite'',/,49(''-''))' + texte(1,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(1,81) = '(''Longueur allouee pour tbiaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbiaux : '',i10)' +c + texte(2,4) = '(/,''Creation of field : '',a64)' + texte(2,5) = '(''Type of field : '',i2)' + texte(2,6) = + > '('' # ! Component ! Unit'',/,49(''-''))' + texte(2,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(2,81) = '(''Allocated length for tbiaux : '',i10)' + texte(2,82) = '(''Used length for tbiaux : '',i10)' +c +c 1.2. ==> unites : non definies +c + if ( prem ) then +c + do 12 , iaux = 1 , nbcmax + unicmp(iaux) = blan16 + 12 continue + prem = .false. +c + endif +c +c==== +c 2. Reperage des composantes en fonction de la presence des tableaux +c==== +c + if ( codret.eq.0 ) then +c + nbcomp = 0 +c +c 2.1. ==> Pour economiser, si HistEtat et Niveau sont presents, on les +c rassemble dans la premiere composante +c + if ( adhist.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = adhist + nomcmp(nbcomp) = 'HistEtat ' +c 1234567890123456 + endif +c + if ( adnivo.ne.0 ) then + if ( adhist.eq.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = adnivo + nomcmp(nbcomp) = 'Niveau ' + else + typcom(nbcomp) = 0 + nomcmp(nbcomp) = 'HistEtatNiveau ' +c 1234567890123456 + endif + endif +c +c 2.2. ==> Composantes standard +c + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = adfami + nomcmp(nbcomp) = 'Famille ' +c 1234567890123456 +c + if ( admere.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = admere + nomcmp(nbcomp) = 'Mere ' + endif +c + if ( adenho.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = adenho + nomcmp(nbcomp) = 'Homologu ' + endif +c + if ( addera.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = addera + nomcmp(nbcomp) = 'Deraffin ' + endif +c + if ( adnoim.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 1 + adress(nbcomp) = adnoim + nomcmp(nbcomp) = 'NoeuInMa ' + endif +c +c 2.3. ==> Pour economiser, on rassemble les termes de InfoSupp dans +c la derniere composante +c + if ( adinsu.ne.0 ) then + nbcomp = nbcomp + 1 + typcom(nbcomp) = 0 + adress(nbcomp) = adinsu + nomcmp(nbcomp) = 'InfoSupp ' + nbinsu = lginsu/nbencf +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbinsu', nbinsu +#endif + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,85)) nbcomp +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbencf*nbcomp.gt.ltbiau ) then + write (ulsort,texte(langue,85)) nbcomp + write (ulsort,texte(langue,81)) ltbiau + write (ulsort,texte(langue,82)) nbencf*nbcomp + codret = 7 + endif +c + endif +c +c==== +c 3. Ecriture sous forme de champ pour les tableaux a une valeur +c par entite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. pseudo-champ ; codret', codret +#endif +c + if ( nbcomp.gt.0 ) then +c +c 3.1. ==> Creation du champ +c + if ( codret.eq.0 ) then +c + nomcha = blan64 + nomcha(1:8) = suffix(3,typenh) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha + write (ulsort,texte(langue,5)) edint + write (ulsort,texte(langue,6)) + do 31 , iaux = 1 , nbcomp + write (ulsort,texte(langue,7)) iaux, nomcmp(iaux), unicmp(iaux) + 31 continue +#endif +c + iaux = edint + dtunit = blan16 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDCRE', nompro +#endif + call mfdcre ( idfmed, nomcha, iaux, + > nbcomp, nomcmp, unicmp, dtunit, nomamd, codret ) +c + endif +c + endif +c +c 3.2. ==> Le tableau des valeurs du champ, en mode non entrelace. +c En fortran, cela correspond au stockage memoire suivant : +c tbiaux(1,1), tbiaux(2,1), tbiaux(3,1), ..., tbiaux(nbenti,1), +c tbiaux(1,2), tbiaux(2,2), tbiaux(3,2), ..., tbiaux(nbenti,2), +c ... +c tbiaux(1,nbcomp), tbiaux(2,nbcomp), ..., tbiaux(nbenti,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. tableau ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.2.1. ==> Les composantes standard +c + do 321 , iaux = 1 , nbcomp +c + if ( typcom(iaux).ne.0 ) then +c + kaux = nbenti*(iaux-1) + laux = adress(iaux)-1 + do 3211 , jaux = 1 , nbenti + tbiaux(kaux+jaux) = imem(laux+jaux) + 3211 continue +c + endif +c + 321 continue +c +c 3.2.2. ==> Historique et niveau dans la premiere composante +c L'historique est un nombre entre 0 et 999, donc il faut +c decaler de 6 chiffres +c + if ( typcom(1).eq.0 ) then +c + kaux = adhist - 1 + laux = adnivo - 1 + do 322 , jaux = 1 , nbenti + tbiaux(jaux) = imem(kaux+jaux) + 1000000*imem(laux+jaux) + 322 continue +c + endif +c + endif +c +c 3.2.3. ==> Informations Supplementaires dans la derniere composante +c On sait que ce sont des valeurs entre 1 et 8, donc < 10 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.3. adinsu', adinsu +#endif +c + if ( adinsu.ne.0 ) then +c +c 3.2.3.1. ==> Premiere valeur pour initialiser le tableau +c + kaux = nbenti*(nbcomp-1) + laux = adress(nbcomp)-1 +cgn write (ulsort,90002) 'nbenti*(nbcomp-1)', kaux +cgn write (ulsort,90002) 'laux', laux + do 32311 , jaux = 1 , nbencf + tbiaux(kaux+jaux) = imem(laux+jaux) +32311 continue +c + do 32312 , jaux = nbencf+1, nbenti + tbiaux(kaux+jaux) = 0 +32312 continue +c +c 3.2.3.2. ==> Valeurs suivantes +c + do 323 , iaux = 2 , nbinsu +c + laux = laux + nbencf + do 3232 , jaux = 1 , nbencf + tbiaux(kaux+jaux) = 10*tbiaux(kaux+jaux) + imem(laux+jaux) + 3232 continue +c + 323 continue +c + endif +c +c 3.3. ==> Ecriture des valeurs du champ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. Ecriture des valeurs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIVW', nompro +#endif + call mfdivw ( idfmed, nomcha, + > numdt, numit, instan, + > typent, typgeo, ednoin, edall, + > nbenti, tbiaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,19)) nomcha + endif +c + endif +c +c==== +c 4. Ecriture sous forme de profil pour les informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. info supp ; codret', codret + write (ulsort,90002) 'lgins2', lgins2 +#endif +c + if ( lgins2.gt.0 ) then +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 12 34567890 + noprof(1:10) = suffix(3,typenh)(1:2)//'InfoSup2' +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'Ecriture du profil', noprof + write (ulsort,90002) 'Valeurs', + > (imem(adins2+iaux),iaux=0,min(lgins2-1,9)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, lgins2, imem(adins2), codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,*) mess14(langue,4,typenh) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esece2.F b/src/tool/ES_HOMARD/esece2.F new file mode 100644 index 00000000..8e5a61ff --- /dev/null +++ b/src/tool/ES_HOMARD/esece2.F @@ -0,0 +1,299 @@ + subroutine esece2 ( typenh, nbencf, nbenca, nbrfma, + > somare, codeen, infosu, codear, + > tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture d'une Entite - 2 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . nbrfma . e . 1 . nbre faces par maille . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . codeen . e .nbencf**. connectivite descendante des mailles . +c . infosu . e .nbencf**. code des faces dans les mailles 3D . +c . codear . e .nbenca**. connectivite des mailles par aretes . +c . tbiaux . s . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECE2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "fahmed.h" +#include "oriett.h" +#include "orieqh.h" +#include "oriefp.h" +#include "oriefy.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nbencf, nbenca, nbrfma + integer somare(2,*) + integer codeen(nbencf,*), infosu(nbencf,*), codear(nbenca,*) + integer tbiaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux, laux + integer orient(8) + integer aret(4) +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Conversion des '',i10,1x,a)' +c + texte(2,4) = '(''... Conversion of '',i10,1x,a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbencf, mess14(langue,3,typenh) + write (ulsort,90002) 'nbencf', nbencf + write (ulsort,90002) 'nbenca', nbenca +#endif +c +c==== +c 2. Mise en place de la connectivite descendante +c==== +c + if ( codret.eq.0 ) then +c + kaux = 0 +c +c 2.1. ==> Triangles +c + if ( typenh.eq.2 ) then +c + do 221 , iaux = 1, nbencf + do 2211, jaux = 1, nbrfma + aret(jaux) = codeen(iaux,jaux) + 2211 continue +cgn write(ulsort,*)aret + call utorat ( somare, aret(1), aret(2), aret(3), + > orient(1), orient(2), orient(3) ) +cgn write(ulsort,*)(orient(jaux),jaux = 1, nbrfma) + do 2212, jaux = 1, nbrfma + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*aret(jaux) + 2212 continue + 221 continue +c +c 2.3. ==> Tetraedres +c + elseif ( typenh.eq.3 ) then +c +cgn write(ulsort,*) typenh + do 231 , iaux = 1, nbencf + do 2311, jaux = 1, nbrfma + laux = nofmed(typenh,jaux,1) +cgn write(ulsort,*) jaux,laux + orient(jaux) = orcott(laux,infosu(iaux,laux)) +cgn write(ulsort,*) laux, codeen(iaux,laux), orient(jaux) + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*codeen(iaux,laux) + 2311 continue + 231 continue +c +c 2.4. ==> Quadrangles +c + elseif ( typenh.eq.4 ) then +c + do 241 , iaux = 1, nbencf + do 2411, jaux = 1, nbrfma + aret(jaux) = codeen(iaux,jaux) + 2411 continue +cgn write(ulsort,*)aret + call utoraq ( somare, aret(1), aret(2), aret(3), aret(4), + > orient(1), orient(2), orient(3), orient(4) ) +cgn write(ulsort,*)(orient(jaux),jaux = 1, nbrfma) + do 2412, jaux = 1, nbrfma + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*aret(jaux) + 2412 continue + 241 continue +c +c 2.5. ==> Pyramides +c + elseif ( typenh.eq.5 ) then +c + do 251 , iaux = 1, nbencf + do 2511, jaux = 1, nbrfma + laux = nofmed(typenh,jaux,1) + orient(jaux) = orcofy(laux,infosu(iaux,laux)) +cgn write(ulsort,*) laux, codeen(iaux,laux), orient(jaux) + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*codeen(iaux,laux) + 2511 continue + 251 continue +c +c 2.6. ==> Hexaedres +c + elseif ( typenh.eq.6 ) then +c + do 261 , iaux = 1, nbencf + do 2611, jaux = 1, nbrfma + laux = nofmed(typenh,jaux,1) + orient(jaux) = orcoqh(laux,infosu(iaux,laux)) +cgn write(ulsort,*) laux, codeen(iaux,laux), orient(jaux) + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*codeen(iaux,laux) + 2611 continue + 261 continue +c +c 2.7. ==> Pentaedres +c + elseif ( typenh.eq.7 ) then +c + do 271 , iaux = 1, nbencf + do 2711, jaux = 1, nbrfma + laux = nofmed(typenh,jaux,1) + orient(jaux) = orcofp(laux,infosu(iaux,laux)) +cgn write(ulsort,*) laux, codeen(iaux,laux), orient(jaux) + kaux = kaux + 1 + tbiaux(kaux) = orient(jaux)*codeen(iaux,laux) + 2711 continue + 271 continue +c +c + else +c +c 2.8. ==> Probleme +c + codret = 28 +c + endif +c + endif +c +c==== +c 3. Quand il peut y avoir une description par arete, on complete +c le tableau avec les premieres valeurs de la connectivite +c pour optimiser le remplissage et utiliser le dimensionnement +c habituel des entites, nbento +c Une entite a nbrfac faces et nbrare aretes. +c La connectivite descendante ecrite dans le fichier med +c est dimensionnee a nbento*nbrfac. +c Dans esece2, on remplit donc le tableau avec deux parties : +c . La connectivite descendante proprement dite, soit +c nbencf*nbrfac variables. +c . La connectivite par aretes des nbenca entites decrites, en +c se limitant aux nbrfac premieres, soit nbenca*nbrfac +c variables. +c Cela fait bien en tout nbento*nbrfac = (nbencf+nbenca)*nbrfac +c On ecrit dans esecs5 la fin des descriptions par aretes, +c donc au dela de la nbrfac-ieme. +c Exemple : les pyramides sont decrites par 5 faces ou 8 aretes. +c Pour toutes celles decrites par aretes, on met ici les numeros +c de leurs 5 premieres aretes. Les autres seront geres avec les +c profils dans esecs5 +c La lecture est faite dans eslee1. +c==== +c + if ( nbenca.gt.0 ) then +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1, nbenca +c + do 311, jaux = 1, nbrfma + kaux = kaux + 1 + tbiaux(kaux) = codear(iaux,jaux) + 311 continue +c + 31 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecen.F b/src/tool/ES_HOMARD/esecen.F new file mode 100644 index 00000000..430ed3f5 --- /dev/null +++ b/src/tool/ES_HOMARD/esecen.F @@ -0,0 +1,370 @@ + subroutine esecen ( idfmed, nomamd, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des ENtites +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECEN' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nbfami.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer numdt, numit + integer ltbiau, tbiaux(*) +c + character*8 nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer typenh, typgeo, typent + integer nbenti, nbencf, nbenca, nbnfma, numfam + integer adcode, adcoar, adhist + integer adnivo, admere, adfill + integer adenho + integer adinsu, lginsu + integer adins2, lgins2 + integer adnoim + integer addera, adinfg + integer adfami, adcofa + integer psomar +c + character*8 nhenti +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des mailles.'')' + texte(1,5) = '(/,''... '',a)' +c + texte(2,4) = '(''. Writings of meshes.'')' + texte(2,4) = '(/,''... '',a)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Ecriture type par type +c==== +c + do 21 , typenh = 0 , 7 +c +c 2.1. ==> decodage des caracteristiques +c + if ( codret.eq.0 ) then +c + nbenca = 0 +c + if ( typenh.eq.0 ) then + nbenti = nbmpto + nhenti = nhmapo + nbencf = nbenti + typgeo = edpoi1 + typent = edmail + numfam = 0 + nbnfma = 1 + elseif ( typenh.eq.1 ) then + nbenti = nbarto + nbencf = nbenti + nhenti = nharet + if ( degre.eq.1 ) then + typgeo = edseg2 + nbnfma = 2 + else + typgeo = edseg3 + nbnfma = 3 + endif + typent = edaret + numfam = numfam - nbfmpo + elseif ( typenh.eq.2 ) then + nbenti = nbtrto + nbencf = nbenti + nhenti = nhtria + if ( degre.eq.1 ) then + typgeo = edtri3 + else + typgeo = edtri6 + endif + typent = edface + numfam = numfam - nbfare + nbnfma = 3 + elseif ( typenh.eq.3 ) then + nbenti = nbteto + nbencf = nbtecf + nbenca = nbteca + nhenti = nhtetr + if ( degre.eq.1 ) then + typgeo = edtet4 + else + typgeo = edte10 + endif + typent = edmail + numfam = numfam - nbftri + nbnfma = 4 + elseif ( typenh.eq.4 ) then + nbenti = nbquto + nbencf = nbenti + nhenti = nhquad + if ( degre.eq.1 ) then + typgeo = edqua4 + else + typgeo = edqua8 + endif + typent = edface + numfam = numfam - nbftet + nbnfma = 4 + elseif ( typenh.eq.5 ) then + nbenti = nbpyto + nbencf = nbpycf + nbenca = nbpyca + nhenti = nhpyra + if ( degre.eq.1 ) then + typgeo = edpyr5 + else + typgeo = edpy13 + endif + typent = edmail + numfam = numfam - nbfqua + nbnfma = 5 + elseif ( typenh.eq.6 ) then + nbenti = nbheto + nbencf = nbhecf + nbenca = nbheca + nhenti = nhhexa + if ( degre.eq.1 ) then + typgeo = edhex8 + else + typgeo = edhe20 + endif + typent = edmail + numfam = numfam - nbfpyr + nbnfma = 6 + else + nbenti = nbpeto + nbencf = nbpecf + nbenca = nbpeca + nhenti = nhpent + if ( degre.eq.1 ) then + typgeo = edpen6 + else + typgeo = edpe15 + endif + typent = edmail + numfam = numfam - nbfhex + nbnfma = 5 + endif +c + endif +c +c 2.2. ==> Determination de toutes les adresses possibles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,4,typenh) + write (ulsort,90002) 'nbenti, nbencf, nbenca', + > nbenti, nbencf, nbenca + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbnfma', nbnfma +#endif +c + if ( nbenti.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD22', nompro +#endif + call utad22 ( nhenti, + > adcode, adcoar, adhist, + > adnivo, admere, adfill, + > adenho, + > adinsu, lginsu, + > adins2, lgins2, + > adnoim, + > addera, adinfg, + > adfami, adcofa, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.1 ) then + psomar = adcode + endif +c + endif +c +c 2.3. ==> ecriture des connectivites +c + if ( codret.eq.0 ) then +c + if ( nbenti.gt.0 ) then +c + jaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECE0', nompro +#endif + call esece0 ( idfmed, nomamd, + > jaux, typgeo, typent, + > nbenti, nbencf, nbenca, nbnfma, + > imem(psomar), + > imem(adcode), imem(adinsu), imem(adcoar), + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret ) +c + endif +c + endif +cgn call gmprsx(nompro,nhenti//'.HistEtat') +cgn call gmprsx(nompro,nhenti//'.Niveau ') +cgn call gmprsx(nompro,nhenti//'.InfoSupp') +c +c 2.3. ==> ecriture des complements +c + if ( codret.eq.0 ) then +c + if ( nbenti.gt.0 ) then +c + jaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECE1', nompro +#endif + call esece1 ( idfmed, nomamd, + > jaux, typgeo, typent, + > nbenti, nbencf, nbenca, + > adfami, adhist, + > adnivo, admere, + > adenho, + > adinsu, lginsu, + > adins2, lgins2, + > adnoim, + > addera, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecf0.F b/src/tool/ES_HOMARD/esecf0.F new file mode 100644 index 00000000..3a643115 --- /dev/null +++ b/src/tool/ES_HOMARD/esecf0.F @@ -0,0 +1,341 @@ + subroutine esecf0 ( idfmed, nomamd, + > typenh, nbfent, numfam, nhenti, + > tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des Familles d'une entite - 0 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbfent . e . 1 . nombre de familles d'entites (cf. nbfami) . +c . numfam . es . 1 . numerotation des familles . +c . nhenti . e . char*8 . objet decrivant l'entite . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECF0' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, nbfent, numfam + integer tbiaux(*) +c + character*64 nomamd + character*8 nhenti +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbgrox + parameter (nbgrox = 10 ) +c + integer iaux, jaux, kaux, laux + integer cptr, kfin, reste + integer codre1 + integer adcofa + integer adcoen + integer nbcode, ngro +c + character*8 saux08 + character*80 nomgro(nbgrox) + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des'',i4,'' familles des '',a)' + texte(1,5) = '(''... Ecriture de la'',i4,''-ieme famille'')' + texte(1,6) = '(''Probleme de dimensionnement de nomgro.'')' +c + texte(2,4) = '(''. Writings of'',i4,'' families for '',a)' + texte(2,5) = '(''... Writings of the'',i4,''-th family'')' + texte(2,6) = '(''Error in size of array nomgro.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbfent, mess14(langue,3,typenh) + call gmprsx ( nompro, nhenti//'.Famille' ) + call gmprsx ( nompro, nhenti//'.Famille.Codes' ) +cc call gmprsx ( nompro, nhenti//'.Famille.Groupe' ) +#endif +c +c==== +c 2. Gestion de la memoire +c==== +c 2.1. ==> Determination des adresses +c 2.1.1. ==> pour les noeuds +c + if ( typenh.lt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 7 + call utad01 ( iaux, nhenti, + > jaux, + > jaux, adcofa, jaux, + > jaux, jaux, jaux, jaux, + > ulsort, langue, codret ) +c +c 2.1.2. ==> pour les mailles +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02', nompro +#endif + iaux = 37 + call utad02 ( iaux, nhenti, + > jaux, jaux, jaux, jaux, + > jaux, adcofa, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Nombre de codes definissant les familles +c + if ( codret.eq.0 ) then +c + call gmliat ( nhenti//'.Famille', 2, nbcode, codre1 ) +c + codret = max ( codret, + > abs(codre1) ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbcode', nbcode +#endif +c + endif +c +c==== +c 3. Ecritures +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Ecritures ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + adcoen = adcofa - 1 + do 31 , iaux = 1 , nbfent +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) iaux + call gmprsx ( nompro, nhenti//'.Famille.Codes' ) +#endif +c + if ( codret.eq.0 ) then +c +c fabrication du numero de la famille a ecrire +c + if ( typenh.lt.0 ) then + numfam = numfam + 1 + else + numfam = numfam - 1 + endif +c +c fabrication du nom de la famille a ecrire +c + call utench ( numfam, '_', jaux, saux08, + > ulsort, langue, codret ) +c + saux64 = blan64 + saux64(1:2) = suffix(3,typenh)(1:2) + saux64( 3:10) = saux08 +c +c les valeurs entieres a memoriser +c . le numero de la famille + tbiaux(1) = iaux +c +c . les nctfen codes definissant les familles + do 311 , jaux = 1, nbcode + tbiaux(jaux+1) = imem(adcoen+jaux) + 311 continue + adcoen = adcoen + nbcode +c + endif +c +c fabrication d'un nom de groupe contenant ces valeurs +c . Les 8 1ers caracteres sont 'Attribut' obligatoirement, pour +c se reperer dans le dump +c . Les caracteres de 2 a nbcode+1 sont les nbcode codes +c convertis en chaine +c Remarque : cela suppose qu'il n'y a pas plus de 9 codes +c et que chaque code est inferieur a 10**8 +c +c nombre de paquets +c + if ( codret.eq.0 ) then +c + reste = mod(nbcode+1,9) + ngro = (nbcode+1-reste)/9 + if ( reste.gt.0 ) then + ngro = ngro + 1 + endif + if ( ngro.gt.nbgrox ) then + codret = 31 + endif +cgn write(ulsort,*) 'Famille : ', saux64 +cgn write(ulsort,90002) 'nbcode ', nbcode +cgn write(ulsort,90002) 'reste ', reste +cgn write(ulsort,90002) 'ngro ', ngro +c + endif +c + if ( codret.eq.0 ) then +c + cptr = 0 + do 312 , jaux = 1, ngro +c + nomgro(jaux) = blan80 +c 12345678 + nomgro(jaux)(1:8) = 'Attribut' + if ( jaux.lt.ngro .or. reste.eq.0 ) then + kfin = 9 + else + kfin = reste + endif + do 3121 , kaux = 1, kfin + cptr = cptr + 1 + call utench ( tbiaux(cptr), 'd', laux, saux08, + > ulsort, langue, codret ) + nomgro(jaux)(8*kaux+1:8*(kaux+1)) = saux08 + 3121 continue + 312 continue +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Famille : ', saux64 + write(ulsort,90002) 'nbcode', nbcode + if ( nbcode.gt.0 ) then + write(ulsort,90002) '.', (tbiaux(jaux),jaux=1,nbcode+1) + endif + write(ulsort,90002) 'ngro', ngro + write(ulsort,*) nomgro +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomamd, saux64, numfam, + > ngro, nomgro, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mfacre', codret + endif +c + endif +c + 31 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.31 ) then + write(ulsort,90002) 'ngro ', ngro + write(ulsort,90002) 'nbgrox', nbgrox + write (ulsort,texte(langue,6)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecfd.F b/src/tool/ES_HOMARD/esecfd.F new file mode 100644 index 00000000..2cd8450a --- /dev/null +++ b/src/tool/ES_HOMARD/esecfd.F @@ -0,0 +1,459 @@ + subroutine esecfd ( idfmed, + > nocdfr, + > ltbiau, tbiaux, ltbsau, tbsaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des Frontieres Discretes +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nocdfr . e . char8 . nom de l'objet description de la frontiere . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ltbsau . e . 1 . longueur allouee a tbsaux . +c . tbsaux . . * . tableau tampon caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECFD' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "motcle.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ltbiau, tbiaux(ltbiau) + integer ltbsau +c + character*8 nocdfr + character*8 tbsaux(ltbsau) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer lnomaf + integer adabsc, psomse, psegli, pnumli, ptypli, pgeoco + integer lgpttg, lgtabl + integer pttgrl, ptngrl, pointl + integer sfsdim, sfmdim, sfnbso, sfnbli, sfnbse + integer ngro +c + character*8 typobs + character*64 saux64 + character*64 nomamd + character*64 nomafr + character*64 noprof + character*200 sau200 +c + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des frontieres discretes.'')' + texte(1,5) = '(5x,''Ecriture de la frontiere discrete '',a)' +c + texte(2,4) = '(''. Writings of discrete boundaries.'')' + texte(2,5) = '(5x,''Writing of the discrete boundary '',a)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +cgn call gmprsx (nompro, nocdfr ) +cgn call gmprsx (nompro, nocdfr//'.CoorNoeu' ) +cgn call gmprsx (nompro, nocdfr//'.NumeLign' ) +cgn call gmprsx (nompro, nocdfr//'.PtrSomLi' ) +cgn call gmprsx (nompro, nocdfr//'.SommSegm' ) +cgn call gmprsx (nompro, nocdfr//'.AbsCurvi' ) +cgn call gmprsx (nompro, nocdfr//'.Groupes' ) +c +c==== +c 2. Caracteristique de la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. nom de la frontiere ; codret', codret +#endif +c +c 2.1. ==> Recuperation du nom du maillage de la frontiere +c + typobs = mccnmf + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomafr, lnomaf, + > jaux, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,5)) nomafr(1:lnomaf) +c + endif +c +c 2.2. ==> Adresses +c + if ( codret.eq.0 ) then +c + call gmliat ( nocdfr, 1, sfsdim, codre1 ) + call gmliat ( nocdfr, 2, sfmdim, codre2 ) + call gmliat ( nocdfr, 3, sfnbso, codre3 ) + call gmliat ( nocdfr, 4, sfnbli, codre4 ) + call gmliat ( nocdfr, 5, sfnbse, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sfsdim', sfsdim + write (ulsort,90002) 'sfmdim', sfmdim + write (ulsort,90002) 'sfnbso', sfnbso + write (ulsort,90002) 'sfnbli', sfnbli + write (ulsort,90002) 'sfnbse', sfnbse +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 ) + call gmadoj ( nocdfr//'.NumeLign', pnumli, iaux, codre2 ) + call gmadoj ( nocdfr//'.TypeLign', ptypli, iaux, codre3 ) + call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre4 ) + call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre5 ) + call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( nocdfr//'.Groupes', iaux, + > lgpttg, lgtabl, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgpttg', lgpttg + write (ulsort,90002) 'lgtabl', lgtabl +#endif +c +c==== +c 3. Creation d'un maillage pour les coordonnees des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. coordonnees des noeuds ; codret', codret +#endif +c +c 3.1. ==> Creation du maillage +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. Creation maillage 1 ; codret', codret +#endif +c +c 123456789012345678901 + sau200 = 'La frontiere discrete' + do 31 , iaux = 1 , 40 + tbsaux(iaux) = blan08 + 31 continue + tbsaux( 1) = 'NomCo ' + tbsaux(10)(8:8) = '0' + tbsaux(11) = 'UniteCo ' + tbsaux(21) = sau200(01:08) + tbsaux(22) = sau200(09:16) + tbsaux(23) = sau200(17:24) + tbsaux(31) = 'NOMAMD ' + call utchs8 ( nomafr, lnomaf, tbsaux(32), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMM0', nompro +#endif + call esemm0 ( idfmed, nomafr, + > sfsdim, sfmdim, sau200, + > 4, tbsaux, + > ulsort, langue, codret) +c + endif +c +c 3.2. ==> Ecriture des coordonnees et des familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. Coordonnees ; codret', codret +#endif +c +c 3.2.1. ==> Familles des noeuds +c Le tableau sert a stocker la description des lignes +c + if ( codret.eq.0 ) then +c + do 321 , iaux = 1 , sfnbso + tbiaux(iaux) = 0 + 321 continue + tbiaux(1) = sfnbli + do 322 , iaux = 0 , sfnbli-1 + tbiaux(iaux+2) = imem(pnumli+iaux) + 322 continue + do 323 , iaux = 0 , sfnbli-1 + tbiaux(iaux+sfnbli+2) = imem(ptypli+iaux) + 323 continue + do 324 , iaux = 0 , sfnbli + tbiaux(iaux+2*sfnbli+2) = imem(psegli+iaux) + 324 continue +cgn write(ulsort,*) (tbiaux(iaux), iaux=1, 3*(sfnbli+1)) +c +c 3.2.2. ==> Ecriture +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMNO', nompro +#endif + call esemno ( idfmed, nomafr, + > sfnbso, sfsdim, rmem(pgeoco), tbiaux, + > ednodt, ednoit, edundt, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Creation d'un maillage pour les abscisses curvilignes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Abscisses curvilignes ; codret', codret +#endif +c +c 4.1. ==> Creation d'un pseudo-maillage +c Le nom doit etre coherent avec eslmh2 +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. Creation maillage 2 ; codret', codret +#endif +c + nomamd = blan64 + nomamd(1:8) = 'AbsCurvi' +c + sau200 = 'Abscisses curvilignes' +c 12345678901234567890123 + do 41 , iaux = 1 , 40 + tbsaux(iaux) = blan08 + 41 continue + tbsaux( 1) = 'NomCo ' + tbsaux(10)(8:8) = '0' + tbsaux(11) = 'UniteCo ' + tbsaux(21) = sau200(01:08) + tbsaux(22) = sau200(09:16) + tbsaux(23) = sau200(17:24) + tbsaux(31) = 'NOMAMD ' + tbsaux(32) = nomamd(1:8) +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMM0', nompro +#endif + call esemm0 ( idfmed, nomamd, + > iaux, iaux, sau200, + > 4, tbsaux, + > ulsort, langue, codret) +c + endif +c +c 4.2. ==> Ecriture des coordonnees et des familles +c La famille sert a stocker le lien sommet/segment +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. Coordonnees ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMNO', nompro +#endif + call esemno ( idfmed, nomamd, + > sfnbse, iaux, rmem(adabsc), imem(psomse), + > ednodt, ednoit, edundt, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Les groupes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Groupes ; codret', codret +#endif +c +c 5.1. ==> Creation d'un profil pour les valeurs entieres +c + if ( codret.eq.0 ) then +c + tbiaux(1) = lgpttg + tbiaux(2) = lgtabl + do 511 , iaux = 0 , lgpttg + tbiaux(iaux+3) = imem(pointl+iaux) + 511 continue + jaux = lgpttg+3 + do 512 , iaux = 1 , lgtabl + tbiaux(jaux+iaux) = imem(pttgrl+iaux-1) + 512 continue +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) (tbiaux(iaux),iaux=1,3+lgpttg+lgtabl) +#endif +c + noprof = blan64 +c 1234567890123456789012 + noprof(1:22) = 'Groupes_des_frontieres' +c + iaux = 3 + lgpttg + lgtabl +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) iaux +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, iaux, tbiaux, codret ) +c + endif +c +c 5.2. ==> Creation d'une famille pour les noms des groupes +c + if ( codret.eq.0 ) then +c + jaux = mod(lgtabl,10) + if ( jaux.eq.0 ) then + iaux = lgtabl/10 + else + iaux = (lgtabl-jaux)/10 + 1 + endif + ngro = iaux + 1 +c + do 521 , iaux = 1 , lgtabl + tbsaux(iaux) = smem(ptngrl+iaux-1) + 521 continue +c + do 522 , iaux = lgtabl+1 , 10*ngro + tbsaux(iaux) = blan08 + 522 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ngro', ngro + do 524 , iaux = 1 , ngro + write(ulsort,*) (tbsaux(10*(iaux-1)+jaux)//'+',jaux=1,10) + 524 continue +#endif +c + iaux = 1 + saux64 = blan64 +c 1234567 + saux64(1:7) = 'Groupes' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomafr, saux64, iaux, + > ngro, tbsaux, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecfe.F b/src/tool/ES_HOMARD/esecfe.F new file mode 100644 index 00000000..801df0c1 --- /dev/null +++ b/src/tool/ES_HOMARD/esecfe.F @@ -0,0 +1,194 @@ + subroutine esecfe ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > numfam, + > tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des Familles des Entites +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . numfam . s . 1 . plus petit numero de famille . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECFE' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nbfami.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer tbiaux(*) + integer numfam +c + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer typenh +c + character*8 nhenti +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des familles'')' +c + texte(2,4) = '(''. Writings of families'')' +c + 1000 format('... ',a,' : ',i8) +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Ecriture type par type +c==== +c + do 21 , typenh = -1 , 7 +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nhenti = nhnoeu + iaux = nbfnoe + numfam = 0 + elseif ( typenh.eq.0 ) then + nhenti = nhmapo + iaux = nbfmpo + numfam = 0 + elseif ( typenh.eq.1 ) then + nhenti = nharet + iaux = nbfare + elseif ( typenh.eq.2 ) then + nhenti = nhtria + iaux = nbftri + elseif ( typenh.eq.3 ) then + nhenti = nhtetr + iaux = nbftet + elseif ( typenh.eq.4 ) then + nhenti = nhquad + iaux = nbfqua + elseif ( typenh.eq.5 ) then + nhenti = nhpyra + iaux = nbfpyr + elseif ( typenh.eq.6 ) then + nhenti = nhhexa + iaux = nbfhex + else + nhenti = nhpent + iaux = nbfpen + endif +c + if ( iaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,1000) 'nbfent', iaux +#endif +c + jaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECF0', nompro +#endif + call esecf0 ( idfmed, nomamd, + > jaux, iaux, numfam, nhenti, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecfs.F b/src/tool/ES_HOMARD/esecfs.F new file mode 100644 index 00000000..902e5338 --- /dev/null +++ b/src/tool/ES_HOMARD/esecfs.F @@ -0,0 +1,292 @@ + subroutine esecfs ( idfmed, nomamd, + > nhsups, + > numfam, + > ltbsau, tbsaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des Familles Supplementaires +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . nhsups . e . char*8 . informations supplementaires caracteres 8 . +c . numfam . es . 1 . numero de famille . +c . ltbsau . e . 1 . longueur allouee a tbsaux . +c . tbsaux . . * . tableau tampon caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECFS' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer numfam + integer ltbsau +c + character*8 nhsups + character*64 nomamd + character*8 tbsaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux + integer codre1, codre2 + integer codre0 + integer adress, nbval + integer ngro +c + character*2 saux02 + character*32 saux32 + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''. Ecriture des familles supplementaires'')' + texte(1,5) = '(''... InfoSupS.Tab'',i2)' + texte(1,81) = '(''Longueur allouee pour tbsaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbsaux : '',i10)' +c + texte(2,4) = '(''. Writings of aditional families'')' + texte(2,5) = '(''... InfoSupS.Tab'',i2)' + texte(2,81) = '(''Allocated length for tbsaux : '',i10)' + texte(2,82) = '(''Used length for tbsaux : '',i10)' +c +#include "impr03.h" +c + 1002 format(10(a8,'+')) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + call gmprsx ( nompro, nhsups ) + call gmprsx ( nompro, nhsups//'.Tab2' ) + call gmprsx ( nompro, nhsups//'.Tab3' ) + call gmprsx ( nompro, nhsups//'.Tab4' ) + call gmprsx ( nompro, nhsups//'.Tab10' ) +c +#endif +c +c==== +c 2. Ecriture +c==== +c + do 21 , iaux = 1 , 10 +c +c 2.1. ==> decodage des caracteristiques +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. ==> decodage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) iaux +#endif +c + jaux = iaux + call utench ( jaux, 'g', kaux, saux02, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmobal ( nhsups//'.Tab'//saux02(1:kaux), codre0 ) +c + if ( codre0.eq.2 ) then +c + call gmliat ( nhsups, jaux, nbval, codre1 ) + call gmadoj ( nhsups//'.Tab'//saux02(1:kaux), + > adress, kaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + else + goto 21 + endif +c + endif +c +c 2.2. ==> creation de la famille eventuelle +c La convention MED veut que le nom d'un groupe soit +c de taille 80 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. ==> creation ; codret', codret +#endif +cgn call gmprsx ( nompro, nhsups//'.Tab'//saux02 ) +c + if ( nbval.gt.0 ) then +c +c 2.2.1. ==> controle +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbval', nbval +#endif +c + if ( (nbval+11).gt.ltbsau ) then + call gmprsx ( nompro, nhsups ) + write (ulsort,texte(langue,81)) ltbsau + write (ulsort,texte(langue,82)) nbval+11 + write (ulsort,*) 'Probleme pour Tab', saux02 + codret = 7 + endif +c + endif +c +c 2.2.2. ==> un premier groupe : le nombre de valeurs +c + if ( codret.eq.0 ) then +c + call utench ( nbval, 'd', jaux, saux32, + > ulsort, langue, codret ) +c + tbsaux(1) = 'Nombre d' + tbsaux(2) = 'e valeur' + tbsaux(3) = 's : ' + tbsaux(4) = saux32( 1: 8) + tbsaux(5) = saux32( 9:16) + tbsaux(6) = saux32(17:24) + tbsaux(7) = saux32(25:32) + do 222 , jaux = 8, 10 + tbsaux(jaux) = blan08 + 222 continue +c + endif +c +c 2.2.3. ==> les groupes suivants : le texte +c + if ( codret.eq.0 ) then +c + kaux = mod(nbval,10) + if ( kaux.eq.0 ) then + jaux = nbval/10 + else + jaux = (nbval-kaux)/10 + 1 + endif + ngro = jaux + 1 +c + do 2231 , jaux = 1 , nbval + tbsaux(10+jaux) = smem(adress+jaux-1) + 2231 continue +c + do 2232 , jaux = 10+nbval+1 , 10*ngro + tbsaux(jaux) = blan08 + 2232 continue +c + endif +c +c 2.2.4. ==> ecriture +c + if ( codret.eq.0 ) then +c + numfam = numfam - 1 + saux64 = blan64 +c 123456789012 + saux64( 1:12) = 'InfoSupS_Tab' + saux64(13:14) = saux02 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Famille ', saux64 + write (ulsort,90002) 'ngro', ngro + do 224 , jaux = 1 , ngro + write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux) + 224 continue +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomamd, saux64, numfam, + > ngro, tbsaux, codret ) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecig.F b/src/tool/ES_HOMARD/esecig.F new file mode 100644 index 00000000..4d7bad2c --- /dev/null +++ b/src/tool/ES_HOMARD/esecig.F @@ -0,0 +1,190 @@ + subroutine esecig ( idfmed, + > nhelig, + > tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des elements IGnores +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nhelig . e . char8 . nom de l'objet decrivant les ignores . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECIG' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "envca1.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer tbiaux(0:*) +c + character*8 nhelig +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer nbelig + integer nbnoel + integer hfmdel, hnoeel +c + character*64 noprof +c + integer codre1, codre2, codre3 + integer codre0 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des elements ignores.'')' +c + texte(2,4) = '(''. Writings of additional information.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +cgn call gmprsx (nompro, nhelig ) +cgn call gmprsx (nompro, nhelig//'.ConnNoeu' ) +cgn call gmprsx (nompro, nhelig//'.FamilMED' ) +c +c==== +c 2. Recuperation des adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. adresses ; codret = ', codret +#endif +c + call gmliat ( nhelig, 1, nbelig, codre1 ) + call gmadoj ( nhelig//'.ConnNoeu', hnoeel, iaux, codre2 ) + call gmadoj ( nhelig//'.FamilMED', hfmdel, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), + > codre1, codre2, codre3 ) +c +c==== +c 3. Ecriture vraie +c==== +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then + nbnoel = 5 + else + nbnoel = 13 + endif +c + tbiaux(0) = nbelig + do 211 , iaux = 1 , nbelig + tbiaux(iaux) = imem(hfmdel+iaux-1) + 211 continue + jaux = nbelig*nbnoel + do 212 , iaux = 1 , jaux + tbiaux(nbelig+iaux) = imem(hnoeel+iaux-1) + 212 continue +c + noprof = blan64 +c 1234567890123456 + noprof(1:16) = 'Elements_Ignores' +c + iaux = nbelig*(nbnoel+1) + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) iaux +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, iaux, tbiaux, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecn1.F b/src/tool/ES_HOMARD/esecn1.F new file mode 100644 index 00000000..ad67286b --- /dev/null +++ b/src/tool/ES_HOMARD/esecn1.F @@ -0,0 +1,304 @@ + subroutine esecn1 ( idfmed, nomamd, + > adhist, adarno, + > adhono, addera, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des Noeuds - 1 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . 1 . nom du maillage MED voulu . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECN1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "enti01.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer adhist, adarno + integer adhono, addera + integer numdt, numit + integer ltbiau, tbiaux(*) +c + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbcmax + parameter ( nbcmax = 20 ) +c + integer iaux, jaux, kaux, laux + integer adress(nbcmax) + integer nbcomp +c + character*16 dtunit + character*16 nomcmp(nbcmax), unicmp(nbcmax) + character*64 nomcha +c + logical prem +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des complements pour les noeuds'')' +c + texte(2,4) = '(''... Writings of additional terms for nodes'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Creation du champ : '',a64)' + texte(1,5) = '(''Type du champ : '',i2)' + texte(1,6) = + > '(''Numero ! Composante ! Unite'',/,49(''-''))' + texte(1,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(1,81) = '(''Longueur allouee pour tbiaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbiaux : '',i10)' +c + texte(2,4) = '(/,''Creation of field : '',a64)' + texte(2,5) = '(''Type of field : '',i2)' + texte(2,6) = + > '('' # ! Component ! Unit'',/,49(''-''))' + texte(2,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(2,81) = '(''Allocated length for tbiaux : '',i10)' + texte(2,82) = '(''Used length for tbiaux : '',i10)' +c +c 1.2. ==> unites : non definies +c + if ( prem ) then +c + do 12 , iaux = 1 , nbcmax + unicmp(iaux) = blan16 + 12 continue + prem = .false. +c + endif +c +c==== +c 2. Reperage des composantes en fonction de la presence des tableaux +c==== +c + if ( codret.eq.0 ) then +c + nbcomp = 0 +c +c 1234567890123456 + if ( adhist.ne.0 ) then + nbcomp = nbcomp + 1 + adress(nbcomp) = adhist + nomcmp(nbcomp) = 'HistEtat ' + endif +c + if ( adarno.ne.0 ) then + nbcomp = nbcomp + 1 + adress(nbcomp) = adarno + nomcmp(nbcomp) = 'AretSupp ' + endif +c + if ( adhono.ne.0 ) then + nbcomp = nbcomp + 1 + adress(nbcomp) = adhono + nomcmp(nbcomp) = 'Homologu ' + endif +c + if ( addera.ne.0 ) then + nbcomp = nbcomp + 1 + adress(nbcomp) = addera + nomcmp(nbcomp) = 'Deraffin ' + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,85)) nbcomp +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbnoto*nbcomp.gt.ltbiau ) then + write (ulsort,texte(langue,85)) nbcomp + write (ulsort,texte(langue,81)) ltbiau + write (ulsort,texte(langue,82)) nbnoto*nbcomp + codret = 7 + endif +c + endif +c +c==== +c 3. Ecritures +c==== +c + if ( nbcomp.gt.0 ) then +c +c 3.1. ==> Creation du champ +c + if ( codret.eq.0 ) then +c + nomcha = blan64 + nomcha(1:8) = suffix(3,-1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha + write (ulsort,texte(langue,5)) edint + write (ulsort,texte(langue,6)) + do 31 , iaux = 1 , nbcomp + write (ulsort,texte(langue,7)) iaux, nomcmp(iaux), unicmp(iaux) + 31 continue +#endif +c + iaux = edint + dtunit = blan16 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDCRE', nompro +#endif + call mfdcre ( idfmed, nomcha, iaux, + > nbcomp, nomcmp, unicmp, dtunit, nomamd, codret ) +c + endif +c + endif +c +c 3.2. ==> Le tableau des valeurs du champ, en mode non entrelace. +c En fortran, cela correspond au stockage memoire suivant : +c tbiaux(1,1), tbiaux(2,1), tbiaux(3,1), ..., tbiaux(nbnoto,1), +c tbiaux(1,2), tbiaux(2,2), tbiaux(3,2), ..., tbiaux(nbnoto,2), +c ... +c tbiaux(1,nbcomp), tbiaux(2,nbcomp), ..., tbiaux(nbnoto,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +c + if ( codret.eq.0 ) then +c + do 32 , iaux = 1 , nbcomp +c + kaux = nbnoto*(iaux-1) + laux = adress(iaux)-1 + do 321 , jaux = 1 , nbnoto + tbiaux(kaux+jaux) = imem(laux+jaux) + 321 continue +c + 32 continue +c + endif +c +c 3.3. ==> Ecriture des valeurs du champ +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIVW', nompro +#endif + call mfdivw ( idfmed, nomcha, + > numdt, numit, instan, + > ednoeu, iaux, ednoin, edall, + > nbnoto, tbiaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,19)) nomcha + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecno.F b/src/tool/ES_HOMARD/esecno.F new file mode 100644 index 00000000..d1231ab2 --- /dev/null +++ b/src/tool/ES_HOMARD/esecno.F @@ -0,0 +1,195 @@ + subroutine esecno ( idfmed, nomamd, + > nhnoeu, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des NOeuds +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECNO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer numdt, numit + integer ltbiau, tbiaux(*) +c + character*8 nhnoeu + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer adcoor, adhist, adarno + integer adhono, addera + integer adcoco, adinfg + integer adreco + integer adfami, adcofa +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des noeuds.'')' +c + texte(2,4) = '(''. Writings of nodes.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +ccc call gmprsx ( nompro, nhnoeu ) +ccc call gmprsx ( nompro, nhnoeu//'.HistEtat' ) +c +c==== +c 2. Adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD21', nompro +#endif + call utad21 ( nhnoeu, + > adcoor, adhist, adarno, + > adhono, addera, + > adcoco, adinfg, + > adreco, + > adfami, adcofa, + > ulsort, langue, codret ) +c +c==== +c 3. Ecritures +c==== +c 3.1. ==> Ecriture de la connectivite et des familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. connectivite ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMNO', nompro +#endif + call esemno ( idfmed, nomamd, + > nbnoto, sdim, rmem(adcoor), imem(adfami), + > numdt, numit, instan, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Ecriture des complements +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. complements ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECN1', nompro +#endif + call esecn1 ( idfmed, nomamd, + > adhist, adarno, + > adhono, addera, + > numdt, numit, instan, + > ltbiau, tbiaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecs1.F b/src/tool/ES_HOMARD/esecs1.F new file mode 100644 index 00000000..7d817b4e --- /dev/null +++ b/src/tool/ES_HOMARD/esecs1.F @@ -0,0 +1,186 @@ + subroutine esecs1 ( idfmed, + > nomail, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations Supplementaires - 1 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomail . e . char*8 . structure du maillage a ecrire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECS1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer adinsu, lginsu +c + character*2 saux02 + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des renumerotations'')' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''... Writings of numbering'')' + texte(2,7) = '(''First values : '',10i6)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Ecriture des informations supplementaires sous forme de profil +c==== +c + do 21 , iaux = 1, 10 +c +c 2.1. ==> decodage des caracteristiques +c + if ( codret.eq.0 ) then +c + jaux = iaux + call utench ( jaux, 'g', kaux, saux02, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 123456789012 + noprof(1:12) = 'InfoSupE_Tab' + noprof(13:kaux+12) = saux02(1:kaux) + call gmobal ( nomail//'.InfoSupE.Tab'//saux02(1:kaux), codret ) +c + endif +c + if ( codret.eq.2 ) then +c + call gmadoj ( nomail//'.InfoSupE.Tab'//saux02(1:kaux), + > adinsu, lginsu, codret ) +c + else +c + goto 21 +c + endif +cgn print *,saux02,lginsu +c +c 2.2. ==> Ecriture sous forme de profil +c + if ( lginsu.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) lginsu + write (ulsort,texte(langue,7)) + > (imem(jaux), jaux = adinsu, adinsu+min(9,lginsu-1)) +cgn write (ulsort,91020) (imem(jaux),jaux=adinsu,adinsu+lginsu-1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, lginsu, imem(adinsu), codret ) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecs2.F b/src/tool/ES_HOMARD/esecs2.F new file mode 100644 index 00000000..118950d8 --- /dev/null +++ b/src/tool/ES_HOMARD/esecs2.F @@ -0,0 +1,291 @@ + subroutine esecs2 ( idfmed, + > nomail, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations Supplementaires - 2 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomail . e . char*8 . structure du maillage a ecrire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECS2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer typenh + integer nbenac, nbento, adenho, adenca + integer codre0 +c + integer nbattx + parameter ( nbattx = 19 ) + integer tabaux(nbattx) +c + logical afaire +c + character*8 saux08 + character*8 norenu + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des renumerotations'')' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''... Writings of numbering'')' + texte(2,7) = '(''First values : '',10i6)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. La renumerotation existe-t-elle ? +c==== +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.RenuMail', jaux ) +c + if ( jaux.eq.1 ) then + call gmnomc ( nomail//'.RenuMail', norenu, codret ) + afaire = .true. + else + afaire = .false. + endif +c + endif +c +c==== +c 3. Ecriture des renumerotations sous forme de profil +c==== +c + if ( afaire ) then +c +c 3.1. ==> Les renumerotations des entites +c + if ( codret.eq.0 ) then +c + do 31 , typenh = -1 , 7 +c +c 3.1.1. ==> La renumerotation existe-t-elle ? +c Si non, on passe a l'entite suivante +c + if ( codret.eq.0 ) then +c + saux08 = suffix(3,typenh)(1:2)//'HOMARD' + call gmobal ( norenu//'.'//saux08, jaux ) + if ( jaux.ne.2 ) then + goto 31 + endif +c + endif +c +c 3.1.2. ==> Nombre et adresse +c + if ( codret.eq.0 ) then +c + iaux = typenh + jaux = 10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03', nompro +#endif + call utre03 ( iaux, jaux, norenu, + > nbenac, nbento, adenho, adenca, + > ulsort, langue, codret) +c + endif +c +c 3.1.3. ==> Ecriture si la longueur n'est pas nulle +c + if ( nbenac.gt.0 ) then +c + if ( codret.eq.0 ) then +c + noprof = blan64 + noprof(1:8) = saux08 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbenac + write (ulsort,texte(langue,7)) + > (imem(adenho+jaux-1), jaux = 1, min(10,nbenac)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, nbenac, imem(adenho), codret ) +c + endif +c + endif +c + 31 continue +c + endif +c +c 3.2. ==> La branche des nombres lies aux renumerotations +c 3.2.1. ==> Longueur et adresse +c + if ( codret.eq.0 ) then +c + saux08 = 'Nombres ' + call gmadoj ( norenu//'.'//saux08, jaux, kaux, codret ) +c + endif +c +c 3.2.2. ==> Ecriture +c + if ( codret.eq.0 ) then +c + noprof = blan64 + noprof(1:8) = saux08 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) kaux + write (ulsort,texte(langue,7)) (imem(jaux+iaux-1), iaux = 1, kaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, kaux, imem(jaux), codret ) +c + endif +c +c 3.3. ==> Les attributs lies aux renumerotations +c 3.3.1. ==> Les valeurs +c + if ( codret.eq.0 ) then +c + do 331 , iaux = 1 , nbattx +c + jaux = iaux + call gmliat ( norenu, jaux, kaux, codre0 ) + tabaux(iaux) = kaux +c + codret = max ( abs(codre0), codret ) +c + 331 continue +c + endif +c +c 3.3.2. ==> Ecriture +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 1234567890123456789 + noprof(1:19) = 'Attributs_de_norenu' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbattx + write (ulsort,texte(langue,7)) (tabaux(jaux), jaux = 1, nbattx) +#endif +c + kaux = nbattx +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, kaux, tabaux, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecs3.F b/src/tool/ES_HOMARD/esecs3.F new file mode 100644 index 00000000..6e8ec4a7 --- /dev/null +++ b/src/tool/ES_HOMARD/esecs3.F @@ -0,0 +1,341 @@ + subroutine esecs3 ( idfmed, + > nhnoeu, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations Supplementaires - 3 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECS3' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +#include "enti01.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 nhnoeu + character*8 nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer typenh + integer nbenti + integer codre1, codre2, codre3 + integer codre0 + integer tabaux(3) + integer adress(2), lgtab(2) + logical tabsim +c + character*1 saux01(2) + character*8 nhenti + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data saux01 / 'A', 'B' / +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des recollements'')' + texte(1,5) = '(/,''..... pour les '',a)' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''... Writings of gluing'')' + texte(2,5) = '(/,''..... for '',a)' + texte(2,7) = '(''First values : '',10i6)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Ecriture par type des recollements sous forme de profil +c==== +c + do 20 , typenh = -1 , 7 +c +c 2.1. ==> decodage des caracteristiques +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nbenti = nbnoto + nhenti = nhnoeu + elseif ( typenh.eq.0 ) then + nbenti = nbmpto + nhenti = nhmapo + elseif ( typenh.eq.1 ) then + nbenti = nbarto + nhenti = nharet + elseif ( typenh.eq.2 ) then + nbenti = nbtrto + nhenti = nhtria + elseif ( typenh.eq.3 ) then + nbenti = nbteto + nhenti = nhtetr + elseif ( typenh.eq.4 ) then + nbenti = nbquto + nhenti = nhquad + elseif ( typenh.eq.5 ) then + nbenti = nbpyto + nhenti = nhpyra + elseif ( typenh.eq.6 ) then + nbenti = nbheto + nhenti = nhhexa + else + nbenti = nbpeto + nhenti = nhpent + endif +c + endif +c + if ( nbenti.eq.0 ) then + goto 20 + endif +c +c 2.2. ==> Le recollement existe-t-il ? +c Si non, on passe a l'entite suivante +c + if ( codret.eq.0 ) then +c + call gmobal ( nhenti//'.Recollem', codre0 ) + if ( codre0.eq.1 ) then + tabsim = .false. + elseif ( codre0.eq.2 ) then + tabsim = .true. + else + goto 20 + endif +c + endif +c +c 2.3. ==> decodage dans le cas d'un objet simple +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,typenh) +#endif +c +c 2.3.1. ==> decodage dans le cas d'un objet simple +c + if ( tabsim ) then +c + if ( codret.eq.0 ) then +c +cc call gmprsx ( nompro, nhenti ) +cc call gmprsx ( nompro, nhenti//'.Recollem' ) + call gmadoj ( nhenti//'.Recollem', + > adress(1), lgtab(1), codre0 ) +c + codret = max ( abs(codre0), codret ) + lgtab(2) = 0 +c + endif +c + else +c +c 2.3.2. ==> decodage dans le cas d'un objet structure +c + if ( codret.eq.0 ) then +c + call gmliat ( nhenti//'.Recollem', 1, tabaux(1), codre1 ) + call gmliat ( nhenti//'.Recollem', 2, tabaux(2), codre2 ) + call gmliat ( nhenti//'.Recollem', 3, tabaux(3), codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( tabaux(1).gt.0 ) then +c + call gmadoj ( nhenti//'.Recollem.ListeA', + > adress(1), lgtab(1), codre1 ) + call gmadoj ( nhenti//'.Recollem.ListeB', + > adress(2), lgtab(2), codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + else +c + lgtab(1) = 0 + lgtab(2) = 0 +c + endif +c + endif +c + endif +c +c 2.4. ==> Ecriture +c + noprof = blan64 + noprof(1:2) = suffix(3,typenh)(1:2) +c 3456789012 + noprof(3:12) = '_Recollem_' +c +c 2.4.1. ==> Ecriture des attributs de l'objet structure +c + if ( .not.tabsim ) then +c + if ( codret.eq.0 ) then +c +c 345678901 + noprof(13:21) = 'Attributs' +c + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) iaux + write (ulsort,texte(langue,7))(tabaux(jaux),jaux=1,min(iaux,10)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW_attributs', nompro +#endif + call mpfprw ( idfmed, noprof, iaux, tabaux, codret ) +c + endif +c + endif +c +c 2.4.2. ==> Ecriture des listes +c + do 242 , iaux = 1 , 2 +c + if ( lgtab(iaux).gt.0 ) then +c + if ( codret.eq.0 ) then +c +c 34567 8 901 + noprof(13:21) = 'Liste'//saux01(iaux)//' ' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) lgtab(iaux) + write (ulsort,texte(langue,7)) + >(imem(adress(iaux+jaux)),jaux=0,min(lgtab(iaux)-1,9)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW_'//saux01(iaux), nompro +#endif + call mpfprw ( idfmed, noprof, + > lgtab(iaux), imem(adress(iaux)), codret ) +c + endif +c + endif +c + 242 continue +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecs4.F b/src/tool/ES_HOMARD/esecs4.F new file mode 100644 index 00000000..bf76c9f2 --- /dev/null +++ b/src/tool/ES_HOMARD/esecs4.F @@ -0,0 +1,169 @@ + subroutine esecs4 ( idfmed, + > coocst, + > numdt, numit, instan, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations Supplementaires - 4 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . coocst . e . 1 . coordonnee constante eventuelle . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECS4' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer numdt, numit +c + double precision coocst + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux +c + character*16 dtunit + character*64 novals + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture de la dimension constante '',g15.8)' + texte(1,5) = '(/,''..... pour les '',a)' +c + texte(2,4) = '(''... Writings of constant dimension '',g15.8)' + texte(2,5) = '(/,''..... for '',a)' +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) coocst +#endif +c +c==== +c 2. Ecriture sous forme de valeur scalaire +c==== +c +c 2.1. ==> Creation de la variable scalaire +c + if ( codret.eq.0 ) then +c + novals = blan64 +c 1234567890123 + novals(1:13) = 'Dim_Constante' +c + jaux = edfl64 + sau200(1:64) = novals + do 21 , iaux = 65 , 200 + sau200(iaux:iaux) = ' ' + 21 continue + dtunit = blan16 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPRCRE', nompro +#endif + call mprcre ( idfmed, novals, jaux, sau200, dtunit, codret ) +c + endif +c +c 2.2. ==> Ecriture de la valeur +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPRRVW', nompro +#endif + call mprrvw ( idfmed, novals, numdt, numit, instan, + > coocst, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) coocst +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecs5.F b/src/tool/ES_HOMARD/esecs5.F new file mode 100644 index 00000000..42563654 --- /dev/null +++ b/src/tool/ES_HOMARD/esecs5.F @@ -0,0 +1,263 @@ + subroutine esecs5 ( idfmed, + > nhtetr, nhhexa, nhpyra, nhpent, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations Supplementaires - 5 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECS5' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +#include "enti01.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer typenh + integer nbencf, nbenca, nbrfac, nbrare + integer codre0 + integer adcoar + integer indmin +c + character*2 saux02 + character*8 nhenti + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Ecriture des connectivites par aretes'')' + texte(1,5) = '(/,''..... pour les '',a)' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''... Writings of connectivities by edges'')' + texte(2,5) = '(/,''..... for '',a)' + texte(2,7) = '(''First values : '',10i6)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Ecriture par type des connectivites par aretes sous forme de profil +c==== +c + do 20 , typenh = 3 , 7 +c +c 2.1. ==> decodage des caracteristiques +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.3 ) then + nbencf = nbtecf + nbenca = nbteca + nbrfac = 4 + nbrare = 6 + nhenti = nhtetr + elseif ( typenh.eq.4 ) then + nbencf = 0 + nbenca = 0 + elseif ( typenh.eq.5 ) then + nbencf = nbpycf + nbenca = nbpyca + nbrfac = 5 + nbrare = 8 + nhenti = nhpyra + elseif ( typenh.eq.6 ) then + nbencf = nbhecf + nbenca = nbheca + nbrfac = 6 + nbrare = 12 + nhenti = nhhexa + else + nbencf = nbpecf + nbenca = nbpeca + nbrfac = 5 + nbrare = 9 + nhenti = nhpent + endif +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,3,typenh)//' nbenca', nbenca +#endif +c + if ( nbenca.eq.0 ) then + goto 20 + endif +c +c 2.3. ==> decodage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,typenh) +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.ConnAret', adcoar, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.4. ==> Ecriture pour chaque numero d'aretes +c Quand il peut y avoir une description par arete, on complete +c le tableau avec les premieres valeurs de la connectivite +c pour optimiser le remplissage et utiliser le dimensionnement +c habituel des entites, nbento +c Une entite possede nbrfac faces et nbrare aretes. +c La connectivite descendante ecrite dans le fichier med +c est dimensionnee a nbento*nbrfac. +c Dans esece2, on remplit donc le tableau avec deux parties : +c . La connectivite descendante proprement dite, soit +c nbencf*nbrfac variables. +c . La connectivite par aretes des nbenca entites decrites, en +c se limitant aux nbrfac premieres, soit nbenca*nbrfac +c variables. +c Cela fait bien en tout nbento*nbrfac = (nbencf+nbenca)*nbrfac +c On ecrit dans esecs5 la fin des descriptions par aretes, +c donc au dela de la nbrfac-ieme. +c + if ( nbencf.eq.0 ) then + indmin = 0 + else + indmin = nbrfac + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbrfac', nbrfac + write (ulsort,90002) 'nbrare', nbrare +#endif +c + do 24 , iaux = indmin + 1, nbrare +c + if ( codret.eq.0 ) then +c + if ( iaux.le.9 ) then + saux02 = '00' + write(saux02(2:2),'(i1)') iaux + else + write(saux02,'(i2)') iaux + endif + + noprof = blan64 + noprof(1:2) = suffix(3,typenh)(1:2) +c 3456789012 34 + noprof(3:14) = '_ConnAret_'//saux02 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbenca + write (ulsort,texte(langue,7)) + > (imem(adcoar+jaux), + > jaux=nbenca*(iaux-1),nbenca*(iaux-1)+min(nbenca-1,5)) +#endif +c + jaux = adcoar + nbenca*(iaux-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW '//noprof(1:13), nompro +#endif + call mpfprw ( idfmed, noprof, + > nbenca, imem(jaux), codret ) +c + endif +c + 24 continue +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esecsu.F b/src/tool/ES_HOMARD/esecsu.F new file mode 100644 index 00000000..e405cfac --- /dev/null +++ b/src/tool/ES_HOMARD/esecsu.F @@ -0,0 +1,272 @@ + subroutine esecsu ( idfmed, + > nomail, + > nhnoeu, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > infmgl, + > dimcst, coocst, + > numdt, numit, instan, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : ECriture des informations SUpplementaires +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomail . e . char*8 . structure du maillage a ecrire . +c . infmgl . e . 0:* . 0 : nombre d'informations . +c . . . . >0 : informations maillage globales . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . e . 1 . coordonnee constante eventuelle . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECSU' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer infmgl(0:*) + integer numdt, numit + integer dimcst +c + character*8 nomail + character*8 nhnoeu + character*8 nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + double precision coocst + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des informations supplementaires.'')' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''. Writings of additional information.'')' + texte(2,7) = '(''First values : '',10i6)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +c==== +c 2. Ecriture des informations entieres sous forme de profil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. infos entieres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECS1', nompro +#endif + call esecs1 ( idfmed, + > nomail, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. Ecriture des informations globales sous forme de profil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. infos globales ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 1234567890123456789012 + noprof(1:22) = 'Info_maillage_globales' + iaux = infmgl(0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) iaux + write (ulsort,texte(langue,7)) (infmgl(jaux), jaux = 1, iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, iaux, infmgl(1), codret ) +c + endif +c +c==== +c 4. Ecriture des renumerotations sous forme de profil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. renumerotations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECS2', nompro +#endif + call esecs2 ( idfmed, + > nomail, + > ulsort, langue, codret) +c + endif +c +c==== +c 5. Ecriture des recollements sous forme de profil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. recollements ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECS3', nompro +#endif + call esecs3 ( idfmed, + > nhnoeu, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > ulsort, langue, codret) +c + endif +c +c==== +c 6. Ecriture de la dimension constante sous forme de variable scalaire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. dimcst ; codret', codret +#endif +c + if ( dimcst.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECS4', nompro +#endif + call esecs4 ( idfmed, + > coocst, + > numdt, numit, instan, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 7. Ecriture des connectivites par aretes sous forme de profil +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. connectivite/aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECS5', nompro +#endif + call esecs5 ( idfmed, + > nhtetr, nhhexa, nhpyra, nhpent, + > ulsort, langue, codret) +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esemh0.F b/src/tool/ES_HOMARD/esemh0.F new file mode 100644 index 00000000..638a7cdc --- /dev/null +++ b/src/tool/ES_HOMARD/esemh0.F @@ -0,0 +1,387 @@ + subroutine esemh0 ( nomail, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Ecriture du Maillage Homard - 0 +c - - - - - - +c ______________________________________________________________________ +c Attention : esemh0 et eslmh3 doivent evoluer en parallelle +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char*8 . nom du maillage a ecrire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMH0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer adinse + integer codre1, codre2 +c + logical existe(2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Enregistrement des communs.'')' +c + texte(2,4) = '(''Recording of the commons'')' +c +#include "impr03.h" +c +c==== +c 2. controle des allocations deja presentes +c comme elles n'ont pu se faire qu'ici, on ne verifie pas les tailles +c==== +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomail ) + call gmprsx (nompro, nomail//'.InfoSupE' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab1' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab2' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab3' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab4' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab5' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab6' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab7' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab8' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab9' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab10' ) + call gmprsx (nompro, nomail//'.InfoSupS' ) + call gmprsx (nompro, nomail//'.InfoSupS.Tab2' ) + call gmprsx (nompro, nomail//'.InfoSupS.Tab3' ) + call gmprsx (nompro, nomail//'.InfoSupS.Tab4' ) + call gmprsx (nompro, nomail//'.InfoSupS.Tab5' ) + call gmprsx (nompro, nomail//'.InfoSupS.Tab10' ) +#endif +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.InfoSupE.Tab1', codre1 ) + if ( codre1.eq.2 ) then + existe(1) = .true. + elseif ( codre1.eq.0 ) then + existe(1) = .false. + else + codret = 2 + endif +C + call gmobal ( nomail//'.InfoSupE.Tab2', codre2 ) + if ( codre2.eq.2 ) then + call gmdtoj ( nomail//'.InfoSupE.Tab2', codret ) + elseif ( codre2.ne.0 ) then + codret = 2 + endif +c + endif +c +c==== +c 3. Allocations de la branche pour les informations en entier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3 allocation : codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( .not.existe(1) ) then + iaux = 12 + 2 + 12 + 12 + 9 + 22 + 9 + 9 + 18 + 9 + 8 + 27 + 5 + call gmaloj ( nomail//'.InfoSupE.Tab1', + > ' ', iaux, adinse, codret ) + else + call gmadoj ( nomail//'.InfoSupE.Tab1', adinse, iaux, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nomail//'.InfoSupE', 1, iaux, codret ) +c + endif +c +c==== +c 4. transfert des infos des communs vers la structure +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4 transfert : codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = adinse - 1 +c nombno + imem(iaux+1) = nbnois + imem(iaux+2) = nbnoei + imem(iaux+3) = nbnoma + imem(iaux+4) = nbnomp + imem(iaux+5) = nbnop1 + imem(iaux+6) = nbnop2 + imem(iaux+7) = nbnoim + imem(iaux+8) = nbnoto + imem(iaux+9) = nbpnho + imem(iaux+10) = numip1 + imem(iaux+11) = numap1 + imem(iaux+12) = nbnoin + iaux = iaux + 12 +c nombmp + imem(iaux+1) = nbmpto + imem(iaux+2) = nbppho + iaux = iaux + 2 +c nombar + imem(iaux+1) = nbarac + imem(iaux+2) = nbarde + imem(iaux+3) = nbart2 + imem(iaux+4) = nbarq2 + imem(iaux+5) = nbarq3 + imem(iaux+6) = nbarq5 + imem(iaux+7) = nbarin + imem(iaux+8) = nbarma + imem(iaux+9) = nbarpe + imem(iaux+10) = nbarto + imem(iaux+11) = nbfaar + imem(iaux+12) = nbpaho + iaux = iaux + 12 +c nombtr + imem(iaux+1) = nbtrac + imem(iaux+2) = nbtrde + imem(iaux+3) = nbtrt2 + imem(iaux+4) = nbtrq3 + imem(iaux+5) = nbtrhc + imem(iaux+6) = nbtrpc + imem(iaux+7) = nbtrtc + imem(iaux+8) = nbtrma + imem(iaux+9) = nbtrpe + imem(iaux+10) = nbtrto + imem(iaux+11) = nbptho + imem(iaux+12) = nbtrri + iaux = iaux + 12 +c nombqu + imem(iaux+1) = nbquac + imem(iaux+2) = nbqude + imem(iaux+3) = nbquma + imem(iaux+4) = nbquq2 + imem(iaux+5) = nbquq5 + imem(iaux+6) = nbqupe + imem(iaux+7) = nbquto + imem(iaux+8) = nbpqho + imem(iaux+9) = nbquri + iaux = iaux + 9 +c nombte + imem(iaux+1) = nbteac + imem(iaux+2) = nbtea2 + imem(iaux+3) = nbtea4 + imem(iaux+4) = nbtede + imem(iaux+5) = nbtef4 + imem(iaux+6) = nbteh1 + imem(iaux+7) = nbteh2 + imem(iaux+8) = nbteh3 + imem(iaux+9) = nbteh4 + imem(iaux+10) = nbtep0 + imem(iaux+11) = nbtep1 + imem(iaux+12) = nbtep2 + imem(iaux+13) = nbtep3 + imem(iaux+14) = nbtep4 + imem(iaux+15) = nbtep5 + imem(iaux+16) = nbtedh + imem(iaux+17) = nbtedp + imem(iaux+18) = nbtema + imem(iaux+19) = nbtepe + imem(iaux+20) = nbteto + imem(iaux+21) = nbtecf + imem(iaux+22) = nbteca + iaux = iaux + 22 +c nombhe + imem(iaux+1) = nbheac + imem(iaux+2) = nbheco + imem(iaux+3) = nbhede + imem(iaux+4) = nbhedh + imem(iaux+5) = nbhema + imem(iaux+6) = nbhepe + imem(iaux+7) = nbheto + imem(iaux+8) = nbhecf + imem(iaux+9) = nbheca + iaux = iaux + 9 +c nombpe + imem(iaux+1) = nbpeac + imem(iaux+2) = nbpeco + imem(iaux+3) = nbpede + imem(iaux+4) = nbpedp + imem(iaux+5) = nbpema + imem(iaux+6) = nbpepe + imem(iaux+7) = nbpeto + imem(iaux+8) = nbpecf + imem(iaux+9) = nbpeca + iaux = iaux + 9 +c nombpy + imem(iaux+1) = nbpyac + imem(iaux+2) = nbpyh1 + imem(iaux+3) = nbpyh2 + imem(iaux+4) = nbpyh3 + imem(iaux+5) = nbpyh4 + imem(iaux+6) = nbpyp0 + imem(iaux+7) = nbpyp1 + imem(iaux+8) = nbpyp2 + imem(iaux+9) = nbpyp3 + imem(iaux+10) = nbpyp4 + imem(iaux+11) = nbpyp5 + imem(iaux+12) = nbpydh + imem(iaux+13) = nbpydp + imem(iaux+14) = nbpyma + imem(iaux+15) = nbpype + imem(iaux+16) = nbpyto + imem(iaux+17) = nbpycf + imem(iaux+18) = nbpyca + iaux = iaux + 18 +c nbfami + imem(iaux+1) = nbfnoe + imem(iaux+2) = nbfmpo + imem(iaux+3) = nbfare + imem(iaux+4) = nbftri + imem(iaux+5) = nbfqua + imem(iaux+6) = nbftet + imem(iaux+7) = nbfhex + imem(iaux+8) = nbfpyr + imem(iaux+9) = nbfpen + iaux = iaux + 9 +c dicfen + imem(iaux+ 1) = ncffno + imem(iaux+ 2) = ncffmp + imem(iaux+ 3) = ncffar + imem(iaux+ 4) = ncfftr + imem(iaux+ 5) = ncffqu + imem(iaux+ 6) = ncffte + imem(iaux+ 7) = ncffhe + imem(iaux+ 8) = ncffpy + imem(iaux+ 9) = ncffpe + imem(iaux+10) = ncefno + imem(iaux+11) = ncefmp + imem(iaux+12) = ncefar + imem(iaux+13) = nceftr + imem(iaux+14) = ncefqu + imem(iaux+15) = nctfno + imem(iaux+16) = nctfmp + imem(iaux+17) = nctfar + imem(iaux+18) = nctftr + imem(iaux+19) = nctfqu + imem(iaux+20) = nctfte + imem(iaux+21) = nctfhe + imem(iaux+22) = nctfpy + imem(iaux+23) = nctfpe + imem(iaux+24) = ncxfno + imem(iaux+25) = ncxfar + imem(iaux+26) = ncxftr + imem(iaux+27) = ncxfqu + iaux = iaux + 27 +c envada + imem(iaux+1) = nbiter + imem(iaux+2) = nivinf + imem(iaux+3) = nivsup + imem(iaux+4) = niincf + imem(iaux+5) = nisucf + iaux = iaux + 5 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres remplissage InfoSupE : codret', + > codret + call gmprsx (nompro, nomail ) + call gmprsx (nompro, nomail//'.InfoSupE' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab1' ) + call gmprsx (nompro, nomail//'.InfoSupE.Tab2' ) +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esemh1.F b/src/tool/ES_HOMARD/esemh1.F new file mode 100644 index 00000000..1090ee0a --- /dev/null +++ b/src/tool/ES_HOMARD/esemh1.F @@ -0,0 +1,557 @@ + subroutine esemh1 ( nomail, nomfic, lnomfi, + > optecr, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhsups, + > suifro, nocdfr, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Ecriture du Maillage Homard - 1 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char*8 . nom du maillage a ecrire . +c . nomfic . e .char*(*). nom du fichier . +c . lnomfi . e . 1 . longueur du nom du fichier . +c . optecr . e . 1 . option d'ecriture . +c . . . . >0 : on ecrit la frontiere discrete . +c . . . . <0 : on n'ecrit pas la frontiere discrete . +c . nhsups . e . char*8 . informations supplementaires caracteres 8 . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nocdfr . e . char8 . nom de l'objet description de la frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMH1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "dicfen.h" +#include "envex1.h" +#include "envca1.h" +#include "nbutil.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lnomfi + integer optecr + integer suifro +c + character*8 nomail, nhsups + character*(*) nomfic +c + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent, nhelig + character*8 nocdfr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux + integer codre0 + integer codre1, codre2, codre3 + integer*8 idfmed + integer ltrav1, ltrav2 + integer ptrav1, ptrav2 + integer dimcst, lgnoig, nbnoco + integer adcocs + integer infmgl(0:30) + integer nbpqt + integer adinss + integer numdt, numit + integer sfnbso +c + character*8 ntrav1, ntrav2 + character*64 nomamd + character*80 saux80 + character*200 sau200 +c + double precision instan +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Ecriture complete.'')' + texte(1,5) = '(''Ecriture sans les frontieres.'')' +c + texte(2,4) = '(''Full writings.'')' + texte(2,5) = '(''Writings without any boundary.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( optecr.gt.0 ) then + iaux = 4 + else + iaux = 5 + endif + write (ulsort,texte(langue,iaux)) +#endif +c +#include "esimpr.h" +c +c 1.2. ==> tableaux de travail +c + jaux = 0 + do 12 , iaux = 1 , 10 + call gmliat ( nhsups, iaux, kaux, codre0 ) + if ( codre0.eq.0 ) then + jaux = max(jaux,kaux) + else + codret = codre0 + endif + 12 continue +c + if ( codret.eq.0 ) then +c + if ( mod(suifro,2).eq.0 ) then + call gmliat ( nocdfr, 3, sfnbso, codret ) + else + sfnbso = 0 + codre2 = 0 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre elements ignores', nbelig + write (ulsort,90002) 'Noeuds de la frontiere ', sfnbso +#endif +c + if ( codret.eq.0 ) then +c + ltrav1 = max ( 4*nbnoto, + > nbmpto, 5*nbarto, 5*nbtrto, 6*nbteto, 5*nbquto, + > 7*nbpyto, 8*nbheto, 5*nbpeto, 14*nbelig+1, + > sfnbso ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> ltrav1', ltrav1 +#endif + call gmalot ( ntrav1, 'entier ', ltrav1 , ptrav1, codre1 ) +c +c A TRAITER pas clair le +11 ... + ltrav2 = 25*( max ( nctfno, nctfmp, nctfar, nctftr, nctfqu, + > nctfte, nctfpy, nctfhe, nctfpe, 40 ) + 11 ) + ltrav2 = max ( ltrav2, jaux+11 ) + call gmalot ( ntrav2, 'chaine ', ltrav2 , ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 1.2. ==> Instants d'enregistrement du maillage +c + if ( codret.eq.0 ) then +c + numdt = ednodt + numit = ednoit + instan = edundt +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'fichier', nomfic(1:lnomfi) + write (ulsort,90003) 'nomail',nomail + write (ulsort,90002) 'numdt ',numdt + write (ulsort,90002) 'numit ',numit + write (ulsort,90004) 'dt ',instan +#endif +c + endif +c +c==== +c 2. ouverture en mode d'ecrasement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. ouverture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFIOPE', nompro +#endif + call mfiope ( idfmed, nomfic(1:lnomfi), edcrea, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,9)) + endif +c + endif +c +c==== +c 3. description du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. description fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + saux80 = blan80 + saux80(1:54) = + > 'Maillage au format HOMARD avec gestion des historiques' +c 123456789012345678901234567890123456789012345678901234 +c 12345678901234567890 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESDESC', nompro +#endif + call esdesc ( idfmed, saux80, sau200, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. creation du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. creation maillage ; codret', codret + write (ulsort,90002) 'sdim', sdim + write (ulsort,90002) 'mdim', mdim +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhsups//'.Tab3', adinss, iaux, codre1 ) + call gmliat ( nhsups, 1, iaux, codre2 ) + nbpqt = iaux - 1 +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + nomamd = blan64 + nomamd(1:8) = nomail +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMM0', nompro +#endif + call esemm0 ( idfmed, nomamd, + > sdim, mdim, sau200, + > nbpqt, smem(adinss), + > ulsort, langue, codret) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'ESEMM0', codret + endif +c + endif +c +c==== +c 5. Ecriture des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Ecriture des noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECNO', nompro +#endif + call esecno ( idfmed, nomamd, + > nhnoeu, + > numdt, numit, instan, + > ltrav1, imem(ptrav1), + > ulsort, langue, codret) +c + endif +c +c==== +c 6. Ecriture des entites mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Ecriture des mailles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECEN', nompro +#endif + call esecen ( idfmed, nomamd, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > numdt, numit, instan, + > ltrav1, imem(ptrav1), + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. Ecriture des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Ecriture des familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMH2', nompro +#endif + call esemh2 ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsups, + > ltrav1, imem(ptrav1), ltrav2, smem(ptrav2), + > ulsort, langue, codret) +c + endif +c +c==== +c 8. Ecriture des informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Informations supp ; codret', codret +#endif +c 8.1. ==> informations globales au maillage +c + if ( codret.eq.0 ) then +c + call gmliat ( nhnoeu, 2, dimcst, codre1 ) + call gmliat ( nhnoeu, 3, lgnoig, codre2 ) + call gmliat ( nhnoeu, 4, nbnoco, codre3) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c +c envca1 + divers + infmgl( 1) = sdim + infmgl( 2) = mdim + infmgl( 3) = degre + infmgl( 4) = maconf + infmgl( 5) = homolo + infmgl( 6) = hierar + infmgl( 7) = rafdef + infmgl( 8) = nbmane + infmgl( 9) = typcca + infmgl(10) = typsfr + infmgl(11) = maextr + infmgl(12) = mailet + infmgl(13) = dimcst + infmgl(14) = lgnoig + infmgl(15) = nbnoco +c nbutil + infmgl(16) = sdimca + infmgl(17) = mdimca +c + infmgl(0) = 17 +c + endif +c +c 8.2. ==> Une coordonnee constante ? +c + if ( codret.eq.0 ) then +c + if ( dimcst.gt.0 ) then +c + call gmadoj ( nhnoeu//'.CoorCons', adcocs, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 8.3 ==> ecriture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECSU', nompro +#endif + call esecsu ( idfmed, + > nomail, + > nhnoeu, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > infmgl, + > dimcst, rmem(adcocs), + > numdt, numit, instan, + > ulsort, langue, codret ) +c + endif +c +c==== +c 9. Ecriture des eventuels elements ignores +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. Elements ignores ; codret', codret +#endif +c + if ( nbelig.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECIG', nompro +#endif + call esecig ( idfmed, + > nhelig, + > imem(ptrav1), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. Ecriture de l'eventuelle frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. Frontiere discrete ; codret', codret +#endif +c + if ( mod(suifro,2).eq.0 .and. optecr.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECFD', nompro +#endif + call esecfd ( idfmed, + > nocdfr, + > ltrav1, imem(ptrav1), ltrav2, smem(ptrav2), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 11. fermeture du fichier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. fermeture du fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo ( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c +c==== +c 12. menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 13. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esemh2.F b/src/tool/ES_HOMARD/esemh2.F new file mode 100644 index 00000000..9e167e91 --- /dev/null +++ b/src/tool/ES_HOMARD/esemh2.F @@ -0,0 +1,245 @@ + subroutine esemh2 ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsups, + > ltbiau, tbiaux, ltbsau, tbsaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Ecriture du Maillage Homard - 2 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e .char64 . nom du maillage MED voulu . +c . nhsups . e . char*8 . informations supplementaires caracteres 8 . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ltbsau . e . 1 . longueur allouee a tbsaux . +c . tbsaux . . * . tableau tampon caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMH2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca2.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ltbiau, tbiaux(ltbiau) + integer ltbsau +c + character*8 tbsaux(*) + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhsups +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer ngro, numfam +c + character*64 saux64 + character*80 saux80(2) +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des familles'')' +c + texte(2,4) = '(''. Writings of families'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +#include "esimpr.h" +c +c==== +c 2. La famille nulle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. famille nulle ; codret = ', codret +#endif +c + if ( codret.eq.0) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. La famille nulle' +#endif + saux64 = blan64 +c 1234567890123 + saux64(1:13) = 'famille_nulle' + numfam = 0 + ngro = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomamd, saux64, numfam, + > ngro, saux80, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mfacre', codret + endif +c + endif +c +c==== +c 3. Les familles des entites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. entites ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECFE', nompro +#endif + call esecfe ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > numfam, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. La famille de la date et du titre +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. date et titre ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. La famille de la date et du titre' +#endif + saux64 = blan64 +c 1234567890123 + saux64(1:13) = 'date_et_titre' + numfam = numfam - 1 + ngro = 2 +c 90123456789012345678901234567890 + saux80(1) = ladate//' ' + saux80(2) = titre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomamd, saux64, numfam, + > ngro, saux80, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mfacre', codret + endif +c + endif +c +c==== +c 5. Les familles des informations complementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Info supp ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '. Familles des informations complementaires' +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECFS', nompro +#endif + call esecfs ( idfmed, nomamd, + > nhsups, + > numfam, + > ltbsau, tbsaux, + > ulsort, langue, codret) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esemho.F b/src/tool/ES_HOMARD/esemho.F new file mode 100644 index 00000000..9e8e6058 --- /dev/null +++ b/src/tool/ES_HOMARD/esemho.F @@ -0,0 +1,301 @@ + subroutine esemho ( typobs, nrosec, nretap, nrsset, + > optecr, + > suifro, nocdfr, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Ecriture du Maillage HOmard +c - - - - -- +c ______________________________________________________________________ +c tant que rien n'a change, on a archive des informations dans +c les sous-tableaux des branches InfoSupE et InfoSupS +c Entiers de InfoSupE : +c Tab1 : communs entiers +c Tab2 : type des elements +c Tab3, Tab4, Tab5 et Tab6 sont reserves au transfert +c d'informations du maillage au format MED. +c Tab10 : activation des groupes des frontieres a suivre +c Chaines de InfoSupS : +c Tab3, Tab4 et Tab5 sont reserves au transfert +c d'informations du maillage au format MED. +c Tab10 : nom des groupes des frontieres a suivre +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . char*8 . mot-cle correspondant a l'objet a ecrire . +c . nrosec . e . 1 . numero de section pour les mesures de temps. +c . nretap . e . 1 . numero d'etape . +c . nrsset . e . 1 . numero de sous-etape . +c . optecr . e . 1 . option d'ecriture . +c . . . . >0 : on ecrit la frontiere discrete . +c . . . . <0 : on n'ecrit pas la frontiere discrete . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nocdfr . e . char8 . nom de l'objet description de la frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMHO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 typobs +c + integer nrosec, nretap, nrsset + integer optecr + integer suifro +c + character*8 nocdfr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava +c + integer lnomfi +c + integer iaux, jaux +c + character*8 nomail + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + character*6 saux + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + if ( nrosec.gt.0 ) then + call gtdems (nrosec) + endif +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(//,a6,'' SAUVEGARDE DU MAILLAGE HOMARD'')' + texte(1,5) = '(36(''=''),/)' + texte(1,6) = + > '(/,5x,''Ecriture du maillage '',a,'' sur le fichier'')' + texte(1,7) = '(/,1x,''Mot-cle : '',a8)' +c + texte(2,4) = '(//,a6,'' RECORDING OF HOMARD MESH'')' + texte(2,5) = '(31(''=''),/)' + texte(2,6) = '(/,5x,''Writing of mesh '',a,'' on file'')' + texte(2,7) = '(/,1x,''Keyword : '',a8)' +c +#include "impr03.h" +c +c 1.3. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. nom du maillage et du fichier +c==== +c + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTOSNO', nompro +#endif + iaux = 0 + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,6)) nomail + write (ulsort,*) ' '//nomfic(1:lnomfi) +c + endif +c +c==== +c 3. Branche des informations entieres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Branche des entiers ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMH0', nompro +#endif + call esemh0 ( nomail, + > ulsort, langue, codret) +c + endif +c +c==== +c 4. recuperation des donnees du maillage d'entree +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. recuperation entree ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sdim', sdim + write (ulsort,90002) 'mdim', mdim +#endif +c call gmprsx(nompro, nhelig) +c call gmprsx(nompro, nhelig//'.Numero') +c call gmprsx(nompro, nhelig//'.ConnNoeu') +c call gmprsx(nompro, nhelig//'.Type') +c call gmprsx(nompro, nhelig//'.FamilMED') +c +c==== +c 5. appel du programme utilitaire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. appel de esemh1 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMH1', nompro +#endif + call esemh1 ( nomail, nomfic, lnomfi, + > optecr, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhsups, + > suifro, nocdfr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. La fin ; codret', codret +#endif +c +c 6.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,7)) typobs + codret = 7 +c + endif +c +c 6.2. ==> fin des mesures de temps de la section +c + if ( nrosec.gt.0 ) then + call gtfims (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/ES_HOMARD/esle01.F b/src/tool/ES_HOMARD/esle01.F new file mode 100644 index 00000000..a7222477 --- /dev/null +++ b/src/tool/ES_HOMARD/esle01.F @@ -0,0 +1,265 @@ + subroutine esle01 ( idfmed, nomamd, nomcha, + > nbcomp, nomcmp, unicmp, + > optio1, optio2, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture noeud-maille - 01 +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED . +c . nomcha . e . char64 . nom du champ MED voulu . +c . nbcomp . s . 1 . nombre de composantes du champ . +c . nomcmp . s . * . nom des composantes du champ . +c . unicmp . s . * . unite des composantes du champ . +c . optio1 . e . * . 0 : erreur si le champ n'est pas trouve . +c . . . . 1 : pas de probleme . +c . optio2 . s . 1 . 0 ou 1 selon la presence du champ . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLE01' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer optio1, optio2 + integer nbcomp +c + character*16 nomcmp(*), unicmp(*) + character*64 nomamd + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer nbchfi, nrocha + integer typcha + integer nbseq +c + character*16 dtunit + character*64 nomch0 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Lecture du champ : '',a64)' + texte(1,5) = '(''Type du champ : '',i2)' + texte(1,6) = + > '(''Numero ! Composante ! Unite'',/,49(''-''))' + texte(1,7) = '(i6,'' ! '',a16,'' ! '',a16)' +c + texte(2,4) = '(/,''Readings of field: '',a64)' + texte(2,5) = '(''Type of field: '',i2)' + texte(2,6) = + > '('' # ! Component ! Unit'',/,49(''-''))' + texte(2,7) = '(i6,'' ! '',a16,'' ! '',a16)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha +#endif +c +#include "esimpr.h" +c +c 1.2. ==> champ absent a priori +c + optio2 = 0 +c +c==== +c 2. Lectures +c==== +c 2.1. ==> nombre de champs dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFD', nompro +#endif + call mfdnfd ( idfmed, nbchfi, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbchfi', nbchfi +#endif +c + endif +c + do 20 , nrocha = 1 , nbchfi +c +c 2.2. ==> nombre de composantes du champ courant +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFC', nompro +#endif + iaux = nrocha + call mfdnfc ( idfmed, iaux, nbcomp, codret ) +c + endif +c +c 2.3. ==> lecture du nom du champ, des noms et des unites +c de ses composantes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDFDI', nompro +#endif +c + nomch0 = blan64 + iaux = nrocha + jaux = edtrue + call mfdfdi ( idfmed, iaux, nomch0, nomamd, jaux, + > typcha, nomcmp, unicmp, + > dtunit, nbseq, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,93020) 'caracteristiques du champ', nomch0 + write (ulsort,texte(langue,5)) typcha + write (ulsort,texte(langue,6)) + do 231 , iaux = 1 , nbcomp + write (ulsort,texte(langue,7)) iaux, nomcmp(iaux), unicmp(iaux) + 231 continue + endif +#endif +c + endif +c +c 2.4. ==> Si c'est le bon, on sort +c + if ( codret.eq.0 ) then +c + if ( nomch0.eq.nomcha ) then +c + if ( typcha.ne.edint ) then + codret = 231 + endif + if ( nbseq.ne.1 ) then + write (ulsort,90002) 'nbseq ', nbseq + codret = 232 + goto 30 + endif +c + optio2 = 1 + goto 40 +c + endif +c + endif +c + 20 continue +c +c==== +c 2.5. ==> Impossible de trouver le bon champ +c==== +c + 30 continue +c + if ( optio1.eq.0 ) then +c + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,92)) + write (ulsort,90002) 'Nombre de champs presents', nbchfi + do 301 , nrocha = 1 , nbchfi + iaux = nrocha + call mfdnfc ( idfmed, iaux, nbcomp, codret ) + nomch0 = blan64 + jaux = edtrue + call mfdfdi ( idfmed, iaux, nomch0, nomamd, jaux, + > typcha, nomcmp, unicmp, + > dtunit, nbseq, codret ) + write (ulsort,texte(langue,32)) nomch0 + write (ulsort,texte(langue,5)) typcha + 301 continue + codret = 1 +c + endif +c +c==== +c 4. la fin +c==== +c + 40 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esle02.F b/src/tool/ES_HOMARD/esle02.F new file mode 100644 index 00000000..2d038116 --- /dev/null +++ b/src/tool/ES_HOMARD/esle02.F @@ -0,0 +1,404 @@ + subroutine esle02 ( idfmed, + > typenh, nhenti, nbenca, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture noeud-maille - 02 +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenti . e . char*8 . objet decrivant l'entite . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLE02' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "impr02.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh + integer nbenca +c + character*8 nhenti +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux, laux + integer nbprof + integer nbvapr, adins2 + integer typpro + integer adcoar + integer codre1, codre2, codre3 + integer codre0 + integer tabaux(3) +c + character*1 saux01(2) + character*64 noprof + character*64 saux64 +c + logical afaire +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data saux01 / 'A', 'B' / +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des profils pour les '',a)' +c + texte(2,4) = '(''... Readings of profiles for '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbenca', nbenca +#endif +c +c==== +c 2. Lecture sous forme de profil pour les informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Lecture profil ; codret', codret +#endif +c 2.1. ==> Nombre de profils +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFNPF', nompro +#endif + call mpfnpf ( idfmed, nbprof, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) nbprof +#endif +c + endif +c +c 2.2. ==> Parcours des profils +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. ==> Parcours profil ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + afaire = .true. +c + do 22 , iaux = 1 , nbprof +c +c 2.2.1. ==> nom et taille du profil a lire +#ifdef _DEBUG_HOMARD_ + write (ulsort,90032) 'Profil numero', iaux +#endif +c + if ( codret.eq.0 ) then +c + jaux = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPFI', nompro +#endif + call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr +#endif +c + endif +c +c 2.2.2. ==> On ne continue que pour les informations supplementaires, +c les recollements ou les connectivites par arete +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.2. suite ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + typpro = 0 + saux64 = blan64 +c 12 34567890 + saux64(1:10) = suffix(3,typenh)(1:2)//'InfoSup2' + if ( noprof.eq.saux64 ) then + typpro = -1 + endif +c + if ( typpro.eq.0 ) then +c + saux64 = blan64 +c 12 3456789012 + saux64(1:12) = suffix(3,typenh)(1:2)//'_Recollem_' + if ( noprof(1:12).eq.saux64(1:12) ) then + typpro = -2 + endif +c + endif +c + if ( typpro.eq.0 ) then +c + saux64 = blan64 +c 12 3456789012 + saux64(1:12) = suffix(3,typenh)(1:2)//'_ConnAret_' + if ( noprof(1:12).eq.saux64(1:12) ) then + read ( noprof(13:14) , fmt='(i2)' ) typpro + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typpro', typpro + if ( typpro.gt.0 ) then + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr + endif +#endif +c + endif +c +c 2.2.3. ==> informations supplementaires +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.3. infos compl. ; codret', codret + write (ulsort,90002) 'typpro', typpro +#endif +c + if ( codret.eq.0 ) then +c + if ( typpro.eq.-1 ) then +c +c 2.2.3.1. ==> Allocation du tableau receptacle +c + if ( codret.eq.0 ) then + call gmaloj ( nhenti//'.InfoSup2', ' ', + > nbvapr, adins2, codret ) + endif +c +c 2.2.3.2. ==> Lecture de la liste des valeurs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR pour InfoSup2', nompro +#endif + call mpfprr ( idfmed, noprof, imem(adins2), codret ) +c + endif +c +c 2.2.4. ==> recollements +c + elseif ( typpro.eq.-2 ) then +c +c 2.2.4.1. ==> Allocation de la structure generale si maille +c + if ( codret.eq.0 ) then +c + if ( afaire ) then + if ( typenh.ge.0 ) then + call gmaloj ( nhenti//'.Recollem', ' ', 0, jaux, codret ) + endif + afaire = .false. + endif +c + endif +c +c 2.2.4.2. ==> Attributs +c +c 345678901 + saux64(13:21) = 'Attributs' + if ( noprof.eq.saux64 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR / '//saux64, nompro +#endif + call mpfprr ( idfmed, noprof, tabaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhenti//'.Recollem', 1, tabaux(1), codre1 ) + call gmecat ( nhenti//'.Recollem', 2, tabaux(2), codre2 ) + call gmecat ( nhenti//'.Recollem', 3, tabaux(3), codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + endif +c +c 2.2.4.3. ==> listes +c + if ( typenh.ge.0 ) then + laux = 2 + else + laux = 1 + endif +c + do 2243 , jaux = 1 , laux +c +c 34567 8 901 + saux64(13:21) = 'Liste'//saux01(jaux)//' ' + if ( noprof.eq.saux64 ) then +c + if ( codret.eq.0 ) then +c + if ( typenh.ge.0 ) then + call gmaloj ( nhenti//'.Recollem.Liste'//saux01(jaux), + > ' ', nbvapr, kaux, codret ) + else + call gmaloj ( nhenti//'.Recollem', + > ' ', nbvapr, kaux, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR / '//saux64, nompro +#endif + call mpfprr ( idfmed, noprof, imem(kaux), codret ) +c + endif +c + endif +c + 2243 continue +c +c 2.2.5. ==> suite de la connectivite par aretes +c + elseif ( typpro.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.ConnAret', adcoar, jaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c + jaux = adcoar + nbenca*(typpro-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR / '//noprof, nompro +#endif + call mpfprr ( idfmed, noprof, imem(jaux), codret ) +cgn write(ulsort,*) imem(jaux) +c + endif +c + endif +c + endif +c + 22 continue +c + endif +cgn call gmprsx ( nompro,nhenti//'.ConnAret' ) +cgn call gmprsx ( nompro,nhenti//'.Recollem' ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esle03.F b/src/tool/ES_HOMARD/esle03.F new file mode 100644 index 00000000..aec3f7e9 --- /dev/null +++ b/src/tool/ES_HOMARD/esle03.F @@ -0,0 +1,223 @@ + subroutine esle03 ( idfmed, + > nbnoto, sdim, coonoe, dimcst, + > coocst, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture - 03 +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nbnoto . e . 1 . nombre total de noeuds . +c . sdim . e . 1 . dimension du maillage HOMARD . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . coocst . s . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLE03' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbnoto, sdim, dimcst +c + double precision coonoe(nbnoto,sdim) + double precision coocst(11) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer numdt, numit +c + double precision daux +c + character*64 novals +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''... Coordonnes extremes'')' + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' +c + texte(2,5) = '(''... Extreme coordinates'')' + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) +#endif +c +#include "esimpr.h" +c +c==== +c 2. Si une des coordonnees est constante, lecture de la valeur +c sous forme de valeur scalaire +c==== +c + if ( dimcst.gt.0 ) then +c + novals = blan64 +c 1234567890123 + novals(1:13) = 'Dim_Constante' +c + numdt = ednodt + numit = ednoit +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPRRVR', nompro +#endif + call mprrvr ( idfmed, novals, numdt, numit, + > daux, codret ) +c + if ( codret.eq.0 ) then + coocst(1) = daux + endif +c + endif +c +c==== +c 3. Les extrema +c==== +c 3.1. ==> La fonction de calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMMCO', nompro +#endif + call utmmco ( coocst(2), coocst(5), coocst(8), + > nbnoto, sdim, coonoe, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Un rangement different si la coordonnee X ou Y est constante +c + if ( codret.eq.0 ) then +c + if ( dimcst.eq.1 ) then +c +c 3.2.1. ==> x est constant : il faut decaler y en z et x en y, +c puis affecter la constante a x +c + coocst(10) = coocst(9) + coocst(9) = coocst(8) + coocst(7) = coocst(6) + coocst(6) = coocst(5) + coocst(4) = coocst(3) + coocst(3) = coocst(2) + coocst(8) = -1.d0 + coocst(5) = coocst(1) + coocst(2) = coocst(1) +c + elseif ( dimcst.eq.2 ) then +c +c 3.2.2. ==> y est constant : il faut decaler y en z, +c puis affecter la constante a y +c + coocst(10) = coocst(9) + coocst(7) = coocst(6) + coocst(4) = coocst(3) + coocst(9) = -1.d0 + coocst(6) = coocst(1) + coocst(3) = coocst(1) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + write (ulsort,texte(langue,4)) 'z', coocst(4), coocst(7) + endif +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslee0.F b/src/tool/ES_HOMARD/eslee0.F new file mode 100644 index 00000000..5f9f5a01 --- /dev/null +++ b/src/tool/ES_HOMARD/eslee0.F @@ -0,0 +1,206 @@ + subroutine eslee0 ( idfmed, nomamd, + > typenh, typgeo, typent, + > nbencf, nbenca, nbrfma, nbrama, + > codeen, coaren, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture d'une Entite - 0 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typent . e . 1 . type d'entite au sens MED . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . nbrfma . e . 1 . nbre noeuds par maille si connec. par noeud. +c . . . . nbre faces par maille si connectivite desce. +c . nbrama . e . 1 . nbre aretes par maille si volume . +c . codeen . s .nbencf**. connectivite descendante des mailles . +c . coaren . s .nbenca**. connectivite des mailles par aretes . +c . tabaux . . * . tableau tampon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEE0' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typgeo, typent + integer nbencf, nbenca, nbrfma, nbrama + integer codeen(*), coaren(*) + integer tabaux(*) +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer dim1 + integer typcon +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des '',i10,1x,a)' +c + texte(2,4) = '(''... Readings of '',i10,1x,a)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbencf, mess14(langue,3,typenh) +#endif +c +c==== +c 2. Lecture des connectivites +c==== +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.1 ) then + iaux = -nbrfma + dim1 = 2 + else + iaux = 1 + dim1 = nbencf + endif + if ( typenh.eq.0 ) then + typcon = ednoda + else + typcon = eddesc + endif +ccc write (ulsort,90002) 'typent', typent +ccc write (ulsort,90002) 'typgeo', typgeo +ccc write (ulsort,90002) 'iaux ', iaux +ccc write (ulsort,90002) 'nbencf', nbencf +ccc write (ulsort,90002) 'nbrfma, nbrama', nbrfma, nbrama +ccc write (ulsort,90002) 'dim1 ', dim1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMC', nompro +#endif + call eslmmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > iaux, nbencf, dim1, nbrfma, + > typcon, + > codeen, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Mise en place de la connectivite des volumes +c==== +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.3 .or. typenh.eq.5 .or. + > typenh.eq.6 .or. typenh.eq.7 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEE1', nompro +#endif + call eslee1 ( typenh, nbencf, nbenca, nbrfma, nbrama, + > codeen, coaren, tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslee1.F b/src/tool/ES_HOMARD/eslee1.F new file mode 100644 index 00000000..31abfccd --- /dev/null +++ b/src/tool/ES_HOMARD/eslee1.F @@ -0,0 +1,173 @@ + subroutine eslee1 ( typenh, nbencf, nbenca, nbrfma, nbrama, + > codeen, coaren, tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture d'une Entite - 1 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . nbrfma . e . 1 . nbre faces par maille si connectivite desce. +c . nbrama . e . 1 . nbre aretes par maille si volume . +c . codeen . s .nbencf**. connectivite descendante des mailles . +c . coaren . s .nbenca**. connectivite des mailles par aretes . +c . tbiaux . e . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEE1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "fahmed.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nbencf, nbenca, nbrfma, nbrama + integer codeen(nbencf,nbrfma), coaren(nbenca,nbrama) + integer tbiaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux,laux +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Connectivite pour les '',i10,1x,a)' +c + texte(2,4) = '(''... Connectivity for the '',i10,1x,a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbencf, mess14(langue,3,typenh) +#endif +c +c==== +c 2. Mise en place de la connectivite descendante +c==== +c + if ( codret.eq.0 ) then +c + kaux = 0 +c + do 21 , iaux = 1, nbencf + do 211, jaux = 1, nbrfma + laux = nofmed(typenh,jaux,1) +cgn write(ulsort,*) jaux,laux + kaux = kaux + 1 + codeen(iaux,laux) = abs(tbiaux(kaux)) + 211 continue + 21 continue +c + endif +c +c==== +c 3. Mise en place de l'eventuelle connectivite par arete +c En coherence avec l'ecriture par esece2 +c==== +c + if ( nbenca.gt.0 ) then +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1, nbenca + do 311, jaux = 1, nbrfma + kaux = kaux + 1 + coaren(iaux,jaux) = tbiaux(kaux) + 311 continue + 31 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslee2.F b/src/tool/ES_HOMARD/eslee2.F new file mode 100644 index 00000000..bcc4ac02 --- /dev/null +++ b/src/tool/ES_HOMARD/eslee2.F @@ -0,0 +1,479 @@ + subroutine eslee2 ( idfmed, nomamd, + > nhenti, + > typenh, typgeo, typent, + > nbenti, nbencf, nbenca, + > tbiaux, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture d'une Entite - 3 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . 1 . nom du maillage MED voulu . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typent . e . 1 . type d'entite au sens MED . +c . nbenti . e . 1 . nombre d'entites . +c . nbencf . e . 1 . nombre d'entites decrites par faces . +c . nbenca . e . 1 . nombre d'entites decrites par aretes . +c . tbiaux . . * . tableau tampon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEE2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "impr02.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typgeo, typent + integer nbenti, nbencf, nbenca + integer tbiaux(*) +c + character*8 nhenti + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbcmax + parameter ( nbcmax = 20 ) +c + integer iaux, jaux, kaux + integer iaux1, iaux2, iaux3 + integer nbcomp + integer adress + integer adhist + integer nbinsu + integer numdt, numit +c + character*8 saux08 + character*16 saux16 + character*16 nomcmp(nbcmax), unicmp(nbcmax) + character*64 nomcha + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des complements pour les '',a)' + texte(1,5) = + > '(''Impossible de trouver le nombre d''''infos supps.'')' +c + texte(2,4) = '(''... Readings of additional terms for '',a)' + texte(2,5) = '(''The number of info supp cannot be found'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. Lecture sous forme de champ pour les tableaux a une valeur +c par entite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Lecture champ ; codret', codret +#endif +c +c 2.1. ==> Reperage du champ et du nombre de ses composantes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLE01_'//suffix(3,typenh),nompro +#endif + nomcha = blan64 + nomcha(1:8) = suffix(3,typenh) + iaux = 0 + call esle01 ( idfmed, nomamd, nomcha, + > nbcomp, nomcmp, unicmp, + > iaux, jaux, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,90003) 'nomcmp', (nomcmp(iaux),iaux=1,nbcomp) +#endif +c +c 2.2. ==> Lecture des valeurs du champ, en mode non entrelace. +c En fortran, cela correspond au stockage memoire suivant : +c tbiaux(1,1), tbiaux(2,1), tbiaux(3,1), ..., tbiaux(nbenti,1), +c tbiaux(1,2), tbiaux(2,2), tbiaux(3,2), ..., tbiaux(nbenti,2), +c ... +c tbiaux(1,nbcomp), tbiaux(2,nbcomp), ..., tbiaux(nbenti,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. Lecture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c A TRAITER plus tard +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'MFDIVR', nompro +cgn #endif +cgn call mfdivr ( idfmed, nomcha, numdt, numit, +cgn > ednoeu, iaux, ednoin, +cgn > edall, +cgn > tbiaux, codret ) +c + numdt = ednodt + numit = ednoit + noprof = blan64 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIPR', nompro +#endif + call mfdipr ( idfmed, nomcha, numdt, numit, + > typent, typgeo, 1, noprof, ednoin, + > edall, + > tbiaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,18)) nomcha + endif +c + endif +c +c 2.3. ==> Transfert +c 2.3.1. ==> Les composantes standard +c Point special pour InfoSupp : +c . Pour les segments, c'est 1 : le numero du noeud milieu +c donc on le traite comme une composante standard +c . Pour les mailles 3D, ce sont les codes des faces dans les +c volumes ; on le traitera plus tard +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.1. Transfert standard ; codret', codret + write (ulsort,90002) 'typenh', typenh +#endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.1 ) then + saux16 = 'HistEtatNiveau ' + else + saux16 = 'InfoSupp ' + endif +c + do 231 , iaux = 1 , nbcomp +cgn write (ulsort,90016) 'nomcmp', iaux, nomcmp(iaux)//'xxxxx' +c + if ( codret.eq.0 ) then +c +c 1234567890123456 + if ( nomcmp(iaux).ne.'HistEtatNiveau ' .and. + > nomcmp(iaux).ne.saux16 ) then +c + saux08 = nomcmp(iaux)(1:8) +cgn write(ulsort,90003) 'Composante', saux08 +c + if ( codret.eq.0 ) then +c + if ( saux08.eq.'Famille ' ) then + call gmadoj ( nhenti//'.Famille.EntiFamm', + > adress, jaux, codret ) + else + call gmaloj ( nhenti//'.'//saux08, ' ', + > nbenti, adress, codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + kaux = nbenti*(iaux-1) + adress = adress - 1 + do 2311 , jaux = 1 , nbenti + imem(adress+jaux) = tbiaux(kaux+jaux) + 2311 continue +c + endif +c + endif +c + endif +c + 231 continue +c +cgn call gmprsx ( nompro,nhenti//'.Famille') +cgn call gmprsx ( nompro,nhenti//'.Famille.EntiFamm') +c + endif +c +c 2.3.2. ==> Historique et niveau rassembles (eventuellement) sur +c la premiere composante (cf. esece1). +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.2 ; Historique niveau ; codret', codret +#endif +c + if ( nomcmp(1).eq.'HistEtatNiveau ' ) then +c 1234567890123456 +c +c 2.3.2.1. ==> Historique +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.HistEtat', ' ', nbenti, adhist, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'tbiaux :' +cgn write (ulsort,91141) (iaux,tbiaux(iaux),iaux=1,nbenti) + write (ulsort,91141) (iaux,tbiaux(iaux),iaux=1,10) + write (ulsort,91141) (iaux,tbiaux(iaux),iaux=nbenti-10,nbenti) +#endif +c + adhist = adhist - 1 + do 2321 , jaux = 1 , nbenti + imem(adhist+jaux) = mod(tbiaux(jaux),1000000) + 2321 continue +c +cgn call gmprsx ( nompro,nhenti//'.HistEtat') +c + endif +c +c 2.3.2.2. ==> Puis niveau +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Niveau ', ' ', nbenti, adress, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + adress = adress - 1 + do 2322 , jaux = 1 , nbenti + imem(adress+jaux) = (tbiaux(jaux)-imem(adhist+jaux))/1000000 + 2322 continue +c +cgn call gmprsx ( nompro,nhenti//'.Niveau ') +c + endif +c + endif +c +c 2.3.3. ==> Les informations supplementaires, sauf pour les segments +c . Pour les mailles 3D, ce sont les codes des faces dans les +c volumes ; c'est un nombre compris entre 1 et 8 et il y +c a autant d'informations que de nombre des faces, +c donc 3, 4, 5 ou 6 selon le cas +c Remarque : InfoSupp est stocke sur la derniere +c composante (cf. esece1). +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.3. informations supp ; codret', codret + write (ulsort,90002) 'typenh', typenh +#endif +c + if ( typenh.ge.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90016) 'nomcmp', nbcomp, nomcmp(nbcomp)//'xxxxx' +#endif +c +c 2.3.3.1. ==> Des informations ont ete stockees +c + if (nomcmp(nbcomp).eq.'InfoSupp ' ) then +c 1234567890123456 +c +c 2.3.3.1.1. ==> Decompte du nombre d'informations +c + if ( codret.eq.0 ) then +c + nbinsu = 1 + kaux = tbiaux(nbenti*nbcomp-nbenca) +c + jaux = 1 + do 2331 , iaux = 1 , 10 +c + jaux = jaux * 10 + if ( kaux.ge.jaux ) then + nbinsu = nbinsu + 1 + else + goto 23311 + endif +c + 2331 continue +c + write (ulsort,texte(langue,5)) + codret = 1 +c +23311 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> nbinsu', nbinsu +#endif +c + endif +c +c 2.3.3.1.2. ==> Allocation +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.3.1.2 Allocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + jaux = nbencf*nbinsu + call gmaloj ( nhenti//'.InfoSupp', ' ', jaux, adress, codret ) + adress = adress - 1 +c + endif +c +c 2.3.3.1.3. ==> Transfert +c + if ( codret.eq.0 ) then +c + kaux = nbenti*(nbcomp-1) + adress = adress + nbencf*(nbinsu-1) + do 23331 , jaux = 1 , nbencf + imem(adress+jaux) = mod(tbiaux(kaux+jaux),10) +23331 continue +c + iaux1 = 10 + do 23332 , iaux = nbinsu-1, 1 , -1 +c + iaux2 = iaux1 + iaux1 = 10*iaux1 + adress = adress - nbencf + do 23333 , jaux = 1 , nbencf + iaux3 = mod(tbiaux(kaux+jaux),iaux1) + imem(adress+jaux) = ( iaux3 - mod(iaux3,iaux2) ) / iaux2 +23333 continue +c +23332 continue +c + endif +c +cgn call gmprsx ( nompro,nhenti//'.InfoSupp' ) +c +c 2.3.3.2. ==> Rien n'a ete stocke : on alloue un tableau vide pour +c les volumes +c + else +c + if ( typenh.ne.4 ) then +c + jaux = 0 + call gmaloj ( nhenti//'.InfoSupp', ' ', jaux, + > adress, codret ) +c + endif +c + endif +c + endif +c +c==== +c 3. Lecture sous forme de profil pour les informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Lecture profil ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLE02_'//mess14(langue,1,typenh), + > nompro +#endif + call esle02 ( idfmed, + > typenh, nhenti, nbenca, + > ulsort, langue, codret) +c + endif +cgn call gmprsx(nompro, nhenti//'.ConnAret') +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esleen.F b/src/tool/ES_HOMARD/esleen.F new file mode 100644 index 00000000..0df43bc9 --- /dev/null +++ b/src/tool/ES_HOMARD/esleen.F @@ -0,0 +1,429 @@ + subroutine esleen ( idfmed, nomamd, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture des ENtites +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEEN' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ltbiau, tbiaux(ltbiau) +c + character*8 nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer typenh, typgeo, typent + integer nbenti, nbencf, nbenca, nbrfma, nbrama, numfam + integer nctfen, nbfent + integer adcode, adcoar + integer adfami, adcofa + integer codre0 + integer codre1, codre2, codre3, codre4 +c + character*8 nhenti, nhenfa +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Lecture des mailles.'')' + texte(1,5) = '(''... Taille du tableau temporaire :'',i10)' + texte(1,6) = '(''.. Lecture des '',a14)' +c + texte(2,4) = '(''. Readings of meshes.'')' + texte(2,5) = '(''... Size of temporary array :'',i10)' + texte(2,6) = '(''.. Readings of the '',a14)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +c==== +c 2. Lecture type par type +c==== +c + do 21 , typenh = 0 , 7 +c +c 2.1. ==> decodage des caracteristiques +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.1. decodage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,typenh) +#endif +c + nbenca = 0 + nbrama = 0 +c + if ( typenh.eq.0 ) then + nbenti = nbmpto + nhenti = nhmapo + nbencf = nbenti + typgeo = edpoi1 + typent = edmail + numfam = 0 + nctfen = nctfmp + nbfent = nbfmpo + nbrfma = 1 + elseif ( typenh.eq.1 ) then + nbenti = nbarto + nbencf = nbenti + nhenti = nharet + if ( degre.eq.1 ) then + typgeo = edseg2 + nbrfma = 2 + else + typgeo = edseg3 + nbrfma = 3 + endif + typent = edaret + numfam = numfam - nbfmpo + nctfen = nctfar + nbfent = nbfare + elseif ( typenh.eq.2 ) then + nbenti = nbtrto + nbencf = nbenti + nhenti = nhtria + if ( degre.eq.1 ) then + typgeo = edtri3 + else + typgeo = edtri6 + endif + typent = edface + numfam = numfam - nbfare + nctfen = nctftr + nbfent = nbftri + nbrfma = 3 + elseif ( typenh.eq.3 ) then + nbenti = nbteto + nbencf = nbtecf + nbenca = nbteca + nhenti = nhtetr + if ( degre.eq.1 ) then + typgeo = edtet4 + else + typgeo = edte10 + endif + typent = edmail + numfam = numfam - nbftri + nctfen = nctfte + nbfent = nbftet + nbrfma = 4 + nbrama = 6 + elseif ( typenh.eq.4 ) then + nbenti = nbquto + nbencf = nbenti + nhenti = nhquad + if ( degre.eq.1 ) then + typgeo = edqua4 + else + typgeo = edqua8 + endif + typent = edface + numfam = numfam - nbftet + nctfen = nctfqu + nbfent = nbfqua + nbrfma = 4 + elseif ( typenh.eq.5 ) then + nbenti = nbpyto + nbencf = nbpycf + nbenca = nbpyca + nhenti = nhpyra + if ( degre.eq.1 ) then + typgeo = edpyr5 + else + typgeo = edpy13 + endif + typent = edmail + numfam = numfam - nbfqua + nctfen = nctfpy + nbfent = nbfpyr + nbrfma = 5 + nbrama = 8 + elseif ( typenh.eq.6 ) then + nbenti = nbheto + nbencf = nbhecf + nbenca = nbheca + nhenti = nhhexa + if ( degre.eq.1 ) then + typgeo = edhex8 + else + typgeo = edhe20 + endif + typent = edmail + numfam = numfam - nbfpyr + nctfen = nctfhe + nbfent = nbfhex + nbrfma = 6 + nbrama = 12 + else + nbenti = nbpeto + nbencf = nbpecf + nbenca = nbpeca + nhenti = nhpent + if ( degre.eq.1 ) then + typgeo = edpen6 + else + typgeo = edpe15 + endif + typent = edmail + numfam = numfam - nbfhex + nctfen = nctfpe + nbfent = nbfpen + nbrfma = 5 + nbrama = 9 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,90002) 'nbenti, nbencf, nbenca', + > nbenti, nbencf, nbenca + endif +#endif +c + endif +c +c 2.2. ==> gestion de la memoire +c 2.2.1. ==> connectivite +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2.1. connectivite ; codret = ', codret +#endif +c + if ( nbenti.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfent', nbfent + write (ulsort,90002) 'nbrfma', nbrfma + write (ulsort,90002) 'nbrama', nbrama + write (ulsort,90002) 'numfam', numfam + endif +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhenti, 1, nbenti, codre1 ) + call gmecat ( nhenti, 2, nbenca, codre2 ) + if ( typenh.eq.1 ) then + iaux = 2*nbencf + else + iaux = nbrfma*nbencf + endif + call gmaloj ( nhenti//'.ConnDesc', ' ', iaux, + > adcode, codre3 ) + if ( nbenca.gt.0 ) then + iaux = nbrama*nbenca + call gmaloj ( nhenti//'.ConnAret', ' ', iaux, + > adcoar, codre4 ) + else + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + endif +c +c 2.2.2. ==> appel du programme generique pour l'allocation de +c la branche liee aux familles +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2.2. familles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFE', nompro +#endif + iaux = typenh + call utalfe ( iaux, nhenti, + > nbenti, nctfen, nbfent, + > nhenfa, adfami, adcofa, + > ulsort, langue, codret) +c + endif +c +c 2.3. ==> Lecture des connectivites +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.3. lecture ; codret = ', codret +#endif +c + if ( nbenti.gt.0 ) then +c + if ( codret.eq.0 ) then +c + jaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEE0', nompro +#endif + call eslee0 ( idfmed, nomamd, + > jaux, typgeo, typent, + > nbencf, nbenca, nbrfma, nbrama, + > imem(adcode), imem(adcoar), + > tbiaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.4. ==> Lecture des complements +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.4. complements ; codret = ', codret +#endif +c + if ( nbenti.gt.0 ) then +c + if ( codret.eq.0 ) then +c + jaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEE2', nompro +#endif + call eslee2 ( idfmed, nomamd, + > nhenti, + > jaux, typgeo, typent, + > nbenti, nbencf, nbenca, + > tbiaux, + > ulsort, langue, codret ) +c +cgn call gmprsx ( nompro, nhenti ) +cgn call gmprsx ( nompro, nhenti//'.Famille' ) +cgn call gmprsx ( nompro, nhenti//'.ConnDesc' ) +cgn call gmprsx ( nompro, nhenti//'.HistEtat' ) +cgn call gmprsx ( nompro, nhenti//'.Mere' ) +cgn call gmprsx ( nompro, nhenti//'.InfoSupp' ) +c + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslefe.F b/src/tool/ES_HOMARD/eslefe.F new file mode 100644 index 00000000..88b7fc3a --- /dev/null +++ b/src/tool/ES_HOMARD/eslefe.F @@ -0,0 +1,681 @@ + subroutine eslefe ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsups, + > ltbsau, tbsaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture des Familles des Entites +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . nhsups . e . char*8 . informations supplementaires caracteres 8 . +c . ltbsau . e . 1 . longueur allouee a tbsaux . +c . tbsaux . . * . tableau tampon caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEFE' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "envca2.h" +c +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ltbsau +c + character*8 tbsaux(ltbsau) + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhsups + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbgrox + parameter (nbgrox = 10000 ) +c + integer iaux, jaux, kaux + integer cptr, kdeb, kfin, reste + integer typenh + integer nbfmed, nrofam, numfam, natt, ngro + integer adress, nbval + integer codre0 + integer codre1, codre2 + integer adcono, adcomp, adcoar, adcotr, adcoqu + integer adcote, adcopy, adcohe, adcope + integer adcoen + integer adnogr, lgnogr + integer numtab, numgro +c + character*8 nhenti + character*8 ntnogr + character*32 saux32 + character*80 nomgro + character*64 nomfam +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''. Lecture des familles'')' + texte(1,6) = '(''Allongement de nomgro.'')' + texte(1,81) = '(''Longueur allouee pour tbsaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbsaux : '',i10)' +c + texte(2,4) = '(''. Readings of families'')' + texte(2,6) = '(''Extension of nomgro.'')' + texte(2,81) = '(''Allocated length for tbsaux : '',i10)' + texte(2,82) = '(''Used length for tbsaux : '',i10)' +c +#include "impr03.h" +c + 1002 format(10(a8,'+')) + 1003 format(a80,'+') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c + codret = 0 +c +c==== +c 2. Preparatifs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Preparatifs ; codret', codret +#endif +c + do 21 , typenh = -1 , 7 +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + nhenti = nhnoeu + iaux = nbfnoe + elseif ( typenh.eq.0 ) then + nhenti = nhmapo + iaux = nbfmpo + elseif ( typenh.eq.1 ) then + nhenti = nharet + iaux = nbfare + elseif ( typenh.eq.2 ) then + nhenti = nhtria + iaux = nbftri + elseif ( typenh.eq.3 ) then + nhenti = nhtetr + iaux = nbftet + elseif ( typenh.eq.4 ) then + nhenti = nhquad + iaux = nbfqua + elseif ( typenh.eq.5 ) then + nhenti = nhpyra + iaux = nbfpyr + elseif ( typenh.eq.6 ) then + nhenti = nhhexa + iaux = nbfhex + else + nhenti = nhpent + iaux = nbfpen + endif +c + if ( iaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,90002) 'nbfent', iaux +#endif +c + call gmadoj ( nhenti//'.Famille.Codes', adcoen, iaux, codre1 ) +c + codret = max ( codret, + > codre1 ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.-1 ) then + adcono = adcoen + elseif ( typenh.eq.0 ) then + adcomp = adcoen + elseif ( typenh.eq.1 ) then + adcoar = adcoen + elseif ( typenh.eq.2 ) then + adcotr = adcoen + elseif ( typenh.eq.3 ) then + adcote = adcoen + elseif ( typenh.eq.4 ) then + adcoqu = adcoen + elseif ( typenh.eq.5 ) then + adcopy = adcoen + elseif ( typenh.eq.6 ) then + adcohe = adcoen + else + adcope = adcoen + endif +c + endif +c + 21 continue +c +ccc write (ulsort,90002) 'adcono', adcono +ccc write (ulsort,90002) 'adcomp', adcomp +ccc write (ulsort,90002) 'adcoar', adcoar +ccc write (ulsort,90002) 'adcotr', adcotr +ccc write (ulsort,90002) 'adcote', adcote +ccc write (ulsort,90002) 'adcoqu', adcoqu +ccc write (ulsort,90002) 'adcopy', adcopy +ccc write (ulsort,90002) 'adcohe', adcohe +ccc write (ulsort,90002) 'adcope', adcope +c==== +c 3. Nombre de familles dans le fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Nombre de familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFA', nompro +#endif + call mfanfa ( idfmed, nomamd, nbfmed, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,29)) nbfmed +#endif +c + endif +c +c==== +c 4. Lecture des familles MED decrivant les familles HOMARD +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Lecture des familles ; codret', codret +#endif +c +c 4.0. ==> Allocation d'un tableau tampon pour les noms des groupes +c + if ( codret.eq.0 ) then +c + lgnogr = nbgrox*10 + call gmalot ( ntnogr , 'chaine ', lgnogr, adnogr, codret ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lgnogr', lgnogr +#endif +c + endif +c + do 40 , nrofam = 1 , nbfmed +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrofam', nrofam +#endif +c +c 4.1. ==> Caracterisations de la famille en cours de lecture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFG', nompro +#endif + iaux = nrofam + call mfanfg ( idfmed, nomamd, iaux, ngro, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'ngro ', ngro +#endif +c +c 4.2. ==> Ici, on decode les familles HOMARD +c ATTENTION : le test est severe mais il faudrait +c avoir une fonction qui ne renvoie que le nom de la famille, +c sans retourner nomgro +c + if ( codret.eq.0 ) then +c + if ( ngro.gt.nbgrox ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lgnogr', lgnogr + write(ulsort,90002) 'ngro ', ngro + write (ulsort,texte(langue,6)) +#endif + iaux = ngro*10 + 100 + call gmmod ( ntnogr, adnogr, lgnogr, iaux, 1, 1, codret ) + lgnogr = iaux +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lgnogr', lgnogr +#endif +c + endif +c + endif +c +c 4.3. ==> Lecture du contenu de la famille +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFAFAI', nompro +#endif + iaux = nrofam + call mfafai ( idfmed, nomamd, iaux, nomfam, numfam, + > smem(adnogr), codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... Famille ', nomfam + write (ulsort,90002) 'numfam', numfam + write (ulsort,*) (smem(adnogr+iaux),iaux=0,ngro-1) + call gmprot(nompro, ntnogr, 1, 41 ) +#endif +c +c 4.5. ==> Rangement +c + if ( codret.eq.0 ) then +c + do 45 , typenh = -1 , 7 +c + if ( nomfam(1:2).eq.suffix(3,typenh)(1:2) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... Famille ', nomfam + write (ulsort,90002) 'numfam', numfam +#endif +c +c 4.5.1. ==> le numero de la famille HOMARD +c Attention : le numero de la famille HOMARD associee est +c le 1er attribut (cf. esecf0). Il faut gerer le decalage +c des codes en consequence +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTS8CH', nompro +#endif + iaux = 80 + call uts8ch ( smem(adnogr), iaux, nomgro, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... nomgro : ', nomgro +#endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-4.5.1." +#endif + call utchen ( nomgro(9:16), kaux, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Numero famille HOMARD', kaux +#endif + kaux = kaux - 1 +c +c 4.5.2. ==> les codes +c + if ( typenh.eq.-1 ) then + natt = nctfno + adcoen = adcono + kaux*nctfno + elseif ( typenh.eq.0 ) then + natt = nctfmp + adcoen = adcomp + kaux*nctfmp + elseif ( typenh.eq.1 ) then + natt = nctfar + adcoen = adcoar + kaux*nctfar + elseif ( typenh.eq.2 ) then + natt = nctftr + adcoen = adcotr + kaux*nctftr + elseif ( typenh.eq.3 ) then + natt = nctfte + adcoen = adcote + kaux*nctfte + elseif ( typenh.eq.4 ) then + natt = nctfqu + adcoen = adcoqu + kaux*nctfqu + elseif ( typenh.eq.5 ) then + natt = nctfpy + adcoen = adcopy + kaux*nctfpy + elseif ( typenh.eq.6 ) then + natt = nctfhe + adcoen = adcohe + kaux*nctfhe + else + natt = nctfpe + adcoen = adcope + kaux*nctfpe + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'natt', natt +#endif +c + reste = mod(natt+1,9) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'reste', reste +#endif +c + cptr = adcoen - 1 + kdeb = 2 + do 451 , jaux = 1, ngro + if ( jaux.lt.ngro .or. reste.eq.0 ) then + kfin = 9 + else + kfin = reste + endif + iaux = 80 + call uts8ch ( smem(adnogr+10*(jaux-1)), iaux, nomgro, + > ulsort, langue, codret ) + do 4511 , iaux = kdeb, kfin +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-do 4511" +#endif + call utchen ( nomgro(8*iaux+1:8*(iaux+1)), kaux, + > ulsort, langue, codret ) + cptr = cptr + 1 + imem(cptr) = kaux + 4511 continue + kdeb = 1 + 451 continue +c + endif +c + endif +c + 45 continue +c + endif +c + 40 continue +ccc call gmprsx ( nompro, nhnoeu//'.Famille' ) +ccc call gmprsx ( nompro, nhnoeu//'.Famille.Codes' ) +ccc call gmprsx ( nompro, nhnoeu//'.Famille.Groupe' ) +ccc call gmprsx ( nompro, nharet//'.Famille' ) +ccc call gmprsx ( nompro, nharet//'.Famille.Codes' ) +c +c==== +c 5. Lecture des familles de sauvegarde +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Lecture familles sauv. ; codret', codret +#endif +c + do 50 , nrofam = 1 , nbfmed +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrofam', nrofam +#endif +c +c 5.1. ==> Caracterisations de la famille en cours de lecture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFG', nompro +#endif + iaux = nrofam + call mfanfg ( idfmed, nomamd, iaux, ngro, codret ) +c + endif +c +c 5.2. ==> Controles +c + if ( codret.eq.0 ) then +c + if ( 10*ngro.gt.ltbsau ) then + write (ulsort,texte(langue,81)) ltbsau + write (ulsort,texte(langue,82)) 10*ngro + codret = 52 + endif +c + endif +c +c 5.3. ==> Lecture du contenu de la famille +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFAFAI', nompro +#endif + iaux = nrofam + call mfafai ( idfmed, nomamd, iaux, nomfam, numfam, + > tbsaux, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... Famille ', nomfam + write (ulsort,90002) 'numfam', numfam + do 5353 , jaux = 1 , ngro + write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux) + 5353 continue +#endif +c +c 5.3. ==> Rangement +c + if ( codret.eq.0 ) then +c +c 5.3.1. ==> La date et le titre +c + if ( nomfam(1:13).eq.'date_et_titre' ) then +c + if ( codret.eq.0 ) then +c + iaux = len(ladate) + call uts8ch ( tbsaux, iaux, ladate, + > ulsort, langue, codret ) +c + endif + if ( codret.eq.0 ) then +c + iaux = 80 + call uts8ch ( tbsaux(11), iaux, titre, + > ulsort, langue, codret ) +c + endif +cgn print *,ladate +cgn print *,titre +c +c 5.3.2. ==> Les informations supplementaires (cf. esecfs) +c + elseif ( nomfam(1:12).eq.'InfoSupS_Tab' ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... Famille ', nomfam + write (ulsort,90002) 'numfam', numfam + write (ulsort,90002) 'ngro', ngro + do 53299 , jaux = 1 , ngro + write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux) +53299 continue +#endif +c +c La categorie +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-5.3.2.a" +#endif + call utchen ( nomfam(13:64), numtab, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c Le nombre de valeurs +c + do 5321 , jaux = 1 , ngro +c + kaux = 10*(jaux-1) + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'kaux', kaux + write (ulsort,*) 'tbsaux(kaux)', tbsaux(kaux) +#endif + if ( tbsaux(kaux).eq.'Nombre d' ) then +c + numgro = jaux +c + saux32 = + > tbsaux(kaux+3)//tbsaux(kaux+4)//tbsaux(kaux+5)//tbsaux(kaux+6) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-5.3.2.b" +#endif + call utchen ( saux32, nbval, ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbval ', nbval + write (ulsort,90002) 'numgro', numgro +#endif +c + goto 53210 +c + endif +c + 5321 continue +53210 continue +c + endif +c +c Gestion memoire +c + if ( codret.eq.0 ) then +c + call utlgut ( jaux, nomfam, + > ulsort, langue, codret ) + call gmaloj ( nhsups//'.'//nomfam(10:jaux) , ' ', + > nbval, adress, codre1 ) + call gmecat ( nhsups , numtab, nbval, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c Les valeurs +c il faut supprimer le pseudo-groupe du nombre de valeurs +c + if ( codret.eq.0 ) then +c + do 5322 , jaux = 1 , ngro + if ( jaux.ne.numgro ) then + kaux = 10*(jaux-1) + do 53221 , iaux = 1, 10 + smem(adress) = tbsaux(kaux+iaux) + adress = adress + 1 +53221 continue + endif + 5322 continue +c do 5322 , jaux = 0 , nbval-1 +c smem(adress+jaux) = tbsaux(11+jaux) +c 5322 continue +c + endif +c + endif +c + endif +c + 50 continue +c +c==== +c 6. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntnogr , codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslen1.F b/src/tool/ES_HOMARD/eslen1.F new file mode 100644 index 00000000..09180a9c --- /dev/null +++ b/src/tool/ES_HOMARD/eslen1.F @@ -0,0 +1,303 @@ + subroutine eslen1 ( idfmed, nomamd, + > nhnoeu, + > dimcst, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture des Noeuds - 1 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds . +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . . . . eventuelle, 0 si toutes varient . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLEN1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "gmreel.h" +c +#include "impr02.h" +#include "nombno.h" +#include "envca1.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer dimcst + integer ltbiau, tbiaux(*) +c + character*8 nhnoeu + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbcmax + parameter ( nbcmax = 20 ) +c + integer iaux, jaux, kaux, laux + integer codre1, codre2 + integer codre0 + integer nbcomp + integer typenh + integer pcoono, adcocs + integer numdt, numit +c + character*16 nomcmp(nbcmax), unicmp(nbcmax) + character*64 nomcha + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''... Lecture des complements pour les noeuds'')' + texte(1,81) = '(''Longueur allouee pour tbiaux : '',i10)' + texte(1,82) = '(''Longueur necessaire pour tbiaux : '',i10)' +c + texte(2,4) = '(''... Readings of additional terms for nodes'')' + texte(2,81) = '(''Allocated length for tbiaux : '',i10)' + texte(2,82) = '(''Used length for tbiaux : '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Lecture sous forme de champ pour les tableaux +c==== +c 2.1. ==> Reperage du champ et du nombre de ses composantes +c + nomcha = blan64 + nomcha(1:8) = suffix(3,-1) + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLE01_no', nompro +#endif + call esle01 ( idfmed, nomamd, nomcha, + > nbcomp, nomcmp, unicmp, + > iaux, jaux, + > ulsort, langue, codret) +c + if ( codret.eq.0 ) then +c + if ( nbnoto*nbcomp.gt.ltbiau ) then + write (ulsort,texte(langue,85)) nbcomp + write (ulsort,texte(langue,81)) ltbiau + write (ulsort,texte(langue,82)) nbnoto*nbcomp + codret = 7 + endif +c + endif +c +c 2.2. ==> Lecture des valeurs du champ, en mode non entrelace. +c En fortran, cela correspond au stockage memoire suivant : +c tabaux(1,1), tabaux(2,1), tabaux(3,1), ..., tabaux(nbnoto,1), +c tabaux(1,2), tabaux(2,2), tabaux(3,2), ..., tabaux(nbnoto,2), +c ... +c tabaux(1,nbcomp), tabaux(2,nbcomp), ..., tabaux(nbnoto,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. Lecture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + numdt = ednodt + numit = ednoit + iaux = 0 +c A TRAITER plus tard +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'MFDIVR', nompro +cgn#endif +cgn call mfdivr ( idfmed, nomcha, numdt, numit, +cgn > ednoeu, iaux, ednoin, +cgn > edall, +cgn > tbiaux, codret ) + noprof = blan64 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIPR', nompro +#endif + call mfdipr ( idfmed, nomcha, numdt, numit, + > ednoeu, iaux, 1, noprof, ednoin, + > edall, + > tbiaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,18)) nomcha + endif +c + endif +c +c 2.3. ==> Transfert +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , nbcomp +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhnoeu//'.'//nomcmp(iaux), ' ', + > nbnoto, laux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + kaux = nbnoto*(iaux-1) + laux = laux - 1 + do 231 , jaux = 1 , nbnoto + imem(laux+jaux) = tbiaux(kaux+jaux) + 231 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nhnoeu//'.'//nomcmp(iaux) ) +#endif +c + 23 continue +c + endif +c +c==== +c 3. Lecture sous forme de profil pour les informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Lecture profil ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + typenh = -1 + iaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLE02_'//mess14(langue,1,typenh), + > nompro +#endif + call esle02 ( idfmed, + > typenh, nhnoeu, iaux, + > ulsort, langue, codret) +c + endif +c +c==== +c 4. Coordonnees extremes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. coo extremes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 11 + call gmaloj ( nhnoeu//'.CoorCons', ' ', iaux, adcocs, codre1 ) + call gmadoj ( nhnoeu//'.Coor', pcoono, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLE03', nompro +#endif + call esle03 ( idfmed, + > nbnoto, sdim, rmem(pcoono), dimcst, + > rmem(adcocs), + > ulsort, langue, codret) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/esleno.F b/src/tool/ES_HOMARD/esleno.F new file mode 100644 index 00000000..c0f890e5 --- /dev/null +++ b/src/tool/ES_HOMARD/esleno.F @@ -0,0 +1,217 @@ + subroutine esleno ( idfmed, nomamd, + > nhnoeu, + > dimcst, lgnoig, nbnoco, + > ltbiau, tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : LEcture des NOeuds +c - - -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . dimcst . e . 1 . 0, si toutes les coordonnees varient . +c . . . . i, si la i-eme est constante et n'est pas . +c . . . . memorisee sur chaque noeud . +c . lgnoig . e . 1 . nombre de noeuds lies aux elements ignores . +c . nbnoco . e . 1 . nbr noeuds pour la non-conformite initiale . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLENO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +#include "dicfen.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer dimcst, lgnoig, nbnoco + integer ltbiau, tbiaux(*) +c + character*8 nhnoeu + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer codre0 + integer adnoig + integer pcoono + integer pfamno, pcfano +c + character*8 nhnofa +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Lecture des noeuds.'')' +c + texte(2,4) = '(''. Readings of nodes.'')' +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Gestion de la memoire +c==== +c 2.1. ==> la base +c + call gmecat ( nhnoeu, 1, nbnoto, codre1 ) + call gmecat ( nhnoeu, 2, dimcst, codre2 ) + call gmecat ( nhnoeu, 3, lgnoig, codre3 ) + call gmecat ( nhnoeu, 4, nbnoco, codre4 ) + call gmaloj ( nhnoeu//'.InfoGene', ' ', lgnoig, adnoig, codre5 ) + iaux = sdim * nbnoto + call gmaloj ( nhnoeu//'.Coor', ' ', iaux, pcoono, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c +c 2.2. ==> appel du programme generique pour l'allocation de +c la branche liee aux familles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFE', nompro +#endif + iaux = -1 + call utalfe ( iaux, nhnoeu, + > nbnoto, nctfno, nbfnoe, + > nhnofa, pfamno, pcfano, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. Lectures +c==== +c 3.1. ==> Lecture de la connectivite et des familles +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMNO', nompro +#endif + call eslmno ( idfmed, nomamd, + > iaux, + > nbnoto, sdim, rmem(pcoono), imem(pfamno), + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Lecture des complements +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEN1', nompro +#endif + call eslen1 ( idfmed, nomamd, + > nhnoeu, + > dimcst, + > ltbiau, tbiaux, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nhnoeu ) + call gmprsx ( nompro, nhnoeu//'.Coor' ) + call gmprsx ( nompro, nhnoeu//'.HistEtat' ) + call gmprsx ( nompro, nhnoeu//'.AretSupp' ) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh1.F b/src/tool/ES_HOMARD/eslmh1.F new file mode 100644 index 00000000..646455d9 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh1.F @@ -0,0 +1,523 @@ + subroutine eslmh1 ( typobs, nomail, + > suifro, nocdfr, ncafdg, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 1 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . char*8 . mot-cle correspondant a l'objet a lire . +c . nomail . s . char*8 . nom du maillage a lire . +c . suifro . es . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . . . . <0 : le maillage est absent du fichier . +c . nocdfr . s . char*8 . nom de l'objet description de la frontiere . +c . ncafdg . s . char*8 . nom de l'objet groupes frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "dicfen.h" +#include "envex1.h" +#include "envca1.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "front1.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer suifro +c + character*8 typobs + character*(*) nomail + character*8 nocdfr, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer codre0 + integer codre1, codre2 + integer lnomai, lnomfi + integer*8 idfmed + integer typnom + integer dimcst, lgnoig, nbnoco + integer natmax, ngrmax + integer lgpeli + integer lnomaf + integer ltrav1, ltrav2 + integer ptrav1, ptrav2 +c + character*8 ntrav1, ntrav2 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*64 nomamd + character*64 nomafr + character*200 nomfic +c + logical exiren +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Lecture du maillage '',a,'' sur le fichier'')' +c + texte(2,4) = '(5x,''Readings of mesh '',a,'' on file'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c + codret = 0 +c +c==== +c 2. nom du maillage et du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. maillage/fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTOSNO', nompro +#endif + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( lnomai, nomail, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) nomail(1:lnomai) + write (ulsort,*) ' '//nomfic(1:lnomfi) + endif +c +c==== +c 3. ouverture du fichier et lectures preliminaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. ouverture du fichier ; codret', codret +#endif +c +c 3.1. ==> Ouverture du fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + iaux = 3 +#else + iaux = 1 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESOUVL', nompro +#endif + call esouvl ( idfmed, nomfic(1:lnomfi), iaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + codret = 1 + endif +c + endif +c +c 3.2. ==> Lectures de base +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH2', nompro +#endif + call eslmh2 ( idfmed, + > nomail, lnomai, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > dimcst, lgnoig, nbnoco, + > sdimca, mdimca, + > exiren, lgpeli, + > suifro, nomafr, lnomaf, + > ulsort, langue, codret) +c + endif +c +c==== +c 4. allocation de la tete du maillage HOMARD +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. allocation de la tete ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( exiren ) then + iaux = 1 + else + iaux = 2 + endif + typnom = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAHMA', nompro +#endif + call utahma ( nomail, typnom, iaux, + > sdim, mdim, degre, mailet, maconf, + > homolo, hierar, rafdef, + > nbmane, typcca, typsfr, maextr, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Recuperation des communs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Recuperation communs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nomamd = blan64 + nomamd(1:8) = nomail +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH3', nompro +#endif + call eslmh3 ( idfmed, nomamd, + > nhsupe, + > nbfmed, natmax, ngrmax, + > ulsort, langue, codret) +c + endif +c +c==== +c 6. tableaux de travail +c On doit tenir compte des caracteristiques des familles pour +c le dimensionnement du tableau tbsaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. tableaux de travail ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnoto', nbnoto + write (ulsort,90002) 'nbmpto', nbmpto + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'nbteto, nbtecf, nbteca', + > nbteto, nbtecf, nbteca + write (ulsort,90002) 'nbheto, nbhecf, nbheca', + > nbheto, nbhecf, nbheca + write (ulsort,90002) 'nbpyto, nbpycf, nbpyca', + > nbpyto, nbpycf, nbpyca + write (ulsort,90002) 'nbpeto, nbpecf, nbpeca', + > nbpeto, nbpecf, nbpeca + write (ulsort,90002) 'nbfmed', nbfmed + write (ulsort,90002) 'ngrmax', ngrmax + write (ulsort,90002) 'lgpeli', lgpeli + write (ulsort,90002) 'sfsdim', sfsdim + write (ulsort,90002) 'sfnbso', sfnbso + write (ulsort,90002) 'sfnbse', sfnbse +#endif +c + ltrav1 = max ( 4*nbnoto, + > nbmpto, 5*nbarto, 5*nbtrto, 5*nbquto, + > 6*nbteto, 2*nbteca, + > 7*nbpyto, 3*nbpyca, + > 8*nbheto, 6*nbheca, + > 5*nbpeto, 4*nbpeca, + > lgpeli, + > sfnbso ) + call gmalot ( ntrav1, 'entier ', ltrav1 , ptrav1, codre1 ) + ltrav2 = 25*( max ( nctfno, nctfmp, nctfar, nctftr, nctfqu, + > nctfte, nctfpy, nctfhe, nctfpe, 30 ) + 1 ) + ltrav2 = max ( ltrav2, 25*natmax+10*ngrmax ) + call gmalot ( ntrav2, 'chaine ', ltrav2 , ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 7. Lecture des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Lecture des noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLENO', nompro +#endif + call esleno ( idfmed, nomamd, + > nhnoeu, + > dimcst, lgnoig, nbnoco, + > ltrav1, imem(ptrav1), + > ulsort, langue, codret) +c + endif +c +c==== +c 8. Lecture des entites mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Lecture des mailles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEEN', nompro +#endif + call esleen ( idfmed, nomamd, + > nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > ltrav1, imem(ptrav1), + > ulsort, langue, codret ) +c + endif +c +c==== +c 9. Les renumerotations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. Les renumerotations ; codret', codret +#endif +c + if ( exiren ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH4', nompro +#endif + call eslmh4 ( idfmed, + > nomail, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 10. Lecture des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. les familles ; codret', codret +#endif +c + if ( codret.eq.0) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLEFE', nompro +#endif + call eslefe ( idfmed, nomamd, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsups, + > ltrav2, smem(ptrav2), + > ulsort, langue, codret ) +c + endif +c +c==== +c 11. Lecture des elements ignores +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. Elements ignores ; codret', codret +#endif +c + if ( lgpeli.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH6', nompro +#endif + call eslmh6 ( idfmed, + > nhelig, + > imem(ptrav1), + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 11. Lecture de l'eventuelle frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. Frontiere discrete ; codret', codret +#endif +c + if ( mod(suifro,2).eq.0 ) then +c + if ( lnomaf.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH7', nompro +#endif + call eslmh7 ( idfmed, + > nocdfr, ncafdg, + > ltrav1, imem(ptrav1), ltrav2, smem(ptrav2), + > nomafr, lnomaf, + > ulsort, langue, codret ) +c + endif +c + else +c + suifro = -abs(suifro) +c + endif +c + endif +c +c==== +c 12. Fermeture du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. Fermeture du fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo ( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) nomfic(1:lnomfi) + write (ulsort,texte(langue,10)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx ( nompro, nomail ) + endif +#endif +c +c==== +c 13. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) nomfic(1:lnomfi) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh2.F b/src/tool/ES_HOMARD/eslmh2.F new file mode 100644 index 00000000..0276421d --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh2.F @@ -0,0 +1,498 @@ + subroutine eslmh2 ( idfmed, + > nomail, lnomai, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > dimcst, lgnoig, nbnoco, + > sdimca, mdimca, + > exiren, lgpeli, + > suifro, nomafr, lnomaf, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 2 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomail . e . char*8 . nom du maillage a lire . +c . lnomai . e . 1 . longueur du nom du maillage . +c . sdim . s . 1 . dimension de l'espace . +c . mdim . s . 1 . dimension du maillage . +c . degre . s . 1 . degre du maillage . +c . maconf . s . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . homolo . s . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . hierar . s . 1 . maillage hierarchique . +c . . . . 0 : non . +c . . . . 1 : oui . +c . rafdef . s . 1 . 0 : macro-maillage . +c . . . . 1 : le maillage est inchange . +c . . . . 2 : le maillage est issu du raffinement pur. +c . . . . d'un autre maillage . +c . . . . 3 : le maillage est issu du deraffinement . +c . . . . pur d'un autre maillage . +c . . . . 4 : le maillage est issu de raffinement et . +c . . . . de deraffinement d'un autre maillage . +c . . . . 12 : le maillage est un maillage passe de . +c . . . . degre 1 a 2 . +c . . . . 21 : le maillage est un maillage passe de . +c . . . . degre 2 a 1 . +c . nbmane . s . 1 . nombre maximum de noeuds par element . +c . typcca . s . 1 . type du code de calcul . +c . typsfr . s . 1 . type du suivi de frontiere . +c . . . . 0 : aucun . +c . . . . 1 : maillage de degre 1, avec projection . +c . . . . des nouveaux sommets . +c . . . . 2 : maillage de degre 2, seuls les noeuds . +c . . . . P1 sont sur la frontiere ; les noeuds . +c . . . . P2 restent au milieu des P1 . +c . . . . 3 : maillage de degre 2, les noeuds P2 . +c . . . . etant sur la frontiere . +c . maextr . s . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . mailet . s . 1 . presence de mailles etendues . +c . . . . 1 : aucune . +c . . . . 2x : TRIA7 . +c . . . . 3x : QUAD9 . +c . . . . 5x : HEXA27 . +c . dimcst . s . 1 . 0, si toutes les coordonnees varient . +c . . . . i, si la i-eme est constante et n'est pas . +c . . . . memorisee sur chaque noeud . +c . lgnoig . s . 1 . nombre de noeuds lies aux elements ignores . +c . nbnoco . s . 1 . nbr noeuds pour la non-conformite initiale . +c . sdimca . s . 1 . dimension de l'espace du maillage de calcul. +c . mdimca . s . 1 . dimension du maillage du maillage de calcul. +c . exiren . s . 1 . vrai/faux selon presence de renumerotations. +c . lgpeli . s . 1 . longueur du profil des elements elimines . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nomafr . s . char64 . nom du maillage MED de la frontiere . +c . lnomaf . s . 1 . longueur du nom du maillage de la frontiere. +c . . . . 0 : le maillage est absent du fichier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "front1.h" +c +c 0.3. ==> arguments +c + integer lnomai + integer*8 idfmed + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet + integer dimcst, lgnoig, nbnoco + integer sdimca, mdimca + integer lgpeli + integer suifro + integer lnomaf +c + character*64 nomail + character*64 nomafr +c + logical exiren +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer infmgl(30) + integer nbprof + integer nbvapr +c + logical exiigl +c + character*64 noprof + character*64 nomam2 + integer typrep +c + character*16 nomaxe(3), uniaxe(3) +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Aucun profil dans le fichier ?'')' + texte(1,5) = '(''Les informations globales sont absentes.'')' +c + texte(2,5) = '(''No profile into the file?'')' + texte(2,5) = '(''Global information are missing.'')' +c +#include "esimpr.h" +c +#include "impr03.h" +c +c==== +c 2. Le maillage est-il present dans le fichier ? +c si oui, on retourne les dimensions de l'espace et du maillage +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNOM', nompro +#endif + call eslnom ( idfmed, nomail, lnomai, + > sdim, mdim, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,22)) nomail(1:lnomai) + write (ulsort,texte(langue,23)) 'de l''espace', sdim + write (ulsort,texte(langue,23)) 'du maillage', mdim + endif +#endif +c +c==== +c 3. Recuperation des parametres essentiels +c==== +c 3.1. ==> Nombre de profils +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. Nombre de profils ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFNPF', nompro +#endif + call mpfnpf ( idfmed, nbprof, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) nbprof +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbprof.eq.0 ) then + write (ulsort,texte(langue,86)) nbprof + write (ulsort,texte(langue,4)) + codret = 31 + endif +c + endif +c +c 3.2. ==> Parcours des profils +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. Parcours des profils ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + exiigl = .false. + exiren = .false. + lgpeli = 0 +c + do 32 , iaux = 1 , nbprof +c +c 3.2.1. ==> nom et taille du profil a lire +c + if ( codret.eq.0 ) then +c + jaux = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPFI', nompro +#endif + call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr +#endif +c + endif +c +c 3.2.2. ==> Les profils que l'on cherche +c + if ( codret.eq.0 ) then +c +c 3.2.2.1 ==> Recuperation des parametres essentiels +c +c 1234567890123456789012 + if ( noprof(1:22).eq.'Info_maillage_globales' ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, infmgl, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,79)) + endif +c + endif +c + if ( codret.eq.0 ) then +c + exiigl = .true. +c +c envca1 + divers + degre = infmgl( 3) + maconf = infmgl( 4) + homolo = infmgl( 5) + hierar = infmgl( 6) + rafdef = infmgl( 7) + nbmane = infmgl( 8) + typcca = infmgl( 9) + typsfr = infmgl(10) + maextr = infmgl(11) + mailet = infmgl(12) + dimcst = infmgl(13) + lgnoig = infmgl(14) + nbnoco = infmgl(15) +c nbutil + sdimca = infmgl(16) + mdimca = infmgl(17) +c + endif +c +c 3.2.2.2. ==> Presence de renumerotation +c +c 1234567890123456789 + elseif ( noprof(1:19).eq.'Attributs_de_norenu' ) then +c + exiren = .true. +c +c 3.2.2.3. ==> Presence d'elements ignores +c +c 1234567890123456 + elseif ( noprof(1:16).eq.'Elements_Ignores' ) then +c + lgpeli = nbvapr +c + endif +c + endif +c + 32 continue +c + endif +c +c 3.3. ==> controle +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. controle ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( .not.exiigl ) then +c + write (ulsort,texte(langue,5)) + codret = 33 +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgpeli', lgpeli +#endif +c +c==== +c 4. L'eventuelle frontiere discrete +c Le nom doit etre coherent avec esecfd +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Frontiere discrete ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro', suifro +#endif +c + if ( mod(suifro,2).eq.0 ) then +c +c 4.1. ==> Nom du maillage de la frontiere +c + if ( codret.eq.0 ) then +c + nomam2 = blan64 + nomam2(1:8) = 'AbsCurvi' + iaux = 8 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNOF', nompro +#endif + call eslnof ( idfmed, + > nomail, lnomai, + > nomam2, iaux, + > nomafr, lnomaf, sfsdim, sfmdim, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,22)) nomafr + write (ulsort,texte(langue,23)) 'de l''espace', sfsdim + write (ulsort,texte(langue,23)) 'du maillage', sfmdim + endif +#endif +c + endif +c +c 4.2. ==> Si le maillage de la frontiere existe : +c + if ( lnomaf.gt.0 ) then +c +c 4.2.1. ==> Nombre de noeuds du maillage de la frontiere +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMN-'//nomafr(1:lnomaf),nompro +#endif + call eslmmn ( idfmed, nomafr, lnomaf, + > sfnbso, + > ulsort, langue, codret ) +c + endif +c +c 4.2.2. ==> Nombre de noeuds de la description +c + if ( codret.eq.0 ) then +c + iaux = 8 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMN-'//nomam2(1:iaux),nompro +#endif + call eslmmn ( idfmed, nomam2, iaux, + > sfnbse, + > ulsort, langue, codret ) +c + endif +c + endif +c + else +c + sfsdim = 0 + sfmdim = 0 + sfnbso = 0 + sfnbse = 0 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sfsdim', sfsdim + write (ulsort,90002) 'sfmdim', sfmdim + write (ulsort,90002) 'sfnbso', sfnbso + write (ulsort,90002) 'sfnbse', sfnbse +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh3.F b/src/tool/ES_HOMARD/eslmh3.F new file mode 100644 index 00000000..ecba6bbb --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh3.F @@ -0,0 +1,519 @@ + subroutine eslmh3 ( idfmed, nomamd, + > nhsupe, + > nbfmed, natmax, ngrmax, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 3 +c - - - - - - +c ______________________________________________________________________ +c Attention : esemh0 et eslmh3 doivent evoluer en parallelle +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomamd . e . char64 . nom du maillage MED voulu . +c . nhsupe . e . char8 . informations supplementaires entieres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH3' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envex1.h" +c +#include "envada.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombno.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nancnb.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbfmed, natmax, ngrmax +c + character*8 nhsupe + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux, laux + integer lgnpro + integer codre1, codre2 + integer codre0 + integer nbprof + integer nbvapr, adlipr +c + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,5x,''Mise a jour des communs'')' +c + texte(2,4) = '(/,5x,''Updating of commons'')' +c +#include "esimpr.h" +c +#include "impr03.h" +c +c==== +c 2. Recuperation des parametres essentiels +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Lecture des profils ; codret', codret +#endif +c 2.1. ==> Nombre de profils +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFNPF', nompro +#endif + call mpfnpf ( idfmed, nbprof, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) nbprof +#endif +c + endif +c +c 2.2. ==> Parcours des profils +c + do 22 , iaux = 1 , nbprof +c +c 2.2.1. ==> nom et taille du profil a lire +c + if ( codret.eq.0 ) then +c + jaux = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPFI', nompro +#endif + call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr +#endif +c + endif +c +c 2.2.2. ==> On ne continue que pour les InfoSupE +c + if ( codret.eq.0 ) then +c + if ( noprof(10:12).ne.'Tab' ) then + goto 22 + endif +c + endif +c +c 2.2.3. ==> Allocation du tableau receptacle +c + if ( codret.eq.0 ) then +c + call utlgut ( lgnpro, noprof, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utchen ( noprof(13:lgnpro), jaux, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhsupe//'.'//noprof(10:lgnpro) , ' ', + > nbvapr, adlipr, codre1 ) + call gmecat ( nhsupe , jaux, nbvapr, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.2.4. ==> Lecture de la liste des valeurs +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, imem(adlipr), codret ) +c + endif +c +c 2.2.5. ==> Transfert le cas echeant +c + if ( codret.eq.0 ) then +c +c 2.2.5.1. ==> Tab1 : communs entiers +c + if ( jaux.eq.1 ) then +c + kaux = adlipr - 1 +c nombno + nbnois = imem(kaux+1) + nbnoei = imem(kaux+2) + nbnoma = imem(kaux+3) + nbnomp = imem(kaux+4) + nbnop1 = imem(kaux+5) + nbnop2 = imem(kaux+6) + nbnoim = imem(kaux+7) + nbnoto = imem(kaux+8) + nbpnho = imem(kaux+9) + numip1 = imem(kaux+10) + numap1 = imem(kaux+11) + nbnoin = imem(kaux+12) + kaux = kaux + 12 +c nombmp + nbmpto = imem(kaux+1) + nbppho = imem(kaux+2) + kaux = kaux + 2 +c nombar + nbarac = imem(kaux+1) + nbarde = imem(kaux+2) + nbart2 = imem(kaux+3) + nbarq2 = imem(kaux+4) + nbarq3 = imem(kaux+5) + nbarq5 = imem(kaux+6) + nbarin = imem(kaux+7) + nbarma = imem(kaux+8) + nbarpe = imem(kaux+9) + nbarto = imem(kaux+10) + nbfaar = imem(kaux+11) + nbpaho = imem(kaux+12) + kaux = kaux + 12 +c nombtr + nbtrac = imem(kaux+1) + nbtrde = imem(kaux+2) + nbtrt2 = imem(kaux+3) + nbtrq3 = imem(kaux+4) + nbtrhc = imem(kaux+5) + nbtrpc = imem(kaux+6) + nbtrtc = imem(kaux+7) + nbtrma = imem(kaux+8) + nbtrpe = imem(kaux+9) + nbtrto = imem(kaux+10) + nbptho = imem(kaux+11) + nbtrri = imem(kaux+12) + kaux = kaux + 12 +c nombqu + nbquac = imem(kaux+1) + nbqude = imem(kaux+2) + nbquma = imem(kaux+3) + nbquq2 = imem(kaux+4) + nbquq5 = imem(kaux+5) + nbqupe = imem(kaux+6) + nbquto = imem(kaux+7) + nbpqho = imem(kaux+8) + nbquri = imem(kaux+9) + kaux = kaux + 9 +c nombte + nbteac = imem(kaux+1) + nbtea2 = imem(kaux+2) + nbtea4 = imem(kaux+3) + nbtede = imem(kaux+4) + nbtef4 = imem(kaux+5) + nbteh1 = imem(kaux+6) + nbteh2 = imem(kaux+7) + nbteh3 = imem(kaux+8) + nbteh4 = imem(kaux+9) + nbtep0 = imem(kaux+10) + nbtep1 = imem(kaux+11) + nbtep2 = imem(kaux+12) + nbtep3 = imem(kaux+13) + nbtep4 = imem(kaux+14) + nbtep5 = imem(kaux+15) + nbtedh = imem(kaux+16) + nbtedp = imem(kaux+17) + nbtema = imem(kaux+18) + nbtepe = imem(kaux+19) + nbteto = imem(kaux+20) + nbtecf = imem(kaux+21) + nbteca = imem(kaux+22) + kaux = kaux + 22 +c nombhe + nbheac = imem(kaux+1) + nbheco = imem(kaux+2) + nbhede = imem(kaux+3) + nbhedh = imem(kaux+4) + nbhema = imem(kaux+5) + nbhepe = imem(kaux+6) + nbheto = imem(kaux+7) + nbhecf = imem(kaux+8) + nbheca = imem(kaux+9) + kaux = kaux + 9 +c nombpe + nbpeac = imem(kaux+1) + nbpeco = imem(kaux+2) + nbpede = imem(kaux+3) + nbpedp = imem(kaux+4) + nbpema = imem(kaux+5) + nbpepe = imem(kaux+6) + nbpeto = imem(kaux+7) + nbpecf = imem(kaux+8) + nbpeca = imem(kaux+9) + kaux = kaux + 9 +c nombpy + nbpyac = imem(kaux+1) + nbpyh1 = imem(kaux+2) + nbpyh2 = imem(kaux+3) + nbpyh3 = imem(kaux+4) + nbpyh4 = imem(kaux+5) + nbpyp0 = imem(kaux+6) + nbpyp1 = imem(kaux+7) + nbpyp2 = imem(kaux+8) + nbpyp3 = imem(kaux+9) + nbpyp4 = imem(kaux+10) + nbpyp5 = imem(kaux+11) + nbpydh = imem(kaux+12) + nbpydp = imem(kaux+13) + nbpyma = imem(kaux+14) + nbpype = imem(kaux+15) + nbpyto = imem(kaux+16) + nbpycf = imem(kaux+17) + nbpyca = imem(kaux+18) + kaux = kaux + 18 +c nbfami + nbfnoe = imem(kaux+1) + nbfmpo = imem(kaux+2) + nbfare = imem(kaux+3) + nbftri = imem(kaux+4) + nbfqua = imem(kaux+5) + nbftet = imem(kaux+6) + nbfhex = imem(kaux+7) + nbfpyr = imem(kaux+8) + nbfpen = imem(kaux+9) + kaux = kaux + 9 +c dicfen + ncffno = imem(kaux+ 1) + ncffmp = imem(kaux+ 2) + ncffar = imem(kaux+ 3) + ncfftr = imem(kaux+ 4) + ncffqu = imem(kaux+ 5) + ncffte = imem(kaux+ 6) + ncffhe = imem(kaux+ 7) + ncffpy = imem(kaux+ 8) + ncffpe = imem(kaux+ 9) + ncefno = imem(kaux+10) + ncefmp = imem(kaux+11) + ncefar = imem(kaux+12) + nceftr = imem(kaux+13) + ncefqu = imem(kaux+14) + nctfno = imem(kaux+15) + nctfmp = imem(kaux+16) + nctfar = imem(kaux+17) + nctftr = imem(kaux+18) + nctfqu = imem(kaux+19) + nctfte = imem(kaux+20) + nctfhe = imem(kaux+21) + nctfpy = imem(kaux+22) + nctfpe = imem(kaux+23) + ncxfno = imem(iaux+24) + ncxfar = imem(iaux+25) + ncxftr = imem(iaux+26) + ncxfqu = imem(iaux+27) + kaux = kaux + 27 +c envada + nbiter = imem(kaux+1) + nivinf = imem(kaux+2) + nivsup = imem(kaux+3) + niincf = imem(kaux+4) + nisucf = imem(kaux+5) + kaux = kaux + 5 +c +c 2.2.5.2. ==> Tab7 : pointeurs des informations generales +c + elseif ( jaux.eq.7 ) then +c + kaux = nbvapr + call gmecat ( nhsupe , jaux, kaux, codret ) +c + endif +c + endif +c + 22 continue +c +ccc write (ulsort,90002) 'nbnoto', nbnoto +ccc write (ulsort,90002) 'nbmpto', nbmpto +ccc write (ulsort,90002) 'nbarto', nbarto +ccc write (ulsort,90002) 'nbtrto', nbtrto +ccc write (ulsort,90002) 'nbteto', nbteto +ccc write (ulsort,90002) 'nbquto', nbquto +ccc write (ulsort,90002) 'nbpyto', nbpyto +ccc write (ulsort,90002) 'nbheto', nbheto +ccc write (ulsort,90002) 'nbpeto', nbpeto +c +cgn call gmprsx (nompro,nhsupe) +c +c 2.3. ==> Archivage +c + if ( codret.eq.0 ) then +c + nancno = nbnoto + nancar = nbarto + nanctr = nbtrto + nancqu = nbquto + nancte = nbteto + nanctf = nbtecf + nancta = nbteca + nanche = nbheto + nanchf = nbhecf + nancha = nbheca + nancpe = nbpeto + nancpf = nbpecf + nancpa = nbpeca + nancpy = nbpyto + nancyf = nbpycf + nancya = nbpyca +c + endif +c +c==== +c 3. Recuperation du dimensionnement des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Lecture des familles ; codret', codret +#endif +c +c 3.1. ==> Nombre de familles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFA', nompro +#endif + call mfanfa ( idfmed, nomamd, nbfmed, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,29)) nbfmed +#endif +c + endif +c +c 3.2. ==> Recherche des nombres maximaux de groupe +c + if ( codret.eq.0 ) then +c + natmax = 0 + ngrmax = 0 +c + do 320 , laux = 1 , nbfmed +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFG', nompro +#endif + iaux = laux +ccc call efnatt ( idfmed, nomamd, iaux, jaux, codre1 ) + call mfanfg ( idfmed, nomamd, iaux, kaux, codret ) +ccc write (ulsort,90002) 'natt ', jaux +ccc write (ulsort,90002) 'ngro ', kaux +c + endif +c + if ( codret.eq.0 ) then +c + ngrmax = max ( ngrmax, kaux ) +c + endif +c + 320 continue +c + endif +ccc write (ulsort,90002) 'nbfmed', nbfmed +ccc write (ulsort,90002) 'ngrmax', ngrmax +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh4.F b/src/tool/ES_HOMARD/eslmh4.F new file mode 100644 index 00000000..2071f3c0 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh4.F @@ -0,0 +1,335 @@ + subroutine eslmh4 ( idfmed, + > nomail, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 4 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nomail . e . char*8 . nom du maillage a lire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH4' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envex1.h" +#include "enti01.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux, laux + integer codre1, codre2 + integer codre0 + integer nbprof + integer nbvapr, adenho + integer typenh +c + integer nbattx + parameter ( nbattx = 19 ) + integer tbiaux(nbattx) +c + character*8 norenu + character*8 saux08 + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Renumerotations'')' + texte(1,7) = '(''Premieres valeurs : '',10i6)' +c + texte(2,4) = '(''... Numbers'')' + texte(2,7) = '(''First values : '',10i6)' +c +#include "esimpr.h" +c +c==== +c 2. Recuperation des parametres essentiels +c==== +c 2.1. ==> Nombre de profils +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFNPF', nompro +#endif + call mpfnpf ( idfmed, nbprof, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) nbprof +#endif +c + endif +c +c 2.2. ==> Parcours des profils +c + if ( codret.eq.0 ) then +c + do 22 , iaux = 1 , nbprof +c +c 2.2.1. ==> nom et taille du profil a lire +c + if ( codret.eq.0 ) then +c + jaux = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPFI', nompro +#endif + call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr +#endif +c + endif +c +c 2.2.2. ==> On ne continue que pour les renumerotations +c + if ( codret.eq.0 ) then +c + jaux = -2 + saux08 = 'Nombres ' + if ( noprof(1:8).eq.saux08 ) then + jaux = 8 + else + do 222 , typenh = -1 , 7 + saux08 = suffix(3,typenh)(1:2)//'HOMARD' + if ( noprof(1:8).eq.saux08 ) then + jaux = typenh + goto 223 + endif + 222 continue + endif +c + if ( jaux.eq.-2 ) then + goto 22 + else + typenh = jaux + endif +c + endif +c +c 2.2.3. ==> Allocation du tableau receptacle +c + 223 continue +c + if ( typenh.le.7 ) then +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.RenuMail', codre1 ) + if ( codre1.eq.1 ) then + codret = 0 + elseif ( codre1.eq.0 ) then + call gmaloj ( nomail//'.RenuMail', ' ', 0, jaux, codret ) + else + codret = 1 + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nomail//'.RenuMail', norenu, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + jaux = 30 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01', nompro +#endif + call utre01 ( typenh, jaux, + > norenu, nbvapr, 0, + > adenho, kaux, laux, + > ulsort, langue, codret) +c + endif +c + elseif ( typenh.eq.8 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( norenu//'.'//saux08, ' ', + > nbvapr, adenho, codre1 ) + call gmecat ( norenu , 19, nbvapr, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c 2.2.4. ==> Lecture de la liste des valeurs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, imem(adenho), codret ) +ccc call gmprsx ( nompro, norenu//'.'//saux08 ) +c + endif +c + 22 continue +c + endif +c +c==== +c 3. les attributs +c Il faut le faire seulement maintenant, sinon certaines valeurs +c sont ecrasees par utre01 +c==== +c +c 3.1. ==> Allocation eventuelle +c + if ( codret.eq.0 ) then +c + call gmnomc ( nomail//'.RenuMail', norenu, codret ) +c + endif +c +c 3.2. ==> Lecture +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 1234567890123456789 + noprof(1:19) = 'Attributs_de_norenu' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, tbiaux, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbattx + write (ulsort,texte(langue,7)) (tbiaux(jaux), jaux = 1, nbattx) +#endif +c +c 3.3. ==> Transfert +c + if ( codret.eq.0 ) then +c + do 33 , jaux = 1 , nbattx +c + kaux = jaux + call gmecat ( norenu, kaux, tbiaux(jaux), codre0 ) +c + codret = max ( abs(codre0), codret ) +c + 33 continue +c + endif +c +c 3.4. ==> Initialisation des nombres de mailles du calcul +c + if ( codret.eq.0 ) then +c + nbmapo = tbiaux(3) + nbsegm = tbiaux(5) + nbtria = tbiaux(7) + nbtetr = tbiaux(9) + nbquad = tbiaux(11) + nbpyra = tbiaux(13) + nbhexa = tbiaux(15) + nbpent = tbiaux(17) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh5.F b/src/tool/ES_HOMARD/eslmh5.F new file mode 100644 index 00000000..e7b8c131 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh5.F @@ -0,0 +1,194 @@ + subroutine eslmh5 ( typenh, norenu, reento, reenac, adenhn, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 5 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . reento . e . 1 . nombre d'entites . +c . reenac . e . 1 . nbr d'elements utiles et contenant entites . +c . adenhn . e . 1 . adresse du numero d'entite dans HOMARD . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer reento, reenac, adenhn +c + character*8 norenu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ideb, ifin + integer adencn +c + character*3 saux03 +#ifdef _DEBUG_HOMARD_ + character*6 saux06 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Mise a jour des renumerotations relatives aux '',a)' + texte(1,5) = '(a3,''Calcul impossible a allouer.'')' + texte(1,6) = + > '(''Adresse de '',a3,''HOMARD impossible a trouver.'')' +c + texte(2,4) = '(''Updating of renumbering for '',a)' + texte(2,5) = '(a3,''Calcul cannot be allocated.'')' + texte(2,6) = + > '(''Adress for '',a3,''HOMARD cannot be found.'')' +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + saux06 = 're'//suffix(2,typenh)(1:2)//'to' + write (ulsort,*) '==> ', saux06, ' = ', reento + saux06 = 're'//suffix(2,typenh)(1:2)//'ac' + write (ulsort,*) '==> ', saux06, ' = ', reenac +#endif +c +c 1.2. ==> types d'entites +c + saux03 = '.'//suffix(3,typenh)(1:2) +cgn write(ulsort,*) saux03 +c + codret = 0 +c + if ( reenac.ne.0 .and. reento.ne.0 ) then +c +c==== +c 2. Numerotation dans le calcul +c==== +c + jaux = 21 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE01', nompro +#endif + call utre01 ( typenh, jaux, + > norenu, reenac, reento, + > adenhn, adencn, kaux, + > ulsort, langue, codret) +c +c==== +c 3. Numerotation dans HOMARD +c==== +c + if ( codret.eq.0 ) then +c + ideb = adencn + ifin = adencn + reento - 1 + do 311 , iaux = ideb , ifin + imem(iaux) = 0 + 311 continue +c + do 312 , iaux = 1, reenac + jaux = imem(adenhn+iaux-1) + if ( jaux.ne.0 ) then + imem(adencn+jaux-1) = iaux + endif + 312 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + write(ulsort,texte(langue,4+codret)) saux03 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh6.F b/src/tool/ES_HOMARD/eslmh6.F new file mode 100644 index 00000000..3d52f2c3 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh6.F @@ -0,0 +1,186 @@ + subroutine eslmh6 ( idfmed, + > nhelig, + > tbiaux, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 6 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nhelig . e . char8 . nom de l'objet decrivant les ignores . +c . tbiaux . . * . tableau tampon entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH6' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envca1.h" +#include "envex1.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer tbiaux(0:*) +c + character*8 nhelig +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer hfmdel, hnoeel + integer nbnoel + integer codre1, codre2, codre3 + integer codre0 +c + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c +#include "impr03.h" +c +c==== +c 2. les elements ignores +c==== +c 2.1. ==> Lecture +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 1234567890123456 + noprof(1:16) = 'Elements_Ignores' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, tbiaux, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof +#endif +c +c 2.2. ==> Allocations +c + if ( codret.eq.0 ) then +c + nbelig = tbiaux(0) +c + if ( degre.eq.1 ) then + nbnoel = 5 + else + nbnoel = 13 + endif +c + iaux = nbelig * nbnoel + call gmaloj ( nhelig//'.ConnNoeu', ' ', iaux , hnoeel, codre1 ) + call gmaloj ( nhelig//'.FamilMED', ' ', nbelig, hfmdel, codre2 ) + call gmecat ( nhelig, 1, nbelig, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +cgn write (ulsort,90002) 'tbiaux', (tbiaux(iaux),iaux=1,14) +c +c 2.3. ==> Transfert +c + if ( codret.eq.0 ) then +c + do 231 , iaux = 1 , nbelig + imem(hfmdel+iaux-1) = tbiaux(iaux) + 231 continue + jaux = nbelig*nbnoel + do 232 , iaux = 1 , jaux + imem(hnoeel+iaux-1) = tbiaux(nbelig+iaux) + 232 continue +c + endif +cgn call gmprsx ( nompro, nhelig ) +cgn call gmprsx ( nompro, nhelig//'.ConnNoeu' ) +cgn call gmprsx ( nompro, nhelig//'.FamilMED' ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmh7.F b/src/tool/ES_HOMARD/eslmh7.F new file mode 100644 index 00000000..6c56af16 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmh7.F @@ -0,0 +1,392 @@ + subroutine eslmh7 ( idfmed, + > nocdfr, ncafdg, + > ltbiau, tbiaux, ltbsau, tbsaux, + > nomafr, lnomaf, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage Homard - phase 7 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier MED . +c . nocdfr . s . char8 . nom de l'objet description de la frontiere . +c . ncafdg . s . char*8 . nom de l'objet groupes frontiere . +c . ltbiau . e . 1 . longueur allouee a tbiaux . +c . tbiaux . e . * . tableau de travail . +c . ltbsau . e . 1 . longueur allouee a tbsaux . +c . tbsaux . . * . tableau tampon caracteres . +c . nomafr . e . char64 . nom du maillage MED de la frontiere . +c . lnomaf . e . 1 . longueur du nom du maillage de la frontiere. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMH7' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "front1.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ltbiau, tbiaux(ltbiau) + integer ltbsau + integer lnomaf +c + character*8 tbsaux(ltbsau) + character*8 nocdfr, ncafdg + character*64 nomafr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 +c + integer pgeoco, psomse, pnumli, ptypli, psegli, adabsc + integer lgpttg, lgtabl + integer pttgrl, ptngrl, pointl + integer ngro +c + character*64 noprof + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. intialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Recuperation de la frontiere discrete '',a)' +c + texte(2,4) = '(5x,''Readings of the discrete boundary '',a)' +c +#include "impr03.h" +c +#include "esimpr.h" +c + write (ulsort,texte(langue,4)) nomafr(1:lnomaf) +c + codret = 0 +c +c==== +c 2. Allocation de l'objet frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Allocations frontiere ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sfsdim', sfsdim + write (ulsort,90002) 'sfmdim', sfmdim + write (ulsort,90002) 'sfnbso', sfnbso + write (ulsort,90002) 'sfnbse', sfnbse +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( nocdfr, 'Cal_Fron', 0, iaux, codre1 ) + call gmecat ( nocdfr, 1, sfsdim, codre2 ) + call gmecat ( nocdfr, 2, sfmdim, codre3 ) + call gmecat ( nocdfr, 3, sfnbso, codre4 ) + call gmecat ( nocdfr, 5, sfnbse, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + iaux = sfsdim*sfnbso + call gmaloj ( nocdfr//'.CoorNoeu', ' ', iaux, pgeoco, codre1 ) + call gmaloj ( nocdfr//'.SommSegm', ' ', sfnbse, psomse, codre2 ) + call gmaloj ( nocdfr//'.AbsCurvi', ' ', sfnbse, adabsc, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c==== +c 3. Lecture des coordonnes des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Lecture ; codret', codret +#endif +c +c 3.1. ==> Lecture des coordonnees et des familles des noeuds +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMNO-'//nomafr(1:lnomaf), nompro +#endif + call eslmno ( idfmed, nomafr, + > iaux, + > sfnbso, sfsdim, rmem(pgeoco), tbiaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Description des lignes +c + if ( codret.eq.0 ) then +c + sfnbli = tbiaux(1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sfnbli', sfnbli + write(ulsort,*) (tbiaux(iaux), iaux=1, 2*(sfnbli+1)+1) +#endif + call gmecat ( nocdfr, 4, sfnbli, codre1 ) + call gmaloj ( nocdfr//'.NumeLign', ' ', sfnbli, pnumli, codre2 ) + call gmaloj ( nocdfr//'.TypeLign', ' ', sfnbli, ptypli, codre3 ) + call gmaloj ( nocdfr//'.PtrSomLi', ' ', sfnbli+1, psegli, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 321 , iaux = 0 , sfnbli-1 + imem(pnumli+iaux) = tbiaux(iaux+2) + 321 continue + do 322 , iaux = 0 , sfnbli-1 + imem(ptypli+iaux) = tbiaux(iaux+sfnbli+2) + 322 continue + do 323 , iaux = 0 , sfnbli + imem(psegli+iaux) = tbiaux(iaux+2*sfnbli+2) + 323 continue +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nocdfr ) + call gmprsx ( nompro, nocdfr//'.NumeLign' ) + call gmprsx ( nompro, nocdfr//'.TypeLign' ) + call gmprsx ( nompro, nocdfr//'.PtrSomLi' ) +#endif +c + endif +c +c==== +c 4. Lecture des abscisses curvilignes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Abscisses curvilignes ; codret', codret +#endif +c Le nom doit etre coherent avec eslmh2 +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. Creation maillage 2 ; codret', codret +#endif +c + saux64 = blan64 + saux64(1:8) = 'AbsCurvi' +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMNO-'//saux64(1:8), nompro +#endif + call eslmno ( idfmed, saux64, + > iaux, + > sfnbse, iaux, rmem(adabsc), imem(psomse), + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Lecture des groupes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Groupes ; codret', codret +#endif +c +c 5.1. ==> Lecture des valeurs entieres +c + if ( codret.eq.0 ) then +c + noprof = blan64 +c 1234567890123456789012 + noprof(1:22) = 'Groupes_des_frontieres' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, tbiaux, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof +#endif +c +c 5.2. ==> Memoire +c + if ( codret.eq.0 ) then +c + lgpttg = tbiaux(1) + lgtabl = tbiaux(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgpttg', lgpttg + write (ulsort,90002) 'lgtabl', lgtabl + write(ulsort,*) (tbiaux(iaux),iaux=1,3+lgpttg+lgtabl) +#endif +c + iaux = 1 + jaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAPTC', nompro +#endif + call utaptc ( nocdfr//'.Groupes', iaux, jaux, + > lgpttg, lgtabl, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nocdfr//'.Groupes', ncafdg, codret ) +c + endif +c +c 5.3. ==> Lecture des caracteres +c + if ( codret.eq.0 ) then +c + jaux = mod(lgtabl,10) + if ( jaux.eq.0 ) then + iaux = lgtabl/10 + else + iaux = (lgtabl-jaux)/10 + 1 + endif + ngro = iaux + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFAFAI', nompro +#endif + iaux = 2 + call mfafai ( idfmed, nomafr, iaux, saux64, jaux, + > tbsaux, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... Famille ', saux64 + write (ulsort,90002) 'numfam', jaux + do 5353 , iaux = 1 , ngro + write(ulsort,*) (tbsaux(10*(iaux-1)+jaux)//'+',jaux=1,10) + 5353 continue +#endif +c + endif +c +c 5.4. ==> Transfert +c + if ( codret.eq.0 ) then +c + do 541 , iaux = 0 , lgpttg + imem(pointl+iaux) = tbiaux(iaux+3) + 541 continue +c + jaux = lgpttg+3 + do 542 , iaux = 1 , lgtabl + imem(pttgrl+iaux-1) = tbiaux(jaux+iaux) + 542 continue +c + do 543 , iaux = 1 , lgtabl + smem(ptngrl+iaux-1) = tbsaux(iaux) + 543 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nocdfr ) + call gmprot (nompro, nocdfr//'.CoorNoeu', 1 , 20 ) + call gmprot (nompro, nocdfr//'.CoorNoeu', sfnbso-20 , sfnbso ) + call gmprsx (nompro, nocdfr//'.NumeLign' ) + call gmprsx (nompro, nocdfr//'.PtrSomLi' ) + call gmprot (nompro, nocdfr//'.SommSegm', 1 , 20 ) + call gmprot (nompro, nocdfr//'.SommSegm', sfnbse-20 , sfnbse ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 1 , 20 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', sfnbse-20 , sfnbse ) + call gmprsx (nompro, nocdfr//'.Groupes' ) + endif +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_HOMARD/eslmho.F b/src/tool/ES_HOMARD/eslmho.F new file mode 100644 index 00000000..5eea64f3 --- /dev/null +++ b/src/tool/ES_HOMARD/eslmho.F @@ -0,0 +1,618 @@ + subroutine eslmho ( typobs, nrosec, nretap, nrsset, + > nomail, typecc, + > suifro, nocdfr, ncafdg, + > ulsort, langue, codret) +c +c on peut ne stocker que des listes restreintes pour les +c homologues si on veut optimiser le stockage +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie : Lecture du Maillage HOmard +c - - - - -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . char*8 . mot-cle correspondant a l'objet a lire . +c . nrosec . e . 1 . numero de section pour les mesures de temps. +c . nretap . e . 1 . numero d'etape . +c . nrsset . e . 1 . numero de sous-etape . +c . nomail . s . char*8 . nom de l'objet maillage homard lu . +c . typecc . s . 1 . type de code de calcul associe . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nocdfr . s . char8 . nom de l'objet description de la frontiere . +c . ncafdg . s . char*8 . nom de l'objet groupes frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMHO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nomber.h" +#include "nombar.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 typobs +c + integer nrosec, nretap, nrsset + integer typecc + integer suifro +c + character*8 nomail + character*8 nocdfr + character*8 ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava +c + integer numead + integer voarno, vofaar, vovoar, vovofa + integer ppovos, pvoiso + integer pposif, pfacar + integer adnohn + integer admphn + integer adarhn + integer adtrhn + integer adquhn + integer adtehn + integer adhehn + integer adpyhn + integer adpehn + integer iaux, jaux, kaux + integer codre1 +c + character*6 saux + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + logical exiren +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + if ( nrosec.gt.0 ) then + call gtdems (nrosec) + endif +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' RECUPERATION DU MAILLAGE HOMARD'')' + texte(1,5) = '(38(''=''),/)' + texte(1,6) = '(''Mot-cle : '',a8)' +c + texte(2,4) = '(/,a6,'' READINGS OF HOMARD MESH'')' + texte(2,5) = '(30(''=''),/)' + texte(2,6) = '(''Keyword : '',a8)' +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +c==== +c 2. Lecture du maillage +c==== +c 2.1. ==> Lecture +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH1', nompro +#endif + call eslmh1 ( typobs, nomail, + > suifro, nocdfr, ncafdg, + > ulsort, langue, codret) +c +c 2.2. ==> Les structures +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then + typecc = typcca + endif +c +c==== +c 3. Reconstitution des informations supprimees a l'ecriture +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Reconstitution ; codret', codret +#endif +c +c 3.1. ==> les parentes +c +c 3.1.1. ==> filles des aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFAR', nompro +#endif + call utmfar ( nomail, ulsort, langue, codret) +c + endif +c +c 3.1.2. ==> filles des faces +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFFA', nompro +#endif + call utmffa ( nomail, ulsort, langue, codret) +c + endif +c +c 3.1.3. ==> fils des volumes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFVO', nompro +#endif + call utmfvo ( nomail, ulsort, langue, codret) +c +cgn call gmprsx(nompro,nhtetr//'.Mere') +cgn call gmprsx(nompro,nhhexa//'.Fille') +cgn call gmprsx(nompro,nhhexa//'.InfoSup2') +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres 3.1. parentes : codret', codret +#endif +c +c 3.2. ==> les voisinages +c + if ( codret.eq.0 ) then +c + voarno = 1 + vofaar = 1 + vovoar = 0 + vovofa = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres 3.2. voisinages : codret', codret +#endif +c + endif +c +c 3.3. ==> la renumerotation +c +c 3.3.1. ==> existe-t-il une renumerotation ? +c attention : il faut utiliser le nom compose, car si la +c structure n'existe pas, norenu vaut 'Indefini' +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.RenuMail', codre1 ) + if ( codre1.eq.1 ) then + exiren = .true. + elseif ( codre1.eq.0 ) then + exiren = .false. + else + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres 3.3.1 : codret', codret +#endif +c + endif +c +c 3.3.2. ==> reactualisation des communs en attendant une vraie +c exploitation de la structure partout +c + if ( exiren ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, norenu ) + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 30 + call utre03 ( iaux, jaux, norenu, + > renoac, renoto, adnohn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_mp', nompro +#endif + iaux = 0 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > rempac, rempto, admphn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + iaux = 1 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > rearac, rearto, adarhn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > retrac, retrto, adtrhn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_te', nompro +#endif + iaux = 3 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > reteac, reteto, adtehn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > requac, requto, adquhn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_py', nompro +#endif + iaux = 5 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > repyac, repyto, adpyhn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_he', nompro +#endif + iaux = 6 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > reheac, reheto, adhehn, kaux, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro +#endif + iaux = 7 + jaux = -30 + call utre03 ( iaux, jaux, norenu, + > repeac, repeto, adpehn, kaux, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Apres 3.3.2 : codret', codret +#endif +c +c 3.3.3. ==> creation des tableaux reciproques +c + if ( codret.eq.0 ) then +c + if ( exiren ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_no', nompro +#endif + iaux = -1 + call eslmh5 ( iaux, norenu, renoto, renoac, adnohn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_mp', nompro +#endif + iaux = 0 + call eslmh5 ( iaux, norenu, rempto, rempac, admphn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_ar', nompro +#endif + iaux = 1 + call eslmh5 ( iaux, norenu, rearto, rearac, adarhn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_tr', nompro +#endif + iaux = 2 + call eslmh5 ( iaux, norenu, retrto, retrac, adtrhn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_te', nompro +#endif + iaux = 3 + call eslmh5 ( iaux, norenu, reteto, reteac, adtehn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_qu', nompro +#endif + iaux = 4 + call eslmh5 ( iaux, norenu, requto, requac, adquhn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_py', nompro +#endif + iaux = 5 + call eslmh5 ( iaux, norenu, repyto, repyac, adpyhn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_he', nompro +#endif + iaux = 6 + call eslmh5 ( iaux, norenu, reheto, reheac, adhehn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMH5_pe', nompro +#endif + iaux = 7 + call eslmh5 ( iaux, norenu, repeto, repeac, adpehn, + > ulsort, langue, codret) +c + endif +c + endif +c + endif +c +c==== +c 5. meres adoptives des faces pour la non conformite initiale +c Il faut le faire seulement maintenant, une fois que toutes les +c autres grandeurs ont ete initialisees +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. meres adoptives ; codret', codret +#endif +c + if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC08', nompro +#endif + call utnc08 ( nharet, nhtria, nhquad, nhvois, + > numead, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. verification de la conformite +c les messages sont toujours imprimes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. verification conformite ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOMA', nompro +#endif + call utcoma ( nomail, + > iaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,6)) typobs +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + if ( nrosec.gt.0 ) then + call gtfims (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/ES_MED/CMakeLists.txt b/src/tool/ES_MED/CMakeLists.txt new file mode 100644 index 00000000..08d5bc3b --- /dev/null +++ b/src/tool/ES_MED/CMakeLists.txt @@ -0,0 +1,81 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de ES_MED + +SET(ES_MED_SOURCES + ./esdesc.F + ./esech1.F + ./esech2.F + ./esech3.F + ./esemm0.F + ./esemm1.F + ./esemmb.F + ./esemmc.F + ./esemmd.F + ./esemmf.F + ./esemmq.F + ./esemno.F + ./eses11.F + ./esesm1.F + ./esesmd.F + ./eslch1.F + ./eslch2.F + ./eslch3.F + ./eslch4.F + ./eslch5.F + ./eslch6.F + ./eslch7.F + ./eslch8.F + ./eslent.F + ./eslimd.F + ./eslmm1.F + ./eslmm2.F + ./eslmmb.F + ./eslmmc.F + ./eslmmd.F + ./eslmmf.F + ./eslmmn.F + ./eslmno.F + ./eslnma.F + ./eslnof.F + ./eslnom.F + ./eslnum.F + ./eslpg1.F + ./eslpg2.F + ./eslpr1.F + ./eslsc1.F + ./eslsch.F + ./eslsm0.F + ./eslsm1.F + ./eslsm2.F + ./eslsm3.F + ./eslsm4.F + ./eslsm5.F + ./eslsmd.F + ./esouvl.F + ./esveri.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/ES_MED ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (ES_MED ${ES_MED_SOURCES}) + +INSTALL(TARGETS ES_MED EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/ES_MED/esdesc.F b/src/tool/ES_MED/esdesc.F new file mode 100644 index 00000000..c984908f --- /dev/null +++ b/src/tool/ES_MED/esdesc.F @@ -0,0 +1,193 @@ + subroutine esdesc ( idfmed, saux, descri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - format MED - DESCription +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . saux . e . 1 . texte complementaire eventuel . +c . descri . s . 1 . description enregistree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESDESC' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "nuvers.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ulsort, langue, codret +c + character*(*) saux + character*200 descri +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer numann, datheu +c + character*5 saux05 + character*48 ladate +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + codret = 0 +c +c==== +c 2. description du fichier +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> Les 20 premiers caracteres ne doivent pas changer, de +c maniere a assurer la compatibilite avec les logiciels +c en couplage avec HOMARD +c +c 'HOMARD VN.P NITER ' +c 123456 12345678 I5 A50 +c 12345678901234567890123456 +c + descri = ' ' + descri( 1: 6) = 'HOMARD' + descri( 8:15) = nuvers + call utench ( nbiter, 'D', iaux, saux05, + > ulsort, langue, codret ) + descri(17:21) = saux05 +c +c 2.2. ==> Date de creation du fichier +c + call utdhlg ( ladate, langue ) + descri(23:70) = ladate +c +c 2.3. ==> Eventuel texte libre +c + call utlgut ( iaux, saux, + > ulsort, langue, codret ) + if ( codret.eq.0 .and.iaux.gt.0 ) then + iaux = min(iaux,80) + descri(81:80+iaux) = saux(1:iaux) + else + codret = 0 + endif +c +c 2.4. ==> Copyright +c 2345678901234567890 + descri(142:160) = 'Copyright 1996 EDF,' +c 23456789012345678901 + descri(162:181) = ' Copyright 2015 EDF,' +c 2345678901 + descri(182:191) = ' Copyright' + call utdhco ( numann, datheu ) + call utench ( numann, 'D', iaux, saux05, + > ulsort, langue, codret ) + descri(192:196) = saux05 +c 7890 + descri(197:200) = ' EDF' + endif +c +c 2.5. ==> Appel du programme MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,47)) descri +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICOW', nompro +#endif + call mficow ( idfmed, descri, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mficow', codret + write(ulsort,texte(langue,80)) + write(ulsort,texte(langue,47)) descri + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esech1.F b/src/tool/ES_MED/esech1.F new file mode 100644 index 00000000..34ba8b68 --- /dev/null +++ b/src/tool/ES_MED/esech1.F @@ -0,0 +1,529 @@ + subroutine esech1 ( idfmed, nomcha, + > nbcomp, nbtvch, + > caraen, carare, caraca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un CHamp au format MED - phase 1 +c - - - -- - +c remarque : on n'ecrit que les champs reels +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en sortie . +c . nomcha . e . char64 . nom du champ . +c . nbcomp . e . 1 . nombre de composantes . +c . nbtvch . e . 1 . nombre de tableaux associes . +c . caraen . e . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . carare . e . nbtvch . caracteristiques reelles du champ . +c . . . . 1. valeur du pas de temps . +c . caraca . e . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbsqch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECH1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbcomp, nbtvch + integer caraen(nbinec,nbtvch) +c + double precision carare(nbtvch) +c + character*8 caraca(nbincc,nbtvch) + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nrotv, nbpg + integer typenh + integer nbvalc + integer typgeo, numdt, numit, ngauss, nbval, nbvapr + integer nrtafo + integer typcha + integer typgef, ngausf, nbenmx, nbvapf, nbtyas + integer carsup, carsuf, nbtafo + integer typint + integer adtra1 + integer advale, advalr, adobch, adprpg, adtyas + integer adcono, adcopg, adpopg +c + double precision dtval +c + character*6 saux06 + character*8 nomfon, obprof, oblopg + character*8 ntrav1 + character*64 nolopg + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Tableau numero '',i6,/,21(''-''))' + texte(1,5) = + > '(''. Ecriture sur les '',a,'' au pas de temps : '',i6)' + texte(1,6) = + > '(''. Ecriture sur les '',a,'' sans pas de temps'')' + texte(1,7) = '(''. Profil : '',a)' + texte(1,8) = '(''. Localisation des points de Gauss : '',a)' + texte(1,13) = '(''... Premiere valeur : '',g14.7)' + texte(1,14) = '(''... Derniere valeur : '',g14.7)' +c + texte(2,4) = '(/,''Table # '',i6,/,14(''-''))' + texte(2,5) = + > '(''. Writings over the '',a,'' at time step # '',i6)' + texte(2,6) = '(''. Writings over the '',a,'' without time step'')' + texte(2,7) = '(''. Profile: '',a)' + texte(2,8) = '(''. Localization of points of Gauss: '',a)' + texte(2,13) = '(''... First value: '',g14.7)' + texte(2,14) = '(''... Last value : '',g14.7)' +c +#include "impr03.h" +c +c==== +c 2. on parcourt tous les tableaux +c==== +c + codret = 0 +cgn write (ulsort,90002) 'nbtvch', nbtvch +c + do 20 , nrotv = 1 , nbtvch +c +c 2.1. ==> caracteristiques du tableau courant +c + if ( codret.eq.0 ) then +c + typgeo = caraen(1,nrotv) + numdt = caraen(2,nrotv) + numit = caraen(3,nrotv) + ngauss = caraen(4,nrotv) + nbval = caraen(5,nrotv) + nbvapr = caraen(6,nrotv) + nbtyas = caraen(7,nrotv) + carsup = caraen(8,nrotv) + nrtafo = caraen(9,nrotv) + dtval = carare(nrotv) + nomfon = caraca(1,nrotv) + obprof = caraca(2,nrotv) + oblopg = caraca(3,nrotv) + if ( typgeo.eq.0 ) then + typenh = ednoeu + elseif ( carsup.eq.1 ) then + typenh = ednoma + else + typenh = edmail + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrotv + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'numdt ', numdt + write (ulsort,90002) 'numit ', numit + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbval ', nbval + write (ulsort,90002) 'nbvapr', nbvapr + if ( nbvapr.gt.0 ) then + write (ulsort,90003) 'obprof', obprof + endif + write (ulsort,90002) 'nbtyas', nbtyas + if ( nbtyas.gt.0 ) then + write (ulsort,90002) + > 'typass', (caraen(20+iaux,nrotv),iaux=1,nbtyas) + endif + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nrtafo', nrtafo + if ( numdt.ne.ednodt ) then + write (ulsort,90004) 'dtval ', dtval + endif + if ( oblopg.ne.blan08 ) then + write (ulsort,90003) 'oblopg', oblopg + endif +#endif +c + endif +c +c 2.2. ==> en l'absence de valeurs, on passe au tableau suivant +c + if ( codret.eq.0 ) then +c + if ( nbval.eq.0 ) then + goto 20 + endif +c + endif +c +c 2.3. ==> recuperation de la fonction +c on controle que les caracterisations sont bien les memes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nomfon) + call gmprot (nompro,nomfon//'.ValeursR', 1, 10) + call gmprot (nompro,nomfon//'.ValeursR', nbval-9, nbval) + call gmprot (nompro,nomfon//'.ValeursE', 1, 10) + call gmprot (nompro,nomfon//'.ValeursE', nbval-9, nbval) + call gmprsx (nompro,nomfon//'.InfoPrPG' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nomfon, + > typcha, + > typgef, ngausf, nbenmx, nbvapf, nbtyas, + > carsuf, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'typcha', typcha + if ( typcha.eq.edfl64 ) then + write (ulsort,texte(langue,13)) rmem(advalr) + write (ulsort,texte(langue,14)) rmem(advalr+nbval*nbtafo-1) + else + write (ulsort,texte(langue,13)) imem(advale) + write (ulsort,texte(langue,14)) imem(advale+nbval*nbtafo-1) + endif + endif +#endif +c + if ( codret.eq.0 ) then + if ( typgef.ne.typgeo ) then + saux06 = 'typgeo' + codret = 1 + iaux = typgef + jaux = typgeo + elseif ( ngausf.ne.ngauss ) then + saux06 = 'ngauss' + codret = 2 + iaux = ngausf + jaux = ngauss + elseif ( nbenmx.ne.nbval ) then + saux06 = 'nbval ' + codret = 3 + iaux = nbenmx + jaux = nbval + elseif ( nbvapf.ne.nbvapr ) then + saux06 = 'nbvapr' + codret = 4 + iaux = nbvapf + jaux = nbvapr + elseif ( carsuf.ne.carsup ) then + saux06 = 'carsup' + codret = 5 + iaux = carsuf + jaux = carsup + endif + if ( codret.ne.0 ) then + write (ulsort,texte(langue,36)) saux06, iaux + write (ulsort,texte(langue,37)) saux06, jaux + endif + endif +c +c 2.4. ==> le profil eventuel +c + if ( codret.eq.0 ) then +c + if ( nbvapr.gt.0 ) then +c + if ( obprof.eq.smem(adprpg) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( obprof, + > iaux, noprof, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,61)) noprof + endif +#endif +c + else + codret = 5 + endif +c + else +c + noprof = ednopl +c + endif +c + endif +c +c 2.5. ==> les eventuelles localisations de points de Gauss +c + if ( codret.eq.0 ) then +c + if ( oblopg.eq.blan08 ) then + nolopg = ednoga + else + if ( oblopg.eq.smem(adprpg+1) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPG', nompro +#endif + call utcapg ( oblopg, + > nolopg, iaux, jaux, kaux, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,81)) nolopg + endif +#endif +c + else + codret = 6 + endif + endif +c + endif +c +c 2.6. ==> allocation d'un tableau de travail +c + if ( codret.eq.0 ) then +c + if ( ngauss.eq.ednopg ) then + nbpg = 1 + else + nbpg = ngauss + endif + jaux = nbpg*nbval*nbcomp +cgn write (ulsort,*)'allocation a nbpg*nbval*nbcomp = ', jaux + if ( typcha.eq.edfl64 ) then + call gmalot ( ntrav1, 'reel ', jaux, adtra1, codret ) + else + call gmalot ( ntrav1, 'entier ', jaux, adtra1, codret ) + endif +c + endif +c +c 2.7. ==> transfert des valeurs dans le tableau de travail +c + if ( codret.eq.0 ) then +c + if ( nbvapr.gt.0 ) then + nbvalc = nbvapr + else + nbvalc = nbenmx + endif +c + if ( typcha.eq.edfl64 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECH2', nompro +#endif + call esech2 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > rmem(advalr), rmem(adtra1), + > ulsort, langue, codret ) +cgn print *,(rmem(adtra1+iaux),iaux=0,nbval*nbcomp-1) + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECH3', nompro +#endif + call esech3 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > imem(advale), imem(adtra1), + > ulsort, langue, codret ) +cgn print *,(imem(adtra1+iaux),iaux=0,nbval*nbcomp- + endif +c + endif +c +c 2.8. ==> ecriture MED +c Le tableau a ete converti dans le mode MED non entrelace. +c + if ( codret.eq.0 ) then +c + jaux = medtrf(typgeo) + if ( jaux.ge.1 ) then + jaux = ( jaux + mod(jaux,2) ) / 2 + endif + if ( numdt.ne.ednodt ) then + write (ulsort,texte(langue,5)) mess14(langue,3,jaux), numdt + else + write (ulsort,texte(langue,6)) mess14(langue,3,jaux) + endif + if ( nbvapr.gt.0 ) then + write (ulsort,texte(langue,7)) noprof + endif + if ( carsup.gt.1 ) then + write (ulsort,texte(langue,8)) nolopg + endif +cgn print *,(rmem(adtra1+iaux),iaux=0,nbval*nbcomp-1) +cgn write (ulsort,90003)'Pour nomcha', nomcha +cgn write (ulsort,90002)'numdt, numit', numdt, numit +cgn write (ulsort,90004)'instant', dtval +cgn write (ulsort,90002)'mailles(0)/noeuds(3)/elno(4)', typenh +cgn write (ulsort,90002)'type MED', typgeo +cgn write (ulsort,90003)'Profil', noprof +cgn write (ulsort,90003)'Localisation des points de Gauss', nolopg +cgn write (ulsort,90002)'Nombre de valeurs', nbval +cgn write (ulsort,90002) 'ngauss', ngauss +cgn write (ulsort,90004)'1ere et derniere valeurs', +cgn > rmem(adtra1),rmem(adtra1-1+nbval) +c + if ( ngauss.eq.ednopg ) then + jaux = nbval + else + jaux = nbpg*nbval + endif +c + if ( typcha.eq.edfl64 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDRPW', nompro +#endif + call mfdrpw ( idfmed, nomcha, numdt, numit, dtval, + > typenh, typgeo, + > edstco, noprof, nolopg, ednoin, edall, + > nbval, rmem(adtra1), codret ) +cgn write (ulsort,*)(imem(adtra1+iaux),iaux=0,nbval*nbcomp-1) + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIPW', nompro +#endif + call mfdipw ( idfmed, nomcha, numdt, numit, dtval, + > typenh, typgeo, + > edstco, noprof, nolopg, ednoin, edall, + > nbval, imem(adtra1), codret ) + endif +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,19)) nomcha + endif +c + endif +c +c 2.9. ==> liberation du tableau d'ecriture +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav1, codret ) + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esech2.F b/src/tool/ES_MED/esech2.F new file mode 100644 index 00000000..787c6b5f --- /dev/null +++ b/src/tool/ES_MED/esech2.F @@ -0,0 +1,208 @@ + subroutine esech2 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > vafonc, trav1, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un CHamp au format MED - phase 2 +c - - - -- - +c Ce programme est le symetrique de ESLCH5 +c remarque : esech2 et esech3 sont des clones +c 2 : double precision +c 3 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrtafo . es . 1 . numero courant du tableau de la fonction . +c . nbcomp . e . 1 . nombre de composantes du champ . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . renume . e . * . renumerotation des entites . +c . nbvalc . e . 1 . nombre de valeurs par composante . +c . nbpg . e . 1 . nombre de points de Gauss, s'il y en a . +c . . . . si le champ est sans point de Gauss, nbpg . +c . . . . vaut 1 pour aider au traitement . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECH2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nrtafo + integer nbtafo + integer nbpg, nbvalc, nbcomp +c + double precision trav1(nbpg,nbvalc,nbcomp) + double precision vafonc(nbtafo,nbpg,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp, nugaus +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''. Premiere valeur : '',g14.7)' + texte(1,6) = '(''. Derniere valeur : '',g14.7)' +c + texte(2,5) = '(''. First value: '',g14.7)' + texte(2,6) = '(''. Last value : '',g14.7)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '=============================================' + write (ulsort,texte(langue,58)) nbvalc + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,texte(langue,111)) nbtafo + write (ulsort,texte(langue,57)) nbpg + write (ulsort,90002) 'nrtafo', nrtafo + write (ulsort,texte(langue,5)) vafonc(nrtafo,1,1) + write (ulsort,texte(langue,6)) vafonc(nrtafo,nbpg,nbvalc) +#endif +c +c==== +c . Sans points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 est declare ainsi : trav1(nbpg,nbensu,nbcomp), ce qui +c corrrespond a trav1(nbensu,nbcomp) sans points de Gauss. +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1), trav1(2,1), trav1(3,1), ..., trav1(nbensu,1), +c trav1(1,2), trav1(2,2), trav1(3,2), ..., trav1(nbensu,2), +c ... +c trav1(1,nbcomp), trav1(2,nbcomp), ..., trav1(nbensu,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +c +c . Avec nbpg points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 sera declare ainsi : trav1(nbpg,nbensu,nbcomp). +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1,1), trav1(2,1,1), ..., trav1(nbpg,1,1), trav1(1,2,1), +c trav1(2,2,1), ..., trav1(nbpg,2,1), trav1(1,3,1), ..., +c trav1(1,nbensu,1), trav1(2,nbensu,1), ..., trav1(nbpg,nbensu,1), +c trav1(1,1,2), trav1(2,1,2), ..., trav1(nbpg,1,2), trav1(1,2,2), +c trav1(2,2,2), ..., trav1(nbpg,2,2), trav1(1,3,2), ..., +c trav1(1,nbensu,2), trav1(2,nbensu,2), ..., trav1(nbpg,nbensu,2), +c ... +c trav1(1,1,nrcomp), trav1(2,1,nrcomp), ..., trav1(nbpg,1,nrcomp), +c trav1(1,2,nrcomp), trav1(2,2,nrcomp), ..., trav1(nbpg,2,nrcomp), +c trav1(1,3,nrcomp), ..., trav1(nbpg,nbensu,nrcomp) +c on a ainsi tous les points de Gauss de la premiere maille de la +c premiere composante, puis tous les points de Gauss de la +c deuxieme maille de la premiere composante, etc. jusqu'a la fin de +c la premiere composante. Ensuite on recommence avec la deuxieme +c composante. +c +c . Remarque : C'est ce que MED appelle le mode non entrelace. +c==== +c + codret = 0 +c + do 20 , nrcomp = 1 , nbcomp +cgn print *,'nrcomp,nrtafo,nbvalc = ',nrcomp,nrtafo,nbvalc +c + if ( nbpg.eq.1 ) then + do 21 , iaux = 1 , nbvalc +cgn print *,'iaux = ',iaux +cgn print *,'vafonc(',nrtafo,',1,',iaux,') = ',vafonc(nrtafo,1,iaux) + trav1(1,iaux,nrcomp) = vafonc(nrtafo,1,iaux) +cgn write(12,*) 'trav1 = ',trav1(1,iaux,nrcomp) + 21 continue + else + do 22 , iaux = 1 , nbvalc + do 221 , nugaus = 1 , nbpg + trav1(nugaus,iaux,nrcomp) = vafonc(nrtafo,nugaus,iaux) + 221 continue + 22 continue + endif +c + nrtafo = nrtafo + 1 +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrtafo', nrtafo +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esech3.F b/src/tool/ES_MED/esech3.F new file mode 100644 index 00000000..528de7dd --- /dev/null +++ b/src/tool/ES_MED/esech3.F @@ -0,0 +1,208 @@ + subroutine esech3 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > vafonc, trav1, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un CHamp au format MED - phase 3 +c - - - -- - +c Ce programme est le symetrique de ESLCH5 +c remarque : esech2 et esech3 sont des clones +c 2 : double precision +c 3 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrtafo . es . 1 . numero courant du tableau de la fonction . +c . nbcomp . e . 1 . nombre de composantes du champ . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . renume . e . * . renumerotation des entites . +c . nbvalc . e . 1 . nombre de valeurs par composante . +c . nbpg . e . 1 . nombre de points de Gauss, s'il y en a . +c . . . . si le champ est sans point de Gauss, nbpg . +c . . . . vaut 1 pour aider au traitement . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESECH3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nrtafo + integer nbtafo + integer nbpg, nbvalc, nbcomp +c + integer trav1(nbpg,nbvalc,nbcomp) + integer vafonc(nbtafo,nbpg,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp, nugaus +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''. Premiere valeur : '',i10)' + texte(1,6) = '(''. Derniere valeur : '',i10)' +c + texte(2,5) = '(''. First value: '',i10)' + texte(2,6) = '(''. Last value : '',i10)' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '=============================================' + write (ulsort,texte(langue,58)) nbvalc + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,texte(langue,111)) nbtafo + write (ulsort,texte(langue,57)) nbpg + write (ulsort,90002) 'nrtafo', nrtafo + write (ulsort,texte(langue,5)) vafonc(nrtafo,1,1) + write (ulsort,texte(langue,6)) vafonc(nrtafo,nbpg,nbvalc) +#endif +c +c==== +c . Sans points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 est declare ainsi : trav1(nbpg,nbensu,nbcomp), ce qui +c corrrespond a trav1(nbensu,nbcomp) sans points de Gauss. +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1), trav1(2,1), trav1(3,1), ..., trav1(nbensu,1), +c trav1(1,2), trav1(2,2), trav1(3,2), ..., trav1(nbensu,2), +c ... +c trav1(1,nbcomp), trav1(2,nbcomp), ..., trav1(nbensu,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +c +c . Avec nbpg points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 sera declare ainsi : trav1(nbpg,nbensu,nbcomp). +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1,1), trav1(2,1,1), ..., trav1(nbpg,1,1), trav1(1,2,1), +c trav1(2,2,1), ..., trav1(nbpg,2,1), trav1(1,3,1), ..., +c trav1(1,nbensu,1), trav1(2,nbensu,1), ..., trav1(nbpg,nbensu,1), +c trav1(1,1,2), trav1(2,1,2), ..., trav1(nbpg,1,2), trav1(1,2,2), +c trav1(2,2,2), ..., trav1(nbpg,2,2), trav1(1,3,2), ..., +c trav1(1,nbensu,2), trav1(2,nbensu,2), ..., trav1(nbpg,nbensu,2), +c ... +c trav1(1,1,nrcomp), trav1(2,1,nrcomp), ..., trav1(nbpg,1,nrcomp), +c trav1(1,2,nrcomp), trav1(2,2,nrcomp), ..., trav1(nbpg,2,nrcomp), +c trav1(1,3,nrcomp), ..., trav1(nbpg,nbensu,nrcomp) +c on a ainsi tous les points de Gauss de la premiere maille de la +c premiere composante, puis tous les points de Gauss de la +c deuxieme maille de la premiere composante, etc. jusqu'a la fin de +c la premiere composante. Ensuite on recommence avec la deuxieme +c composante. +c +c . Remarque : C'est ce que MED appelle le mode non entrelace. +c==== +c + codret = 0 +c + do 20 , nrcomp = 1 , nbcomp +cgn print *,'nrcomp,nrtafo,nbvalc = ',nrcomp,nrtafo,nbvalc +c + if ( nbpg.eq.1 ) then + do 21 , iaux = 1 , nbvalc +cgn print *,'iaux = ',iaux +cgn print *,'vafonc(',nrtafo,',1,',iaux,') = ',vafonc(nrtafo,1,iaux) + trav1(1,iaux,nrcomp) = vafonc(nrtafo,1,iaux) +cgn write(12,*) 'trav1 = ',trav1(1,iaux,nrcomp) + 21 continue + else + do 22 , iaux = 1 , nbvalc + do 221 , nugaus = 1 , nbpg + trav1(nugaus,iaux,nrcomp) = vafonc(nrtafo,nugaus,iaux) + 221 continue + 22 continue + endif +c + nrtafo = nrtafo + 1 +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrtafo', nrtafo +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemm0.F b/src/tool/ES_MED/esemm0.F new file mode 100644 index 00000000..5e1b5c2e --- /dev/null +++ b/src/tool/ES_MED/esemm0.F @@ -0,0 +1,215 @@ + subroutine esemm0 ( idfmed, nomamd, + > sdim, mdim, descri, + > nbpqt, inftbl, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED - phase 0 +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . sdim . e . 1 . dimension de l'espace . +c . mdim . e . 1 . dimension du maillage . +c . inftbl . e .nbpqt*10. tables en caracteres des infos generales . +c . . . . regroupees par paquets de 80 caracteres . +c . . . . pour gerer la conversion en pseudo-groupe . +c . . . . paquet 1 : 1 : 'NomCo' . +c . . . . 2/3, 4/5, 6/7 : nom coordonnees . +c . . . . 8 : nom du repere utilise . +c . . . . paquet 2 : 1 : 'UniteCo' . +c . . . . 2/3, 4/5, 6/7 : unite coord. . +c . . . . paquet 3 : titre (limite a 80 caracteres) . +c . . . . paquet 4 : 1 : 'NOMAMD' . +c . . . . 2-7 : nom du maillage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMM0' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer sdim, mdim + integer nbpqt +c + character*8 inftbl(10*nbpqt) +c + character*64 nomamd + character*200 descri +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux + integer typrep + integer stype +c + character*16 nomaxe(3), uniaxe(3) + character*16 dtunit +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Ecriture complete.'')' + texte(1,5) = '(''Ecriture uniquement de la renumerotation.'')' +c + texte(2,4) = '(''Full writings.'')' + texte(2,5) = '(''Writings of numbering only.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c + codret = 0 +c +c==== +c 2. restauration des noms et unites des axes +c==== +c + do 21 , iaux = 1, nbpqt +c + jaux = 10*(iaux-1) + 1 +cgn write (ulsort,90064) jaux, '%'//inftbl(jaux)//'%' +c +c 2.1. Repere et noms des coordonnees +c + if ( inftbl(jaux).eq.'NomCo ' ) then +c + read ( inftbl(jaux+9), '(i8)' ) typrep +cgn write (ulsort,90002)'typrep',typrep + do 211 , kaux = 1 , sdim + nomaxe(kaux) = inftbl(jaux+2*kaux-1)//inftbl(jaux+2*kaux) +cgn write (ulsort,90064) kaux, '%'//nomaxe(kaux)//'%' + 211 continue +c +c 2.2. Unites des coordonnees +c + elseif ( inftbl(jaux).eq.'UniteCo ' ) then +c + do 212 , kaux = 1 , sdim + uniaxe(kaux) = inftbl(jaux+2*kaux-1)//inftbl(jaux+2*kaux) +cgn write (ulsort,90064) kaux, '%'//uniaxe(kaux)//'%' + 212 continue +c + endif +c + 21 continue +c +c==== +c 3. creation du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. creation du maillage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c a TRAITER mettre dtunit dans inftbl + dtunit = blan16 + stype = edsodi +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'idfmed', idfmed + write (ulsort,90003) 'nomamd', nomamd + write (ulsort,90002) 'len(nomamd)', len(nomamd) + write (ulsort,90002) 'sdim ', sdim + write (ulsort,90002) 'mdim ', mdim + write (ulsort,90002) 'ednost', ednost + write (ulsort,90003) 'descri', descri + write (ulsort,90003) 'dtunit', dtunit + write (ulsort,90002) 'stype ', stype + write (ulsort,90002) 'typrep', typrep + write (ulsort,90003) 'nomaxe', nomaxe + write (ulsort,90003) 'uniaxe', uniaxe +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHCRE', nompro +#endif + call mmhcre ( idfmed, nomamd, sdim, mdim, ednost, descri, + > dtunit, stype, typrep, nomaxe, uniaxe, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mmhcre', codret + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemm1.F b/src/tool/ES_MED/esemm1.F new file mode 100644 index 00000000..45ac3fca --- /dev/null +++ b/src/tool/ES_MED/esemm1.F @@ -0,0 +1,1015 @@ + subroutine esemm1 ( idfmed, nomamd, lnomam, + > nbnoto, + > coonca, fameno, noeele, famele, typele, + > numfam, nomfam, + > grfmpo, grfmtb, + > nbpqt, inftbl, + > eqpntr, eqinfo, + > eqnoeu, + > eqaret, eqtria, eqquad, + > eqtetr, eqhexa, + > tabaux, listma, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED - phase 1 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . lnomam . e . 1 . longueur du nom du maillage voulu . +c . fameno . e . nbnoto . famille med des noeuds . +c . famele . e . nbelem . famille med des elements . +c . noeele . e . nbelem . noeuds des elements . +c . . . *nbmane. . +c . typele . e . nbelem . type des elements . +c . coonca . s . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . numfam . e . nbfmed . numero des familles . +c . nomfam . e .10nbfmed. nom des familles . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . inftbl . e .nbpqt*10. tables en caracteres des infos generales . +c . . . . regroupees par paquets de 80 caracteres . +c . . . . pour gerer la conversion en pseudo-groupe . +c . . . . paquet 1 : 1 : 'NomCo' . +c . . . . 2/3, 4/5, 6/7 : nom coordonnees . +c . . . . 8 : nom du repere utilise . +c . . . . paquet 2 : 1 : 'UniteCo' . +c . . . . 2/3, 4/5, 6/7 : unite coord. . +c . . . . paquet 3 : titre (limite a 80 caracteres) . +c . . . . paquet 4 : 1 : 'NOMAMD' . +c . . . . 2-7 : nom du maillage . +c . tabaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . listma . . nbelem . tableau auxiliaire . +c . eqpntr . e .5*nbequi. 5i-4 : nombre de paires de noeuds pour . +c . . . . l'equivalence i . +c . . . . 5i-3 : idem pour les mailles-points . +c . . . . 5i-2 : idem pour les aretes . +c . . . . 5i-1 : idem pour les triangles . +c . . . . 5i : idem pour les quadrangles . +c . eqinfo . e .33nbequi. nom et description de chaque equivalence . +c . eqnoeu . e .2*nbeqno. liste des paires de noeuds equivalents avec. +c . . . . la convention : eqnoeu(i)<-->eqnoeu(i+1) . +c . eqmapo . e .2*nbeqmp. idem pour les mailles-points . +c . eqaret . e .2*nbeqar. idem pour les aretes . +c . eqtria . e .2*nbeqtr. idem pour les triangles . +c . eqquad . e .2*nbeqqu. idem pour les quadrangles . +c . eqtetr . e .2*nbeqte. idem pour les tetraedres . +c . eqhexa . e .2*nbeqhe. idem pour les hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMM1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "indefi.h" +c +#include "envca1.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer lnomam + integer ulsort, langue, codret +c + integer nbnoto + integer fameno(nbnoto) + integer noeele(nbelem,nbmane), famele(nbelem), typele(nbelem) + integer grfmpo(0:nbfmed) + integer numfam(nbfmed) + integer eqpntr(5*nbequi) + integer eqnoeu(2*nbeqno) + integer eqaret(2*nbeqar) + integer eqtria(2*nbeqtr), eqquad(2*nbeqqu) + integer eqtetr(2*nbeqte), eqhexa(2*nbeqhe) + integer tabaux(nbelem*nbmane), listma(nbelem) + integer nbpqt +c + character*8 grfmtb(10*ngrouc) + character*8 inftbl(10*nbpqt) + character*8 nomfam(10,nbfmed) + character*8 eqinfo(33*nbequi) +c + character*64 nomamd +c + double precision coonca(nbnoto,sdimca) +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer typnoe, typpoi, typseg, typtri, typtet, typenc + integer typqua, typhex, typpyr, typpen + integer ibtetr, ibtria, ibsegm, ibmapo, ialist, lamail + integer ibquad, ibhexa, ibpyra, ibpent + integer iaux, jaux, kaux +#ifdef _DEBUG_HOMARD_ + integer iaux1 +#endif + integer ngro, numero + integer adeqin, adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe + integer tbiaux(3,10) + integer numdt, numit +c + character*32 saux32 + character*64 saux64 + character*80 saux80 + character*200 sau200 +c + double precision instan +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Maille numero '',i10,'', de type'',i10)' + texte(1,5) = + > '(''==> Ce type de maille est inconnu pour MED.'')' +c + texte(2,4) = '(''Mesh #'',i10,'', with type'',i10)' + texte(2,5) = '(''==> This type is unknown for MED.'')' +c +#include "impr03.h" +#include "esimpr.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'nomamd = ', nomamd +#endif +c +c==== +c 2. preliminaires +c==== +c 2.1. ==> grandeurs de base +c + typnoe = 0 + typpoi = edpoi1 + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typtet = edtet4 + typqua = edqua4 + typpyr = edpyr5 + typhex = edhex8 + typpen = edpen6 + else + typseg = edseg3 + if ( mod(mailet,2).eq.0 ) then + typtri = edtri7 + else + typtri = edtri6 + endif + typtet = edte10 + if ( mod(mailet,3).eq.0 ) then + typqua = edqua9 + else + typqua = edqua8 + endif + typpyr = edpy13 + if ( mod(mailet,5).eq.0 ) then + typhex = edhe27 + else + typhex = edhe20 + endif + typpen = edpe15 + endif +c +c 2.2. ==> rangements des mailles selon le type +c + ibtetr = 0 + ibtria = nbtetr + ibsegm = nbtetr + nbtria + ibmapo = nbtetr + nbtria + nbsegm + ibquad = nbtetr + nbtria + nbsegm + nbmapo + ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +c +cgn write (ulsort,90002) 'nbtetr', nbtetr +cgn write (ulsort,90002) 'nbtria', nbtria +cgn write (ulsort,90002) 'nbsegm', nbsegm +cgn write (ulsort,90002) 'nbquad', nbquad +cgn write (ulsort,90002) 'nbhexa', nbhexa +cgn write (ulsort,90002) 'nbpyra', nbpyra +cgn write (ulsort,90002) 'typtet,typtri,typseg,typpoi', +cgn > typtet,typtri,typseg,typpoi +cgn write (ulsort,90002) 'typqua,typhex,typpyr,typpen', +cgn > typqua,typhex,typpyr,typpen + do 22 , lamail = 1, nbelem + typenc = typele(lamail) +cgn write (ulsort,90002) 'lamail, typenc', lamail, typenc + if ( typenc.eq.typtet ) then + ibtetr = ibtetr+1 + ialist = ibtetr + elseif ( typenc.eq.typtri ) then + ibtria = ibtria+1 + ialist = ibtria + elseif ( typenc.eq.typseg ) then + ibsegm = ibsegm+1 + ialist = ibsegm + elseif ( typenc.eq.typpoi ) then + ibmapo = ibmapo+1 + ialist = ibmapo + elseif ( typenc.eq.typqua ) then + ibquad = ibquad+1 + ialist = ibquad + elseif ( typenc.eq.typhex ) then + ibhexa = ibhexa+1 + ialist = ibhexa + elseif ( typenc.eq.typpyr ) then + ibpyra = ibpyra+1 + ialist = ibpyra + elseif ( typenc.eq.typpen ) then + ibpent = ibpent+1 + ialist = ibpent + else + write(ulsort,texte(langue,4)) lamail, typenc + write(ulsort,texte(langue,5)) + codret = 1 + endif + listma(ialist) = lamail + 22 continue +c + ibtetr = 1 + ibtria = nbtetr + 1 + ibsegm = nbtetr + nbtria + 1 + ibmapo = nbtetr + nbtria + nbsegm + 1 + ibquad = nbtetr + nbtria + nbsegm + nbmapo + 1 + ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + 1 + ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + 1 + ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra + 1 +cgn write (ulsort,90002) 'ibtetr, ibtria, ibsegm, ibmapo', +cgn > ibtetr, ibtria, ibsegm, ibmapo +cgn write (ulsort,90002) 'ibquad, ibhexa, ibpyra, ibpent', +cgn > ibquad, ibhexa, ibpyra, ibpent +c +c 2.3. ==> Instants d'enregistrement du maillage +c + if ( codret.eq.0 ) then +c + numdt = ednodt + numit = ednoit + instan = edundt +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'numdt', numdt + write(ulsort,90002) 'numit', numit + write(ulsort,90004) 'dt ', instan +#endif +c + endif +c +c 2.4. ==> description du fichier +c + if ( codret.eq.0 ) then +c + saux80 = blan80 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESDESC', nompro +#endif + call esdesc ( idfmed, saux80, sau200, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. creation du maillage +c remarque : on met la meme description que pour le fichier complet +c attention a ne pas changer les rubriques de cette description car +c cela sert de reperage pour les codes en couplage avec HOMARD +c pour definir le numero d'iteration +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. creation du maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'nomamd = ', nomamd + write(ulsort,90002) 'sdimca', sdimca + write(ulsort,90002) 'mdimca', mdimca +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMM0', nompro +#endif + call esemm0 ( idfmed, nomamd, + > sdimca, mdimca, sau200, + > nbpqt, inftbl, + > ulsort, langue, codret) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'esemm0', codret + endif +c + endif +c +c==== +c 4. les noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. les noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMNO', nompro +#endif + call esemno ( idfmed, nomamd, + > nbnoto, sdimca, coonca, fameno, + > numdt, numit, instan, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. les mailles : +c . la connectivite +c . les numeros des familles +c On transferera les informations de connectivite depuis le +c tableau de stockage, noeele, vers le tableau de lecture, itrav1. +c Pour cela, on explorera les mailles les unes apres les autres. +c On a donc interet a batir le tableau itrav1 maille par maille. +c C'est ce que MED appelle le mode entrelace. +c Remarque : on met une valeur bidon au tableau tbiaux pour ne +c pas avoir de message avec ftnchek +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. les mailles ; codret', codret +#endif +c + kaux = 1 + tbiaux(1,1) = iindef +c +c 5.1. ==> les tetraedres +c + if ( codret.eq.0 ) then +c + if ( nbtetr.gt.0 ) then +c + iaux = 3 + if ( degre.eq.1 ) then + jaux = 4 + else + jaux = 10 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_te', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typtet, + > nbtetr, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibtetr), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.2. ==> les triangles +c + if ( codret.eq.0 ) then +c + if ( nbtria.gt.0 ) then +c + iaux = 2 + if ( degre.eq.1 ) then + jaux = 3 + elseif ( mod(mailet,2).eq.0 ) then + jaux = 7 + else + jaux = 6 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_tr', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typtri, + > nbtria, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibtria), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.3. ==> les segments +c + if ( codret.eq.0 ) then +c + if ( nbsegm.gt.0 ) then +c + iaux = 1 + if ( degre.eq.1 ) then + jaux = 2 + else + jaux = 3 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_se', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typseg, + > nbsegm, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibsegm), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4. ==> les mailles-points +c + if ( codret.eq.0 ) then +c + if ( nbmapo.gt.0 ) then +c + iaux = 0 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_mp', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typpoi, + > nbmapo, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibmapo), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.5. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbquad.gt.0 ) then +c + iaux = 4 + if ( degre.eq.1 ) then + jaux = 4 + elseif ( mod(mailet,3).eq.0 ) then + jaux = 9 + else + jaux = 8 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_qu', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typqua, + > nbquad, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibquad), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.6. ==> les pyramides +c + if ( codret.eq.0 ) then +c + if ( nbpyra.gt.0 ) then +c + iaux = 5 + if ( degre.eq.1 ) then + jaux = 5 + else + jaux = 13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_py', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typpyr, + > nbpyra, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibpyra), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.7. ==> les hexaedres +c + if ( codret.eq.0 ) then +c + if ( nbhexa.gt.0 ) then +c + iaux = 6 + if ( degre.eq.1 ) then + jaux = 8 + elseif ( mod(mailet,5).eq.0 ) then + jaux = 27 + else + jaux = 20 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_he', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typhex, + > nbhexa, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibhexa), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.8. ==> les pentaedres +c + if ( codret.eq.0 ) then +c + if ( nbpent.gt.0 ) then +c + iaux = 7 + if ( degre.eq.1 ) then + jaux = 6 + else + jaux = 15 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMB_pe', nompro +#endif + call esemmb ( idfmed, nomamd, + > iaux, edmail, typpen, + > nbpent, jaux, nbelem, kaux, + > ednoda, nbelem, + > noeele, tbiaux, famele, listma(ibpent), + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. les familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. les familles ; codret', codret +#endif +c + if ( codret .eq. 0) then +c + if ( nbfmed.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre de familles MED', nbfmed +#endif +c + do 61 , iaux = 1 , nbfmed +c + if ( codret.eq.0 ) then +c + numero = numfam(iaux) +c + if ( ngrouc.eq.0 ) then + ngro = 0 + else + ngro = ( grfmpo(iaux) - grfmpo(iaux-1) ) / 10 + endif +c + saux64( 1: 8) = nomfam(1,iaux) + saux64( 9:16) = nomfam(2,iaux) + saux64(17:24) = nomfam(3,iaux) + saux64(25:32) = nomfam(4,iaux) + saux64(33:40) = nomfam(5,iaux) + saux64(41:48) = nomfam(6,iaux) + saux64(49:56) = nomfam(7,iaux) + saux64(57:64) = nomfam(8,iaux) +c + endif +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.eq.0 ) then +c write (ulsort,90002) 'Familles MED numero ', iaux +c + kaux = 0 + do 621 , jaux = 1 , nbnoto +cgn print *,'. fameno(jaux) = ',fameno(jaux) + if ( fameno(jaux).eq.numero ) then + kaux = kaux + 1 + endif + 621 continue +c + iaux1 = 0 + do 622 , jaux = 1 , nbelem +cgn print *,'. famele(jaux)) = ',famele(jaux) + if ( famele(jaux).eq.numero ) then + iaux1 = iaux1 + 1 + endif + 622 continue +c + call utinfm ( numero, saux64, + > ngro, grfmtb(grfmpo(iaux-1)+1), + > kaux, iaux1, + > ulsort, langue, codret ) +c + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFACRE', nompro +#endif + call mfacre ( idfmed, nomamd, saux64, numero, + > ngro, grfmtb(grfmpo(iaux-1)+1), codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mfacre', codret + endif +c + endif +c + 61 continue +c + endif +c + endif +c +c==== +c 7. equivalences +c la convention de stockage MED des listes d'equivalences est que +c l'entite Liste(j) est associee a Liste(j+1) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. equivalences ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + adeqin = 1 + adeqno = 1 + adeqmp = 1 + adeqar = 1 + adeqtr = 1 + adeqqu = 1 + adeqte = 1 + adeqhe = 1 +c + do 71 , iaux = 1, nbequi +c +c 7.1. ==> nom et description de l'equivalence +c + if ( codret.eq.0 ) then +c + call uts8ch ( eqinfo(adeqin), 64, saux64, + > ulsort, langue, codret ) + adeqin = adeqin + 8 +c + endif +c + if ( codret.eq.0 ) then +c + call uts8ch ( eqinfo(adeqin), 200, sau200, + > ulsort, langue, codret ) + adeqin = adeqin + 25 +c + endif +c +c 7.2. ==> creation de l'equivalence dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCRE', nompro +#endif + call meqcre ( idfmed, nomamd, saux64, sau200, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'meqcre', codret + endif +c + endif +c +c 7.3. ==> equivalence de noeuds +c + if ( codret.eq.0 ) then +c + jaux = eqpntr(5*iaux-4) + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMQ_no', nompro +#endif + call esemmq ( idfmed, nomamd, saux64, + > numdt, numit, + > ednoeu, typnoe, + > jaux, eqnoeu(adeqno), + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'ESEMMQ_no', codret + endif + adeqno = adeqno + 2*jaux +c + endif +c + endif +c +c 7.4. ==> equivalence de mailles-points +c + if ( codret.eq.0 ) then +c + jaux = eqpntr(5*iaux-3) + if ( jaux.gt.0 ) then +c + codret = 74 +c + endif +c + endif +c +c 7.5. ==> equivalence de segments +c + if ( codret.eq.0 ) then +c + jaux = eqpntr(5*iaux-2) + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMQ_ar', nompro +#endif + call esemmq ( idfmed, nomamd, saux64, + > numdt, numit, + > edmail, typseg, + > jaux, eqaret(adeqar), + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'ESEMMQ_ar', codret + endif + adeqar = adeqar + 2*jaux +c + endif +c + endif +c +c 7.6. ==> equivalence de triangles +c + if ( codret.eq.0 ) then +c + jaux = eqpntr(5*iaux-1) + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMQ_tr', nompro +#endif + call esemmq ( idfmed, nomamd, saux64, + > numdt, numit, + > edmail, typtri, + > jaux, eqtria(adeqtr), + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'ESEMMQ_tr', codret + endif + adeqtr = adeqtr + 2*jaux +c + endif +c + endif +c +c 7.7. ==> equivalence de quadrangles +c + if ( codret.eq.0 ) then +c + jaux = eqpntr(5*iaux) + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMQ_qu', nompro +#endif + call esemmq ( idfmed, nomamd, saux64, + > numdt, numit, + > edmail, typqua, + > jaux, eqquad(adeqqu), + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'ESEMMQ_qu', codret + endif + adeqqu = adeqqu + 2*jaux +c + endif +c + endif +c +c 7.9. ==> equivalence d'hexaedres +c + if ( codret.eq.0 ) then +c + if ( nbeqhe.gt.0 ) then +c +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'ESEMMQ_he', nompro +cgn#endif +cgn call esemmq ( idfmed, nomamd, saux64, +cgn > numdt, numit, +cgn > edmail, typhex, +cgn > nbeqhe, eqhexa(adeqhe), +cgn > ulsort, langue, codret ) +cgn if ( codret.ne.0 ) then +cgn write(ulsort,texte(langue,78)) 'ESEMMQ_he', codret +cgn endif +cgn adeqhe = adeqhe + 2*nbeqhe +c + endif +c + endif +c + 71 continue +c + endif +c +c==== +c 8. informations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. informations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,22)) nomamd(1:lnomam) +c + tbiaux(1,1) = nbmapo + tbiaux(1,2) = nbsegm + tbiaux(1,3) = nbtria + tbiaux(1,4) = nbquad + tbiaux(1,5) = nbtetr + tbiaux(1,6) = nbhexa + tbiaux(1,7) = nbpent + tbiaux(1,8) = nbpyra + tbiaux(2,1) = 2 + if ( degre.eq.1 ) then + tbiaux(2,2) = 4 + else + tbiaux(2,2) = 5 + endif + do 81 , iaux = 3 , 8 + tbiaux(2,iaux) = tbiaux(2,iaux-1) + 3 + 81 continue +c + iaux = 1 + jaux = 0 + if ( langue.eq.1 ) then +c 12345678901234567890123456789012 + saux32 = 'dans le fichier ' + else + saux32 = 'in the file ' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINMA', nompro +#endif + call utinma ( iaux, saux32, + > sdimca, mdimca, degre, + > nbnoto, jaux, jaux, jaux, + > jaux, jaux, + > iaux, nbelem, + > nbmapo, tbiaux(1,2), tbiaux(1,3), tbiaux(1,4), + > tbiaux(1,5), tbiaux(1,6), tbiaux(1,8), tbiaux(1,7), + > jaux, + > nbmane, nbmaae, nbmafe, + > ulsort, langue, codret) +c + write(ulsort,texte(langue,29)) nbfmed + write(ulsort,texte(langue,31)) ngrouc +c + if ( nbequi.ne.0 ) then + write(ulsort,texte(langue,41)) nbequi + write(ulsort,texte(langue,42)) mess14(langue,3,-1), nbeqno + tbiaux(2,1) = 0 + tbiaux(2,2) = 1 + tbiaux(2,3) = 2 + tbiaux(2,4) = 4 + tbiaux(3,1) = nbeqmp + tbiaux(3,2) = nbeqar + tbiaux(3,3) = nbeqtr + tbiaux(3,4) = nbeqqu + do 821 , iaux = 1 , 4 + if ( tbiaux(1,iaux).gt.0 ) then + write(ulsort,texte(langue,42)) + > mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux) + endif + 821 continue + tbiaux(2,5) = 3 + tbiaux(2,6) = 6 + tbiaux(3,5) = nbeqte + tbiaux(3,6) = nbeqhe +cgn do 822 , iaux = 5, 6 +cgn if ( ( tbiaux(1,iaux).gt.0 ) .and. +cgn > ( tbiaux(3,iaux).gt.0 ) ) then +cgn write(ulsort,texte(langue,42)) +cgn > mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux) +cgn endif +cgn 822 continue + endif +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemmb.F b/src/tool/ES_MED/esemmb.F new file mode 100644 index 00000000..22a8a488 --- /dev/null +++ b/src/tool/ES_MED/esemmb.F @@ -0,0 +1,227 @@ + subroutine esemmb ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbmato, nbrfma, nbelem, numfam, + > typcon, dim1, + > conmai, infosu, fammai, listma, + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED +c - - - - - +c - phase B +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nbmato . e . 1 . nombre de mailles . +c . nbrfma . e . 1 . nbre noeuds par maille si connec. par noeud. +c . . . . nbre faces par maille si connectivite desce. +c . nbelem . e . 1 . nombre d'elements, tous types confondus . +c . numfam . e . 1 . decalage dans la numerotation des familles . +c . . . . 1 : le tableau est pris tel quel . +c . . . . <=0 : le tableau passe negatif et est . +c . . . . decale de numfam . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typcon . e . 1 . type de connectivite . +c . . . . 0 : par noeud (ednoda) . +c . . . . 1 : descendante (eddesc) . +c . dim1 . e . 1 . 1ere dimension de la connectivite . +c . conmai . e .nbelem**. connectivite des mailles . +c . infosu . e . nbelem . informations supplementaire sur les mailles. +c . fammai . e . nbelem . famille med des mailles . +c . listma . e . 1 . liste des mailles a ecrire . +c . . . . si listma(1) vaut 0, on ecrit tout . +c . . . . si listma(1) vaut -1, on ecrit tout et les . +c . . . . descriptions sont inversees . +c . . . . si listma(1) vaut -2, on ecrit les segments. +c . . . . en degre 2 a partir de esece0 . +c . . . . si listma(1) vaut -3, on ecrit les segments. +c . . . . en degre 3 a partir de esece0 . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . tabaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMMF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nbmato, nbrfma, nbelem, numfam + integer typcon, dim1 + integer conmai(dim1,*), infosu(nbelem), fammai(nbelem) + integer listma(nbmato), tabaux(*) + integer numdt, numit +c + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des '',i10,1x,a)' +c + texte(2,4) = '(''. Writings of '',i10,1x,a)' +c +#include "esimpr.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listma(1)', listma(1) + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbmato', nbmato + write (ulsort,90002) 'nbrfma', nbrfma + write (ulsort,90002) 'typcon', typcon + write (ulsort,90002) 'dim1 ', dim1 + write (ulsort,90002) 'numdt', numdt + write (ulsort,90002) 'numit', numit +#endif +c + codret = 0 +c +c==== +c 2. Ecriture de la connectivite +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMC', nompro +#endif + call esemmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbmato, nbrfma, nbelem, + > typcon, dim1, + > conmai, infosu, listma, + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Ecriture de la famille d'appartenance +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMF', nompro +#endif + call esemmf ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbmato, nbelem, numfam, + > fammai, listma, + > numdt, numit, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemmc.F b/src/tool/ES_MED/esemmc.F new file mode 100644 index 00000000..383d671b --- /dev/null +++ b/src/tool/ES_MED/esemmc.F @@ -0,0 +1,291 @@ + subroutine esemmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbmato, nbrfma, nbelem, + > typcon, dim1, + > conmai, infosu, listma, + > numdt, numit, instan, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED +c - - - - - +c - Connectivites +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nbmato . e . 1 . nombre de mailles . +c . nbrfma . e . 1 . nbre noeuds par maille si connec. par noeud. +c . . . . nbre faces par maille si connectivite desce. +c . nbelem . e . 1 . nombre d'elements, tous types confondus . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typcon . e . 1 . type de connectivite . +c . . . . 0 : par noeud (ednoda) . +c . . . . 1 : descendante (eddesc) . +c . dim1 . e . 1 . 1ere dimension de la connectivite . +c . conmai . e .nbelem**. connectivite des mailles . +c . infosu . e . nbelem . informations supplementaire sur les mailles. +c . fammai . e . nbelem . famille med des mailles . +c . listma . e . 1 . liste des mailles a ecrire . +c . . . . si listma(1) vaut 0, on ecrit tout . +c . . . . si listma(1) vaut -1, on ecrit tout et les . +c . . . . descriptions sont inversees . +c . . . . si listma(1) vaut -2, on ecrit les segments. +c . . . . en degre 1 a partir de esece0 . +c . . . . si listma(1) vaut -3, on ecrit les segments. +c . . . . en degre 2 a partir de esece0 . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . tabaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMMF' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nbmato, nbrfma, nbelem + integer typcon, dim1 + integer conmai(dim1,*), infosu(nbelem) + integer listma(nbmato), tabaux(*) + integer numdt, numit +c + character*64 nomamd +c + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux +c + character*6 saux06 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des '',i10,1x,a)' +c + texte(2,4) = '(''. Writings of '',i10,1x,a)' +c +#include "esimpr.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listma(1)', listma(1) + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbmato', nbmato + write (ulsort,90002) 'nbrfma', nbrfma + write (ulsort,90002) 'typcon', typcon + write (ulsort,90002) 'dim1 ', dim1 + write (ulsort,90002) 'numdt', numdt + write (ulsort,90002) 'numit', numit +#endif +c + codret = 0 +c +c==== +c 2. Creation du tableau de travail +c==== +c 2.1. ==> Creation de la connectivite par noeud +c + if ( codret.eq.0 ) then +c + kaux = 0 +c + if ( typcon.eq.ednoda ) then +c + if ( listma(1).eq.0 ) then +c +cgn print *,'passage 211' + do 211 , iaux = 1, nbmato + do 2111, jaux = 1, nbrfma + kaux = kaux + 1 + tabaux(kaux) = conmai(iaux,jaux) + 2111 continue + 211 continue +c + elseif ( listma(1).lt.0 ) then +cgn print *,'passage 212 avec nbrfma =', nbrfma +c + do 212 , iaux = 1, nbmato +cgn print *,conmai(1,iaux), conmai(2,iaux) + do 2121, jaux = 1, nbrfma + kaux = kaux + 1 + tabaux(kaux) = conmai(jaux,iaux) + 2121 continue + 212 continue +c + else +cgn print *,'passage 213' +c + do 213 , iaux = 1, nbmato + do 2131, jaux = 1, nbrfma + kaux = kaux + 1 + tabaux(kaux) = conmai(listma(iaux),jaux) + 2131 continue + 213 continue +c + endif +c +c 2.2. ==> Creation de la connectivite descendante : +c les mailles a partir de esece0 +c + else +c +c . degre 1 +c + if ( listma(1).eq.-2 ) then +c +cgn print *,'passage 222 avec nbrfma =', nbrfma + do 222 , iaux = 1, nbmato +cgn print *,conmai(1,iaux), conmai(2,iaux) + do 2221, jaux = 1, 2 + kaux = kaux + 1 + tabaux(kaux) = conmai(jaux,iaux) + 2221 continue + 222 continue +c + elseif ( listma(1).eq.-3 ) then +c +c . degre 2 : on ajoute le noeud central +c + do 223 , iaux = 1, nbmato +cgn print *,conmai(1,iaux), conmai(2,iaux) + do 2231, jaux = 1, 2 + kaux = kaux + 1 + tabaux(kaux) = conmai(jaux,iaux) + 2231 continue + kaux = kaux + 1 + tabaux(kaux) = infosu(iaux) + 223 continue +c + endif +c + endif +c + endif +c +c==== +c 3. Ecriture de la connectivite +c==== +c + if ( codret.eq.0 ) then +c +cgn print *,(tabaux(iaux),iaux=1,nbrfma*nbmato) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHCYW', nompro +#endif + call mmhcyw ( idfmed, nomamd, numdt, numit, instan, + > typent, typgeo, typcon, edfuin, + > nbmato, tabaux, codret ) + if ( codret.ne.0 ) then + saux06 = 'mmhcyw' + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) + write (ulsort,texte(langue,78)) saux06, codret + write (ulsort,texte(langue,80)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemmd.F b/src/tool/ES_MED/esemmd.F new file mode 100644 index 00000000..e8ef6bf2 --- /dev/null +++ b/src/tool/ES_MED/esemmd.F @@ -0,0 +1,453 @@ + subroutine esemmd ( nocmai, mcfima, mcnoma, typouv, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MeD +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmai . e . char*8 . nom de l'objet maillage calcul . +c . mcfima . e . char*8 . mot-cle pour le fichier du maillage . +c . mcnoma . e . char*8 . mot-cle du nom du maillage dans le fichier . +c . typouv . e . 1 . type d'ouverture du fichier a ecrire . +c . . . . 0 : ecrasement . +c . . . . 1 : enrichissement . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . -10 : fichier inconnu . +c . . . . -20 : nom de maillage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMMD' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nbutil.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer typouv +c + character*8 nocmai, mcfima, mcnoma +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer adnomb + integer pfamen, pcoonc, pfamee, pnoeel, ptypel + integer pgrpo, pgrtab + integer pnumfa, pnomfa + integer nbpqt + integer pinftb + integer adeqpo, adeqin + integer adeqno, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe + integer ptrav1, ptrav2 +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer codre0 +c + integer*8 idfmed + integer lnomfi, lnomam + integer nbnomb + integer nbnoto +c + character*8 typobs + character*8 ntrav1, ntrav2 + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb + character*64 nomamd + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. premiers decodages +c==== +c +c 2.1. ==> nom du fichier contenant le maillage +c + typobs = mcfima + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) 'en sortie' + codret = -10 + endif +c +c 2.2. ==> nom du maillage dans le fichier +c + if ( codret.eq.0 ) then + typobs = mcnoma + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + call utosme ( typobs, ulsort, langue ) + if ( codret.eq.4 ) then + write (ulsort,texte(langue,52)) lnomam + write (ulsort,texte(langue,53)) len(nomamd) + endif + codret = -20 + endif + endif +c +c==== +c 3. ouverture en mode d'ecrasement ou d'enrichissement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. ouverture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typouv.eq.0 ) then + iaux = edcrea + else + iaux = edrdwr + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFIOPE', nompro +#endif + call mfiope ( idfmed, nomfic(1:lnomfi), iaux, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,9)) + endif + endif +c +c==== +c 4. recuperation des donnees du maillage de calcul +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. recuperation ; codret', codret +#endif +c +c 4.1. ==> l'objet de tete +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocmai ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmai, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sdimca', sdimca + write (ulsort,90002) 'mdimca', mdimca + call gmprsx (nompro, ncnoeu ) + call gmprsx (nompro, nccono ) + call gmprsx (nompro, ncfami ) + call gmprsx (nompro,ncfami//'.Nom') + call gmprsx (nompro,ncfami//'.Groupe') +#endif +c + endif +c +c 4.2. ==> objets lies au maillage de calcul +c +c 4.2.1. ==> les informations generales +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncinfo//'.Table' , pinftb, iaux, codre0 ) + call gmliat ( ncinfo, 1, iaux, codre2 ) + nbpqt = iaux - 1 +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 4.2.2. ==> les nombres +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMC', nompro +#endif + call utnbmc ( imem(adnomb), + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c + endif +c +c 4.2.3. ==> les nombres +c + if ( codret.eq.0 ) then +c + call gmliat ( ncnoeu, 1, nbnoto, codre1 ) + call gmliat ( nccono, 1, nbelem, codre2 ) + call gmliat ( nccono, 2, nbmane, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c +c 4.2.4. ==> les adresses +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 6006 + call utad11 ( iaux, ncnoeu, nccono, + > pcoonc, pfamen, jaux, jaux, + > ptypel, pfamee, pnoeel, jaux, + > ulsort, langue, codret ) +c +c 4.2.5. ==> les familles +c + pnumfa = 1 + pnomfa = 1 + pgrpo = 1 + pgrtab = 1 +c + if ( nbfmed.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD13', nompro +#endif + iaux = 6 + if ( ngrouc.gt.0 ) then + iaux = iaux*5 + endif + call utad13 ( iaux, ncfami, + > pnumfa, pnomfa, + > pgrpo, jaux, pgrtab, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro, ncfami//'.Groupe') +cgn call gmprsx (nompro, ncfami//'.Groupe.Pointeur') +cgn call gmprsx (nompro, ncfami//'.Groupe.Taille') +cgn call gmprsx (nompro, ncfami//'.Groupe.Table') +c +c 4.2.6. ==> les equivalences +c + if ( nbequi.ne.0 ) then +c + call gmadoj ( ncequi//'.Pointeur', adeqpo, iaux, codre1 ) + call gmadoj ( ncequi//'.InfoGene', adeqin, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + call gmadoj ( ncequi//'.Noeud', adeqno, iaux, codre1 ) + call gmadoj ( ncequi//'.Arete', adeqar, iaux, codre2 ) + call gmadoj ( ncequi//'.Trian', adeqtr, iaux, codre3 ) + call gmadoj ( ncequi//'.Quadr', adeqqu, iaux, codre4 ) + call gmadoj ( ncequi//'.Tetra', adeqte, iaux, codre5 ) + call gmadoj ( ncequi//'.Hexae', adeqhe, iaux, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c +c 4.2.7. ==> la frontiere +c + endif +c +c 4.3. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c + iaux = nbelem*(nbmane+1)+nbsegm+nbtria + call gmalot ( ntrav1, 'entier ', iaux , ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbelem , ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + endif +c +c=== +c 5. ecriture proprement dite +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. ecriture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMM1', nompro +#endif + call esemm1 ( idfmed, nomamd, lnomam, + > nbnoto, + > rmem(pcoonc), imem(pfamen), imem(pnoeel), + > imem(pfamee), imem(ptypel), + > imem(pnumfa), smem(pnomfa), + > imem(pgrpo), smem(pgrtab), + > nbpqt, smem(pinftb), + > imem(adeqpo), smem(adeqin), + > imem(adeqno), + > imem(adeqar), imem(adeqtr), imem(adeqqu), + > imem(adeqte), imem(adeqhe), + > imem(ptrav1), imem(ptrav2), + > ulsort, langue, codret ) +c + endif +c +c=== +c 6. nettoyage +c=== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c=== +c 7. fermeture du fichier +c=== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo ( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ne.-10 ) then + write (ulsort,texte(langue,8)) nomfic + if ( codret.ne.-20 ) then + write (ulsort,texte(langue,22)) nomamd + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemmf.F b/src/tool/ES_MED/esemmf.F new file mode 100644 index 00000000..af2514cb --- /dev/null +++ b/src/tool/ES_MED/esemmf.F @@ -0,0 +1,237 @@ + subroutine esemmf ( idfmed, nomamd, + > typenh, typent, typgeo, + > nbmato, nbelem, numfam, + > fammai, listma, + > numdt, numit, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED +c - - - - - +c - Familles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nbmato . e . 1 . nombre de mailles . +c . nbelem . e . 1 . nombre d'elements, tous types confondus . +c . numfam . e . 1 . decalage dans la numerotation des familles . +c . . . . 1 : le tableau est pris tel quel . +c . . . . <=0 : le tableau passe negatif et est . +c . . . . decale de numfam . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . fammai . e . nbelem . famille med des mailles . +c . listma . e . 1 . liste des mailles a ecrire . +c . . . . si listma(1) vaut 0, on ecrit tout . +c . . . . si listma(1) vaut -1, on ecrit tout et les . +c . . . . descriptions sont inversees . +c . . . . si listma(1) vaut -2, on ecrit les segments. +c . . . . en degre 2 a partir de esece0 . +c . . . . si listma(1) vaut -3, on ecrit les segments. +c . . . . en degre 3 a partir de esece0 . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . tabaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMMF' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nbmato, nbelem, numfam + integer fammai(nbelem) + integer listma(nbmato), tabaux(*) + integer numdt, numit +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux +c + character*6 saux06 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ecriture des '',i10,1x,a)' +c + texte(2,4) = '(''. Writings of '',i10,1x,a)' +c +#include "esimpr.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'listma(1)', listma(1) + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbmato', nbmato + write (ulsort,90002) 'numdt', numdt + write (ulsort,90002) 'numit', numit +#endif +c + codret = 0 +c +c==== +c 2. Creation du tableau de travail +c==== +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,*)'fammai',(fammai(iaux),iaux=1,min(30,nbmato)) + if ( listma(1).le.0 ) then +c + if ( numfam.gt.0 ) then +c + do 211 , iaux = 1, nbmato + tabaux(iaux) = fammai(iaux) + 211 continue +c + else +c + do 212 , iaux = 1, nbmato + tabaux(iaux) = -fammai(iaux) + numfam + 212 continue +c + endif +c + else +c + if ( numfam.gt.0 ) then +c + do 221 , iaux = 1, nbmato + tabaux(iaux) = fammai(listma(iaux)) + 221 continue +c + else +c + do 222 , iaux = 1, nbmato + tabaux(iaux) = -fammai(listma(iaux)) + numfam + 222 continue +c + endif +c + endif +c +c==== +c 3. Ecritures +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHFNW', nompro +#endif + call mmhfnw ( idfmed, nomamd, numdt, numit, + > typent, typgeo, + > nbmato, tabaux, codret ) + if ( codret.ne.0 ) then + saux06 = 'mmhfnw' + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) + write (ulsort,texte(langue,78)) saux06, codret + write (ulsort,texte(langue,80)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemmq.F b/src/tool/ES_MED/esemmq.F new file mode 100644 index 00000000..dc7bb978 --- /dev/null +++ b/src/tool/ES_MED/esemmq.F @@ -0,0 +1,268 @@ + subroutine esemmq ( idfmed, nomamd, nomequ, + > numdt, numit, + > typgeo, typmai, + > nbeqen, eqenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED - eQuivalences +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nomequ . e . char64 . nom de l'equivalence . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . nbeqen . e . 1 . nombre de paires d'entites . +c . eqenti . e .2*nbeqen. liste des paires d'entites equivalentes . +c . . . . avec la convention : . +c . . . . eqenti(i)<-->eqenti(i+1) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMMQ' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "envex1.h" +#include "impr02.h" +#include "indefi.h" +c +#include "envca1.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer ulsort, langue, codret +c + integer numdt, numit + integer typgeo, typmai + integer nbeqen + integer eqenti(2,nbeqen) +c + character*64 nomamd + character*64 nomequ +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux + integer nuenmx, nbcibl + integer codre0 + integer codre1, codre2, codre3 + integer ptrav1, ptrav2, ptrav3 +c + character*8 ntrav1, ntrav2, ntrav3 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c + codret = 0 +c +c==== +c 2. preliminaires +c==== +c 2.1. ==> Numero maximal de l'entite source +c + nuenmx = 0 + do 21 , iaux = 1 , nbeqen +cgn write (ulsort,90112) 'eqenti',iaux,eqenti(1,iaux),eqenti(2,iaux) + nuenmx = max (nuenmx, eqenti(1,iaux)) + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nuenmx', nuenmx +#endif +c +c 2.2. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nuenmx, ptrav1, codre1 ) + iaux = nuenmx + 1 + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) + iaux = 2*nbeqen + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) + endif +c +c 2.3. ==> Nombre de cibles par source +c + if ( codret.eq.0 ) then +c + do 231 , iaux = 1 , nuenmx + imem(ptrav1+iaux-1) = 0 + 231 continue +c + do 232 , iaux = 1 , nbeqen + jaux = ptrav1+eqenti(1,iaux)-1 + imem(jaux) = imem(jaux) + 1 + 232 continue +#ifdef _DEBUG_HOMARD_ + call gmprsx ('ntrav1 nombre de cibles', ntrav1) +#endif +c + endif +c +c 2.4. ==> Pointeur +c + if ( codret.eq.0 ) then +c + do 241 , iaux = 1 , nuenmx+1 + imem(ptrav2+iaux-1) = 0 + 241 continue +c + do 242 , iaux = 1 , nuenmx + nbcibl = imem(ptrav1+iaux-1) +cgn write (ulsort,90112) 'cible',iaux,nbcibl + jaux = ptrav2+iaux + imem(jaux) = imem(jaux-1) + nbcibl + 242 continue +#ifdef _DEBUG_HOMARD_ + call gmprsx ('ntrav2 pointeur', ntrav2) +#endif +c + endif +c +c 2.5. ==> Rangement +c + if ( codret.eq.0 ) then +c + do 252 , iaux = 1 , nbeqen +cgn write (ulsort,90112) 'eqenti',iaux,eqenti(1,iaux),eqenti(2,iaux) + jaux = ptrav2+eqenti(1,iaux)-1 + imem(jaux) = imem(jaux) + 1 +cgn write (ulsort,90002) 'imem(jaux)', imem(jaux) + kaux = ptrav3 + 2*(imem(jaux)-1) + imem(kaux ) = eqenti(1,iaux) + imem(kaux+1) = eqenti(2,iaux) + 252 continue +#ifdef _DEBUG_HOMARD_ + call gmprsx ('ntrav3', ntrav3) +#endif +c + endif +c +c +c==== +c 3. ecriture +c la convention de stockage MED des listes d'equivalences est que +c l'entite Liste(j) est associee a Liste(j+1) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. ecriture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCOW', nompro +#endif + call meqcow ( idfmed, nomamd, nomequ, numdt, numit, + > typgeo, typmai, + > nbeqen, imem(ptrav3), codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'meqcow', codret + endif +c + endif +c +c=== +c 4. nettoyage +c=== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esemno.F b/src/tool/ES_MED/esemno.F new file mode 100644 index 00000000..a0986e80 --- /dev/null +++ b/src/tool/ES_MED/esemno.F @@ -0,0 +1,203 @@ + subroutine esemno ( idfmed, nomamd, + > nbnoto, sdim, coonno, fameno, + > numdt, numit, instan, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'un Maillage au format MED - NOeuds +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nbnoto . e . 1 . nombre de noeuds . +c . sdim . e . 1 . dimension . +c . coonno . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdim . . +c . fameno . e . nbnoto . famille des noeuds . +c . numdt . e . 1 . numero du pas de temps . +c . numit . e . 1 . numero d'iteration . +c . instan . e . 1 . pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESEMNO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbnoto, sdim + integer fameno(nbnoto) + integer numdt, numit +c + character*64 nomamd +c + double precision coonno(nbnoto,sdim) + double precision instan +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer typnoe + integer iaux +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,61) = '(''Coordonnees des'',i10,'' noeuds.'')' + texte(1,62) = '(''Familles des'',i10,'' noeuds.'')' +c + texte(2,61) = '(''Coordinates of the'',i10,'' nodes.'')' + texte(2,62) = '(''Families of the'',i10,'' nodes.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. les noeuds +c . les unites +c . les coordonnees +c . les numeros des familles +c le tableau coonno est declare ainsi : coonno(nbnoto,sdim). +c En fortran, cela correspond au stockage memoire suivant : +c coonno(1,1), coonno(2,1), coonno(3,1), ..., coonno(nbnoto,1), +c coonno(1,2), coonno(2,2), coonno(3,2), ..., coonno(nbnoto,2), +c ... +c coonno(1,sdim), coonno(2,sdim), ..., coonno(nbnoto,sdim) +c on a ainsi toutes les abscisses, puis toutes les ordonnees, etc. +c C'est ce que MED appelle le mode non entrelace. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,24)) nbnoto +#endif + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'nomamd = ', nomamd + write(ulsort,90002) 'idfmed', idfmed + write(ulsort,90002) 'sdim', sdim + write(ulsort,90002) 'ednoin', ednoin + write(ulsort,90002) 'nbnoto', nbnoto + write(ulsort,90002) 'numdt', numdt + write(ulsort,90002) 'numit', numit + write(ulsort,90004) 'dt ', instan +cgn print *,'coonno = ',coonno +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHCOW', nompro +#endif + call mmhcow ( idfmed, nomamd, numdt, numit, instan, ednoin, + > nbnoto, coonno, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,78)) 'mmhcow', codret + codret = 61 + endif +c + endif +c + if ( codret.eq.0 ) then +cgn print *,'fameno = ',fameno +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHFNW', nompro +#endif + call mmhfnw ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, + > nbnoto, fameno, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,62)) + write(ulsort,texte(langue,78)) 'mmhfnw', codret + codret = 62 + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ge.61 .and. codret.le.62 ) then + write (ulsort,texte(langue,codret)) nbnoto + endif + write (ulsort,texte(langue,80)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eses11.F b/src/tool/ES_MED/eses11.F new file mode 100644 index 00000000..1a3c8034 --- /dev/null +++ b/src/tool/ES_MED/eses11.F @@ -0,0 +1,187 @@ + subroutine eses11 ( idfmed, nomcha, + > nbcomp, typcha, + > nomcmp, unicmp, + > dtunit, nomamd, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'une Solution au format MED - phase 1.1 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en sortie . +c . nomcha . e . char64 . nom du champ . +c . nbcomp . e . 1 . nombre de composantes . +c . typcha . e . 1 . edin64/edfl64 selon entier/reel . +c . nomcmp . e . nbcomp . noms des composantes . +c . unicmp . e . nbcomp . unites des composantes . +c . dtunit . e . 1 . unite des pas de temps . +c . nomamd . e . char64 . nom du maillage MED . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESES11' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbcomp, typcha +c + character*64 nomcha + character*16 nomcmp(nbcomp), unicmp(nbcomp) + character*16 dtunit + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Creation du champ : '',a)' + texte(1,5) = '(''Type du champ : '',i2)' + texte(1,6) = + > '(''Numero ! Composante ! Unite'',/,49(''-''))' + texte(1,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(1,8) = '(''Unite du pas de temps : '',a)' +c + texte(2,4) = '(/,''Creation of field: '',a)' + texte(2,5) = '(''Type of field: '',i2)' + texte(2,6) = + > '('' # ! Component ! Unit'',/,49(''-''))' + texte(2,7) = '(i6,'' ! '',a16,'' ! '',a16)' + texte(2,8) = '(''Time step unity: '',a)' +c +#include "impr03.h" +c +c==== +c 2. creation du champ +c==== +c + call utlgut ( iaux, nomcha, ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,4)) nomcha(1:iaux) + write (ulsort,texte(langue,5)) typcha + write (ulsort,texte(langue,6)) + do 20 , iaux = 1 , nbcomp + write (ulsort,texte(langue,7)) iaux, nomcmp(iaux), unicmp(iaux) + 20 continue + call utlgut ( iaux, dtunit, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( iaux.gt.0 ) then + write (ulsort,texte(langue,8)) dtunit + endif +c + endif +c +c==== +c 3. creation du champ +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. creation du champ ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDCRE', nompro +#endif + call mfdcre ( idfmed, nomcha, typcha, + > nbcomp, nomcmp, unicmp, + > dtunit, nomamd, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,13)) nomcha + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esesm1.F b/src/tool/ES_MED/esesm1.F new file mode 100644 index 00000000..019da15e --- /dev/null +++ b/src/tool/ES_MED/esesm1.F @@ -0,0 +1,347 @@ + subroutine esesm1 ( idfmed, nomamd, + > nbcham, noobch, nbprof, noobpr, + > nblopg, noobpg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'une Solution au format MED - phase 1 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nbcham . e . 1 . nombre de champs a ecrire . +c . noobch . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nbprof . e . 1 . nombre de profils a ecrire . +c . noobpr . e . nbprof . nom des objets qui contiennent la . +c . . . . description de chaque profil . +c . nblopg . e . 1 . nombre de localisations de points de Gauss . +c . noobpg . e . nblopg . nom des objets qui contiennent la . +c . . . . description de chaque localisation . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c ESESM1 --> ESES11 +c --> ESECH1 --> ESECH2 +c --> ESES12 +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESESM1' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbcham, nbprof, nblopg +c + character*8 noobch(nbcham) + character*8 noobpr(*) + character*8 noobpg(*) + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer adnocp, adcaen, adcare, adcaca + integer adlipr + integer nbcomp, nbtvch, typcha + integer nbvapr + integer typgeo, ngauss, dimcpg + integer adcono, adcopg, adpopg + integer nrcham, nrprof, nrlopg + integer iaux +c + character*16 dtunit + character*64 nomcha, noprof, nolopg + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(/,''Ecriture du profil : '',a)' + texte(1,6) = + > '(/,''Ecriture de la localisation de points de Gauss : '',a)' + texte(1,7) = '(''... Premiere(s) valeur(s) :'',10i6)' + texte(1,100) = '(''... Dernieres valeurs :'',10i6)' +c + texte(2,5) = '(/,''Writing of profile: '',a)' + texte(2,6) = + > '(/,''Writing of localization of Gauss points: '',a)' + texte(2,7) = '(''First values: '',10i6)' + texte(2,100) = '(''Last values: '',10i6)' +c +#include "esimpr.h" +c +c==== +c 2. ecriture des eventuels profils +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. profils ; codret', codret + write (ulsort,90002) 'nbprof', nbprof +#endif +c + if ( codret.eq.0 ) then +c + do 20 , nrprof = 1 , nbprof +c +c 2.1. ==> informations generales sur le profil +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( noobpr(nrprof), + > nbvapr, noprof, adlipr, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> ecriture du profil +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,5)) noprof +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,62)) nbvapr + write (ulsort,texte(langue,7)) + > (imem(iaux), iaux = adlipr, adlipr+min(9,nbvapr-1)) + if ( nbvapr.gt.10 ) then + write (ulsort,texte(langue,100)) + > (imem(iaux), iaux = adlipr+nbvapr-10, adlipr+nbvapr-1) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRW', nompro +#endif + call mpfprw ( idfmed, noprof, nbvapr, imem(adlipr), codret ) +c + endif +c + 20 continue +c + endif +c +c==== +c 3. ecriture des eventuelles localisations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. localisations ; codret', codret + write (ulsort,90002) 'nblopg', nblopg +#endif +c + if ( codret.eq.0 ) then +c + do 30 , nrlopg = 1 , nblopg +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nrlopg', nrlopg + write (ulsort,90003) 'noobpg(nrlopg)', noobpg(nrlopg)//'EEE' +#endif + + if ( noobpg(nrlopg).ne.blan08 ) then +c +c 3.1. ==> informations generales sur la localisation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPG', nompro +#endif +c + call utcapg ( noobpg(nrlopg), + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> ecriture de la localisation +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,6)) nolopg +c + saux64 = blan64 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLCLOW', nompro +#endif +c + call mlclow ( idfmed, nolopg, typgeo, dimcpg, + > rmem(adcono), edfuin, + > ngauss, rmem(adcopg), rmem(adpopg), + > saux64, saux64, + > codret ) +c + endif +c + endif +c + 30 continue +c + endif +c +c==== +c 4. ecriture des valeurs, champ par champ +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. valeurs ; codret', codret + write (ulsort,90002) 'nbcham', nbcham +#endif +c + if ( codret.eq.0 ) then +c + do 40 , nrcham = 1 , nbcham +c +c 4.1. ==> informations generales sur le champ +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, noobch(nrcham)) +cgn call gmprsx (nompro, noobch(nrcham)//'.Nom_Comp') +cgn call gmprsx (nompro, noobch(nrcham)//'.Cham_Ent') +cgn call gmprsx (nompro, noobch(nrcham)//'.Cham_Ree') + call gmprsx (' Fonction Profil LocaPG', + > noobch(nrcham)//'.Cham_Car') +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( noobch(nrcham), + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> creation du champ +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,32)) nomcha + write (ulsort,90002) 'typcha', typcha + write (ulsort,texte(langue,111)) nbtvch +#endif +c + dtunit = smem(adnocp+8+4*nbcomp)//smem(adnocp+8+4*nbcomp+1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESES11', nompro +#endif + call eses11 ( idfmed, nomcha, + > nbcomp, typcha, + > smem(adnocp+8), smem(adnocp+8+2*nbcomp), + > dtunit, nomamd, + > ulsort, langue, codret ) +c + endif +c +c 4.3. ==> ecriture des tableaux lies au champ +c + if ( codret.eq.0 ) then +c + if ( nbtvch.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESECH1', nompro +#endif + call esech1 ( idfmed, nomcha, + > nbcomp, nbtvch, + > imem(adcaen), rmem(adcare), smem(adcaca), + > ulsort, langue, codret ) +c + endif +c + endif +c + 40 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esesmd.F b/src/tool/ES_MED/esesmd.F new file mode 100644 index 00000000..bae28b5e --- /dev/null +++ b/src/tool/ES_MED/esesmd.F @@ -0,0 +1,239 @@ + subroutine esesmd ( nosolu, nomfic, lnomfi, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Ecriture d'une Solution au format MED +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nosolu . e . char*8 . nom de l'objet solution a ecrire . +c . nomfic . e .char*200. nom du fichier ou ecrire la solution . +c . lnomfi . e . 1 . longueur du nom du fichier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . -1 : fichier inconnu . +c . . . . -2 : nom de maillage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESESMD' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "motcle.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer lnomfi +c + character*8 nosolu + character*200 nomfic +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer*8 idfmed +c + integer nbcham, nbfonc, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg + integer lnomam +c + character*8 typobs + character*64 nomamd +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''Champ : '')' +c + texte(2,5) = '(''Field : '')' +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nosolu ) +cgn call gmprsx (nompro, nosolu//'.InfoCham' ) +cgn call gmprsx (nompro, nosolu//'.InfoPaFo' ) +cgn call gmprsx (nompro, nosolu//'.InfoProf' ) + call gmprsx (nompro, nosolu//'.InfoLoPG' ) +#endif +c +c==== +c 2. determination des pointeurs associes aux tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro +#endif + call utcaso ( nosolu, + > nbcham, nbfonc, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx('1er champ :', smem(adinch)) + call gmprsx('1er champ Cham_Car :', smem(adinch)//'.Cham_Car') + if ( nbcham.ge.2 ) then + call gmprsx('2nd champ :', smem(adinch+1)) + call gmprsx('2nd champ Cham_Car :', smem(adinch+1)//'.Cham_Car') + endif +#endif +c +c==== +c 3. ecriture des valeurs, seulement s'il y en a ... +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> nom du maillage de calcul +c + if ( codret.eq.0 ) then + typobs = mccnmp + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + call utosme ( typobs, ulsort, langue ) + if ( codret.eq.4 ) then + write (ulsort,texte(langue,52)) lnomam + write (ulsort,texte(langue,53)) len(nomamd) + codret = -2 + endif + endif + endif +c +c 3.2. ==> ouverture en mode d'enrichissement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'EFOUVR', nompro +#endif + call mfiope ( idfmed, nomfic(1:lnomfi), edrdwr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,9)) + endif +c + endif +c +c 3.3. ==> ecriture veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESESM1', nompro +#endif + call esesm1 ( idfmed, nomamd, + > nbcham, smem(adinch), nbprof, smem(adinpr), + > nblopg, smem(adinlg), + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> fermeture du fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ne.-1 ) then + write (ulsort,texte(langue,8)) nomfic + endif + if ( codret.gt.0 ) then + write (ulsort,texte(langue,22)) nomamd + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch1.F b/src/tool/ES_MED/eslch1.F new file mode 100644 index 00000000..a541af00 --- /dev/null +++ b/src/tool/ES_MED/eslch1.F @@ -0,0 +1,325 @@ + subroutine eslch1 ( idfmed, nomcha, nbsqch, + > nbtmed, litmed, + > option, + > nbtvch, numdtx, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 1 +c - - - -- - +c +c Recuperation pour le champ a lire : +c - du nombre total de tableaux ecrits dans le fichier pour toutes +c les sequences et tous les types geometriques +c - du dernier instant des sequences enregistrees, comme etant celui +c de plus grand numero de pas de temps +c Affichage eventuel +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . nomcha . e . char64 . nom du champ a lire . +c . nbsqch . e . 1 . nombre de sequences associees a ce champ . +c . nbtmed . e . 1 . nombre de types MED . +c . litmed . e .0:nbtmed. liste des types MED . +c . option . e . 1 . 0 : lecture et calcul de nbtvch/numdtx . +c . . . . 1 : lecture et affichage . +c . nbtvch . s . 1 . nombre total de tableaux pour le champ . +c . numdtx . s . 1 . numero du dernier pas de temps . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbsqch, nbtmed + integer litmed(0:nbtmed) + integer option + integer nbtvch, numdtx +c + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer typent, typgeo + integer numseq + integer numdt, numit + integer nrtmed +c + character*64 nolopg + character*64 noprof +c + double precision instan +c + logical afaire +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Lecture d''''un nouveau profil.'')' +c + texte(2,4) = '(''Readings of a new profile.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,32)) nomcha + write (ulsort,90002) 'Nombre total de sequences (nbsqch)',nbsqch + write (ulsort,90002) 'Option', Option +#endif +c +c==== +c 2. On parcourt les sequences +c==== +c + nbtvch = 0 + numdtx = ednodt +c + do 20 , numseq = 1, nbsqch +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '----- Sequence numero', numseq +#endif +c +c==== +c 2. Recuperation du pas de temps et numero d'iteration de la sequence +c==== +c + if ( codret.eq.0 ) then +c + iaux = numseq +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDCSI', nompro +#endif + call mfdcsi ( idfmed, nomcha, iaux, + > numdt, numit, instan, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,17)) nomcha + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,113)) numdt + write (ulsort,texte(langue,114)) numit + write (ulsort,texte(langue,115)) instan +#endif +c + afaire = .true. +c + endif +c +c==== +c 3. On parcourt tous les types de supports +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. On parcourt ; codret', codret +#endif +c + do 30 , nrtmed = 0 , 2*nbtmed +c +c 3.1. ==> Le couple (typent,typgeo) +c + if ( codret.eq.0 ) then +c + if ( nrtmed.eq.0 ) then + typent = ednoeu + typgeo = litmed(nrtmed) + elseif ( nrtmed.le.nbtmed ) then + typent = edmail + typgeo = litmed(nrtmed) + else + typent = ednoma + typgeo = litmed(nrtmed-nbtmed) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo +#endif +c + endif +c +c 3.2. ==> Nombre de profils pour cette sequence et cette entite +c Remarque : cela indique si des valeurs ont ete enregistrees +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNPF', nompro +#endif + call mfdnpf ( idfmed, nomcha, + > numdt, numit, typent, typgeo, + > noprof, nolopg, iaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,2)) codret + endif +c + endif +c +c 3.3. ==> Diagostic pour ce couple (typent,typgeo) +c 0 profil : aucune valeur n'est presente ; on passe au couple suivant +c >1 profil : HOMARD ne sait pas faire +c 1 profil : impeccable. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) iaux + if ( iaux.eq.1 ) then + write (ulsort,texte(langue,61)) noprof + endif + write (ulsort,texte(langue,81)) nolopg +#endif +c + if ( iaux.eq.0 ) then + goto 30 + elseif ( iaux.gt.1 ) then + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,86)) iaux + codret = 33 + endif +c + endif +c +c 3.4. ==> Un profil et un seul : +c 3.4.1. ==> En vue de la lecture : +c . cumul du nombre total de tableaux +c . reperage du dernier pas de temps +c + if ( option.eq.0 ) then +c + if ( codret.eq.0 ) then +c + nbtvch = nbtvch + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numdt', numdt +#endif + if ( numdt.ne.ednodt ) then +c + numdtx = max(numdtx,numdt) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtvch', nbtvch + write (ulsort,90002) 'numdtx', numdtx +#endif +c + endif +c +c 3.4.2. ==> Pour affichage +c + elseif ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + if ( afaire ) then + write (ulsort,*) ' ' + if ( numdt.ne.ednodt ) then + write (ulsort,texte(langue,113)) numdt + write (ulsort,texte(langue,114)) numit + write (ulsort,texte(langue,115)) instan +cgn else +cgn write (ulsort,texte(langue,119)) + endif + afaire = .false. + endif +c + write (ulsort,texte(langue,64)) typgeo +c + endif +c + endif +c + 30 continue +c + 20 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch2.F b/src/tool/ES_MED/eslch2.F new file mode 100644 index 00000000..bfcacb04 --- /dev/null +++ b/src/tool/ES_MED/eslch2.F @@ -0,0 +1,783 @@ + subroutine eslch2 ( idfmed, nomcha, numdtx, typcha, + > nbtmed, litmed, + > nbsqch, nbtvch, nbtvlu, + > nbcham, nbseal, caetal, cartal, + > caraen, carare, caraca, + > nbprof, liprof, + > nblopg, lilopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 2 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . nomcha . e . char64 . nom du champ a lire . +c . numdtx . e . 1 . numero du dernier pas de temps . +c . typcha . e . 1 . edin64/edfl64 selon entier/reel . +c . nbtmed . e . 1 . nombre de types MED . +c . litmed . e .0:nbtmed. liste des types MED . +c . nbsqch . e . 1 . nombre de sequences associees a ce champ . +c . nbtvch . e . 1 . nombre total de tableaux pour le champ . +c . nbtvlu . s . 1 . nombre de tableaux effectivement lus . +c . nbcham . e . 1 . numero du dernier champ enregistre . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . caetal . es . 12 * . caracteristiques entieres de chaque . +c . . . nbseal . tableau a lire . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 2, on prend le dernier pas de temps . +c . . . . 1, le numero du pas de temps est fourni . +c . . . . 0, sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 2, on prend le dernier numero d'ordre . +c . . . . 1, le numero d'ordre est fourni . +c . . . . 0, sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 2, on prend le dernier instant . +c . . . . 1, l'instant est fourni . +c . . . . 0, sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. 1, s'il fait partie du champ en cours . +c . . . . d'examen, 0, sinon . +c . . . . 12. type de champ edfl64/edin64 . +c . cartal . e . nbseal . caracteristiques reelles de chaque . +c . . . . tableau a lire . +c . . . . 1. instant . +c . caraen . s . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . carare . s . nbtvch . caracteristiques reelles des tableaux . +c . . . . 1. valeur du pas de temps . +c . caraca . s . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbtvch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . nbprof . es . 1 . nombre cumule de profils a lire . +c . liprof . s .9*nbrpro. 1-8 : nom du -i-eme profil lu . +c . . . . 9 : nom de l'objet de type 'Profil' associe. +c . nblopg . es . 1 . nombre cumule de localisations Gauss a lire. +c . lilopg . s .9*nbrlpg. 1-8 : nom de la -i-eme localisation lue . +c . . . . 9 : nom de l'objet de type 'LocaPG' associe. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH2' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "esutil.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer numdtx, typcha, nbsqch, nbtvch, nbtvlu, nbtmed + integer nbcham, nbseal + integer litmed(0:nbtmed) + integer caraen(nbinec,nbtvch) + integer caetal(12,*) + integer nbprof, nblopg +c + double precision cartal(*) + double precision carare(nbtvch) +c + character*8 caraca(nbincc,nbtvch) + character*8 liprof(*) + character*8 lilopg(*) + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + double precision epsilo + parameter ( epsilo = 1.d-6 ) +c + integer iaux, jaux + integer typent, typgeo + integer nbval + integer ngauss, nbvapr, carsup, typint + integer numseq + integer numdt, numit + integer nrtmed +c + character*8 obprof, oblopg + character*64 nolopg + character*64 noprof + character*64 saux64 +c + double precision instan +c + logical logaux +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Lecture d''''un nouveau profil.'')' + texte(1,5) = + > '(''Lecture d''''une nouvelle localisation de Gauss.'')' +c + texte(2,4) = '(''Readings of a new profile.'')' + texte(2,5) = '(''Readings of a new Gauss localization.'')' +c +#include "esimpr.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,32)) nomcha + write (ulsort,90002) 'Nombre de sequences a lire (nbseal)',nbseal + write (ulsort,90002) 'Nombre total de sequences (nbsqch)',nbsqch + write (ulsort,90002) 'Dernier pas de temps (numdtx)', numdtx +#endif +c +c==== +c 2. Si on veut le dernier pas de temps, on memorise sa valeur +c==== +c + do 20 , iaux = 1 , nbseal +c + if ( caetal(2,iaux).eq.2 .or. caetal(6,iaux).eq.2 ) then + caetal(2,iaux) = 2 + caetal(3,iaux) = numdtx + caetal(6,iaux) = -2 + endif +c + 20 continue +c +c==== +c 3. On parcourt les sequences du champ +c Recuperation du pas de temps et numero d'iteration de la sequence +c==== +c + nbtvlu = 0 +c + do 30 , numseq = 1, nbsqch +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '----- Sequence numero', numseq +#endif +c + if ( codret.eq.0 ) then +c + iaux = numseq +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDCSI', nompro +#endif + call mfdcsi ( idfmed, nomcha, iaux, + > numdt, numit, instan, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,17)) nomcha + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,113)) numdt + write (ulsort,texte(langue,114)) numit + write (ulsort,texte(langue,115)) instan +#endif +c + endif +c +c==== +c 4. On parcourt tous les types de support +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Exploration des supports, codret', codret +#endif +c + do 40 , nrtmed = 0 , 2*nbtmed +c +c 4.1. ==> Le couple (typent,typgeo) +c + if ( codret.eq.0 ) then +c + if ( nrtmed.eq.0 ) then + typent = ednoeu + typgeo = litmed(nrtmed) + elseif ( nrtmed.le.nbtmed ) then + typent = edmail + typgeo = litmed(nrtmed) + else + typent = ednoma + typgeo = litmed(nrtmed-nbtmed) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo +#endif +c + endif +c +c 4.2. ==> Nombre de profils pour cette sequence et cette entite +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNPF', nompro +#endif + call mfdnpf ( idfmed, nomcha, + > numdt, numit, typent, typgeo, + > noprof, nolopg, iaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,2)) codret + endif +c + endif +c +c 4.3. ==> Diagostic pour ce couple (typent,typgeo) +c 0 profil : aucune valeur n'est presente ; on passe au couple suivant +c >1 profil : HOMARD ne sait pas faire (en principe filtre par eslch1) +c 1 profil : impeccable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) iaux + if ( iaux.eq.1 ) then + write (ulsort,texte(langue,61)) noprof + endif + write (ulsort,texte(langue,81)) nolopg +#endif +c + if ( iaux.eq.0 ) then + goto 40 + elseif ( iaux.gt.1 ) then + write (ulsort,texte(langue,86)) iaux + codret = 43 + endif +c + endif +c +c 4.4. ==> ce tableau fait-il partie de la liste requise ? +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '---------- Examen du support' + write (ulsort,texte(langue,60)) typent + write (ulsort,texte(langue,64)) typgeo +#endif +c + if ( nbseal.gt.0 ) then +cgn print *, '.. numdt, numit de la sequence = ', numdt, numit +c +cgn print *, '.. nbseal = ',nbseal + jaux = -1 + do 44 , iaux = 1 , nbseal +cgn print *, '... support MED caetal(1,',iaux,') =',caetal(1,iaux) +cgn print *, '... typgeo =',typgeo + if ( caetal(1,iaux).eq.-1 .or. + > caetal(1,iaux).eq.typgeo ) then +cgn write(ulsort,*) '... examen ? caetal(11,',iaux,') =', +cgn > caetal(11,iaux) + if ( caetal(11,iaux).eq.1 ) then +cgn write(ulsort,*) '... pas de temps ? caetal(2,',iaux,') = ', +cgn > caetal(2,iaux) +cgn write(ulsort,*) '... pas de temps = caetal(3,',iaux,') = ', +cgn > caetal(3,iaux) +cgn write(ulsort,*) '... nro ordre ? caetal(4,',iaux,') = ', +cgn > caetal(4,iaux) +cgn write(ulsort,*) '... nro ordre = caetal(5,',iaux,') = ', +cgn > caetal(5,iaux) +cgn write(ulsort,*) '... instant ? caetal(6,',iaux,') = ', +cgn > caetal(6,iaux) +cgn write(ulsort,*) '... no/el ? caetal(7,',iaux,') = ', +cgn > caetal(7,iaux) +cgn write(ulsort,*) '... nr chp no/el caetal(8,',iaux,') = ', +cgn > caetal(8,iaux) +cgn write(ulsort,*) '... instant = cartal(',iaux,') = ',cartal(iaux) +cgn write(ulsort,*) '... epsilo =',epsilo +cgn write(ulsort,*) '... abs(cartal(iaux)-instan) =',abs(cartal(iaux)-instan) +c + logaux = .false. +c +c A-t-on le bon numero d'iteration ? +c + if ( caetal(4,iaux).eq.1 .or. + > caetal(4,iaux).eq.2 ) then + if ( caetal(5,iaux).eq.numit ) then +cgn write(ulsort,*)'glop' + logaux = .true. + endif + endif +c +c A-t-on le bon numero d'instant / le bon instant ? +c + if ( caetal(2,iaux).eq.1 .or. + > caetal(2,iaux).eq.2 ) then + if ( caetal(3,iaux).eq.numdt ) then +cgn write(ulsort,*)'glop' + logaux = .true. + else + logaux = .false. + endif + endif + if ( caetal(6,iaux).eq.1 .or. + > caetal(6,iaux).eq.2 ) then + if (abs(cartal(iaux)-instan).le.epsilo) then +cgn write(ulsort,*)'glop' + logaux = .true. + else + logaux = .false. + endif + endif +c +c Rien n'a ete demande +c + if ( caetal(2,iaux).eq.0 .and. + > caetal(4,iaux).eq.0 .and. + > caetal(6,iaux).eq.0) then + logaux = .true. + endif +c +c Enregistrement +c +cgn write(ulsort,99001)'logaux',logaux + if ( logaux ) then + jaux = nrtmed + carsup = caetal(7,iaux) + typint = caetal(10,iaux) +cgn write(ulsort,*) '... no/el ? caetal(7,',iaux,') = ', +cgn > caetal(7,iaux) +c + caetal(9,iaux) = nbcham+1 +cgn print *, '... nr chp caetal(9,',iaux,') = ', +cgn > caetal(9,iaux) + typcha = caetal(12,iaux) +cgn write(ulsort,90002)'carsup',carsup +cgn write(ulsort,90002)'typint',typint +cgn write(ulsort,90002)'typcha',typcha + endif + endif + endif + 44 continue +cgn print *, 'A la fin de 44, .. jaux = ', jaux +c +c rien n'est bon, donc on passe au couple suivant + if ( jaux.eq.-1 ) then + goto 40 + endif +c + endif +c + endif +c +c 4.5. ==> le profil s'il existe +c + if ( noprof.ne.ednopl ) then +c +c 4.5.1. ==> ce profil est-il deja lu ? +c + if ( codret.eq.0 ) then +c + do 451 , iaux = 1 , nbprof + if ( codret.eq.0 ) then + call uts8ch ( liprof(9*(iaux-1)+1), 64, saux64, + > ulsort, langue, codret ) + if ( saux64.eq.noprof ) then + obprof = liprof(9*iaux) + call gmliat ( obprof, 2, nbvapr, codret ) + goto 459 + endif + endif + 451 continue +c + endif +c +c 4.5.2. ==> le profil n'est pas lu. On le lit. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,3)) 'ESLPR1', nompro +#endif + call eslpr1 ( idfmed, + > noprof, obprof, nbvapr, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbprof = nbprof + 1 + call utchs8 ( noprof, 64, liprof(9*(nbprof-1)+1), + > ulsort, langue, codret ) + liprof(9*nbprof) = obprof +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,obprof) + call gmprsx (nompro,obprof//'.NomProfi') + call gmprot (nompro,obprof//'.ListEnti',1,30) +#endif +c + 459 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,62)) nbvapr +#endif +c +c 4.6. ==> la localisation des points de Gauss eventuelle +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.6. pts Gauss eventuel ; codret', codret +#endif + if ( nolopg.eq.ednoga .or. typent.eq.ednoma ) then +cgn if ( ngauss.eq.ednopg .or. typent.eq.ednoma .or. +cgn > ngauss.eq.1 ) then VERRUE SATURNE +c + oblopg = blan08 +c + elseif ( nolopg.ne.edngen ) then +c +c VERRUE en attendant la correction de certains cas-tests +c + if ( nolopg(1:5).eq.'GLOP_' ) then +c 4567890123456789012 + nolopg(14:32) = ' ' + nolopg(33:64) = blan32 + endif +c +c 4.6.1. ==> la localisation est-elle deja lue ? +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,81)) nolopg +#endif +c + do 461 , iaux = 1 , nblopg + if ( codret.eq.0 ) then + call uts8ch ( lilopg(9*(iaux-1)+1), 64, saux64, + > ulsort, langue, codret ) + if ( saux64.eq.nolopg ) then + oblopg = lilopg(9*iaux) + goto 469 + endif + endif + 461 continue +c + endif +c +c 4.6.2. ==> la localisation n'est pas lue. On la lit. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) + write (ulsort,texte(langue,3)) 'ESLPG1', nompro +#endif + call eslpg1 ( idfmed, + > nolopg, oblopg, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nblopg = nblopg + 1 + lilopg(9*nblopg) = oblopg + call utchs8 ( nolopg, 64, lilopg(9*(nblopg-1)+1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,oblopg) + call gmprsx (nompro,oblopg//'.NomLocPG') + call gmprsx (nompro,oblopg//'.CoorNoeu') + call gmprsx (nompro,oblopg//'.CoorPtGa') + call gmprsx (nompro,oblopg//'.PoidPtGa') +#endif +c + endif +c + 469 continue +c + endif +c +c 4.7. ==> nombre de valeurs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNPN', nompro +#endif + call mfdnpn ( idfmed, nomcha, + > numdt, numit, typent, typgeo, + > noprof, edstco, nbvapr, nolopg, ngauss, + > nbval, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,58)) nbval + if ( noprof.ne.ednopl ) then + write (ulsort,texte(langue,61)) noprof + write (ulsort,texte(langue,62)) nbvapr + endif + write (ulsort,texte(langue,57)) ngauss + if ( nolopg.ne.ednoga ) then + write (ulsort,texte(langue,81)) nolopg + endif +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( noprof.eq.ednopl ) then + nbvapr = -1 + obprof = blan08 + endif +c + endif +c +c 4.8. ==> determination de la caracteristique du support +c 1, si aux noeuds par elements +c 2, si aux points de Gauss, associe avec +c un champ aux noeuds par elements +c 3, si aux points de Gauss autonome +c 0, sinon +c Pour un champ aux noeuds par element, a-t-on le bon +c nombre de pseudo-points de Gauss ? +c + if ( codret.eq.0 ) then +c + if ( ngauss.eq.1 .or. ngauss.eq.ednopg ) then + carsup = 0 + else +c + if ( typent.eq.ednoma ) then + oblopg = blan08 + carsup = 1 + iaux = mod(typgeo,100) + if ( iaux.ne.ngauss ) then + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,66)) + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,57)) ngauss + write (ulsort,texte(langue,34)) iaux + codret = 1 + endif + else + carsup = 3 + endif +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,65+carsup)) +#endif +c + endif +c +c 4.9. ==> si c'est bon, on enregistre +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.9. enregistre ; codret', codret +#endif +c +c 4.9.1. ==> enregistrement d'un nouveau tableau +c + if ( codret.eq.0 ) then +c + nbtvlu = nbtvlu + 1 + caraen(1,nbtvlu) = typgeo + caraen(2,nbtvlu) = numdt + caraen(3,nbtvlu) = numit + caraen(4,nbtvlu) = ngauss + caraen(5,nbtvlu) = nbval + caraen(6,nbtvlu) = nbvapr + caraen(7,nbtvlu) = 0 + caraen(8,nbtvlu) = carsup + caraen(11,nbtvlu) = typint + caraen(12,nbtvlu) = typcha + if ( numdt.ne.ednodt ) then + carare(nbtvlu) = instan + else + carare(nbtvlu) = -1789.d0 + endif + caraca(2,nbtvlu) = obprof + caraca(3,nbtvlu) = oblopg +c + endif +c +c 4.9.2. ==> Si d'autres supports sont presents aux memes instants, +c on doit memoriser les correspondances +c + if ( codret.eq.0 ) then +c +cgn print *,'nbtvlu =',nbtvlu +cgn print *,'champ de type',typgeo + do 492 , iaux = 1 , nbtvlu-1 +cgn print *,'. champ',iaux,' de types associes',caraen(7,iaux) +cgn print *,caraen(2,iaux),caraen(3,iaux),caraen(7,iaux) + if ( caraen(2,iaux).eq.numdt .and. + > caraen(3,iaux).eq.numit ) then +c insertion du champ en lecture comme associe au champ iaux + caraen(7,iaux) = caraen(7,iaux) + 1 + jaux = caraen(7,iaux) + if ( 20+jaux.gt.nbinec ) then + codret = 492 + write (ulsort,90002) 'nbinec est trop petit', nbinec + goto 30 + endif + caraen(20+jaux,iaux) = typgeo +c insertion du champ iaux comme associe au champ enlecture + caraen(7,nbtvlu) = caraen(7,nbtvlu) + 1 + jaux = caraen(7,nbtvlu) + if ( 20+jaux.gt.nbinec ) then + codret = 492 + write (ulsort,90002) 'nbinec est trop petit', nbinec + goto 30 + endif + caraen(20+jaux,nbtvlu) = caraen(1,iaux) + endif + 492 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) ' ' + write (ulsort,texte(langue,32)) nomcha + write (ulsort,90002) 'Caracteristiques du tableau', nbtvlu + write (ulsort,texte(langue,69)) caraen(12,nbtvlu) + write (ulsort,texte(langue,64)) caraen(1,nbtvlu) + write (ulsort,texte(langue,113)) caraen(2,nbtvlu) + write (ulsort,texte(langue,114)) caraen(3,nbtvlu) + if ( numdt.ne.ednodt ) then + write (ulsort,texte(langue,115)) carare(nbtvlu) + endif + write (ulsort,texte(langue,57)) caraen(4,nbtvlu) + write (ulsort,texte(langue,58)) caraen(5,nbtvlu) + do 4999 , iaux = 1, caraen(7,nbtvlu) + write (ulsort,texte(langue,60)) caraen(20+iaux,nbtvlu) + 4999 continue + if ( caraen(6,nbtvlu).gt.0 ) then + write (ulsort,texte(langue,61)) noprof + endif + write (ulsort,texte(langue,65+carsup)) + if ( caraen(8,nbtvlu).gt.0 ) then + write (ulsort,texte(langue,81)) nolopg + endif +cgn write(*,91020)(caraen(iaux,nbtvlu),iaux=1,nbinec) + endif +#endif +cc + 40 continue +c +cgn endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'a la fin de '//nompro//', nbtvlu',nbtvlu +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch3.F b/src/tool/ES_MED/eslch3.F new file mode 100644 index 00000000..7ad2f8d8 --- /dev/null +++ b/src/tool/ES_MED/eslch3.F @@ -0,0 +1,333 @@ + subroutine eslch3 ( nrocha, nomcha, nbcomp, nbtvch, + > caraen, caraca, + > nbfonc, defonc, nofonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 3 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrocha . e . 1 . numero du champ dans le rangement HOMARD . +c . nomcha . e . char64 . nom du champ . +c . nbcomp . e . 1 . nombre de composantes . +c . nbtvch . e . 1 . nombre de tableaux associes a ce champ . +c . caraen . e . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . caraca . e . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbtvch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . nbfonc . es . 1 . nombre de fonctions classees . +c . defonc . es . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-20+(7). type des supports associes . +c . nofonc . s .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH3' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "esutil.h" +#include "envex1.h" +#include "meddc0.h" +c +c 0.3. ==> arguments +c + integer nrocha + integer nbcomp, nbtvch + integer nbfonc + integer caraen(nbinec,nbtvch) + integer defonc(nbinec,*) +c + character*8 caraca(nbincc,nbtvch) + character*8 nofonc(3,*) + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer typgeo + integer nrotv, nrfonc + integer ngauss, nbensu, nbvapr, nbtyas, carsup, typint, typcha +c + logical trouve +c + character*8 obprof, oblopg +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Nom du champ : '',a)' + texte(1,5) = '(''Numero du champ :'',i5)' + texte(1,6) = '(''Numero du tableau :'',i5)' +c + texte(2,4) = '(/,''Field Name : '',a)' + texte(2,5) = '(''Field #'',i5)' + texte(2,6) = '(''Array #'',i5)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha + write (ulsort,texte(langue,5)) nrocha + write (ulsort,90002) 'nbtvch', nbtvch + write (ulsort,90002) 'nbcomp', nbcomp +#endif +c +c==== +c 2. on parcourt tous les tableaux de ce champ +c==== +c + codret = 0 +c + do 21 , nrotv = 1 , nbtvch +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nrotv +#endif +cgn write (ulsort,*)(caraen(nrfonc,nrotv), nrfonc = 1 , nbinec) +c +c 2.1. ==> caracteristiques du tableau courant +c + typgeo = caraen(1,nrotv) + ngauss = caraen(4,nrotv) + nbensu = caraen(5,nrotv) + nbvapr = caraen(6,nrotv) + nbtyas = caraen(7,nrotv) + carsup = caraen(8,nrotv) + typint = caraen(11,nrotv) + typcha = caraen(12,nrotv) + obprof = caraca(2,nrotv) + oblopg = caraca(3,nrotv) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbensu', nbensu + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + write (ulsort,90002) 'typcha', typcha +#endif +c +c 2.2. ==> on cherche quelle fonction deja enregistree a ces +c caracteristiques +c quand on l'a, on ajoute le nombre de composantes +c si on ne la trouve pas, on en cree une +c + trouve = .false. +c + do 22 , nrfonc = 1 , nbfonc +c + if ( defonc( 1,nrfonc).eq.typgeo .and. + > defonc( 2,nrfonc).eq.ngauss .and. + > defonc( 3,nrfonc).eq.nbensu .and. + > defonc( 4,nrfonc).eq.nbvapr .and. + > defonc( 5,nrfonc).eq.nbtyas .and. + > defonc( 6,nrfonc).eq.carsup .and. + > defonc(11,nrfonc).eq.typint .and. + > defonc(12,nrfonc).eq.typcha .and. + > nofonc(1,nrfonc).eq.obprof .and. + > nofonc(3,nrfonc).eq.oblopg ) then +c + trouve = .true. +c + if ( carsup.ne.0 ) then + if ( defonc(10,nrfonc).ne.nrocha ) then + trouve = .false. + endif + endif +c + do 221 , iaux = 1, nbtyas + if ( defonc(20+iaux,nrfonc) .ne. + > caraen(20+iaux,nrotv) ) then + trouve = .false. + endif + 221 continue +c + if ( trouve ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Ajout de la composante numero ', nbcomp + write (ulsort,90002) 'a la fonction numero ', nrfonc +#endif + defonc(7,nrfonc) = defonc(7,nrfonc) + nbcomp + goto 21 + endif +c + endif +c + 22 continue +c + nbfonc = nbfonc + 1 + defonc( 1,nrfonc) = typgeo + defonc( 2,nrfonc) = ngauss + defonc( 3,nrfonc) = nbensu + defonc( 4,nrfonc) = nbvapr + defonc( 5,nrfonc) = nbtyas + defonc( 6,nrfonc) = carsup + defonc( 7,nrfonc) = nbcomp + defonc( 8,nrfonc) = 1 + defonc( 9,nrfonc) = 0 + defonc(10,nrfonc) = nrocha + defonc(11,nrfonc) = typint + defonc(12,nrfonc) = typcha + do 220 , iaux = 1, nbtyas + defonc(20+iaux,nrfonc) = caraen(20+iaux,nrotv) + 220 continue + nofonc( 1,nrfonc) = obprof + nofonc( 3,nrfonc) = oblopg +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '=============================================' + write (ulsort,*) 'Creation d''une nouvelle fonction' + write (ulsort,texte(langue,36)) nompro, nbfonc + write (ulsort,texte(langue,64)) defonc(1,nrfonc) + write (ulsort,texte(langue,57)) defonc(2,nrfonc) + write (ulsort,texte(langue,58)) defonc(3,nrfonc) + write (ulsort,texte(langue,62)) defonc(4,nrfonc) + do 229 , iaux = 1, defonc(5,nrfonc) + write (ulsort,texte(langue,60)) defonc(20+iaux,nrfonc) + 229 continue + write (ulsort,texte(langue,111)) defonc(7,nrfonc) + if ( nbvapr.gt.0 ) then + write (ulsort,texte(langue,84)) nofonc(1,nrfonc) + endif + write (ulsort,texte(langue,65+carsup)) + if ( oblopg.ne.blan08 ) then + write (ulsort,texte(langue,83)) nofonc(3,nrfonc) + endif + write (ulsort,*) '=============================================' +#endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,4)) nomcha + write (ulsort,texte(langue,65+carsup)) + write (ulsort,texte(langue,5)) nrocha + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch4.F b/src/tool/ES_MED/eslch4.F new file mode 100644 index 00000000..6e37c3f6 --- /dev/null +++ b/src/tool/ES_MED/eslch4.F @@ -0,0 +1,594 @@ + subroutine eslch4 ( idfmed, + > nrocha, nomcha, nbcomp, nbtvch, + > obcham, caraen, caraca, + > nbfonc, defonc, nofonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 4 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . nrocha . e . 1 . numero du champ dans le rangement HOMARD . +c . nomcha . e . char64 . nom du champ a explorer . +c . nbcomp . e . 1 . nombre de composantes . +c . nbtvch . e . 1 . nombre de tableaux associes a ce champ . +c . obcham . e . char8 . nom de l'objet de type 'InfoCham' associe . +c . caraen . e . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . caraca . e . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbtvch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . nbfonc . es . 1 . nombre de fonctions classees . +c . defonc . es . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 21-nbinec. type des supports associes . +c . nofonc . e .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . . . . 100 : aucune fonction semblable au champ . +c . . . . n'a ete trouvee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH4' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nrocha + integer nbcomp, nbtvch + integer nbfonc + integer caraen(nbinec,nbtvch) + integer defonc(nbinec,nbfonc) +c + character*8 nofonc(3,nbfonc) + character*8 obcham + character*8 caraca(nbincc,nbtvch) + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer typenh + integer nbvalc + integer nrotv, nrfonc + integer numdt, numit + integer nbpg + integer nrtafo + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint, typcha + integer advale, advalr, adobch, adprpg, adtyas + integer adtra1 + integer adlipr +c + logical trouve +c + character*8 ntrav1 + character*64 noprof +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Numero du champ :'',i5)' + texte(1,5) = + > '(''Aucune fonction n''''a les caracteristiques du champ.'')' +c + texte(2,4) = '(''Field # :'',i5)' + texte(2,5) = + > '(''No function with same characteristics than the field.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. on parcourt tous les tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,4)) nrocha + write (ulsort,texte(langue,111)) nbtvch +#endif +c + codret = 0 +c + do 20 , nrotv = 1 , nbtvch +c +c 2.1. ==> on cherche quelle fonction deja enregistree a les +c memes caracteristiques de support, de points de Gauss et +c de profil, meme type d'interpolation +c si on ne la trouve pas, malaise ... +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,38)) 'caraen/caraca', nrotv + write (ulsort,texte(langue,64)) caraen(1,nrotv) + write (ulsort,texte(langue,113)) caraen(2,nrotv) + write (ulsort,texte(langue,114)) caraen(3,nrotv) + write (ulsort,texte(langue,57)) caraen(4,nrotv) + write (ulsort,texte(langue,58)) caraen(5,nrotv) + write (ulsort,texte(langue,62)) caraen(6,nrotv) + do 2111 , iaux = 1 , caraen(7,nrotv) + write (ulsort,texte(langue,60)) caraen(20+iaux,nrotv) + 2111 continue + if ( caraen(11,nrotv).ge.0 .and. caraen(11,nrotv).le.3 ) then + write (ulsort,texte(langue,100+caraen(11,nrotv))) + else + write (ulsort,texte(langue,104)) + endif + write (ulsort,texte(langue,65+caraen(8,nrotv))) + write (ulsort,texte(langue,61)) caraca(2,nrotv) + write (ulsort,texte(langue,81)) caraca(3,nrotv) +#endif +c + trouve = .false. +c + do 21 , iaux = 1 , nbfonc +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Fonction numero ', iaux + write (ulsort,*) ' . defonc(1,iaux) = ', defonc(1,iaux) + write (ulsort,*) ' . defonc(2,iaux) = ', defonc(2,iaux) + write (ulsort,*) ' . defonc(5,iaux) = ', defonc(5,iaux) + write (ulsort,*) ' . defonc(11,iaux) = ', defonc(11,iaux) + write (ulsort,*) ' . nofonc(1,iaux) = ', nofonc(1,iaux) + write (ulsort,*) ' . nofonc(3,iaux) = ', nofonc(3,iaux) +#endif + if ( defonc( 1,iaux).eq.caraen( 1,nrotv) .and. + > defonc( 2,iaux).eq.caraen( 4,nrotv) .and. + > defonc( 5,iaux).eq.caraen( 7,nrotv) .and. + > defonc(11,iaux).eq.caraen(11,nrotv) .and. + > defonc(12,iaux).eq.caraen(12,nrotv) .and. + > nofonc(1,iaux).eq.caraca(2,nrotv) .and. + > nofonc(3,iaux).eq.caraca(3,nrotv) ) then +c + trouve = .true. +c +cgn write (ulsort,*) ' ... defonc(6,iaux) = ', defonc(6,iaux) + if ( defonc(6,iaux).ne.0 ) then +cgn write (ulsort,*) ' ..... defonc(10,iaux) = ', defonc(10,iaux) + if ( defonc(10,iaux).ne.nrocha ) then + trouve = .false. + endif + endif +c + if ( trouve ) then + nrfonc = iaux + goto 220 + endif +c + endif +c + 21 continue +c + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,111)) nbtvch + write (ulsort,texte(langue,5)) + codret = 100 +c + endif +c +c 2.2. ==> recuperation de la fonction +c + 220 continue +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nofonc(2,nrfonc)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nofonc(2,nrfonc), + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,36)) nompro, nrfonc + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,60)) nbtyas + write (ulsort,texte(langue,111)) nbtafo + write (ulsort,texte(langue,57)) ngauss + write (ulsort,texte(langue,58)) nbenmx + write (ulsort,texte(langue,62)) nbvapr + write (ulsort,90002) 'typcha', typcha +#endif +c + caraca(1,nrotv) = nofonc(2,nrfonc) + if ( nbvapr.gt.0 ) then + nbvalc = nbvapr + else + nbvalc = nbenmx + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==> nbvalc = ',nbvalc +#endif +c + endif +c +c 2.3. ==> decodage eventuel du profil +c + if ( codret.eq.0 ) then +c + if ( nbvapr.gt.0 ) then + iaux = nbvapr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( caraca(2,nrotv), + > nbvapr, noprof, adlipr, + > ulsort, langue, codret ) + if ( nbvapr.ne.iaux ) then + codret = 23 + endif + else + noprof = blan64 + endif +c + endif +c +c 2.4. ==> lecture +c +c 2.4.1. ==> caracteristiques +c +cgn print *,'Avant 2.4.1, codret = ',codret + if ( codret.eq.0 ) then +c + numdt = caraen(2,nrotv) + numit = caraen(3,nrotv) +cgn print *,'numdt, numit, ngauss = ',numdt, numit, ngauss + if ( ngauss.eq.ednopg ) then + nbpg = 1 + else + nbpg = ngauss + endif +c + if ( typgeo.eq.0 ) then + typenh = ednoeu + else + if ( caraen(8,nrotv).eq.1 ) then + typenh = ednoma + else + typenh = edmail + endif + endif +c + endif +c +c 2.4.2. ==> allocation d'un tableau de travail +c remarque : on est oblige d'allouer au nombre maximal de +c valeurs, meme dans le cas de profil. +c + if ( codret.eq.0 ) then + iaux = nbenmx*nbpg*nbcomp +cgn print *, +cgn >'nbenmx*nbpg*nbcomp=',nbenmx,'*',nbpg,'*',nbcomp,'=',iaux + if ( typcha.eq.edfl64 ) then + call gmalot ( ntrav1, 'reel ', iaux, adtra1, codret ) + else + call gmalot ( ntrav1, 'entier ', iaux, adtra1, codret ) + endif + endif +c +c 2.4.3. ==> lecture MED brutale +c +c . Sans points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 sera declare ainsi : trav1(nbpg,nbvalc,nbcomp), ce qui +c corrrespond a trav1(nbvalc,nbcomp) sans points de Gauss. +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1), trav1(2,1), trav1(3,1), ..., trav1(nbvalc,1), +c trav1(1,2), trav1(2,2), trav1(3,2), ..., trav1(nbvalc,2), +c ... +c trav1(1,nbcomp), trav1(2,nbcomp), ..., trav1(nbvalc,nbcomp) +c on a ainsi toutes les valeurs pour la premiere composante, puis +c toutes les valeurs pour la seconde composante, etc. +c +c . Avec nbpg points de Gauss : +c Dans la phase de transfert dans les tableaux HOMARD, le tableau +c trav1 sera declare ainsi : trav1(nbpg,nbvalc,nbcomp). +c +c En fortran, cela correspond au stockage memoire suivant : +c trav1(1,1,1), trav1(2,1,1), ..., trav1(nbpg,1,1), trav1(1,2,1), +c trav1(2,2,1), ..., trav1(nbpg,2,1), trav1(1,3,1), ..., +c trav1(1,nbvalc,1), trav1(2,nbvalc,1), ..., trav1(nbpg,nbvalc,1), +c trav1(1,1,2), trav1(2,1,2), ..., trav1(nbpg,1,2), trav1(1,2,2), +c trav1(2,2,2), ..., trav1(nbpg,2,2), trav1(1,3,2), ..., +c trav1(1,nbvalc,2), trav1(2,nbvalc,2), ..., trav1(nbpg,nbvalc,2), +c ... +c trav1(1,1,nrcomp), trav1(2,1,nrcomp), ..., trav1(nbpg,1,nrcomp), +c trav1(1,2,nrcomp), trav1(2,2,nrcomp), ..., trav1(nbpg,2,nrcomp), +c trav1(1,3,nrcomp), ..., trav1(nbpg,nbvalc,nrcomp) +c on a ainsi tous les points de Gauss de la premiere maille de la +c premiere composante, puis tous les points de Gauss de la +c deuxieme maille de la premiere composante, etc. jusqu'a la fin de +c la premiere composante. Ensuite on recommence avec la deuxieme +c composante. +c +c . Remarque : C'est ce que MED appelle le mode non entrelace. +c +c . Remarque : il faut lire selon ce mode non entrelace car on n'est +c jamais certain de la numerotation des mailles. +c +cgn print *,'Avant 2.3.3, codret = ',codret +cgn print *,'idfmed = ',idfmed +cgn write (ulsort,texte(langue,32)) nomcha +cgn write (ulsort,texte(langue,113)) numdt +cgn write (ulsort,texte(langue,114)) numit +cgn write (ulsort,texte(langue,61)) noprof +cgn print *,'rmem(adtra1) = ',rmem(adtra1) +cgn print *,'ednoin, edall, edstco = ', ednoin, edall, edstco +cgn print *,'typenh, typgeo, numdt, numit = ', +cgn >typenh, typgeo,numdt, numit + if ( codret.eq.0 ) then + if ( typcha.eq.edfl64 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDRPR', nompro +#endif + call mfdrpr ( idfmed, nomcha, numdt, numit, + > typenh, typgeo, + > edstco, noprof, ednoin, edall, + > rmem(adtra1), codret ) + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDIPR', nompro +#endif + call mfdipr ( idfmed, nomcha, numdt, numit, + > typenh, typgeo, + > edstco, noprof, ednoin, edall, + > imem(adtra1), codret ) + endif +c +cgn print *,'codret de mfdrpr = ',codret +cgn print *,'rmem(adtra1) = ',rmem(adtra1) +cgn print *,'rmem(adtra1+1) = ',rmem(adtra1+1) +cgn print *,'rmem(final-1) = ',rmem(adtra1+nbenmx*nbpg*nbcomp-2) +cgn print *,'rmem(final) = ',rmem(adtra1+nbenmx*nbpg*nbcomp-1) +cgn print *,'noprof = ',noprof +cgn print 1789, +cgn > (rmem(iaux),iaux=adtra1,adtra1+nbenmx*nbpg*nbcomp-1) +cgn 1789 format(12g14.6) +cgn nrtafo=0 +cgn do 4444,iaux=0,143511 +cgn if ( rmem(adtra1+iaux).gt.1.d-7) nrtafo=nrtafo+1 +cgn 4444 continue +cgn print *,nrtafo + if ( codret.ne.0 ) then + write (ulsort,texte(langue,18)) nomcha + write (ulsort,texte(langue,113)) numdt + write (ulsort,texte(langue,114)) numit + write (ulsort,texte(langue,61)) noprof + endif + endif +cgn if ( nbpg.gt.1 ) then +cgncc if ( nbpg.gt.1 .or. typgeo.eq.206 ) then +cgn call gmprsx (nompro, ntrav1 ) +cgn print *,'en mode non entrelace' +cgn print 1789, +cgn > (rmem(iaux),iaux=adtra1,adtra1+nbvalc*nbcomp*nbpg-1) +cgn 1789 format(12g14.6) +cgn iaux = nbvalc*nbpg*nbcomp +cgn call toto1 ( iaux, rmem(adtra1), ulsort ) +cgn iaux = nbvalc*nbpg +cgn call toto2 ( iaux, nbcomp,rmem(adtra1), ulsort ) +cgn call toto3 ( nbpg, nbvalc,nbcomp,rmem(adtra1), ulsort ) +cgn endif +c +c 2.5. ==> le profil (eventuellement) +c + if ( codret.eq.0 ) then +c + smem(adprpg) = caraca(2,nrotv) +c + endif +c +c 2.6. ==> la localisation des points de Gauss (eventuellement) +c + if ( codret.eq.0 ) then +c + smem(adprpg+1) = caraca(3,nrotv) +c + endif +c +c 2.7. ==> transfert, composante par composante +c +cgn print *,'Avant 2.6, codret = ',codret + if ( codret.eq.0 ) then +c + nrtafo = defonc(8,nrfonc) +c + caraen(9,nrotv) = nrtafo +c + if ( typcha.eq.edfl64 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH5', nompro +#endif + call eslch5 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > rmem(advalr), rmem(adtra1), + > obcham, smem(adobch), + > ulsort, langue, codret ) +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH8', nompro +#endif + call eslch8 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > imem(advale), imem(adtra1), + > obcham, smem(adobch), + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + defonc(8,nrfonc) = nrtafo +c + endif +c +c 2.8. ==> liberation du tableau de lecture +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav1, codret ) + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +cgn call gmprsx (nompro,nofonc(2,nrfonc)//'.ValeursR') + call gmprot (nompro,nofonc(2,nrfonc)//'.ValeursR',1,100) + call gmprsx (nompro,nofonc(2,nrfonc)//'.InfoCham') + call gmprsx (nompro,nofonc(2,nrfonc)//'.InfoPrPG') + endif +#endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch5.F b/src/tool/ES_MED/eslch5.F new file mode 100644 index 00000000..32b9f418 --- /dev/null +++ b/src/tool/ES_MED/eslch5.F @@ -0,0 +1,201 @@ + subroutine eslch5 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > vafonc, trav1, + > obcham, objech, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 5 +c - - - -- - +c Ce programme est le symetrique de ESECH2 +c Remarque : eslch5 et eslch8 sont des clones +c 5 : double precision +c 8 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrtafo . es . 1 . numero courant du tableau de la fonction . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbpg . e . 1 . nombre de points de Gauss, s'il y en a . +c . . . . si le champ est sans point de Gauss, nbpg . +c . . . . vaut 1 pour aider au traitement . +c . nbvalc . e . 1 . nombre de valeurs par composante . +c . nbcomp . e . 1 . nombre de composantes du champ . +c . vafonc . es . * . valeurs de la fonction . +c . trav1 . e . * . valeurs lues . +c . obcham . e . char8 . nom de l'objet de type 'InfoCham' associe . +c . objech . es . nbtafo . nom de l'objet de type 'InfoCham' associe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nrtafo + integer nbtafo + integer nbpg, nbvalc, nbcomp +c + double precision trav1(nbpg,nbvalc,nbcomp) + double precision vafonc(nbtafo,nbpg,*) +c + character*8 obcham + character*8 objech(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp, nugaus +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. '',a,'' = '',i8)' + texte(1,5) = '(''. Premiere valeur : '',g14.7)' + texte(1,6) = '(''. Derniere valeur : '',g14.7)' + texte(1,7) = '(''... Composante numero '',i8)' +c + texte(2,4) = '(''. '',a,'' = '',i8)' + texte(2,5) = '(''. First value : '',g14.7)' + texte(2,6) = '(''. Last value : '',g14.7)' + texte(2,7) = '(''... Composante # '',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'nbtafo', nbtafo + write (ulsort,texte(langue,4)) 'nbpg ', nbpg + write (ulsort,texte(langue,4)) 'nbvalc', nbvalc + write (ulsort,texte(langue,4)) 'nbcomp', nbcomp + write (ulsort,texte(langue,4)) 'nrtafo au depart', nrtafo +#endif +c +c==== +c 2. Transfert +c==== +c + codret = 0 +c + do 20 , nrcomp = 1 , nbcomp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nrcomp + write (ulsort,texte(langue,4)) '==> nrtafo', nrtafo +#endif +c +cgn print *,'nrcomp,nrtafo, nbvalc = ',nrcomp,nrtafo, nbvalc +c +c 2.1. ==> les valeurs numeriques +c + if ( nbpg.eq.1 ) then +c + do 21 , iaux = 1 , nbvalc +cgn write(11,*) 'trav1 = ',trav1(1,iaux,nrcomp) + vafonc(nrtafo,1,iaux) = trav1(1,iaux,nrcomp) + 21 continue +c + else +c + do 22 , iaux = 1 , nbvalc +cgn print *,'trav1(...,',iaux,',',nrcomp,') = ', +cgn > (trav1(nugaus,iaux,nrcomp),nugaus=1,nbpg) + do 221 , nugaus = 1 , nbpg + vafonc(nrtafo,nugaus,iaux) = trav1(nugaus,iaux,nrcomp) + 221 continue + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) vafonc(nrtafo,1,1) + write (ulsort,texte(langue,6)) vafonc(nrtafo,nbpg,nbvalc) +#endif +c +c 2.2. ==> les caracteristiques du champ associe +c + objech(nrtafo) = obcham +c +c 2.3. ==> tableau suivant dans la fonction +c + nrtafo = nrtafo + 1 +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'nrtafo a la fin ', nrtafo +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch6.F b/src/tool/ES_MED/eslch6.F new file mode 100644 index 00000000..73df0a75 --- /dev/null +++ b/src/tool/ES_MED/eslch6.F @@ -0,0 +1,321 @@ + subroutine eslch6 ( nrocha, numcat, nbtvlu, caraen, nomcha, + > nbtosv, caetal, + > nbcham, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 6 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrocha . e . 1 . numero du champ dans le rangement HOMARD . +c . numcat . e . 1 . caracteristique du champ a traiter . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . nbtvlu . e . 1 . nombre de tableaux effectivement lus . +c . caraen . es . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . nomcha . e . char64 . nom du champ . +c . nbtosv . e . 1 . nombre total de tableaux de valeurs . +c . caetal . es . 12 * . caracteristiques entieres de chaque . +c . . . nbtosv . tableau a lire . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 2, on prend le dernier pas de temps . +c . . . . 1, le numero du pas de temps est fourni . +c . . . . 0, sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 2, on prend le dernier numero d'ordre . +c . . . . 1, le numero d'ordre est fourni . +c . . . . 0, sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 2, on prend le dernier instant . +c . . . . 1, l'instant est fourni . +c . . . . 0, sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. 1, s'il fait partie du champ en cours . +c . . . . d'examen, 0, sinon . +c . . . . 12. type de champ edfl64/edin64 . +c . nbcham . e . 1 . nombre de champs retenus . +c . tabaux . es . nbcham . tableau auxiliaire contenant le numero du . +c . . . . champ associe, s'il existe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "esutil.h" +c +c 0.3. ==> arguments +c + integer nrocha, numcat, nbtvlu, nbtosv + integer caraen(nbinec,nbtvlu) + integer caetal(12,*) + integer nbcham, tabaux(nbcham) +c + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numtv, carsup +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''Numero du champ :'',i5)' + texte(1,6) = '(''Recherche dans la categorie : '')' + texte(1,7) = '(''Impossible de trouver le champ ELNO associe.'')' + texte(1,8) = '(''Impossible de trouver le champ ELGA associe.'')' +c + texte(2,4) = '(''Field # :'',i5)' + texte(2,6) = '(''Search in : '')' + texte(2,7) = '(''ELNO connected field cannot be found.'')' + texte(2,8) = '(''ELGA connected field cannot be found.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,4)) nrocha + write (ulsort,texte(langue,111)) nbtvlu + write (ulsort,texte(langue,6)) + if ( numcat.eq.2 ) then + iaux = 3 + else + iaux = numcat + endif + write (ulsort,texte(langue,65+iaux)) + write (ulsort,90002) 'numcat', numcat +#endif +c + codret = 0 +c +c==== +c 2. traitement des champs standard +c==== +c + if ( numcat.eq.0 ) then +c + do 20 , numtv = 1 , nbtvlu +c +c 2.1. ==> caracteristiques generales du tableau +c + carsup = caraen(8,numtv) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Tableau numero', numtv + write (ulsort,texte(langue,65+carsup)) +#endif +c + if ( carsup.eq.numcat ) then + caraen(10,numtv) = 0 + tabaux(nrocha) = 0 + endif +cgn print *, '===> caraen(10,',numtv,') = ',caraen(10,numtv) +c + 20 continue +c +c==== +c 3. traitement des champs aux points de Gauss +c on memorise le numero de l'eventuel champ aux noeuds par element +c qui lui est associe +c a. On cherche le numero dans le fichier de configuration du +c champ correspondant : iaux, tel que caetal(9,iaux) = norcha +c b. on en deduit le numero dans le fichier de configuration du +c champ aux noeuds par element associe : jaux = caetal(8,iaux) +c c. on en deduit le numero dans HOMARD du champ aux noeuds par +c element associe : caetal(9,jaux) +c==== +c + elseif ( numcat.ge.2 ) then +c + do 30 , numtv = 1 , nbtvlu +c + carsup = caraen(8,numtv) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Tableau numero', numtv + write (ulsort,texte(langue,65+carsup)) +#endif +c + if ( carsup.eq.numcat ) then +c + tabaux(nrocha) = -2 + do 311 , iaux = 1 , nbtosv + if ( caetal(9,iaux).eq.nrocha ) then + jaux = caetal(8,iaux) + if ( jaux.gt.0 ) then + caraen(10,numtv) = caetal(9,jaux) + tabaux(nrocha) = caetal(9,jaux) + goto 30 + endif + endif + 311 continue +c +c Aucun champ associe n'a ete trouve : c'est que le traitement +c des points de Gauss a lieu en solo +c + do 312 , iaux = 1 , nbtosv + if ( caetal(9,iaux).eq.nrocha ) then + tabaux(nrocha) = iaux + endif + 312 continue + caraen(8,numtv) = 3 +c + endif +cgn print *, '===> caraen(10,',numtv,') = ',caraen(10,numtv) +c + 30 continue +c +c==== +c 4. traitement des champs aux noeuds par element +c on memorise le numero de l'eventuel champ aux points de Gauss qui +c lui est associe +c==== +c + else +c + do 40 , numtv = 1 , nbtvlu +c + carsup = caraen(8,numtv) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Tableau numero', numtv + write (ulsort,texte(langue,65+carsup)) +#endif +c + if ( carsup.eq.numcat ) then +c + tabaux(nrocha) = -2 + do 411 , iaux = 1 , nbcham + if ( tabaux(iaux).eq.nrocha ) then + caraen(10,numtv) = iaux + tabaux(nrocha) = iaux + goto 40 + endif + 411 continue + caraen(10,numtv) = 0 +c + endif +cgn print *, '===> caraen(10,',numtv,') = ',caraen(10,numtv) +c + 40 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,65+numcat)) + write (ulsort,texte(langue,4)) nrocha + if ( codret.ne.30 ) then + write (ulsort,texte(langue,6+codret)) + endif + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch7.F b/src/tool/ES_MED/eslch7.F new file mode 100644 index 00000000..80c4606c --- /dev/null +++ b/src/tool/ES_MED/eslch7.F @@ -0,0 +1,212 @@ + subroutine eslch7 ( nbtvch, caraen, nbseal, + > carsup, nbfonc, defonc, nrfonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 7 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtvch . e . 1 . nombre de tableaux associes a ce champ . +c . caraen . e . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . carsup . e . 1 . Caracteristique du support de la fonction . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . nbfonc . e . 1 . nombre de fonctions classees . +c . defonc . e . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 21-nbinec. type des supports associes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH7' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "esutil.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbtvch, nbseal, carsup + integer nbfonc, nrfonc + integer caraen(nbinec,nbtvch) + integer defonc(nbinec,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrchas + integer nrotv +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Impossible de trouver la fonction associee.'')' +c + texte(2,4) = '(/,''Connected function cannot be found.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'carsup', carsup +#endif +c +c==== +c 2. on parcourt tous les tableaux de ce champ +c==== +c + codret = 0 +c + do 21 , nrotv = 1 , nbtvch +cgn print *,(caraen(nrfonc,nrotv), nrfonc = 1 , 11) +cgn print *,(caraen(nrfonc,nrotv), nrfonc = 21 , 23) +c +c 2.1. ==> numero du champ associe +c + nrchas = caraen(10,nrotv) +c +c 2.2. ==> on cherche quelle fonction est attachee a ce champ +c quand on l'a trouvee, on memorise son numero +c + do 22 , iaux = 1 , nbfonc +c + if ( defonc(10,iaux).eq.nrchas ) then + defonc(9,nrfonc) = iaux + goto 23 + endif +c + 22 continue +c + 21 continue +c + if ( nbseal.gt.0 .and. carsup.eq.2 ) then + codret = 1 + endif +c + 23 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslch8.F b/src/tool/ES_MED/eslch8.F new file mode 100644 index 00000000..132ebbd1 --- /dev/null +++ b/src/tool/ES_MED/eslch8.F @@ -0,0 +1,201 @@ + subroutine eslch8 ( nrtafo, + > nbtafo, nbpg, nbvalc, nbcomp, + > vafonc, trav1, + > obcham, objech, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un CHamp au format MED - phase 8 +c - - - -- - +c Ce programme est le symetrique de ESECH2 +c Remarque : eslch5 et eslch8 sont des clones +c 5 : double precision +c 8 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nrtafo . es . 1 . numero courant du tableau de la fonction . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbpg . e . 1 . nombre de points de Gauss, s'il y en a . +c . . . . si le champ est sans point de Gauss, nbpg . +c . . . . vaut 1 pour aider au traitement . +c . nbvalc . e . 1 . nombre de valeurs par composante . +c . nbcomp . e . 1 . nombre de composantes du champ . +c . vafonc . es . * . valeurs de la fonction . +c . trav1 . e . * . valeurs lues . +c . obcham . e . char8 . nom de l'objet de type 'InfoCham' associe . +c . objech . es . nbtafo . nom de l'objet de type 'InfoCham' associe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLCH8' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nrtafo + integer nbtafo + integer nbpg, nbvalc, nbcomp +c + integer trav1(nbpg,nbvalc,nbcomp) + integer vafonc(nbtafo,nbpg,*) +c + character*8 obcham + character*8 objech(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrcomp, nUGaus +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. '',a,'' = '',i8)' + texte(1,5) = '(''. Premiere valeur : '',i10)' + texte(1,6) = '(''. Derniere valeur : '',i10)' + texte(1,7) = '(''... Composante numero '',i8)' +c + texte(2,4) = '(''. '',a,'' = '',i8)' + texte(2,5) = '(''. First value : '',i10)' + texte(2,6) = '(''. Last value : '',i10)' + texte(2,7) = '(''... Composante # '',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'nbtafo', nbtafo + write (ulsort,texte(langue,4)) 'nbpg ', nbpg + write (ulsort,texte(langue,4)) 'nbvalc', nbvalc + write (ulsort,texte(langue,4)) 'nbcomp', nbcomp + write (ulsort,texte(langue,4)) 'nrtafo au depart', nrtafo +#endif +c +c==== +c 2. Transfert +c==== +c + codret = 0 +c + do 20 , nrcomp = 1 , nbcomp +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nrcomp + write (ulsort,texte(langue,4)) '==> nrtafo', nrtafo +#endif +c +cgn print *,'nrcomp,nrtafo, nbvalc = ',nrcomp,nrtafo, nbvalc +c +c 2.1. ==> les valeurs numeriques +c + if ( nbpg.eq.1 ) then +c + do 21 , iaux = 1 , nbvalc +cgn write(11,*) 'trav1 = ',trav1(1,iaux,nrcomp) + vafonc(nrtafo,1,iaux) = trav1(1,iaux,nrcomp) + 21 continue +c + else +c + do 22 , iaux = 1 , nbvalc +cgn print *,'trav1(...,',iaux,',',nrcomp,') = ', +cgn > (trav1(nUGaus,iaux,nrcomp),nUGaus=1,nbpg) + do 221 , nUGaus = 1 , nbpg + vafonc(nrtafo,nUGaus,iaux) = trav1(nUGaus,iaux,nrcomp) + 221 continue + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) vafonc(nrtafo,1,1) + write (ulsort,texte(langue,6)) vafonc(nrtafo,nbpg,nbvalc) +#endif +c +c 2.2. ==> les caracteristiques du champ associe +c + objech(nrtafo) = obcham +c +c 2.3. ==> tableau suivant dans la fonction +c + nrtafo = nrtafo + 1 +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 'nrtafo a la fin ', nrtafo +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslent.F b/src/tool/ES_MED/eslent.F new file mode 100644 index 00000000..d6c19acd --- /dev/null +++ b/src/tool/ES_MED/eslent.F @@ -0,0 +1,162 @@ + subroutine eslent ( idfmed, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture de l'ENTete +c - - - --- +c attention : le fichier est deja ouvert +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . numero du fichier a examiner . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLENT' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer lgdesc +c + character*200 descri +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c +c==== +c 2. recherche des differentes infos +c==== +c 2.1. ==> Programme MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICOR', nompro +#endif + call mficor ( idfmed, descri, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'apres mficor, codret = ', codret +#endif +c +c 2.2. ==> Decodage de la longueur +c S'il y a eu un probleme a la lecture, c'est qu'aucune +c description n'a ete fournie. On impose une longueur nulle. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLGUT', nompro +#endif + call utlgut ( lgdesc, descri, + > ulsort, langue, codret ) +c + else +c + lgdesc = 0 + codret = 0 +c + endif +c +c==== +c 3. informations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. informations ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( lgdesc.ne.0 ) then + write(ulsort,texte(langue,47)) descri(1:lgdesc) + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslimd.F b/src/tool/ES_MED/eslimd.F new file mode 100644 index 00000000..940e4ca6 --- /dev/null +++ b/src/tool/ES_MED/eslimd.F @@ -0,0 +1,443 @@ + subroutine eslimd ( nocind, + > numdt, numit, instan, + > yandt, yanrd, yains, + > messin, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture de l'Indicateur au format MED +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocind . s . char*8 . nom de l'objet indicateur d'erreur calcul . +c . numdt . e . 1 . numero du pas de temps eventuel . +c . numit . e . 1 . numero d'ordre eventuel . +c . instan . e . 1 . instant eventuel . +c . yandt . e . 1 . 2, on prend le dernier pas de temps . +c . . . . 1, le numero du pas de temps est fourni . +c . . . . 0, sinon . +c . yanrd . e . 1 . 2, on prend le dernier numero d'ordre . +c . . . . 1, le numero d'ordre est fourni . +c . . . . 0, sinon . +c . yains . e . 1 . 2, on prend le dernier instant . +c . . . . 1, l'instant est fourni . +c . . . . 0, sinon . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . -1 : probleme avec le nom du champ . +c . . . . -2 : probleme avec le nom de la composante . +c . . . . -3 : probleme avec le nom du maillage . +c ______________________________________________________________________ +c +c HOAVLI --> ESLIMD --> ESLSM0 +c -> ESLSM0 -> ESOUVL -> ESVERI -> MFICOM +c -> MLBSTV +c -> MFIOPE +c -> MFISVR +c -> MFICLO +c -> MFIOPE +c -> ESLENT -> MFICOR +c -> ESLNOM -> MMHNMH +c -> MMHMII +c -> MFDNFD +c -> MLCNLC +c -> ESLSM1 -> MFDNFC +c -> MFDFDI +c -> ESLCH1 -> ESLCH2 -> MFDCSI +c -> MFDNPF +c -> ESLPR1 -> MPFPSN +c -> MPFPRR +c -> ESLPG1 -> ESLPG2 -> MLCNLC +c -> MLCLCI +c -> MLCLOR +c -> MFDNPN +c -> ESLCH6 +c -> ESLSM2 -> ESLCH3 +c -> ESLCH7 +c -> ESLSM3 +c -> ESLSM4 -> ESLCH4 -> MFDRPR +c -> ESLCH5 +c -> ESLSM5 +c -> MFICLO +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLIMD' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "motcle.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" + +c 0.3. ==> arguments +c + integer numdt, numit, yandt, yanrd,yains + double precision instan +c + character*8 nocind +c + integer messin +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre0 + integer codre1, codre2, codre3 + integer adcact, adcaet, adcart + integer nbseal, nbtosv +c + integer lnomfi + integer lnocin, lnomam +c + character*8 typobs + character*8 ntrav1, ntrav2, ntrav3 + character*64 nomamd + character*64 nochin + character*64 saux64 + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Probleme pour allouer l''''objet indicateur.'')' + texte(1,5) = '(''Mot-cle : '',a8)' + texte(1,6) = '(''Le nom du champ indicateur est inconnu.'')' + texte(1,7) = + > '(''La composante du champ indicateur est inconnue.'')' +c + texte(2,4) ='(''Problem while allocating the indicator object.'')' + texte(2,5) = '(''Keyword : '',a8)' + texte(2,6) = '(''The name of the indicator field is unknown.'')' + texte(2,7) = + >'(''The name of the indicator field component is unknown.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. premiers decodages +c==== +c +c 2.1. ==> nom du fichier contenant l'indicateur +c + typobs = mccind + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c +c 2.2. ==> nom du maillage dans ce fichier +c + if ( codret.eq.0 ) then +c + typobs = mccnmn + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + call utosme ( typobs, ulsort, langue ) + if ( codret.eq.4 ) then + write (ulsort,texte(langue,52)) lnomam + write (ulsort,texte(langue,53)) len(nomamd) + codret = -3 + endif + endif +c + endif +c +c 2.3. ==> recherche des caracteristiques de l'indicateur +c si le nom de l'indicateur est absent, ... probleme +c +c 2.3.1. ==> nom du champ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3.2. nom du champ ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + typobs = mccnin + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nochin, lnocin, + > jaux, + > ulsort, langue, codret ) +c + if ( codret.eq.2 ) then + codret = -1 + write (ulsort,texte(langue,5)) typobs + write (ulsort,texte(langue,6)) + endif +c + endif +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,32)) nochin(1:lnocin) + endif +c +c==== +c 3. mise en forme du tableau a lire +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. mise en forme ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nbseal = 1 +c + iaux = 8*nbseal + call gmalot ( ntrav1, 'chaine ', iaux, adcact, codre1 ) + iaux = 12*nbseal + call gmalot ( ntrav2, 'entier ', iaux, adcaet, codre2 ) + iaux = 1*nbseal + call gmalot ( ntrav3, 'reel ', iaux, adcart, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + saux64 = blan64 + iaux = 64 +c + call utchs8 ( saux64, iaux, smem(adcact), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utchs8 ( nochin, lnocin, smem(adcact), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'yandt', yandt + write (ulsort,90002) 'yanrd', yanrd + write (ulsort,90002) 'yains', yains +#endif + imem(adcaet+0) = -1 + imem(adcaet+1) = yandt + if ( yandt.eq.1 ) then + imem(adcaet+2) = numdt + write (ulsort,texte(langue,113)) numdt + elseif ( yandt.eq.2 ) then + write (ulsort,texte(langue,93)) + endif + imem(adcaet+3) = yanrd + if ( yanrd.eq.1 ) then + imem(adcaet+4) = numit + write (ulsort,texte(langue,114)) numit +cgn elseif ( yanrd.eq.2 ) then +cgn write (ulsort,texte(langue,94)) + endif + imem(adcaet+5) = yains + if ( yains.eq.1 ) then + rmem(adcart) = instan + write (ulsort,texte(langue,115)) instan + elseif ( yains.eq.2 ) then + write (ulsort,texte(langue,95)) + endif + imem(adcaet+6) = -1 + imem(adcaet+9) = 0 +c + endif +c +c==== +c 4. lecture +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. lecture ; codret', codret +#endif +c +c 4.1. ==> lecture MED +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM0', nompro +#endif +c + iaux = 0 + call eslsm0 ( nocind, nomfic, lnomfi, + > nomamd, lnomam, + > nbseal, nbtosv, + > smem(adcact), imem(adcaet), rmem(adcart), + > messin, iaux, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> on controle qu'il y a bien au moins un tableau +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocind ) + call gmprsx (nompro, nocind//'.InfoPaFo' ) + call gmprsx (nompro, '%%%%%%13' ) + call gmprsx (nompro, nocind//'.InfoCham' ) + call gmprsx (nompro, '%%%%%%11' ) + call gmprsx (nompro, '%%%%%%11.Nom_Comp' ) + call gmprsx (nompro, '%%%%%%11.Cham_Ent' ) + call gmprsx (nompro, '%%%%%%11.Cham_Ree' ) + call gmprsx (nompro, '%%%%%%11.Cham_Car' ) + call gmprsx (nompro, '%%%%%%12' ) + call gmprsx (nompro, '%%%%%%12.ValeursR' ) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,111)) nbtosv +#endif +c + if ( nbtosv.eq.0 ) then +c + write (ulsort,texte(langue,96)) nomamd + if ( yandt.eq.1 ) then + write (ulsort,texte(langue,113)) numdt + endif + if ( yanrd.eq.1 ) then + write (ulsort,texte(langue,114)) numit + endif + if ( yains.eq.1 ) then + write (ulsort,texte(langue,115)) instan + endif + write (ulsort,texte(langue,70)) + write (ulsort,texte(langue,71)) + write (ulsort,texte(langue,72)) + write (ulsort,texte(langue,73)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSC1', nompro +#endif + call eslsc1 ( nomfic, lnomfi, + > messin, + > ulsort, langue, codret ) +c + codret = 2 +c + endif +c + endif +c +c 4.3. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) nomfic + if ( codret.gt.0 .or. codret.eq.-2 ) then + write (ulsort,texte(langue,32)) nochin + endif + if ( codret.gt.0 ) then + if ( yandt.eq.1 ) then + write (ulsort,texte(langue,113)) numdt + elseif ( yandt.eq.2 ) then + write (ulsort,texte(langue,93)) + endif + if ( yanrd.eq.1 ) then + write (ulsort,texte(langue,114)) numit + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmm1.F b/src/tool/ES_MED/eslmm1.F new file mode 100644 index 00000000..fceab71f --- /dev/null +++ b/src/tool/ES_MED/eslmm1.F @@ -0,0 +1,600 @@ + subroutine eslmm1 ( idfmed, nomamd, lnomam, + > titre, + > sdimca, mdimca, + > degre, mailet, homolo, nbmane, + > nbelem, nbmaae, nbmafe, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, ngrouc, nbgrm, + > nbequi, nbeqno, nbeqmp, nbeqar, + > nbeqtr, nbeqqu, + > nbnoto, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture du Maillage au format MED - phase 1 +c - - - - - - +c Remarque : on suppose que le maillage est conforme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . lnomam . e . 1 . longueur du nom du maillage voulu . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMM1' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "equiva.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer lnomam + integer sdimca, mdimca + integer degre, mailet, homolo, nbmane + integer nbelem, nbmaae, nbmafe, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, ngrouc, nbgrm, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + integer nbnoto +c + character*64 nomamd + character*(*) titre +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbmai1, nbmai2 + integer nbseg2, nbseg3 + integer nbtri3, nbtri6, nbtri7 + integer nbtet4, nbte10 + integer nbqua4, nbqua8, nbqua9 + integer nbhex8, nbhe20, nbhe27 + integer nbpen6, nbpe15 + integer nbpyr5, nbpy13 + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer ngro + integer typnoe, typpoi, typseg, typtri, typqua +c + integer iaux, jaux + integer iaux1, iaux2, iaux3, iaux4, iaux5 + integer tbiaux(3,10) + integer numdt, numit + integer nstep, nctcor +c + character*32 saux32 + character*64 saux64 + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de mailles '',a6,'' :'',i10)' + texte(1,5) = + > '(''Ces types de mailles ne sont pas acceptees par HOMARD.'')' +c + texte(2,4) = '(''Number of meshes '',a6,'' :'',i10)' + texte(2,5) = + > '(''These kinds of elements are not treated in HOMARD.'')' +c +#include "esimpr.h" +c + nbnoto = 0 + nbmane = 0 + nbmaae = 0 + nbmafe = 0 + degre = 0 + homolo = 0 +c + nbfmed = 0 + ngrouc = 0 + nbgrm = 0 +c + typnoe = 0 +c + numdt = ednodt + numit = ednoit +c + titre(1:64) = nomamd + iaux = len(titre) + do 11, jaux = 65 , iaux + titre(jaux:jaux) = ' ' + 11 continue +c +c==== +c 2. recherche des differents nombres +c==== +c 2.1. ==> nombre de sommets +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMN', nompro +#endif + call eslmmn ( idfmed, nomamd, lnomam, + > nbnoto, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> les mailles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNMA', nompro +#endif + call eslnma ( idfmed, nomamd, mdimca, + > nbelem, nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpyra, nbpent, + > nbseg2, nbseg3, + > nbtri3, nbtri6, nbtri7, + > nbtet4, nbte10, + > nbqua4, nbqua8, nbqua9, + > nbhex8, nbhe20, nbhe27, + > nbpen6, nbpe15, + > nbpyr5, nbpy13, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbhe27.gt.0 ) then +c + write (ulsort,texte(langue,4)) 'HEXA27', nbhe27 + write (ulsort,texte(langue,5)) + codret = 3 +c + endif + mailet = 1 + if ( nbtri7.gt.0 ) then + mailet = mailet*2 + endif + if ( nbqua9.gt.0 ) then + mailet = mailet*3 + endif + if ( nbhe27.gt.0 ) then + mailet = mailet*5 + endif +c + endif +c +c 2.3. ==> nombre de familles et de groupes cumules +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFA', nompro +#endif + call mfanfa ( idfmed, nomamd, nbfmed, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , nbfmed +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFG', nompro +#endif + call mfanfg ( idfmed, nomamd, iaux, ngro, codre0 ) + codret = max ( abs(codre0), codret ) +c + ngrouc = ngrouc + ngro + nbgrm = max ( ngro, nbgrm ) +c + endif +c + 23 continue +c + endif +c +c==== +c 3. nombres deduits +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Nombre de mailles +c + nbmai1 = nbtet4 + nbtri3 + nbseg2 + > + nbqua4 + nbhex8 + nbpyr5 + nbpen6 + nbmai2 = nbte10 + nbtri6 + nbseg3 + > + nbqua8 + nbhe20 + nbpy13 + nbpe15 + > + nbtri7 + nbqua9 + nbhe27 +c +c 3.2. ==> nbmane : nombre maximal de noeud par element +c + if ( nbmai1.gt.0 ) then +c + if ( nbmai2.gt.0 ) then + write(ulsort,texte(langue,27)) nbmai1, nbmai2 + codret = 30 + endif +c + degre = 1 +c + if ( nbhexa.gt.0 ) then + nbmane = 8 + elseif ( nbpent.gt.0 ) then + nbmane = 6 + elseif ( nbpyra.gt.0 ) then + nbmane = 5 + elseif ( nbtetr.gt.0 .or. nbquad.gt.0 ) then + nbmane = 4 + elseif ( nbtria.gt.0 ) then + nbmane = 3 + else + nbmane = 2 + endif +c + else if ( nbmai2.gt.0 ) then +c + degre = 2 +c + if ( nbhe27.gt.0 ) then + nbmane = 27 + elseif ( nbhe20.gt.0 ) then + nbmane = 20 + elseif ( nbpent.gt.0 ) then + nbmane = 15 + elseif ( nbpyra.gt.0 ) then + nbmane = 13 + elseif ( nbtetr.gt.0 ) then + nbmane = 10 + elseif ( nbqua9.gt.0 ) then + nbmane = 9 + elseif ( nbqua8.gt.0 ) then + nbmane = 8 + elseif ( nbtri7.gt.0 ) then + nbmane = 7 + elseif ( nbtri6.gt.0 ) then + nbmane = 6 + else + nbmane = 3 + endif +c + else +c + nbmane = 1 +c + endif +c +c 3.3. ==> nbmaae : nombre maximal d'aretes par element +c nbmafe : nombre maximal de faces par element +c + if ( nbhexa.gt.0 ) then + nbmaae = 12 + nbmafe = 6 + else if ( nbpent.gt.0 ) then + nbmaae = 9 + nbmafe = 5 + else if ( nbpyra.gt.0 ) then + nbmaae = 8 + nbmafe = 5 + else if ( nbtetr.gt.0 ) then + nbmaae = 6 + nbmafe = 4 + else if ( nbquad.gt.0 ) then + nbmaae = 4 + nbmafe = 1 + else if ( nbtria.gt.0 ) then + nbmaae = 3 + nbmafe = 1 + else if ( nbsegm.gt.0 ) then + nbmaae = 1 + endif +c + endif +c +c==== +c 4. les equivalences +c remarque : il faut le faire seulement maintenant, sinon on ne +c sait pas ce que valent typseg, typtri et typqua. +c==== +c +c 4.1. ==> le nombre d'equivalences +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQNEQ', nompro +#endif + call meqneq ( idfmed, nomamd, nbequi, codret ) +c + endif +c +c 4.2. ==> combien de paires d'entites impliquees +c + nbeqno = 0 + nbeqmp = 0 + nbeqar = 0 + nbeqtr = 0 + nbeqqu = 0 +c + typpoi = edpoi1 + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typqua = edqua4 + else + typseg = edseg3 + typtri = edtri6 + typqua = edqua8 + endif +c + if ( codret.eq.0 ) then +c + jaux = 0 +c + do 42 , iaux = 1, nbequi +c +c 4.2.1. ==> nom et description de l'equivalence +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQEQI', nompro +#endif + call meqeqi ( idfmed, nomamd, iaux, + > saux64, sau200, nstep, nctcor, codret ) +c + endif +c +c 4.2.2. ==> si l'equivalence est interdite, on passe a la suivante +c + if ( codret.eq.0 ) then +c + if ( saux64.eq.eqinte ) then +c + jaux = jaux + 1 + goto 42 +c + endif +c + endif +c +c 4.2.3. ==> nombre d'entites dans chaque categorie +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > ednoeu, typnoe, + > iaux1, codre1 ) +c + if ( nbmapo.ne.0 ) then + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typpoi, + > iaux2, codre2 ) + else + iaux2 = 0 + codre2 = 0 + endif +c + if ( nbsegm.ne.0 ) then + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typseg, + > iaux3, codre3 ) + else + iaux3 = 0 + codre3 = 0 + endif +c + if ( nbtria.ne.0 ) then + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typtri, + > iaux4, codre4 ) + else + iaux4 = 0 + codre4 = 0 + endif +c + if ( nbquad.ne.0 ) then + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typqua, + > iaux5, codre5 ) + else + iaux5 = 0 + codre5 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + if ( codret.eq.0 ) then +c + nbeqno = nbeqno + iaux1 + nbeqmp = nbeqmp + iaux2 + nbeqar = nbeqar + iaux3 + nbeqtr = nbeqtr + iaux4 + nbeqqu = nbeqqu + iaux5 +c + endif +c + 42 continue +c + endif +c +c 4.3. ==> bilan +c + if ( codret.eq.0 ) then +c + nbequi = nbequi - jaux +c + if ( nbeqtr.ne.0 .or. nbeqqu.ne.0 ) then + homolo = 3 + elseif ( nbeqar.ne.0 ) then + homolo = 2 + elseif ( nbeqno.ne.0 ) then + homolo = 1 + else + homolo = 0 + endif +c + endif +c +c==== +c 5. Informations +c==== +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,22)) nomamd(1:lnomam) +c + tbiaux(1,1) = nbmapo + tbiaux(1,2) = nbsegm + tbiaux(1,3) = nbtria + tbiaux(1,4) = nbquad + tbiaux(1,5) = nbtetr + tbiaux(1,6) = nbhexa + tbiaux(1,7) = nbpent + tbiaux(1,8) = nbpyra + tbiaux(2,1) = 2 + if ( degre.eq.1 ) then + tbiaux(2,2) = 4 + else + tbiaux(2,2) = 5 + endif + do 51 , iaux = 3 , 8 + tbiaux(2,iaux) = tbiaux(2,iaux-1) + 3 + 51 continue +c + iaux = 1 + jaux = 0 + if ( langue.eq.1 ) then +c 12345678901234567890123456789012 + saux32 = 'dans le fichier ' + else + saux32 = 'in the file ' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINMA', nompro +#endif + call utinma ( iaux, saux32, + > sdimca, mdimca, degre, + > nbnoto, jaux, jaux, jaux, + > jaux, jaux, + > iaux, nbelem, + > nbmapo, tbiaux(1,2), tbiaux(1,3), tbiaux(1,4), + > tbiaux(1,5), tbiaux(1,6), tbiaux(1,8), tbiaux(1,7), + > jaux, + > nbmane, nbmaae, nbmafe, + > ulsort, langue, codret) +c + write(ulsort,texte(langue,29)) nbfmed + write(ulsort,texte(langue,31)) ngrouc +c + if ( nbequi.ne.0 ) then + write(ulsort,texte(langue,41)) nbequi + write(ulsort,texte(langue,42)) mess14(langue,3,-1), nbeqno + tbiaux(2,1) = 0 + tbiaux(2,2) = 1 + tbiaux(2,3) = 2 + tbiaux(2,4) = 4 + tbiaux(3,1) = nbeqmp + tbiaux(3,2) = nbeqar + tbiaux(3,3) = nbeqtr + tbiaux(3,4) = nbeqqu + do 53 , iaux = 1 , 4 + if ( tbiaux(1,iaux).gt.0 ) then + write(ulsort,texte(langue,42)) + > mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux) + endif + 53 continue + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmm2.F b/src/tool/ES_MED/eslmm2.F new file mode 100644 index 00000000..0bc8eb78 --- /dev/null +++ b/src/tool/ES_MED/eslmm2.F @@ -0,0 +1,1089 @@ + subroutine eslmm2 ( idfmed, nomamd, + > option, + > titre, + > degre, mailet, sdimca, nbmane, nbmail, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, nbeqno, nbeqmp, nbeqar, + > nbeqtr, nbeqqu, + > nbnoto, numano, numael, + > nunoex, fameno, coonca, + > numaex, fammai, noemai, typele, + > grfmpo, grfmta, grfmtb, + > nbpqt, infptr, inftll, inftbl, + > typrep, nomaxe, uniaxe, + > numfam, nomfam, + > eqpntr, eqinfo, + > eqnoeu, + > eqmapo, eqaret, eqtria, eqquad, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture du Maillage au format MED - phase 2 +c - - - - - - +c remarque : on s'arrange pour que les mailles externes soient +c numerotees dans cet ordre : +c . les tetraedres +c . les triangles +c . les aretes +c . les mailles-points +c . les quadrangles +c . les hexaedres +c . les pyramides +c . les pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . unite logique du maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . option . e . 1 . option de lecture du maillage . +c . . . . 1 : lecture integrale . +c . . . . 2 : uniquement les coordonnees des noeuds . +c . fameno . s . nbnoto . famille med des noeuds . +c . coonca . s . nbnoto . coordonnees des noeuds . +c . fammai . s . nbmail . famille med des mailles . +c . noemai . s . nbmail*. table de connectivite des mailles . +c . . . nbmane . . +c . numaex . s . nbmail . numerotation des mailles en entree . +c . nunoex . s . nbnoto . numerotation des noeuds en entree . +c . . . . . +c . grfmpo . s .nbfmed+1. pointeur des groupes des familles . +c . grfmta . s .10ngrouc. taille des groupes des familles . +c . grfmtb . s .10ngrouc. table des groupes des familles . +c . nbpqt . e . 1 . nombre de paquets des infos generales . +c . infptr . s . nbpqt+1. pointeur des informations generales . +c . inftll . s .nbpqt*10. tailles des caracteres des infos generales. +c . inftbl . s .nbpqt*10. tables en caracteres des infos generales . +c . . . . regroupees par paquets de 80 caracteres . +c . . . . pour gerer la conversion en pseudo-groupe . +c . . . . paquet 1 : 1 : 'NomCo' . +c . . . . 2/3, 4/5, 6/7 : nom coordonnees . +c . . . . 8 : nom du repere utilise . +c . . . . paquet 2 : 1 : 'UniteCo' . +c . . . . 2/3, 4/5, 6/7 : unite coord. . +c . . . . paquet 3 : titre (limite a 80 caracteres) . +c . . . . paquet 4 : 1 : 'NOMAMD' . +c . . . . 2-7 : nom du maillage . +c . typrep . e . 1 . type de repere . +c . nomaxe . e . 3 . nom des axes de coordonnees . +c . uniaxe . e . 3 . unite des axes de coordonnees . +c . numfam . s . nbfmed . numero des familles . +c . nomfam . s .10nbfmed. nom des familles . +c . numfam . s . nbfmed . numero des familles . +c . eqpntr . s .5*nbequi. 5i-4 : nombre de paires de noeuds pour . +c . . . . l'equivalence i . +c . . . . 5i-3 : idem pour les mailles-points . +c . . . . 5i-2 : idem pour les aretes . +c . . . . 5i-1 : idem pour les triangles . +c . . . . 5i : idem pour les quadrangles . +c . eqinfo . s .33nbequi. nom et description de chaque equivalence . +c . eqnoeu . s .2*nbeqno. liste des paires de noeuds equivalents avec. +c . . . . la convention : eqnoeu(i)<-->eqnoeu(i+1) . +c . eqmapo . s .2*nbeqmp. idem pour les points . +c . eqaret . s .2*nbeqar. idem pour les aretes . +c . eqtria . s .2*nbeqtr. idem pour les triangles . +c . eqquad . s .2*nbeqqu. idem pour les quadrangles . +c . tabaux . a . * . tableau auxiliaire entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMM2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option +c + integer degre, mailet, sdimca, nbmane + integer nbmail, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + integer nbnoto + integer numano, numael +c + integer fameno(nbnoto) + integer fammai(nbmail), typele(nbmail) + integer numaex(nbmail), nunoex(nbnoto) + integer noemai(nbmail,nbmane) + integer*8 idfmed + integer grfmpo(0:nbfmed), grfmta(10*ngrouc) + integer numfam(nbfmed) + integer nbpqt + integer infptr(0:nbpqt), inftll(10*nbpqt) + integer eqpntr(5*nbequi) + integer eqnoeu(2*nbeqno) + integer eqmapo(2*nbeqmp), eqaret(2*nbeqar) + integer eqtria(2*nbeqtr), eqquad(2*nbeqqu) + integer tabaux(*) + integer typrep +c + character*8 saux08 + character*8 grfmtb(10*ngrouc) + character*8 inftbl(10*nbpqt) + character*8 nomfam(10,nbfmed) + character*8 eqinfo(33*nbequi) + character*16 nomaxe(3), uniaxe(3) + character*64 nomamd + character*(*) titre +c + double precision coonca(nbnoto,sdimca) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nummai + integer iaux, jaux, kaux, laux, maux + integer typnoe, typpoi, typseg, typtri, typtet + integer typqua, typhex, typpyr, typpen + integer ibtetr, ibtria, ibsegm, ibmapo + integer ibquad, ibhexa, ibpyra, ibpent + integer codre1, codre2 + integer codre0 + integer numero, ngro + integer adeqin, adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer numdt, numit + integer nstep, nctcor +c + character*64 saux64 + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ + +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''REPERE NON PREVU ='',i4,/)' +c + texte(2,4) = '(/,''REPERE NON PREVU ='',i4,/)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c + numdt = ednodt + numit = ednoit +c +c==== +c 2. grandeurs de base +c==== +c + typnoe = 0 + typpoi = edpoi1 + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typtet = edtet4 + typqua = edqua4 + typhex = edhex8 + typpyr = edpyr5 + typpen = edpen6 + else + typseg = edseg3 + if ( mod(mailet,2).eq.0 ) then + typtri = edtri7 + else + typtri = edtri6 + endif + typtet = edte10 + if ( mod(mailet,3).eq.0 ) then + typqua = edqua9 + else + typqua = edqua8 + endif + if ( mod(mailet,5).eq.0 ) then + typhex = edhe27 + else + typhex = edhe20 + endif + typpyr = edpy13 + typpen = edpe15 + endif +c + ibtetr = 1 + ibtria = nbtetr + 1 + ibsegm = nbtetr + nbtria + 1 + ibmapo = nbtetr + nbtria + nbsegm + 1 + ibquad = nbtetr + nbtria + nbsegm + nbmapo + 1 + ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + 1 + ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + 1 + ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra + 1 +c +c==== +c 4. les coordonnees des noeuds +c le tableau coonca est declare ainsi : coonca(nbnoto,sdimca). +c En fortran, cela correspond au stockage memoire suivant : +c coonca(1,1), coonca(2,1), coonca(3,1), ..., coonca(nbnoto,1), +c coonca(1,2), coonca(2,2), coonca(3,2), ..., coonca(nbnoto,2), +c ... +c coonca(1,sdimca), coonca(2,sdimca), ..., coonca(nbnoto,sdimca) +c on a ainsi toutes les abscisses, puis toutes les ordonnees, etc. +c C'est ce que MED appelle le mode non entrelace. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. coordonnees ; codret', codret +#endif +c +c 4.1. ==> lecture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMNO', nompro +#endif + call eslmno ( idfmed, nomamd, + > option, + > nbnoto, sdimca, coonca, fameno, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> archivages des informations generales +c Remarque : elles sont regroupees par paquets de +c 80 caracteres pour gerer la conversion en +c pseudo-groupe dans hom.med +c . paquet 1 : 1 : 'NomCo' +c 2/3, 4/5, 6/7 : nom coordonnees +c 8 : nom du repere utilise +c . paquet 2 : 1 : 'UniteCo' +c 2/3, 4/5, 6/7 : unite coordonnees +c . paquet 3 : titre (limite a 80 caracteres) +c . paquet 4 : 1 : 'NOMAMD' +c 2-7 : nom du maillage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. ; codret', codret +#endif +c + if ( option.eq.1 ) then +c +c 4.2.1. ==> la base +c + infptr(0) = 0 + do 4211 , iaux = 1, nbpqt + infptr(iaux) = infptr(iaux-1) + 10 + 4211 continue +c + do 4212 , iaux = 1, 10*nbpqt + inftll(iaux) = 8 + inftbl(iaux) = blan08 + 4212 continue +c +c 4.2.2. ==> le systeme de coordonnees +c +c 4.2.2.1. ==> le type de repere +c + if ( codret.eq.0 ) then +c + call utench ( typrep, 'd', iaux, saux08, + > ulsort, langue, codret ) +c + inftbl(10) = saux08 +c + endif +c +c 4.2.2.2. ==> noms et unites des coordonnees existantes +c + if ( codret.eq.0 ) then +c + inftbl( 1) = 'NomCo ' + inftbl(11) = 'UniteCo ' +c + do 4222 , iaux = 1 , sdimca +c +cgn write (ulsort,90064) iaux, 'nomaxe %'//nomaxe(iaux)//'%' + inftbl(2*iaux) = nomaxe(iaux)(1:8) + inftbl(2*iaux+1) = nomaxe(iaux)(9:16) +c +cgn write (ulsort,90064) iaux, 'uniaxe %'//uniaxe(iaux)//'%' + inftbl(10+2*iaux) = uniaxe(iaux)(1:8) + inftbl(11+2*iaux) = uniaxe(iaux)(9:16) +c + 4222 continue +c + endif +c +c 4.2.3. ==> le titre +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.3. ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = len(titre) + call utchs8 ( titre, iaux, inftbl(21), + > ulsort, langue, codret ) +c + endif +c +c 4.2.4. ==> le nom du maillage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.4. ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + inftbl(31) = 'NOMAMD ' + iaux = len(nomamd) + call utchs8 ( nomamd, iaux, inftbl(32), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. Les mailles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. mailles ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + kaux = 1 +c +c 5.1. ==> les tetraedres +c + if ( codret.eq.0 ) then +c + if ( nbtetr.gt.0 ) then +c + iaux = 3 + if ( degre.eq.1 ) then + jaux = 4 + else + jaux = 10 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_te', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typtet, + > ibtetr, nbtetr, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.2. ==> les triangles +c + if ( codret.eq.0 ) then +c + if ( nbtria.gt.0 ) then +c + iaux = 2 + if ( degre.eq.1 ) then + jaux = 3 + else + if ( mod(mailet,2).eq.0 ) then + jaux = 7 + else + jaux = 6 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_tr', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typtri, + > ibtria, nbtria, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.3. ==> les segments +c + if ( codret.eq.0 ) then +c + if ( nbsegm.gt.0 ) then +c + iaux = 1 + if ( degre.eq.1 ) then + jaux = 2 + else + jaux = 3 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_se', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typseg, + > ibsegm, nbsegm, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4. ==> les mailles points +c + if ( codret.eq.0 ) then +c + if ( nbmapo.gt.0 ) then +c + iaux = 0 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_mp', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typpoi, + > ibmapo, nbmapo, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif + +c +c 5.5. ==> les quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbquad.gt.0 ) then +c + iaux = 4 + if ( degre.eq.1 ) then + jaux = 4 + else + if ( mod(mailet,3).eq.0 ) then + jaux = 9 + else + jaux = 8 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_qu', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typqua, + > ibquad, nbquad, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.6. ==> les pyramides +c + if ( codret.eq.0 ) then +c + if ( nbpyra.gt.0 ) then +c + iaux = 5 + if ( degre.eq.1 ) then + jaux = 5 + else + jaux = 13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_py', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typpyr, + > ibpyra, nbpyra, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.7. ==> les hexaedres +c + if ( codret.eq.0 ) then +c + if ( nbhexa.gt.0 ) then +c + iaux = 6 + if ( degre.eq.1 ) then + jaux = 8 + else + if ( mod(mailet,3).eq.0 ) then + jaux = 27 + else + jaux = 20 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_he', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typhex, + > ibhexa, nbhexa, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.8. ==> les pentaedres +c + if ( codret.eq.0 ) then +c + if ( nbpent.gt.0 ) then +c + iaux = 7 + if ( degre.eq.1 ) then + jaux = 6 + else + jaux = 15 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMB_pe', nompro +#endif + call eslmmb ( idfmed, nomamd, + > iaux, edmail, typpen, + > ibpent, nbpent, jaux, nbmail, kaux, + > ednoda, nbmail, + > noemai, fammai, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. les familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Familles ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + grfmpo(0) = 0 + nbfmen = 0 +c + do 60 , jaux = 1, nbfmed +c + if ( codret.eq.0 ) then +c +c 6.1. ==> Lecture du nombre de groupes +c + iaux = jaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFANFG', nompro +#endif + call mfanfg ( idfmed, nomamd, iaux, ngro, codre1 ) +c + grfmpo(jaux) = grfmpo(iaux-1) + ngro*10 +c +c 6.2. ==> Lecture : +c . du nom de la famille (64) +c . du numero de la famille +c . des noms des groupes (80) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFAFAI', nompro +#endif + call mfafai ( idfmed, nomamd, iaux, + > saux64, numero, grfmtb(grfmpo(iaux-1)+1), + > codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.3. ==> Stockage de la taille reelle des noms des groupes +c + if ( codret.eq.0 ) then +c + do 63 , kaux = 1 , ngro +c + do 631 , maux = 1 , 10 + call utlgut ( laux, grfmtb(grfmpo(iaux-1)+10*(kaux-1)+maux), + > ulsort, langue, codret ) + grfmta(grfmpo(iaux-1)+10*(kaux-1)+maux) = laux + 631 continue +c + 63 continue +c +c 6.4. ==> Stockage du numero et du nom de la famille +c Attention : on stocke sur 80 caracteres pour le futur +c archivage HOM-MED +c + if ( numero.gt.0 ) then + nbfmen = nbfmen + 1 + endif +c + numfam(iaux) = numero +c + call utlgut ( laux, saux64, + > ulsort, langue, codret ) +c + do 64 , kaux = laux+1 , 64 + saux64(kaux:kaux) = ' ' + 64 continue +c + nomfam(1,jaux) = saux64( 1: 8) + nomfam(2,jaux) = saux64( 9:16) + nomfam(3,jaux) = saux64(17:24) + nomfam(4,jaux) = saux64(25:32) + nomfam(5,jaux) = saux64(33:40) + nomfam(6,jaux) = saux64(41:48) + nomfam(7,jaux) = saux64(49:56) + nomfam(8,jaux) = saux64(57:64) +c + endif +c + 60 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c 6.9. ==> impressions +c + if ( codret.eq.0 ) then +c + do 69 , iaux = 1, nbfmed +c + if ( codret.eq.0 ) then +c + numero = numfam(iaux) +c + ngro = ( grfmpo(iaux) - grfmpo(iaux-1) ) / 10 +c + saux64( 1: 8) = nomfam(1,iaux) + saux64( 9:16) = nomfam(2,iaux) + saux64(17:24) = nomfam(3,iaux) + saux64(25:32) = nomfam(4,iaux) + saux64(33:40) = nomfam(5,iaux) + saux64(41:48) = nomfam(6,iaux) + saux64(49:56) = nomfam(7,iaux) + saux64(57:64) = nomfam(8,iaux) +c + jaux = 0 + do 692 , nummai = 1 , nbnoto + if ( fameno(nummai).eq.numero ) then + jaux = jaux + 1 + endif + 692 continue +c + kaux = 0 + do 693 , nummai = 1 , nbmail + if ( fammai(nummai).eq.numero ) then + kaux = kaux + 1 + endif + 693 continue +c + call utinfm ( numero, saux64, + > ngro, grfmtb(grfmpo(iaux-1)+1), + > jaux, kaux, + > ulsort, langue, codret ) +c + endif +c + 69 continue +c + endif +c +#endif +c + endif +c +c==== +c 7. les renumerotations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. renumerotations ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNUM', nompro +#endif + call eslnum ( idfmed, nomamd, degre, + > nbnoto, nbmail, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nunoex, numaex, + > numano, numael, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. equivalences +c la convention de stockage MED des listes d'equivalences est que +c l'entite Liste(j) est associee a Liste(j+1) +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. equivalences ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + adeqin = 1 + adeqno = 1 + adeqmp = 1 + adeqar = 1 + adeqtr = 1 + adeqqu = 1 +c +c par defaut, on n'a aucune equivalence +c + jaux = 5*nbequi + do 80 , iaux = 1, jaux + eqpntr(iaux) = 0 + 80 continue +c + do 81 , iaux = 1, nbequi +c +c 8.1. ==> nom et description de l'equivalence numero iaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQEQI', nompro +#endif + call meqeqi ( idfmed, nomamd, iaux, + > saux64, sau200, nstep, nctcor, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + kaux = 8 + jaux = 8 + call utchs8 ( saux64, jaux*kaux, eqinfo(adeqin), + > ulsort, langue, codret ) + adeqin = adeqin + jaux +c + endif +c + if ( codret.eq.0 ) then +c + jaux = 25 + call utchs8 ( sau200, jaux*kaux, eqinfo(adeqin), + > ulsort, langue, codret ) + adeqin = adeqin + jaux +c + endif +c +c 8.2. ==> equivalence de noeuds +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ_no', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > ednoeu, typnoe, + > jaux, codret ) + endif +c + if ( jaux.ne.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCOR_no', nompro +#endif + call meqcor ( idfmed, nomamd, saux64, numdt, numit, + > ednoeu, typnoe, + > eqnoeu(adeqno), codret ) + endif +c + eqpntr(5*iaux-4) = jaux + adeqno = adeqno + 2*jaux +c + endif +c +c 8.3. ==> equivalence de mailles-points +c + if ( nbmapo.ne.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ_mp', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typpoi, + > jaux, codret ) + endif +c + if ( jaux.ne.0 ) then +c + if ( codret.eq.0 ) then + call meqcor ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typpoi, + > eqmapo(adeqmp), codret ) + endif +c + eqpntr(5*iaux-3) = jaux + adeqmp = adeqmp + 2*jaux +c + endif +c + endif +c +c 8.4. ==> equivalence de segments +c + if ( nbsegm.ne.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ_ar', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typseg, + > jaux, codret ) + endif +c + if ( jaux.ne.0 ) then +c + if ( codret.eq.0 ) then + call meqcor ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typseg, + > eqaret(adeqar), codret ) + endif +c + eqpntr(5*iaux-2) = jaux + adeqar = adeqar + 2*jaux +c + endif +c + endif +c +c 8.5. ==> equivalence de triangles +c + if ( nbtria.ne.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ_tr', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typtri, + > jaux, codret ) + endif +c + if ( jaux.ne.0 ) then +c + if ( codret.eq.0 ) then + call meqcor ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typtri, + > eqtria(adeqtr), codret ) + endif +c + eqpntr(5*iaux-1) = jaux + adeqtr = adeqtr + 2*jaux +c + endif +c + endif +c +c 8.6. ==> equivalence de quadrangles +c + if ( nbquad.ne.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MEQCSZ_qu', nompro +#endif + call meqcsz ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typqua, + > jaux, codret ) + endif +c + if ( jaux.ne.0 ) then +c + if ( codret.eq.0 ) then + call meqcor ( idfmed, nomamd, saux64, numdt, numit, + > edmail, typqua, + > eqquad(adeqqu), codret ) + endif +c + eqpntr(5*iaux ) = jaux + adeqqu = adeqqu + 2*jaux +c + endif +c + endif +c + 81 continue +c + endif +c + endif +c +c==== +c 9. tableau des types +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. tableau des types ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + jaux = ibtetr + nbtetr - 1 + do 91 , nummai = ibtetr, jaux + typele(nummai) = typtet + 91 continue +c + jaux = ibtria + nbtria - 1 + do 92 , nummai = ibtria, jaux + typele(nummai) = typtri + 92 continue +c + jaux = ibsegm + nbsegm - 1 + do 93 , nummai = ibsegm, jaux + typele(nummai) = typseg + 93 continue +c + jaux = ibmapo + nbmapo - 1 + do 94 , nummai = ibmapo, jaux + typele(nummai) = typpoi + 94 continue +c + jaux = ibquad + nbquad - 1 + do 95 , nummai = ibquad, jaux + typele(nummai) = typqua + 95 continue +c + jaux = ibhexa + nbhexa - 1 + do 96 , nummai = ibhexa, jaux + typele(nummai) = typhex + 96 continue +c + jaux = ibpyra + nbpyra - 1 + do 97 , nummai = ibpyra, jaux + typele(nummai) = typpyr + 97 continue +c + jaux = ibpent + nbpent - 1 + do 98 , nummai = ibpent, jaux + typele(nummai) = typpen + 98 continue +c + endif +c + endif +c +c==== +c 10. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmmb.F b/src/tool/ES_MED/eslmmb.F new file mode 100644 index 00000000..b711c10a --- /dev/null +++ b/src/tool/ES_MED/eslmmb.F @@ -0,0 +1,205 @@ + subroutine eslmmb ( idfmed, nomamd, + > typenh, typent, typgeo, + > nmadeb, nbmato, nbrfma, nbelem, numfam, + > typcon, dim1, + > conmai, fammai, + > tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un Maillage au format MED +c - - - - - +c - phase B +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nmadeb . e . 1 . numero de la maille de debut . +c . . . . >=0 : le tableau est pris tel quel . +c . . . . <0 : les descriptions sont inversees . +c . nbmato . e . 1 . nombre de mailles a lire . +c . nbrfma . e . 1 . nbre noeuds par maille si connec. par noeud. +c . . . . nbre faces par maille si connectivite desce. +c . nbelem . e . 1 . nombre d'elements, tous types confondus . +c . numfam . e . 1 . decalage dans la numerotation des familles . +c . . . . 1 : le tableau est pris tel quel . +c . . . . <=0 : le tableau passe negatif et est . +c . . . . decale de numfam . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typcon . e . 1 . type de connectivite . +c . . . . 0 : par noeud (ednoda) . +c . . . . 1 : descendente (eddesc) . +c . dim1 . e . 1 . 1ere dimension de la connectivite . +c . conmai . s .nbelem**. connectivite des mailles . +c . fammai . s . nbelem . famille med des mailles . +c . tbiaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMMB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nmadeb, nbmato, nbrfma, nbelem, numfam + integer typcon, dim1 + integer conmai(dim1,*), fammai(nbelem) + integer tbiaux(*) +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des '',i10,1x,a)' +c + texte(2,4) = '(''... Readings of '',i10,1x,a)' +c +#include "esimpr.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +c + codret = 0 +c +c==== +c 2. Lecture de la famille d'appartenance +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMF', nompro +#endif + call eslmmf ( idfmed, nomamd, + > typenh, typent, typgeo, + > nmadeb, nbmato, nbelem, numfam, + > typcon, + > fammai, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Lecture de la connectivite des mailles +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMC', nompro +#endif + call eslmmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > nmadeb, nbmato, dim1, nbrfma, + > typcon, + > conmai, + > tbiaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) + write (ulsort,texte(langue,78)) nompro, codret + write (ulsort,texte(langue,79)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmmc.F b/src/tool/ES_MED/eslmmc.F new file mode 100644 index 00000000..f289bf56 --- /dev/null +++ b/src/tool/ES_MED/eslmmc.F @@ -0,0 +1,282 @@ + subroutine eslmmc ( idfmed, nomamd, + > typenh, typent, typgeo, + > nmadeb, nbmato, dim1, dim2, + > typcon, + > conmai, + > tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un Maillage au format MED +c - - - - - +c - Connectivites +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . nmadeb . e . 1 . numero de la maille de debut . +c . . . . >=0 : le tableau est pris tel quel . +c . . . . <0 : les descriptions sont inversees . +c . nbmato . e . 1 . nombre de mailles a lire . +c . dim1 . e . 1 . 1ere dimension de la connectivite . +c . dim2 . e . 1 . 2nde dimension de la connectivite . +c . typcon . e . 1 . type de connectivite . +c . . . . 0 : par noeud (ednoda) . +c . . . . 1 : descendante (eddesc) . +c . conmai . s .dim1dim2. connectivite des mailles . +c . tbiaux . . * . tableau tampon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMMC' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nmadeb, nbmato, dim1, dim2 + integer typcon + integer conmai(dim1,dim2) + integer tbiaux(*) +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux, kaux, laux + integer nmafin + integer numdt, numit +c + character*6 saux06 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des '',i10,1x,a)' + texte(1,63) = '(''Toutes les familles sont nulles.'')' +c + texte(2,4) = '(''... Readings of '',i10,1x,a)' + texte(2,63) = '(''All the families are 0.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +c + codret = 0 + nmafin = nmadeb + nbmato - 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcon', typcon + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nmadeb', nmadeb + write (ulsort,90002) 'nbmato', nbmato + write (ulsort,90002) 'nmafin', nmafin + write (ulsort,90002) 'dim1 ', dim1 + write (ulsort,90002) 'dim2 ', dim2 +#endif +c + numdt = ednodt + numit = ednoit +c +c==== +c 2. Lecture de la connectivite des mailles +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHCYR', nompro +#endif + call mmhcyr ( idfmed, nomamd, numdt, numit, + > typent, typgeo, + > typcon, edfuin, + > tbiaux, codret ) + if ( codret.ne.0 ) then + saux06 = 'mmhcyr' + endif +c + endif +c +c==== +c 3. Creation de la connectivite par noeud +c==== +c + kaux = 0 +c + if ( typcon.eq.ednoda ) then +c + if ( codret.eq.0 ) then +c + if ( nmadeb.ge.0 ) then +c + do 31 , iaux = nmadeb , nmafin + do 311, jaux = 1, dim2 + kaux = kaux + 1 + conmai(iaux,jaux) = tbiaux(kaux) + 311 continue + 31 continue +c + else +cgn print *,'passage 32 avec dim2 =', dim2 +c + do 32 , iaux = 1, nbmato +cgn print *,conmai(1,iaux), conmai(2,iaux) + do 321, jaux = 1, dim2 + kaux = kaux + 1 + conmai(jaux,iaux) = tbiaux(kaux) + 321 continue + 32 continue +c + endif +c + endif +c +c==== +c 4. Creation de la connectivite descendante, sauf pour les volumes +c==== +c + else +c + if ( codret.eq.0 ) then +c +c 4.1. ==> Pour les faces +c + if ( typenh.eq.2 .or. typenh.eq.4 ) then +c +cgn print *,'passage 231 avec nmadeb , nmafin =', nmadeb , nmafin + do 41 , iaux = nmadeb , nmafin +cgn print *,(conmai(iaux,jaux),jaux = 1, dim2) + do 411, jaux = 1, dim2 + kaux = kaux + 1 + conmai(iaux,jaux) = abs(tbiaux(kaux)) + 411 continue + 41 continue +c +c 4.2. ==> Pour les segments +c + elseif ( typenh.eq.1 ) then +c +c Le noeud milieu sera gere par les informations supplementaires +c + laux = dim2 - 2 +c +cgn print *,'passage 42 avec dim2, nbmato =', dim2, nbmato + do 42 , iaux = 1, nbmato + do 421, jaux = 1, 2 + kaux = kaux + 1 + conmai(jaux,iaux) = tbiaux(kaux) + 421 continue + kaux = kaux + laux +cgn print *,conmai(1,iaux), conmai(2,iaux) + 42 continue +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) + write (ulsort,texte(langue,78)) saux06, codret + write (ulsort,texte(langue,79)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmmd.F b/src/tool/ES_MED/eslmmd.F new file mode 100644 index 00000000..488659fa --- /dev/null +++ b/src/tool/ES_MED/eslmmd.F @@ -0,0 +1,729 @@ + subroutine eslmmd ( mcfich, mcmail, + > typcca, nocmai, + > option, messin, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture du Maillage au format MeD +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . mcfich . e . char*8 . mot-cle correspondant au fichier a lire . +c . mcmail . e . char*8 . mot-cle correspondant au maillage a lire . +c . typcca . e . 1 . type du code de calcul . +c . nocmai . s . char*8 . nom de l'objet maillage lu . +c . option . e . 1 . option de lecture du maillage . +c . . . . 1 : lecture integrale . +c . . . . 2 : uniquement les coordonnees des noeuds . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . -10 : fichier inconnu . +c . . . . -20 : nom de maillage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMMD' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer typcca +c + integer option + integer messin +c + character*8 mcfich, mcmail, nocmai +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre0 +c + integer pfamen, pcoonc, pnunoe, adcocs + integer pfamee, pnoeel, ptypel, pnuele + integer pnomfa, pnumfa + integer pgrpo, pgrtai + integer pgrtab, pcexno + integer pinfpt, pinftl, pinftb + integer adeqpo, adeqin + integer adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe + integer adnomb + integer ptrav1 + integer*8 idfmed + integer lnomfi, lnomam + integer nbnoto + integer typrep + integer nbpqt +c + integer nctfno + integer sdimca, mdimca + integer degre, mailet, maconf, homolo, hierar, nbmane + integer nbelem, nbmaae, nbmafe, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > numael, numano, + > nbfmed, nbfmen, ngrouc, nbgrm, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + integer nbeqte, nbeqhe +c + character*80 titre + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + character*8 typobs + character*8 ntrav1 + character*16 nomaxe(3), uniaxe(3) + character*64 nomamd + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c==== +c 2. premiers decodages +c==== +c +c 2.1. ==> les constantes +c + nctfno = 1 +c +c 2.2. ==> nom du fichier contenant le maillage +c + typobs = mcfich + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) 'en entree' + codret = -10 + endif +c +c 2.3. ==> nom du maillage dans ce fichier +c + if ( codret.eq.0 ) then + typobs = mcmail + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + call utosme ( typobs, ulsort, langue ) + if ( codret.eq.4 ) then + write (ulsort,texte(langue,52)) lnomam + write (ulsort,texte(langue,53)) len(nomamd) + endif + codret = -20 + endif + endif +cgn write(ulsort,90002) 'Fin etape 2 avec codret', codret +c +c==== +c 3. premiere lecture du fichier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. premiere lecture ; codret', codret +#endif +c +c 3.1. ==> ouverture du fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + iaux = max(3,messin) +#else + iaux = messin +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESOUVL', nompro +#endif + call esouvl ( idfmed, nomfic(1:lnomfi), iaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> le maillage est-il present dans le fichier ? +c si oui, on retourne les dimensions de l'espace et du maillage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNOM', nompro +#endif + call eslnom ( idfmed, nomamd, lnomam, + > sdimca, mdimca, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,90002) 'Fin etape 3.2. avec codret', codret +cgn write (ulsort,90002) 'sdimca', sdimca +cgn write (ulsort,90002) 'mdimca', mdimca +c +c 3.3. ==> premiere lecture : noms et dimensions +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMM1', nompro +#endif + call eslmm1 ( idfmed, nomamd, lnomam, + > titre, + > sdimca, mdimca, + > degre, mailet, homolo, nbmane, + > nbelem, nbmaae, nbmafe, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, ngrouc, nbgrm, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbnoto, + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,90002) 'Fin etape 3.3. avec codret', codret +cgn write (ulsort,90002) 'degre ', degre +c +c==== +c 4. allocation des tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. allocation ; codret', codret +#endif +c +c 4.1. ==> allocation de l'objet de tete +c remarque : on suppose que le maillage est conforme +c c'est a la conversion qu'on fera le tri +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 2 + if ( typcca.eq.16 ) then + hierar = 1 + else + hierar = 0 + endif + maconf = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTACMA', nompro +#endif + call utacma ( nocmai, iaux, typcca, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnoto, nctfno, nbelem, nbmane, jaux, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> objets lies au maillage de calcul +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. ; codret', codret +#endif +c +c 4.2.1. ==> les informations generales +c Remarque : elles sont regroupees par paquets de +c 80 caracteres pour gerer la conversion en +c pseudo-groupe dans hom.med +c . paquet 1 : 1 : 'NomCo ' +c 2/3, 4/5, 6/7 : nom coordonnees +c 8 : nom du repere utilise +c . paquet 2 : 1 : 'UniteCo ' +c 2/3, 4/5, 6/7 : unite coordonnees +c . paquet 3 : titre (limite a 80 caracteres) +c . paquet 4 : 1 : 'NOMAMD ' +c 2-7 : nom du maillage +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + nbpqt = 4 + call gmecat ( ncinfo, 1, nbpqt+1, codre1 ) + call gmaloj ( ncinfo//'.Pointeur', ' ', nbpqt+1, pinfpt, codre3 ) + call gmecat ( ncinfo, 2, 10*nbpqt, codre2 ) + call gmaloj ( ncinfo//'.Taille' , ' ', 10*nbpqt, pinftl, codre4 ) + call gmaloj ( ncinfo//'.Table' , ' ', 10*nbpqt, pinftb, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + endif +c +c 4.2.2. ==> les noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.2. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( option.eq.1 ) then + call gmaloj ( ncnoeu//'.NumeExte', ' ', nbnoto, pnunoe, codre1 ) + call gmaloj ( ncnoeu//'.FamilMED', ' ', nbnoto, pfamen, codre2 ) + iaux = 11 + call gmaloj ( ncnoeu//'.CoorCons', ' ', iaux , adcocs, codre3 ) + iaux = nbnoto * nctfno + call gmaloj ( nccoex//'.Noeud' , ' ', iaux , pcexno, codre4 ) + else + codre1 = 0 + codre2 = 0 + codre3 = 0 + codre4 = 0 + endif + iaux = nbnoto*sdimca + call gmaloj ( ncnoeu//'.Coor' , ' ', iaux , pcoonc, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c 4.2.3. ==> les elements +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.3. elements ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nccono//'.NumeExte', ' ', nbelem, pnuele, codre1 ) + call gmaloj ( nccono//'.FamilMED' , ' ', nbelem, pfamee, codre2 ) + call gmaloj ( nccono//'.Type', ' ', nbelem, ptypel, codre3 ) + iaux = nbelem*nbmane + call gmaloj ( nccono//'.Noeuds' , ' ', iaux , pnoeel, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + endif +c +c 4.2.4. ==> les familles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.4. familles ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( ncfami, 1, nbfmed, codre1 ) + call gmecat ( ncfami, 2, ngrouc, codre2 ) + call gmaloj ( ncfami//'.Numero', ' ', nbfmed , pnumfa, codre3 ) + iaux = 10*nbfmed + call gmaloj ( ncfami//'.Nom', ' ', iaux , pnomfa, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmaloj ( ncfami//'.Groupe', ' ', 0, iaux, codre1 ) + call gmaloj ( ncfami//'.Groupe.Pointeur', ' ', + > nbfmed+1, pgrpo, codre2 ) + iaux = 10*ngrouc + call gmaloj ( ncfami//'.Groupe.Taille', ' ', + > iaux, pgrtai, codre3 ) + call gmaloj ( ncfami//'.Groupe.Table', ' ', + > iaux, pgrtab, codre4 ) + call gmecat ( ncfami//'.Groupe', 1, nbfmed, codre5 ) + call gmecat ( ncfami//'.Groupe', 2, ngrouc*10, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c + endif +c +c 4.2.5. ==> les equivalences +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2.5. equivalences ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + nbeqte = 0 + nbeqhe = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTACME', nompro +#endif + call utacme ( ncequi, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe, + > adeqpo, adeqin, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncequi ) + call gmprsx (nompro, ncequi//'.Pointeur' ) + call gmprsx (nompro, ncequi//'.InfoGene' ) +#endif +c + endif +c + endif +c +c 4.3. ==> tableaux de travail +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. tableaux de travail ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + if ( sdimca.eq.1 ) then + iaux = nbelem*nbmane + elseif ( sdimca.eq.2 ) then + iaux = nbelem*nbmane + nbsegm + else + iaux = nbelem*nbmane + nbsegm + nbtria + endif + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codret ) +c + endif +c + endif +cgn write(ulsort,90002) 'Fin etape 4 avec codret', codret +c +c==== +c 5. remplissage des tableaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. remplissage tableaux ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMM2', nompro +#endif + call eslmm2 ( idfmed, nomamd, + > option, + > titre, + > degre, mailet, sdimca, nbmane, nbelem, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbnoto, numano, numael, + > imem(pnunoe), imem(pfamen), rmem(pcoonc), + > imem(pnuele), imem(pfamee), imem(pnoeel), imem(ptypel), + > imem(pgrpo), imem(pgrtai), smem(pgrtab), + > nbpqt, imem(pinfpt), imem(pinftl), smem(pinftb), + > typrep, nomaxe, uniaxe, + > imem(pnumfa), smem(pnomfa), + > imem(adeqpo), smem(adeqin), + > imem(adeqno), imem(adeqmp), imem(adeqar), + > imem(adeqtr), imem(adeqqu), + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnoeu ) +cgn call gmprsx (nompro, ncnoeu//'.Coor' ) + call gmprsx (nompro, nccono ) +cgn call gmprsx (nompro, nccono//'.Type' ) +cgn call gmprsx (nompro, nccono//'.Noeuds' ) +cgn call gmprsx (nompro, nccono//'.FamilMED' ) +#endif +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncinfo ) + call gmprsx (nompro, ncinfo//'.Pointeur' ) + call gmprsx (nompro, ncinfo//'.Taille' ) + call gmprsx (nompro, ncinfo//'.Table' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncequi ) + call gmprsx (nompro, ncequi//'.Pointeur' ) + call gmprsx (nompro, ncequi//'.InfoGene' ) + call gmprsx (nompro, ncequi//'.Noeud' ) + call gmprsx (nompro, ncequi//'.Point' ) + call gmprsx (nompro, ncequi//'.Arete' ) + call gmprsx (nompro, ncequi//'.Trian' ) + call gmprsx (nompro, ncequi//'.Quadr' ) +#endif +c + endif +c +c=== +c 6. les nombres +c=== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. les nombres ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( ncfami, 3, nbfmen, codre1 ) + call gmadoj ( ncnomb, adnomb, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(adnomb) = nbmaae + imem(adnomb+1) = nbmafe + imem(adnomb+2) = -1 + imem(adnomb+3) = numano + imem(adnomb+4) = numael + imem(adnomb+5) = nbtria + nbquad + imem(adnomb+6) = nbtetr + nbhexa + nbpent + nbpyra + imem(adnomb+11) = nbmapo + imem(adnomb+12) = nbsegm + imem(adnomb+13) = nbtria + imem(adnomb+14) = nbtetr + imem(adnomb+15) = -1 + imem(adnomb+16) = nbquad + imem(adnomb+17) = nbhexa + imem(adnomb+18) = nbpent + imem(adnomb+19) = nbpyra + imem(adnomb+21) = nbfmed + imem(adnomb+22) = nbfmen + imem(adnomb+23) = ngrouc + imem(adnomb+30) = nbequi + imem(adnomb+31) = nbeqno + imem(adnomb+32) = nbeqmp + imem(adnomb+33) = nbeqar + imem(adnomb+34) = nbeqtr + imem(adnomb+35) = nbeqqu +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnomb ) +#endif +c + endif +c + endif +c +c=== +c 7. nettoyage +c=== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. nettoyage ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codret ) +c + endif +c + endif +c +c=== +c 8. fermeture du fichier +c=== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. fermeture du fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo ( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) nomfic(1:lnomfi) + write (ulsort,texte(langue,10)) + endif +c + endif +c +c==== +c 9. Reperage des coordonnes extremes et controle +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. Reperage ; codret', codret +#endif +c + if ( option.eq.1 ) then +c +c 9.1. ==> calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMMC1', nompro +#endif + call utmmc1 ( sdimca, nbnoto, + > rmem(pcoonc), rmem(adcocs), iaux, ncnoeu, + > ulsort, langue, codret ) +c + endif +c +c 9.2. ==> iaux est la dimension reelle du probleme +c + if ( codret.eq.0 ) then +c + if ( iaux.lt.2 ) then + if ( nbtria.gt.0 .or. nbquad.gt.0 .or. + > nbtetr.gt.0 .or. nbhexa.gt.0 .or. + > nbpyra.gt.0 .or. nbpent.gt.0 ) then + codret = 2 + endif + else if ( iaux.lt.3 ) then + if ( nbtetr.gt.0 .or. nbhexa.gt.0 .or. + > nbpyra.gt.0 .or. nbpent.gt.0 ) then + codret = 2 + endif + endif + if ( codret.eq.2 ) then + write (ulsort,texte(langue,99)) + endif +c + endif +c + endif +c +c==== +c 10. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ne.-10 ) then + write (ulsort,texte(langue,8)) nomfic + if ( codret.ne.-20 ) then + write (ulsort,texte(langue,22)) nomamd + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmmf.F b/src/tool/ES_MED/eslmmf.F new file mode 100644 index 00000000..b5375242 --- /dev/null +++ b/src/tool/ES_MED/eslmmf.F @@ -0,0 +1,296 @@ + subroutine eslmmf ( idfmed, nomamd, + > typenh, typent, typgeo, + > nmadeb, nbmato, nbelem, numfam, + > typcon, + > fammai, + > tbiaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un Maillage au format MED +c - - - - - +c - Familles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . nmadeb . e . 1 . numero de la maille de debut . +c . . . . >=0 : le tableau est pris tel quel . +c . . . . <0 : les descriptions sont inversees . +c . nbmato . e . 1 . nombre de mailles a lire . +c . nbelem . e . 1 . nombre d'elements, tous types confondus . +c . numfam . e . 1 . decalage dans la numerotation des familles . +c . . . . 1 : le tableau est pris tel quel . +c . . . . <=0 : le tableau passe negatif et est . +c . . . . decale de numfam . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . typent . e . 1 . type des entites au sens MED . +c . typgeo . e . 1 . type geometrique au sens MED . +c . typcon . e . 1 . type de connectivite . +c . . . . 0 : par noeud (ednoda) . +c . . . . 1 : descendante (eddesc) . +c . fammai . s . nbelem . famille med des mailles . +c . tbiaux . . nbelem . tableau tampon . +c . . . *nbmane. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMMF' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typenh, typent, typgeo + integer nmadeb, nbmato, nbelem, numfam + integer typcon + integer fammai(nbelem) + integer tbiaux(*) +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer numdt, numit + integer datype, chgt, tsf + integer lgtfam +c + character*6 saux06 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Lecture des '',i10,1x,a)' + texte(1,63) = '(''Toutes les familles sont nulles.'')' +c + texte(2,4) = '(''... Readings of '',i10,1x,a)' + texte(2,63) = '(''All the families are 0.'')' +c +#include "impr03.h" +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) +#endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcon', typcon + write (ulsort,90002) 'typenh', typenh + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nmadeb', nmadeb + write (ulsort,90002) 'nbmato', nbmato + write (ulsort,90002) 'nbelem', nbelem + write (ulsort,90002) 'numfam', numfam +#endif +c + numdt = ednodt + numit = ednoit + chgt = 0 + tsf = 0 +c +c==== +c 2. Longueur du tableau des familles +c==== +c + if ( codret.eq.0 ) then +c + datype = edda04 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numdt', numdt + write (ulsort,90002) 'numit', numit + write (ulsort,90002) 'typent', typent + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'datype', datype + write (ulsort,90002) 'typcon', typcon + write (ulsort,90002) 'chgt', chgt + write (ulsort,90002) 'tsf', tsf +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNME', nompro +#endif + call mmhnme ( idfmed, nomamd, numdt, numit, + > typent, typgeo, datype, typcon, chgt, tsf, + > lgtfam, codret ) + if ( codret.ne.0 ) then + saux06 = 'mmhnme' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgtfam', lgtfam +#endif +c + endif +c +c==== +c 3. Remplissage du tableau +c==== +c 3.1. ==> 0 par defaut +c + if ( lgtfam.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,63)) +#endif +c + if ( nmadeb.ge.0 ) then + do 311 , iaux = 1, nbmato + fammai(nmadeb-1+iaux) = 0 + 311 continue + else + do 312 , iaux = 1, nbmato + fammai(iaux) = 0 + 312 continue + endif +c + endif +c +c 3.2. ==> lecture +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHFNR', nompro +#endif + call mmhfnr ( idfmed, nomamd, numdt, numit, + > typent, typgeo, + > tbiaux, codret ) + if ( codret.ne.0 ) then + saux06 = 'mmhfnr' + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( numfam.gt.0 ) then +c + if ( nmadeb.ge.0 ) then + do 321 , iaux = 1, nbmato + fammai(nmadeb-1+iaux) = tbiaux(iaux) + 321 continue + else + do 322 , iaux = 1, nbmato + fammai(iaux) = tbiaux(iaux) + 322 continue + endif +c + else +c + if ( nmadeb.ge.0 ) then + do 323 , iaux = 1, nbmato + fammai(nmadeb-1+iaux) = -tbiaux(iaux) + numfam + 323 continue + else + do 324 , iaux = 1, nbmato + fammai(iaux) = -tbiaux(iaux) + numfam + 324 continue + endif +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh) + write (ulsort,texte(langue,78)) saux06, codret + write (ulsort,texte(langue,79)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmmn.F b/src/tool/ES_MED/eslmmn.F new file mode 100644 index 00000000..c8804a4e --- /dev/null +++ b/src/tool/ES_MED/eslmmn.F @@ -0,0 +1,152 @@ + subroutine eslmmn ( idfmed, nomamd, lnomam, + > nbnoto, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture du Maillage au format MED - nombre de Noeuds +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . lnomam . e . 1 . longueur du nom du maillage voulu . +c . nbnoto . s . 1 . nombre de noeuds du maillage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMMN' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer lnomam + integer nbnoto +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer typnoe +c + integer iaux + integer numdt, numit + integer datype, chgt, tsf +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds :'',i10)' +c + texte(2,4) = '(''Number of nodes:'',i10)' +c +#include "esimpr.h" +c + nbnoto = 0 +c + typnoe = 0 +c + numdt = ednodt + numit = ednoit +c +c==== +c 2. recherche du nombre de noeuds +c==== +c + if ( codret.eq.0 ) then +c + datype = edda00 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNME - noeuds', nompro +#endif + call mmhnme ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, datype, ednoda, chgt, tsf, + > nbnoto, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbnoto +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslmno.F b/src/tool/ES_MED/eslmno.F new file mode 100644 index 00000000..cf6f7e85 --- /dev/null +++ b/src/tool/ES_MED/eslmno.F @@ -0,0 +1,239 @@ + subroutine eslmno ( idfmed, nomamd, + > option, + > nbnoto, sdim, coonno, fameno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un Maillage au format MED - NOeuds +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage de sortie . +c . nomamd . e . char64 . nom du maillage MED . +c . option . e . 1 . option de lecture du maillage . +c . . . . 1 : lecture integrale . +c . . . . 2 : uniquement les coordonnees des noeuds . +c . nbnoto . e . 1 . nombre de noeuds . +c . sdim . e . 1 . dimension . +c . coonno . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdim . . +c . fameno . e . nbnoto . famille des noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLMNO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option +c + integer*8 idfmed + integer nbnoto, sdim + integer fameno(nbnoto) +c + character*64 nomamd +c + double precision coonno(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer typnoe + integer numdt, numit + integer datype, chgt, tsf + integer nbfami +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,61) = '(''Coordonnees des'',i10,'' noeuds.'')' + texte(1,62) = '(''Familles des'',i10,'' noeuds.'')' + texte(1,63) = '(''Toutes les familles sont nulles.'')' +c + texte(2,61) = '(''Coordinates of the'',i10,'' nodes.'')' + texte(2,62) = '(''Families of the'',i10,'' nodes.'')' + texte(2,63) = '(''All the families are 0.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c + codret = 0 +c + numdt = ednodt + numit = ednoit +c +c==== +c 2. les coordonnees des noeuds +c . les unites +c . les coordonnees +c . les numeros des familles +c le tableau coonno est declare ainsi : coonno(nbnoto,sdim). +c En fortran, cela correspond au stockage memoire suivant : +c coonno(1,1), coonno(2,1), coonno(3,1), ..., coonno(nbnoto,1), +c coonno(1,2), coonno(2,2), coonno(3,2), ..., coonno(nbnoto,2), +c ... +c coonno(1,sdim), coonno(2,sdim), ..., coonno(nbnoto,sdim) +c on a ainsi toutes les abscisses, puis toutes les ordonnees, etc. +c C'est ce que MED appelle le mode non entrelace. +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHCOR', nompro +#endif + call mmhcor ( idfmed, nomamd, numdt, numit, + > ednoin, coonno, codret ) +c + endif +c +c==== +c 3. Les familles de noeuds +c Par convention, si le tableau est absent, les familles sont +c toutes nulles. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. familles de noeuds ; codret', codret +#endif +c + if ( option.eq.1 ) then +c +c 3.1. ==> Longueur du tableau des familles +c + if ( codret.eq.0 ) then +c + typnoe = 0 + datype = edda04 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNME', nompro +#endif + call mmhnme ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, datype, ednoda, chgt, tsf, + > nbfami, codret ) +c + endif +c +c 3.2. ==> Remplissage du tableau +c 3.2.1. ==> 0 par defaut +c + if ( nbfami.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,63)) +#endif +c + do 32 , iaux = 1 , nbnoto + fameno(iaux) = 0 + 32 continue +c + endif +c + else +c +c 3.2.2. ==> lecture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHFNR', nompro +#endif + call mmhfnr ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, + > fameno, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ge.61 .and. codret.le.62 ) then + write (ulsort,texte(langue,codret)) nbnoto + endif + write (ulsort,texte(langue,80)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslnma.F b/src/tool/ES_MED/eslnma.F new file mode 100644 index 00000000..d60f28f9 --- /dev/null +++ b/src/tool/ES_MED/eslnma.F @@ -0,0 +1,371 @@ + subroutine eslnma ( idfmed, nomamd, mdim, + > nbelem, nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpyra, nbpent, + > nbseg2, nbseg3, + > nbtri3, nbtri6, nbtri7, + > nbtet4, nbte10, + > nbqua4, nbqua8, nbqua9, + > nbhex8, nbhe20, nbhe27, + > nbpen6, nbpe15, + > nbpyr5, nbpy13, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture du Nombre de MAilles +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . mdim . e . 1 . dimension du maillage . +c . nbelem . s . 1 . nombre d'elements dans le maillage . +c . nbmapo . s . 1 . nombre de mailles-points . +c . nbsegm . s . 1 . nombre de segments . +c . nbtria . s . 1 . nombre de triangles . +c . nbtetr . s . 1 . nombre de tetraedres . +c . nbseg2 . s . 1 . nombre de segments a 2 noeuds . +c . nbseg3 . s . 1 . nombre de segments a 3 noeuds . +c . nbtrik . s . 1 . nombre de triangles a k noeuds . +c . nbtet4 . s . 1 . nombre de tetraedres a 4 noeuds . +c . nbte10 . s . 1 . nombre de tetraedres a 10 noeuds . +c . nbquak . s . 1 . nombre de quadrangles a k noeuds . +c . nbhexk . s . 1 . nombre d'hexaedres a k noeuds . +c . nbpen6 . s . 1 . nombre de pentaedres a 6 noeuds . +c . nbpe15 . s . 1 . nombre de pentaedres a 15 noeuds . +c . nbpyr5 . s . 1 . nombre de pyramides a 5 noeuds . +c . nbpy13 . s . 1 . nombre de pyramides a 13 noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLNMA' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer mdim + integer nbelem, nbmapo, nbsegm, nbtria, nbtetr + integer nbquad, nbhexa, nbpyra, nbpent + integer nbseg2, nbseg3 + integer nbtri3, nbtri6, nbtri7 + integer nbtet4, nbte10 + integer nbqua4, nbqua8, nbqua9 + integer nbhex8, nbhe20, nbhe27 + integer nbpen6, nbpe15 + integer nbpyr5, nbpy13 +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer codre0 + integer codre1, codre2, codre3 +c + integer numdt, numit + integer datype, chgt, tsf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + nbmapo = 0 + nbsegm = 0 + nbtria = 0 + nbtetr = 0 +c + nbseg2 = 0 + nbseg3 = 0 + nbtri3 = 0 + nbtri6 = 0 + nbtri7 = 0 + nbtet4 = 0 + nbte10 = 0 +c + nbqua4 = 0 + nbqua8 = 0 + nbqua9 = 0 + nbpen6 = 0 + nbpe15 = 0 + nbhex8 = 0 + nbhe20 = 0 + nbhe27 = 0 + nbpyr5 = 0 + nbpy13 = 0 +c + numdt = ednodt + numit = ednoit + datype = edda01 +c +c==== +c 2. recherche des differents nombres d'elements +c==== +c +c 2.1. ==> les mailles points +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNME', nompro +#endif + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpoi1, datype, ednoda, chgt, tsf, + > nbmapo, codret ) + endif +c +c 2.2. ==> les segments +c + if ( codret.eq.0 ) then + if ( mdim.ge.1 ) then + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edseg2, datype, ednoda, chgt, tsf, + > nbseg2, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edseg3, datype, ednoda, chgt, tsf, + > nbseg3, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + endif + endif +c +c 2.3. ==> les triangles +c + if ( codret.eq.0 ) then + if ( mdim.ge.2 ) then + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edtri3, datype, ednoda, chgt, tsf, + > nbtri3, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edtri6, datype, ednoda, chgt, tsf, + > nbtri6, codre2 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edtri7, datype, ednoda, chgt, tsf, + > nbtri7, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) + endif + endif +c +c 2.4. ==> les tetraedres +c + if ( codret.eq.0 ) then + if ( mdim.eq.3 ) then + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edtet4, datype, ednoda, chgt, tsf, + > nbtet4, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edte10, datype, ednoda, chgt, tsf, + > nbte10, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + endif + endif +c +c 2.5. ==> les quadrangles +c + if ( codret.eq.0 ) then + if ( mdim.ge.2 ) then + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edqua4, datype, ednoda, chgt, tsf, + > nbqua4, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edqua8, datype, ednoda, chgt, tsf, + > nbqua8, codre2 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edqua9, datype, ednoda, chgt, tsf, + > nbqua9, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) + endif + endif +c +c 2.6. ==> les hexaedres +c + if ( codret.eq.0 ) then + if ( mdim.eq.3 ) then +c + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edhex8, datype, ednoda, chgt, tsf, + > nbhex8, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edhe20, datype, ednoda, chgt, tsf, + > nbhe20, codre2 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edhe27, datype, ednoda, chgt, tsf, + > nbhe27, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif + endif +c +c 2.7. ==> les pentaedres +c + if ( codret.eq.0 ) then + if ( mdim.eq.3 ) then +c + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpen6, datype, ednoda, chgt, tsf, + > nbpen6, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpe15, datype, ednoda, chgt, tsf, + > nbpe15, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif + endif +c +c 2.8. ==> les pyramides +c + if ( codret.eq.0 ) then + if ( mdim.eq.3 ) then +c + + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpyr5, datype, ednoda, chgt, tsf, + > nbpyr5, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpy13, datype, ednoda, chgt, tsf, + > nbpy13, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif + endif +c +c==== +c 3. nombres deduits +c==== +c + if ( codret.eq.0 ) then +c + iaux = nbseg2 + > + nbtri3 + nbqua4 + > + nbtet4 + nbhex8 + nbpyr5 + nbpen6 + jaux = nbseg3 + > + nbtri6 + nbqua8 + nbtri7 + nbqua9 + > + nbte10 + nbhe20 + nbpy13 + nbpe15 + nbhe27 +c + if ( iaux.gt.0 ) then +c + nbelem = iaux + nbmapo + nbsegm = nbseg2 + nbtria = nbtri3 + nbtetr = nbtet4 + nbquad = nbqua4 + nbhexa = nbhex8 + nbpyra = nbpyr5 + nbpent = nbpen6 +c + else if ( jaux.gt.0 ) then +c + nbelem = jaux + nbmapo + nbsegm = nbseg3 + nbtria = max(nbtri6, nbtri7) + nbtetr = nbte10 + nbquad = max(nbqua8, nbqua9) + nbhexa = max(nbhe20, nbhe27) + nbpyra = nbpy13 + nbpent = nbpe15 +c + else +c + nbelem = nbmapo +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslnof.F b/src/tool/ES_MED/eslnof.F new file mode 100644 index 00000000..b384d968 --- /dev/null +++ b/src/tool/ES_MED/eslnof.F @@ -0,0 +1,332 @@ + subroutine eslnof ( idfmed, + > nomam1, lnoma1, + > nomam2, lnoma2, + > nomafr, lnomaf, sdim, mdim, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture - NOm du maillage de la Frontiere +c - - - -- - +c ______________________________________________________________________ +c Remarque : eslnom et eslnof sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage d'entree . +c . nomam1 . e . char64 . nom du maillage 1 a exclure . +c . lnoma1 . e . 1 . longueur nom du maillage 1 a exclure . +c . nomam2 . e . char64 . nom du maillage 2 a exclure . +c . lnoma2 . e . 1 . longueur nom du maillage 2 a exclure . +c . nomafr . s . char64 . nom du maillage MED de la frontiere . +c . lnomaf . s . 1 . longueur du nom du maillage de la frontiere. +c . . . . 0 : le maillage est absent du fichier . +c . sdim . s . 1 . dimension de l'espace . +c . mdim . s . 1 . dimension du maillage . +c . typrep . s . 1 . type de repere . +c . nomaxe . s . 3 . nom des axes de coordonnees . +c . uniaxe . s . 3 . unite des axes de coordonnees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLNOF' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer lnoma1, lnoma2 + integer lnomaf + integer sdim, mdim + integer typrep +c + character*16 nomaxe(3), uniaxe(3) + character*64 nomam1 + character*64 nomam2 + character*64 nomafr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbmaie + integer nromai + integer typema + integer stype, nstep +c + integer iaux, jaux + integer ptrav1, ptrav2 + integer codre1, codre2 + integer codre0 +c + character*8 ntrav1, ntrav2 + character*16 saux16 + character*64 saux64 + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + sdim = 0 +c + texte(1,4) = '(''Nombre de maillages :'',i3)' + texte(1,5) = '(''Nom du maillage numero'',i3,'' : '',a64)' + texte(1,6) = '(''Maillage a exclure : '',a)' +c + texte(2,4) = '(''Number of meshes:'',i3)' + texte(2,5) = '(''Name of mesh #'',i3,'': '',a64)' + texte(2,6) = '(''Mesh not to take: '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nomam1(1:lnoma1) + write (ulsort,texte(langue,6)) nomam2(1:lnoma2) +#endif +c +c==== +c 2. le maillage est-il present ? +c==== +c +c 2.1. ==> combien de maillages +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.1. combien de maillages ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNMH', nompro +#endif + call mmhnmh ( idfmed, nbmaie, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,20)) +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,4)) nbmaie +#endif + endif +c + endif +c +c 2.2. ==> structures de stockage des noms des maillages du fichier +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2. structures ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 8*nbmaie + call gmalot ( ntrav1, 'chaine ', iaux , ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbmaie , ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3. ==> numero et dimension du maillage voulu +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.3. numero et dimension ; codret =', codret +#endif +c + nromai = 0 +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , nbmaie +c +c 2.3.1. ==> nom et dimension du maillage numero iaux +c sdim : Dimension de l'espace de calcul. +c mdim : Dimension du maillage. +c + if ( codret.eq.0 ) then +c 12345678901234567890123456789012 + saux64( 1:32) = ' ' + saux64(33:64) = ' ' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHMII', nompro +#endif + call mmhmii ( idfmed, iaux, + > saux64, sdim, mdim, typema, sau200, + > saux16, stype, nstep, + > typrep, nomaxe, uniaxe, + > codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,20)) + endif +c + endif +c + if ( codret.eq.0 ) then + call utlgut ( jaux, saux64, + > ulsort, langue, codret ) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) iaux, saux64 +#endif +c +c 2.3.2. ==> archivage de ce nom +c + if ( codret.eq.0 ) then +c + call utchs8 ( saux64, jaux, smem(ptrav1+8*(iaux-1)), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(ptrav2+iaux-1) = jaux +c + endif +c +c 2.3.3. ==> comparaison avec le nom voulu +c il ne doit etre ni le maillage HOMARD, ni le +c stockage des abscisses survilignes +c une fois le maillage trouve, on s'assure qu'il est decrit +c en non structure +c + if ( codret.eq.0 ) then +c + if ( jaux.eq.lnoma1 ) then + if ( saux64(1:jaux).eq.nomam1(1:lnoma1) ) then + goto 23 + endif + endif +c + if ( jaux.eq.lnoma2 ) then + if ( saux64(1:jaux).eq.nomam2(1:lnoma2) ) then + goto 23 + endif + endif +c + if ( typema.ne.ednost ) then + write (ulsort,texte(langue,22)) saux64(1:jaux) + write (ulsort,texte(langue,28)) typema + codret = 11 + endif + lnomaf = jaux + nomafr = blan64 + nomafr(1:jaux) = saux64(1:jaux) + goto 24 +c + endif +c + 23 continue +c +c 2.3.4. ==> le maillage voulu est inconnu dans ce fichier +c + lnomaf = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmaie +c + do 234 , iaux = 1 , nbmaie +c + jaux = imem(ptrav2+iaux-1) + call uts8ch ( smem(ptrav1+8*(iaux-1)), jaux, saux64, + > ulsort, langue, codre1 ) + write (ulsort,texte(langue,5)) iaux, saux64 +c + 234 continue +#endif +c + endif +c +c 2.4. ==> menage +c + 24 continue +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslnom.F b/src/tool/ES_MED/eslnom.F new file mode 100644 index 00000000..e546bb76 --- /dev/null +++ b/src/tool/ES_MED/eslnom.F @@ -0,0 +1,304 @@ + subroutine eslnom ( idfmed, nomamd, lnomam, + > sdim, mdim, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture - NOm du Maillage +c - - - -- - +c ______________________________________________________________________ +c Remarque : eslnom et eslnof sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identificateur du fichier de . +c . . . . maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . lnomam . e . 1 . longueur du nom du maillage voulu . +c . sdim . s . 1 . dimension de l'espace . +c . mdim . s . 1 . dimension du maillage . +c . typrep . s . 1 . type de repere . +c . nomaxe . s . 3 . nom des axes de coordonnees . +c . uniaxe . s . 3 . unite des axes de coordonnees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : le maillage est absent du fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLNOM' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer lnomam + integer sdim, mdim + integer typrep +c + character*16 nomaxe(3), uniaxe(3) + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer nbmaie + integer typema + integer stype, nstep +c + integer iaux, jaux + integer ptrav1, ptrav2 + integer codre1, codre2 + integer codre0 +c + character*8 ntrav1, ntrav2 + character*16 saux16 + character*64 saux64 + character*200 sau200 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + mdim = 0 +c + texte(1,4) = '(''Nombre de maillages :'',i3)' + texte(1,5) = '(''Nom du maillage numero'',i3,'' : '',a64)' +c + texte(2,4) = '(''Number of meshes:'',i3)' + texte(2,5) = '(''Name of mesh #'',i3,'': '',a64)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,22)) nomamd(1:lnomam) +#endif +c +c==== +c 2. le maillage est-il present ? +c==== +c 2.1. ==> combien de maillages +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. combien de maillages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNMH', nompro +#endif + call mmhnmh ( idfmed, nbmaie, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,20)) +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,4)) nbmaie +#endif + endif +c + endif +c +c 2.2. ==> structures de stockage des noms des maillages du fichier +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. structures ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 8*nbmaie + call gmalot ( ntrav1, 'chaine ', iaux , ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbmaie , ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3. ==> numero et dimension du maillage voulu +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. numero et dimension ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , nbmaie +c +c 2.3.1. ==> nom et dimension du maillage numero iaux +c sdim : Dimension de l'espace de calcul. +c mdim : Dimension du maillage. +c + if ( codret.eq.0 ) then +c 12345678901234567890123456789012 + saux64( 1:32) = ' ' + saux64(33:64) = ' ' +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHMII', nompro +#endif + call mmhmii ( idfmed, iaux, + > saux64, sdim, mdim, typema, sau200, + > saux16, stype, nstep, + > typrep, nomaxe, uniaxe, + > codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,20)) + endif +c + endif +c + if ( codret.eq.0 ) then + call utlgut ( jaux, saux64, + > ulsort, langue, codret ) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) iaux, saux64 +#endif +c +c 2.3.2. ==> archivage de ce nom +c + if ( codret.eq.0 ) then +c + call utchs8 ( saux64, jaux, smem(ptrav1+8*(iaux-1)), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(ptrav2+iaux-1) = jaux +c + endif +c +c 2.3.3. ==> comparaison avec le nom voulu +c une fois le maillage trouve, on s'assure qu'il est decrit +c en non structure +c + if ( codret.eq.0 ) then + if ( jaux.eq.lnomam ) then + if ( saux64(1:jaux).eq.nomamd(1:lnomam) ) then + if ( typema.ne.ednost ) then + write (ulsort,texte(langue,22)) nomamd(1:lnomam) + write (ulsort,texte(langue,28)) typema + codret = 11 + endif + goto 24 + endif + endif + endif +c + 23 continue +c +c 2.3.4. ==> le maillage voulu est inconnu dans ce fichier +c + codret = 3 + write (ulsort,texte(langue,12)) nomamd(1:lnomam) + write (ulsort,texte(langue,4)) nbmaie +c + do 234 , iaux = 1 , nbmaie +c + jaux = imem(ptrav2+iaux-1) + call uts8ch ( smem(ptrav1+8*(iaux-1)), jaux, saux64, + > ulsort, langue, codre1 ) + write (ulsort,texte(langue,5)) iaux, saux64 +c + 234 continue +c + endif +c +c 2.4. ==> menage +c + 24 continue +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sdim', sdim + write (ulsort,90002) 'mdim', mdim +#endif +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslnum.F b/src/tool/ES_MED/eslnum.F new file mode 100644 index 00000000..683f3737 --- /dev/null +++ b/src/tool/ES_MED/eslnum.F @@ -0,0 +1,444 @@ + subroutine eslnum ( idfmed, nomamd, degre, + > nbnoto, nbelem, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nunoex, nuelex, + > numano, numael, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture des NUMerotations +c - - - --- +c Par defaut, on part du principe que les elements externes sont +c numerotes dans cet ordre : +c tetraedres, triangles, segments, mailles-points, +c quadrangles, hexaedres, pyramides, pentaedres +c Voir eslmm2 pour confirmation. +c +c Si la table de renumerotation est fournie, on ecrase la +c correspondance. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . unite logique du maillage d'entree . +c . nomamd . e . char64 . nom du maillage MED . +c . degre . e . 1 . degre du maillage . +c . nbnoto . e . 1 . nombre de noeuds dans le maillage . +c . nbelem . e . 1 . nombre d'elements dans le maillage . +c . nbmapo . e . 1 . nombre de mailles-points . +c . nbsegm . e . 1 . nombre de segments . +c . nbtria . e . 1 . nombre de triangles . +c . nbtetr . e . 1 . nombre de tetraedres . +c . nbhexa . e . 1 . nombre d'hexaedres . +c . nbpyra . e . 1 . nombre de pyramides . +c . nbpent . e . 1 . nombre de pentaedres . +c . nuelex . s . nbelem . numerotation des elements en exterieur . +c . nunoex . s . nbnoto . numerotation des noeuds en exterieur . +c . numano . s . 1 . numero maximum des noeuds . +c . numael . s . 1 . numero maximum des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLNUM' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer degre + integer nbnoto, nbelem + integer nbmapo, nbsegm, nbtria, nbtetr + integer nbquad, nbhexa, nbpent, nbpyra + integer nunoex(nbnoto), nuelex(nbelem) + integer numano, numael +c + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer typnoe, typseg, typtri, typqua + integer typtet, typhex, typpyr, typpen + integer ibtetr, ibtria, ibsegm, ibmapo + integer ibquad , ibhexa, ibpyra, ibpent + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8, codre9 + integer codre0 + integer ntabno, ntabpo, ntabse, ntabtr, ntabqu + integer ntabte, ntabhe, ntabpy, ntabpe + integer numdt, numit + integer datype, chgt, tsf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. grandeurs de base +c==== +c + typnoe = 0 + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typqua = edqua4 + typtet = edtet4 + typhex = edhex8 + typpyr = edpyr5 + typpen = edpen6 + else + typseg = edseg3 + typtri = edtri6 + typqua = edqua8 + typtet = edte10 + typhex = edhe20 + typpyr = edpy13 + typpen = edpe15 + endif +c + ibtetr = 1 + ibtria = nbtetr + 1 + ibsegm = nbtetr + nbtria + 1 + ibmapo = nbtetr + nbtria + nbsegm + 1 + ibquad = nbtetr + nbtria + nbsegm + nbmapo + 1 + ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + 1 + ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + 1 + ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra + 1 +c + numdt = ednodt + numit = ednoit + datype = edda03 +c +c==== +c 3. les renumerotations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. les renumerotations ; codret = ', codret +#endif +c +c 3.1. ==> initialisation a la non renumerotation +c + if ( codret.eq.0 ) then +c + do 311 , iaux = 1, nbnoto + nunoex(iaux) = iaux + 311 continue + do 312 , iaux = 1, nbelem + nuelex(iaux) = iaux + 312 continue + numano = nbnoto + numael = nbelem +c + endif +c +c 3.2. ==> le nombre de noeuds et de mailles a renumeroter +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHNME_NO', nompro +#endif + call mmhnme ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, datype, ednoda, chgt, tsf, + > ntabno, codre1 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, edpoi1, datype, ednoda, chgt, tsf, + > ntabpo, codre2 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typseg, datype, ednoda, chgt, tsf, + > ntabse, codre3 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typtri, datype, ednoda, chgt, tsf, + > ntabtr, codre4 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typqua, datype, ednoda, chgt, tsf, + > ntabqu, codre5 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typtet, datype, ednoda, chgt, tsf, + > ntabte, codre6 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typhex, datype, ednoda, chgt, tsf, + > ntabhe, codre7 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typpyr, datype, ednoda, chgt, tsf, + > ntabpy, codre8 ) + call mmhnme ( idfmed, nomamd, numdt, numit, + > edmail, typpen, datype, ednoda, chgt, tsf, + > ntabpe, codre9 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + 1000 format(a,' = ',10i13) + write (ulsort,1000) 'ntabno', ntabno + write (ulsort,1000) 'ntabpo', ntabpo + write (ulsort,1000) 'ntabse', ntabse + write (ulsort,1000) 'ntabtr', ntabtr + write (ulsort,1000) 'ntabqu', ntabqu + write (ulsort,1000) 'ntabte', ntabte + write (ulsort,1000) 'ntabhe', ntabhe + write (ulsort,1000) 'ntabpy', ntabpy + write (ulsort,1000) 'ntabpe', ntabpe + else + write (ulsort,1000) 'codrei', + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 + endif +#endif +c +c 3.3. ==> les tables de renumerotation +c +c 3.3.1. ==> les noeuds +c + if ( codret.eq.0 ) then + if ( nbnoto.gt.0 .and. ntabno.eq.nbnoto ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_NO', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > ednoeu, typnoe, nunoex, + > codret ) + if ( codret.eq.0 ) then + do 331 , iaux = 1, nbnoto + numano = max(numano,nunoex(iaux)) + 331 continue + endif + endif + endif +c +c 3.3.2. ==> les mailles-points +c + if ( codret.eq.0 ) then + if ( nbmapo.gt.0 .and. ntabpo.eq.nbmapo ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_MP', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, edpoi1, nuelex(ibmapo), + > codret ) + if ( codret.eq.0 ) then + jaux = ibmapo + nbmapo - 1 + do 332 , iaux = ibmapo , jaux + numael = max(numael,nuelex(iaux)) + 332 continue + endif + endif + endif +c +c 3.3.3. ==> les segments +c + if ( codret.eq.0 ) then + if ( nbsegm.gt.0 .and. ntabse.eq.nbsegm ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_AR', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typseg, nuelex(ibsegm), + > codret ) + if ( codret.eq.0 ) then + jaux = ibsegm + nbsegm - 1 + do 333 , iaux = ibsegm , jaux + numael = max(numael,nuelex(iaux)) + 333 continue + endif + endif + endif +c +c 3.3.4. ==> les triangles +c + if ( codret.eq.0 ) then + if ( nbtria.gt.0 .and. ntabtr.eq.nbtria ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_TR', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typtri, nuelex(ibtria), + > codret ) + if ( codret.eq.0 ) then + jaux = ibtria + nbtria - 1 + do 334 , iaux = ibtria, jaux + numael = max(numael,nuelex(iaux)) + 334 continue + endif + endif + endif +c +c 3.3.5. ==> les tetraedres +c + if ( codret.eq.0 ) then + if ( nbtetr.gt.0 .and. ntabte.eq.nbtetr ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_TE', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typtet, nuelex(ibtetr), + > codret ) + if ( codret.eq.0 ) then + jaux = ibtetr + nbtetr - 1 + do 335 , iaux = ibtetr, jaux + numael = max(numael,nuelex(iaux)) + 335 continue + endif + endif + endif +c +c 3.3.6. ==> les quadrangles +c + if ( codret.eq.0 ) then + if ( nbquad.gt.0 .and. ntabqu.eq.nbquad ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_QU', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typqua, nuelex(ibquad), + > codret ) + if ( codret.eq.0 ) then + jaux = ibquad + nbquad - 1 + do 336 , iaux = ibquad, jaux + numael = max(numael,nuelex(iaux)) + 336 continue + endif + endif + endif +c +c 3.3.7. ==> les hexaedres +c + if ( codret.eq.0 ) then + if ( nbhexa.gt.0 .and. ntabhe.eq.nbhexa ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_HE', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typhex, nuelex(ibhexa), + > codret ) + if ( codret.eq.0 ) then + jaux = ibhexa + nbhexa - 1 + do 337 , iaux = ibhexa, jaux + numael = max(numael,nuelex(iaux)) + 337 continue + endif + endif + endif +c +c 3.3.8. ==> les pyramides +c + if ( codret.eq.0 ) then + if ( nbpyra.gt.0 .and. ntabpy.eq.nbpyra ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_PY', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typpyr, nuelex(ibpyra), + > codret ) + if ( codret.eq.0 ) then + jaux = ibpyra + nbpyra - 1 + do 338 , iaux = ibpyra, jaux + numael = max(numael,nuelex(iaux)) + 338 continue + endif + endif + endif +c +c 3.3.9. ==> les pentaedres +c + if ( codret.eq.0 ) then + if ( nbpent.gt.0 .and. ntabpe.eq.nbpent ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMHENR_PE', nompro +#endif + call mmhenr ( idfmed, nomamd, numdt, numit, + > edmail, typpen, nuelex(ibpent), + > codret ) + if ( codret.eq.0 ) then + jaux = ibpent + nbpent - 1 + do 339 , iaux = ibpent, jaux + numael = max(numael,nuelex(iaux)) + 339 continue + endif + endif + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslpg1.F b/src/tool/ES_MED/eslpg1.F new file mode 100644 index 00000000..363459b3 --- /dev/null +++ b/src/tool/ES_MED/eslpg1.F @@ -0,0 +1,209 @@ + subroutine eslpg1 ( idfmed, + > nolopg, oblopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture des localisations des Points de Gauss +c - - - - - +c au format MED - phase 1 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med . +c . nolopg . e . char64 . nom de la localisation a lire . +c . oblopg . s . char*8 . nom de l'objet de type 'LocaPG' associe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLPG1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed +c + character*8 oblopg + character*64 nolopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c + integer typgeo, ngauss, dimcpg + integer adcono, adcopg, adpopg +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Points de Gauss dans le fichier MED :'')' + texte(1,5) = '(/,''Lecture de la localisation '',a)' +c + texte(2,4) = '(''Gauss points in MED file :'')' + texte(2,5) = '(/,''Readings of localization '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nolopg +#endif +c +#include "esimpr.h" +c +c==== +c 2. caracterisation de la localisation a lire +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLPG2', nompro +#endif +c + call eslpg2 ( idfmed, + > nolopg, typgeo, ngauss, dimcpg, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,81)) nolopg + write (ulsort,texte(langue,64)) typgeo + write (ulsort,texte(langue,57)) ngauss +#endif +c + endif +c +c==== +c 3. Allocation de la localisation +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPG', nompro +#endif +c + call utalpg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Lecture de la localisation +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLCLOR', nompro +#endif + call mlclor ( idfmed, nolopg, edfuin, + > rmem(adcono), rmem(adcopg), rmem(adpopg), + > codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nolopg + iaux = mod(typgeo,100) + jaux = (typgeo-iaux) / 100 + call utimpg ( 2, ngauss, iaux, jaux, + > rmem(adcono), rmem(adcopg), rmem(1), + > ulsort, langue, codret ) +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, oblopg ) + call gmprsx (nompro, oblopg//'.NomLocPG' ) + call gmprsx (nompro, oblopg//'.CoorNoeu' ) + call gmprsx (nompro, oblopg//'.CoorPtGa' ) + call gmprsx (nompro, oblopg//'.PoidPtGa' ) +#endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslpg2.F b/src/tool/ES_MED/eslpg2.F new file mode 100644 index 00000000..a094c3be --- /dev/null +++ b/src/tool/ES_MED/eslpg2.F @@ -0,0 +1,214 @@ + subroutine eslpg2 ( idfmed, + > nolopg, typgeo, ngauss, dimcpg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture des localisations des Points de Gauss +c - - - - - +c au format MED - phase 2 +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med . +c . nolopg . e . char64 . nom de la localisation a lire . +c . typgeo . s . 1 . type geometrique associe a la localisation . +c . ngauss . s . 1 . nombre de points de Gauss de la localis. . +c . dimcpg . e . 1 . dimension des coordonnees des pts de Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme dans la lecture . +c . . . . -1 : la localisation n'est pas enregistree . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLPG2' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer typgeo, ngauss, dimcpg +c + character*64 nolopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrolpg, nbrlpg + integer nsmc, sgtype +c + character*64 giname, isname + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Recherche de la localisation des points de Gauss : '',a)' + texte(1,5) = '(''.. Reperage de la localisation : '',a)' + texte(1,6) = + > '(''Elle n''''est pas enregistree dans le fichier.'')' +c + texte(2,4) = '(''Research of Gauss points localization : '',a)' + texte(2,5) = '(''.. This localization is found : '',a)' + texte(2,6) = '(''It is not stored inthe file.'')' +c +#include "esimpr.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nolopg +#endif +c A TRAITER : utiliser directepent mlclni +c==== +c 2. Combien de localisations enregistrees ? +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLCNLC', nompro +#endif +c + call mlcnlc ( idfmed, nbrlpg, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,82)) nbrlpg +#endif +c + endif +c +c==== +c 3. Lecture de chacune des localisations +c==== +c + do 31 , nrolpg = 1 , nbrlpg +c +c 3.1. ==> caracterisation de la localisation numero nrolpg +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLCLCI', nompro +#endif +c + call mlclci ( idfmed, nrolpg, + > saux64, typgeo, dimcpg, ngauss, + > giname, isname, nsmc, sgtype, + > codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,79)) + endif +c + endif +c +c 3.2. ==> Si c'est la bonne, on sort +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) saux64 +#endif +c + if ( nolopg.eq.saux64 ) then + goto 39 + endif +c + endif +c + 31 continue +c +c 3.2. ==> si on arrive ici, c'est qu'on n'a pas trouve la +c localisation recherchee +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,4)) nolopg + write (ulsort,texte(langue,6)) + codret = -1 +c + endif +c + 39 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslpr1.F b/src/tool/ES_MED/eslpr1.F new file mode 100644 index 00000000..6ba93d29 --- /dev/null +++ b/src/tool/ES_MED/eslpr1.F @@ -0,0 +1,182 @@ + subroutine eslpr1 ( idfmed, + > noprof, obprof, nbvapr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'un PRofil au format MED - phase 1 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . noprof . e . char64 . nom du profil a lire . +c . obprof . s . char*8 . nom de l'objet de type 'Profil' associe . +c . nbvapr . s . 1 . nombre de valeurs du profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLPR1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbvapr +c + character*64 noprof + character*8 obprof +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer adlipr +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Longueur du profil dans le fichier MED :'')' +c + texte(2,4) = '(''Profile length in MED file :'')' +c +#include "esimpr.h" +cgn print *, '. nbcomp = ', nbcomp +cgn print *, '. typerr = ', typerr +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,61)) noprof +#endif +c +c==== +c 2. taille du profil a lire +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPSN', nompro +#endif + call mpfpsn ( idfmed, noprof, nbvapr, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,62)) nbvapr +#endif +c + endif +c +c==== +c 3. Allocation du profil +c==== +c + if ( codret.eq.0 ) then +c + call utalpr ( obprof, + > nbvapr, noprof, + > adlipr, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Lecture du profil +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFPRR', nompro +#endif + call mpfprr ( idfmed, noprof, imem(adlipr), codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,obprof) + call gmprsx (nompro,obprof//'.NomProfi') + call gmprsx (nompro,obprof//'.ListEnti') +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslsc1.F b/src/tool/ES_MED/eslsc1.F new file mode 100644 index 00000000..c39de84b --- /dev/null +++ b/src/tool/ES_MED/eslsc1.F @@ -0,0 +1,312 @@ + subroutine eslsc1 ( nomfic, lnomfi, + > messin, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution - Champs presents - phase 1 +c - - - - - - +c Affichage des noms des champs contenus dans le fichier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomfic . e . char* . nom du fichier . +c . lnomfi . e . 1 . longueur du nom du fichier . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSC1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "litme0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer lnomfi +c + character*200 nomfic +c + integer messin +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer*8 idfmed + integer typcha + integer iaux + integer adnocp + integer nbchfi, nrocha, nbcomp + integer lmesh, nbsqch + integer nbtvch, numdtx +c + character*8 ntrav1 + character*16 dtunit + character*64 nomcha + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,7) = + > '(/,''Description des'',i6,'' champs presents dans le fichier'')' +c + texte(2,7) = + > '(/,''Description of the'',i6,'' field in this file'')' +c + 1000 format (53('-')) +c +#include "esimpr.h" +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. prealables +c==== +c +#include "litmed.h" +c +c 2.1. ==> ouverture du fichier MED +c +#ifdef _DEBUG_HOMARD_ + iaux = max(3,messin) +#else + iaux = messin +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESOUVL', nompro +#endif + call esouvl ( idfmed, nomfic(1:lnomfi), iaux, + > ulsort, langue, codret ) +c +c 2.2. ==> nombre de champs dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFD', nompro +#endif + call mfdnfd ( idfmed, nbchfi, codret ) +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,7)) nbchfi + write (ulsort,*) nomfic(1:lnomfi) + endif +c + endif +c +c==== +c 3. caracterisation des champs +c==== +c + if ( codret.eq.0 ) then +c + do 30 , nrocha = 1 , nbchfi +c + write (ulsort,1000) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) ' ' + write (ulsort,90002) 'Champ numero', nrocha + endif +#endif +c +c 3.1. ==> nombre de composantes du champ courant +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFC', nompro +#endif + iaux = nrocha + call mfdnfc ( idfmed, iaux, nbcomp, codret ) +c + endif +c +c 3.2. ==> allocation des tableaux decrivant le champ et ses composantes +c remarque : ce dimensionnement suppose que : +c 1. le nom des composantes se code sur 16 caracteres +c 2. le nom des unites des composantes se code sur 16 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre de composantes', nbcomp +#endif + iaux = 4*nbcomp + call gmalot ( ntrav1, 'chaine ', iaux, adnocp, codret ) +c + endif +c +c 3.3. ==> lecture du nom du champ, des noms et des unites +c de ses composantes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDFDI', nompro +#endif + nomcha = blan64 + iaux = nrocha + call mfdfdi ( idfmed, iaux, + > nomcha, saux64, lmesh, typcha, + > smem(adnocp), smem(adnocp+2*nbcomp), + > dtunit, nbsqch, codret ) +c + endif +c +c 3.4. ==> Affichage +c + if ( codret.eq.0 ) then + call utlgut ( iaux, saux64, ulsort, langue, codret ) + endif + if ( codret.eq.0 ) then + write (ulsort,texte(langue,96)) saux64(1:iaux) + endif +c + if ( codret.eq.0 ) then + call utlgut ( iaux, nomcha, ulsort, langue, codret ) + endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,32)) nomcha(1:iaux) + do 34 , iaux = 1 , nbcomp + write (ulsort,texte(langue,54)) + > smem(adnocp+2*iaux-2)//smem(adnocp+2*iaux-1) + 34 continue +c + endif +c +c +c 3.5. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codret ) +c + endif +c +c 3.6. ==> On parcourt toutes les sequences et tous les types de support +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH1', nompro +#endif + call eslch1 ( idfmed, nomcha, nbsqch, + > nbtmed, litmed, + > iaux, + > nbtvch, numdtx, + > ulsort, langue, codret ) +c + endif +c + 30 continue +c + write (ulsort,1000) +c + endif +c +c==== +c 4. fermeture du fichier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*)'Avant 4, codret = ',codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/ES_MED/eslsch.F b/src/tool/ES_MED/eslsch.F new file mode 100644 index 00000000..6e74c540 --- /dev/null +++ b/src/tool/ES_MED/eslsch.F @@ -0,0 +1,226 @@ + subroutine eslsch ( nochso, + > nbseal, adcact, adcaet, adcart, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution - les CHamps a lire +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nochso . e . char8 . nom de l'objet decrivant les chmps a lire . +c . . . . si blanc, on lit tous les champs du fichier. +c . nbseal . s . 1 . nombre de sequences a lire . +c . . . . si = -1, on lit tous les champs du fichier . +c . adcact . s . 1 . adresse du champ CarCaChp de nochso . +c . adcaet . s . 1 . adresse du champ CarEnChp de nochso . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 1, si numero du pas de temps, 0 sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 1, si numero d'ordre, 0 sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 1, si instant, 0 sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. 1, s'il fait partie du champ en cours . +c . . . . d'examen, 0, sinon . +c . . . . 12. type de champ edfl64/edin64 . +c . adcart . s . 1 . adresse du champ CarReChp de nochso . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSCH' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbseal, adcact, adcaet, adcart +c + character*8 nochso +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(/,''Lecture de tous les champs du fichier'')' +c + texte(2,4) = '(/,''Readings of all fields from the file.'')' +c +#include "impr03.h" +c +c==== +c 2. tous les champs sont a lire +c==== +c + if ( nochso.eq.blan08 ) then +c + nbseal = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 3. on lit les champs enregistres +c==== +c + else +c +c 3.1. ==> reperage des informations stockees +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nochso ) + call gmprsx (nompro, nochso//'.CarCaChp' ) + call gmprsx (nompro, nochso//'.CarEnChp' ) + call gmprsx (nompro, nochso//'.CarReChp' ) +#endif +c + call gmliat ( nochso, 1, nbseal, codre1 ) + call gmadoj ( nochso//'.CarCaChp', adcact, iaux, codre2 ) + call gmadoj ( nochso//'.CarEnChp', adcaet, iaux, codre3 ) + call gmadoj ( nochso//'.CarReChp', adcart, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +c 3.2. ==> impression +c +cgn print *,nbseal + if ( codret.eq.0 ) then +c + do 32 , iaux = 1 , nbseal +c + if ( codret.eq.0 ) then +c + jaux = len(saux64) + call uts8ch ( smem(adcact+8*(iaux-1)), jaux, saux64, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( jaux, saux64, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,32)) saux64(1:jaux) + if ( imem(adcaet+12*iaux-11).gt.0 ) then + write (ulsort,texte(langue,113)) imem(adcaet+12*iaux-10) + endif + if ( imem(adcaet+12*iaux-9).gt.0 ) then + write (ulsort,texte(langue,114)) imem(adcaet+12*iaux-8) + endif + if ( imem(adcaet+12*iaux-7).gt.0 ) then + write (ulsort,texte(langue,115)) rmem(adcart+iaux-1) + endif + write (ulsort,*) ' ' +c + endif +c + 32 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslsm0.F b/src/tool/ES_MED/eslsm0.F new file mode 100644 index 00000000..897fe802 --- /dev/null +++ b/src/tool/ES_MED/eslsm0.F @@ -0,0 +1,792 @@ + subroutine eslsm0 ( nocson, nomfic, lnomfi, + > nomamd, lnomam, + > nbseal, nbtosv, + > cactal, caetal, cartal, + > messin, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format Med - phase 0 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocson . s . char*8 . nom de l'objet solution calcul iteration n . +c . nomfic . e . char* . nom du fichier . +c . lnomfi . e . 1 . longueur du nom du fichier . +c . nomamd . e . char64 . nom du maillage MED . +c . lnomam . e . 1 . longueur du nom du maillage . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . nbtosv . s . 1 . nombre total de sequences lues . +c . cactal . e .8*nbseal. caracteristiques caracteres de chaque . +c . . . . tableau a lire . +c . . . . 1,...,8. nom du champ associe . +c . caetal . es . 12 * . caracteristiques entieres de chaque . +c . . . nbseal . tableau a lire . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 2, on prend le dernier pas de temps . +c . . . . 1, le numero du pas de temps est fourni . +c . . . . 0, sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 2, on prend le dernier numero d'ordre . +c . . . . 1, le numero d'ordre est fourni . +c . . . . 0, sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 2, on prend le dernier instant . +c . . . . 1, l'instant est fourni . +c . . . . 0, sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. 1, s'il fait partie du champ en cours . +c . . . . d'examen, 0, sinon . +c . . . . 12. type de champ edfl64/edin64 . +c . cartal . e . nbseal . caracteristiques reelles de chaque . +c . . . . tableau a lire . +c . . . . 1. instant . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . option . e . 1 . 1 : on controle que l'on a les couples (aux. +c . . . . noeuds par element/aux points de Gauss) . +c . . . . 0 : pas de controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c ESLSMD -> ESLSM0 -> ESOUVL -> ESVERI -> MFICOM +c /ESLIMD -> MLBSTV +c -> MFIOPE +c -> MFISVR +c -> MFICLO +c -> MFIOPE +c -> ESLENT -> MFICOR +c -> ESLNOM -> MMHNMH +c -> MMHMII +c -> MFDNFD +c -> MLCNLC +c -> ESLSM1 -> MFDNFC +c -> MFDFDI +c -> ESLCH1 +c -> ESLCH2 -> MFDCSI +c -> MFDNPF +c -> ESLPR1 -> MPFPSN +c -> MPFPRR +c -> ESLPG1 -> ESLPG2 -> MLCNLC +c -> MLCLCI +c -> MLCLOR +c -> MFDNPN +c -> ESLCH6 +c -> ESLSM2 -> ESLCH3 +c -> ESLCH7 +c -> ESLSM3 +c -> ESLSM4 -> ESLCH4 -> MFDRPR +c -> ESLCH5 +c -> ESLSM5 +c -> MFICLO +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer lnomfi, lnomam + integer nbseal, nbtosv + integer caetal(12,*) +c + double precision cartal(*) +c + character*8 nocson + character*8 cactal(*) + character*64 nomamd + character*200 nomfic +c + integer messin, option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + integer nbchfi, nbcham, nbfonc, nbprof, nblopg + integer nbrpro, nbrlpg + integer nbpafo + integer adinch, adinpf, adinpr, adinlg + integer adtra1, adtra2 + integer typrep +c + integer*8 idfmed +c + character*8 ntrav1, ntrav2 + character*16 nomaxe(3), uniaxe(3) +#ifdef _DEBUG_HOMARD_ + character*8 saux08 +#endif +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. prealables +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. prealables ; codret', codret +#endif +c +c 2.1. ==> ouverture du fichier MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + iaux = max(3,messin) +#else + iaux = messin +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESOUVL', nompro +#endif + call esouvl ( idfmed, nomfic(1:lnomfi), iaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> le maillage est-il present dans le fichier ? +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLNOM', nompro +#endif + call eslnom ( idfmed, nomamd, lnomam, + > iaux, jaux, + > typrep, nomaxe, uniaxe, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. nombre de champs dans le fichier : s'il n'y en n'a pas, on met +c tout a zero et on passera par-dessus la suite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. nb champs dans fichier ; codret', codret +#endif +c +c 3.1. ==> nombre de champs dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFD', nompro +#endif + call mfdnfd ( idfmed, nbchfi, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'Nombre de champs dans le fichier', nbchfi + endif +#endif +c + endif +c +c 3.2. ==> nombre de localisations de points de Gauss dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLCNLC', nompro +#endif + call mlcnlc ( idfmed, nbrlpg, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,79)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,82)) nbrlpg +#endif +c + endif +c +c 3.3. ==> nombre de profils dans le fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MPFNPF', nompro +#endif + call mpfnpf ( idfmed, nbrpro, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,86)) nbrpro +#endif +c + endif +c +c 3.4. ==> allocation de l'objet solution : la tete et la +c branche des champs +c On suppose qu'il n'y a ni fonction, ni profil, ni +c localisation de points de Gauss +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALSO', nompro +#endif + call utalso ( nocson, + > nbchfi, iaux, iaux, iaux, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. caracterisations des champs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. caracterisations champs ; codret', codret +#endif +c + nbtosv = 0 + nbprof = 0 + nblopg = 0 +c + if ( nbchfi.ne.0 ) then +c +c 4.1. ==> tableaux temporaires pour stocker les noms des eventuels +c profils et localisations de points de Gauss a lire +c + if ( codret.eq.0 ) then +c + iaux = 9*nbchfi*nbrpro + call gmalot ( ntrav1, 'chaine', iaux, adtra1, codre1 ) + iaux = 9*nbchfi*nbrlpg + call gmalot ( ntrav2, 'chaine', iaux, adtra2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 4.2. ==> A partir des nbchfi champs contenus dans le fichier, on +c cree les caracteristiques de ce qu'il faut lire. On +c recupere leur nombre, nbcham, et le nombre total de +c tableaux de valeurs auxquels cela correspond, nbtosv +c On ne s'interesse ici qu'aux caracteristiques des tableaux +c de valeurs. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM1', nompro +#endif + call eslsm1 ( idfmed, nomamd, + > nbchfi, option, + > nbseal, cactal, caetal, cartal, + > nbcham, smem(adinch), nbtosv, + > nbprof, smem(adtra1), + > nblopg, smem(adtra2), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbseal',nbseal + if ( nbseal.gt.0 ) then + write (ulsort,90005) 'caetal',(caetal(iaux,1),iaux=1,12) + write (ulsort,90004) 'cartal',cartal(1) + endif + if ( codret.eq.0 ) then + write (ulsort,90002) 'Nbre de champs a lire (nbcham) ', nbcham + write (ulsort,90002) 'Nbre cumule de sequences (nbtosv)', nbtosv + write (ulsort,90002) 'Nbre cumule de profils (nbprof) ', nbprof +cgn call gmprsx (nompro, ntrav1 ) + endif +#endif +c +c 4.3. ==> stockage de l'information sur les champs dans la +c structure solution +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'Avant 4.3., codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nocson, 1, nbcham, codre1 ) + call gmmod ( nocson//'.InfoCham', + > adinch, nbchfi, nbcham, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +40000 format(/,'Apres 4.3., solution ',a8,/,29('='),/) + write (ulsort,40000) nocson + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoCham' ) +cgn call gmprsx (nompro, '%%%%%%14' ) +cgn call gmprsx (nompro, '%%%%%%14.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%17.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%18.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%14.Cham_Ree' ) +cgn call gmprsx (nompro, '%%%%%%14.Cham_Car' ) + endif +#endif +c +c 4.4.==> creations des structures representant les profils +c necessaires aux champs a lire +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'Avant 4.4., codret', codret +#endif +c + if ( nbprof.ne.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nocson//'.InfoProf', ' ', + > nbprof, adinpr, codre1 ) + call gmecat ( nocson, 3, nbprof, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 44 , iaux = 1 , nbprof + smem(adinpr+iaux-1) = smem(adtra1+5*iaux-1) + 44 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +40004 format(/,'Apres 4.4., solution ',a8,/,29('='),/) + if ( codret.eq.0 ) then + write (ulsort,40004) nocson + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoProf' ) +cgn call gmprsx (nompro, '%%%%%%%6' ) +cgn call gmprsx (nompro, '%%%%%%%6.NomProfi' ) +cgn call gmprsx (nompro, '%%%%%%%6.ListEnti' ) + endif +#endif +c + endif +c +c 4.5. ==> creations des structures representant les localisations de +c points de Gauss necessaires aux champs a lire +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Avant 4.5., codret', codret +#endif +c + if ( nblopg.ne.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nocson//'.InfoLoPG', ' ', + > nblopg, adinlg, codre1 ) + call gmecat ( nocson, 4, nblopg, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 45 , iaux = 1 , nblopg + smem(adinlg+iaux-1) = smem(adtra2+9*iaux-1) + 45 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +40005 format(/,'Apres 4.5., solution ',a8,/,29('='),/) + if ( codret.eq.0 ) then + write (ulsort,40005) nocson + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoLoPG' ) + endif +#endif +c + endif +c +c 4.6. ==> menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 5. les fonctions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. les fonctions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtosv.ne.0 ) then +c +c 5.1.==> classement des champs en fonctions +c a priori, on suppose qu'il y a autant de fonctions differents +c que de tableaux ; on pourrait corriger ensuite en fonction +c des regroupements qui auront ete faits dans eslsm2, mais +c c'est inutile de passer du temps a cela car les tableaux +c sont detruits a la fin de cette sequence. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre de fonctions suppose', nbtosv + write (ulsort,90002) 'nbinec', nbinec +#endif + iaux = nbinec*nbtosv + call gmalot ( ntrav1, 'entier', iaux, adtra1, codre1 ) + iaux = 3*nbtosv + call gmalot ( ntrav2, 'chaine', iaux, adtra2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM2', nompro +#endif + call eslsm2 ( nbcham, smem(adinch), nbseal, + > nbfonc, imem(adtra1), smem(adtra2), option, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'Nombre de fonctions (nbfonc)',nbfonc + call gmprsx (nompro, ntrav1 ) + call gmprsx (nompro, ntrav2 ) + endif +#endif +c +c 5.2. ==> creations des structures pour les fonctions +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'Avant 5.2, codret',codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM3', nompro +#endif +c + call eslsm3 ( nbfonc, imem(adtra1), + > smem(adtra2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, ntrav2 ) + endif +#endif +c + endif +c +c 5.3. ==> lecture des valeurs numeriques et des eventuels profils +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'Avant 5.3, codret',codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM4', nompro +#endif +c + call eslsm4 ( idfmed, + > nbcham, smem(adinch), + > nbfonc, imem(adtra1), smem(adtra2), + > ulsort, langue, codret ) +c + endif +c +c 5.4. ==> regroupement des fonctions en paquets +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Avant 5.4, codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nocson//'.InfoPaFo', ' ', nbfonc, adinpf, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM5', nompro +#endif +c + call eslsm5 ( nbfonc, imem(adtra1), smem(adtra2), nbseal, + > nbpafo, smem(adinpf), option, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nocson, 2, nbpafo, codre1 ) + call gmmod ( nocson//'.InfoPaFo', + > adinpf, nbfonc, nbpafo, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,40054) nocson + endif +40054 format(/,'Apres 5.4., solution ',a8,/,29('='),/) + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoPaFo' ) + do 54555 , iaux = adinpf , adinpf+nbpafo-1 + call gmprsx (nompro, smem(iaux) ) +54555 continue + call gmprsx (nompro, '%%Fo002I' ) + call gmprsx (nompro, '%%%%%%12' ) + call gmprsx (nompro,'%%%%%%12.ValeursR') + call gmprsx (nompro,'%%%%%%12.InfoPrPG') + call gmprsx (nompro, '%%%%%%10' ) + write (ulsort,*) '+++++++++++++++++++++++++++++++++++++++++' +#endif +c + endif +c +c 5.5. ==> menage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'Avant 5.5, codret',codret +#endif +c + if ( codret.eq.0 ) then +c +ccc call gmprsx (nompro, ntrav1 ) + call gmlboj ( ntrav1, codre1 ) +ccc call gmprsx (nompro, ntrav2 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c==== +c 6. fermeture du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. fermeture du fichier ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo( idfmed, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +33333 format(80('*')) +44444 format(80('=')) + if ( codret.eq.0 ) then + call gmprsx (nompro, nocson ) + call gmprsx (nompro, nocson//'.InfoCham' ) + call gmprsx (nompro, nocson//'.InfoPaFo' ) + call gmprsx (nompro, nocson//'.InfoProf' ) + write (ulsort,44444) + do 61 , iaux = 6,20,2 + call utench ( iaux, 'd', codre0, saux08, + > ulsort, langue, codret ) + if (iaux.le.9 ) then + saux08(1:7) = '%%%%%%%' + else + saux08(1:6) = '%%%%%%' + endif + call gmprsx (nompro,saux08) + call gmprsx (nompro,saux08//'.NomProfi') + call gmprsx (nompro,saux08//'.ListEnti') + write (ulsort,33333) +61 continue + write (ulsort,44444) + do 62 , iaux = 42,46 + call utench ( iaux, 'd', codre0, saux08, + > ulsort, langue, codret ) + if (iaux.le.9 ) then + saux08(1:7) = '%%%%%%%' + else + saux08(1:6) = '%%%%%%' + endif + call gmprsx (nompro,saux08) + call gmprsx (nompro,saux08//'.Fonction') + if ( iaux.eq.42 ) then + call gmprsx (nompro,'%%%%%%36') + call gmprsx (nompro,'%%%%%%36.ValeursR') + call gmprsx (nompro,'%%%%%%36.InfoPrPG') + write (ulsort,33333) + endif + call utench ( iaux-5, 'd', codre0, saux08, + > ulsort, langue, codret ) + saux08(1:6) = '%%%%%%' + call gmprsx (nompro,saux08) + call gmprsx (nompro,saux08//'.ValeursR') + call gmprsx (nompro,saux08//'.InfoPrPG') + write (ulsort,33333) +62 continue + write (ulsort,44444) + do 63 , iaux = 5,34 + if ( mod(iaux,2).eq.1 .or. iaux.ge.21 ) then + call utench ( iaux, 'd', codre0, saux08, + > ulsort, langue, codret ) + if (iaux.le.9 ) then + saux08(1:7) = '%%%%%%%' + else + saux08(1:6) = '%%%%%%' + endif + call gmprsx (nompro,saux08) + endif +63 continue +cgn call gmprsx (nompro, '%%%%%%14' ) +cgn call gmprsx (nompro, '%%%%%%14.Nom_Comp' ) +cgn call gmprsx (nompro, '%%%%%%14.Cham_Ent' ) +cgn call gmprsx (nompro, '%%%%%%14.Cham_Ree' ) +cgn call gmprsx (nompro, '%%%%%%14.Cham_Car' ) +cgn call gmprsx (nompro, '%%%%%%23' ) +cgn call gmprsx (nompro, '%%Fo004J') +cgn call gmprsx (nompro, '%%%%%%21' ) +cgn call gmprsx (nompro, '%%%%%%21.InfoPrPG' ) + endif +#endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) nomfic +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslsm1.F b/src/tool/ES_MED/eslsm1.F new file mode 100644 index 00000000..7c0429bc --- /dev/null +++ b/src/tool/ES_MED/eslsm1.F @@ -0,0 +1,784 @@ + subroutine eslsm1 ( idfmed, nomamd, + > nbchfi, option, + > nbseal, cactal, caetal, cartal, + > nbcham, nocham, nbtosv, + > nbprof, liprof, + > nblopg, lilopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MED - phase 1 +c - - - - - - +c En sortie, on a des tableaux caracteristiques des champs contenus +c dans le fichier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . nomamd . e . char64 . nom du maillage MED . +c . nbchfi . e . 1 . nombre de champs dans le fichier . +c . option . e . 1 . 1 : on controle que l'on a les couples (aux. +c . . . . noeuds par element/aux points de Gauss) . +c . . . . 0 : pas de controle . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . cactal . e .8*nbseal. caracteristiques caracteres de chaque . +c . . . . tableau a lire . +c . . . . 1,..,8. nom du champ associe . +c . caetal . es . 12 * . caracteristiques entieres de chaque . +c . . . nbseal . tableau a lire . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 2, on prend le dernier pas de temps . +c . . . . 1, le numero du pas de temps est fourni . +c . . . . 0, sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 2, on prend le dernier numero d'ordre . +c . . . . 1, le numero d'ordre est fourni . +c . . . . 0, sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 2, on prend le dernier instant . +c . . . . 1, l'instant est fourni . +c . . . . 0, sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. 1, s'il fait partie du champ en cours . +c . . . . d'examen, 0, sinon . +c . . . . 12. type de champ edfl64/edin64 . +c . cartal . e . nbseal . caracteristiques reelles de chaque . +c . . . . tableau a lire . +c . . . . 1. instant . +c . nbcham . s . 1 . nombre de champs a lire . +c . nocham . s . nbchfi . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nbtosv . s . 1 . nombre total de tableaux de valeurs . +c . nbprof . es . 1 . nombre cumule de profils a lire . +c . liprof . s .9*nbrpro. 1-8 : nom du -i-eme profil lu . +c . . . . 9 : nom de l'objet de type 'Profil' associe. +c . nblopg . es . 1 . nombre cumule de localisations Gauss a lire. +c . lilopg . s .9*nbrlpg. 1-8 : nom de la -i-eme localisation lue . +c . . . . 9 : nom de l'objet de type 'LocaPG' associe. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM1' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "litme0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer option + integer nbchfi, nbseal + integer nbtosv, nbcham + integer nbprof, nblopg + integer caetal(12,*) +c + double precision cartal(*) +c + character*8 nocham(nbchfi) + character*8 cactal(*) + character*8 liprof(*) + character*8 lilopg(*) + character*64 nomamd +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer lmesh, typcha + integer iaux, jaux, kaux + integer adnocp, adcaen, adcare, adcaca + integer nrocha, nbcomp + integer nbsqch, nbtvlu + integer adtra1 + integer nbtvch, numdtx +c + character*8 ntrav1 + character*8 obcham + character*64 saux64 + character*64 nomcha, nomach +c + logical alire +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c +#include "impr03.h" +c +#include "litmed.h" +c + nbcham = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Debut de '//nompro//', nbseal', nbseal + write (ulsort,90002) 'Nombre de champs dans le fichier', nbchfi +cgn write (ulsort,*) '. Premier champ a lire = ', +cgn > cactal(1),cactal(2),cactal(3),cactal(4), +cgn > cactal(5),cactal(6),cactal(7),cactal(8) +#endif +c +c==== +c 2. caracterisation des champs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. caracterisation champ ; codret', codret +#endif +c + nbtosv = 0 +c + if ( codret.eq.0 ) then +c + do 20 , nrocha = 1 , nbchfi +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,*) ' ' + write (ulsort,*) '.......................................'// + > '.......................................' + write (ulsort,90002) 'Dans le fichier, champ numero', nrocha + endif +#endif +c +c 2.1. ==> allocation de la structure decrivant le champ numero nrocha. +c le nom de la structure est conserve dans obcham +c + if ( codret.eq.0 ) then +c + call gmalot ( obcham, 'InfoCham', 0, iaux, codret ) +c + endif +c +c 2.2. ==> nombre de composantes du champ courant +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDNFC', nompro +#endif + iaux = nrocha + call mfdnfc ( idfmed, iaux, nbcomp, codret ) +c + endif +c +c 2.3. ==> allocation des tableaux decrivant le champ et ses composantes +c remarque : ce dimensionnement suppose que : +c 1. le nom des champs est code sur 64 caracteres +c 2. le nom des composantes l'est sur 16 +c 3. le nom des unites des composantes l'est sur 16 +c 4. le nom de l'unite du pas de temps l'est sur 16 +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,85)) nbcomp +#endif +c + call gmecat ( obcham, 1, nbcomp, codre1 ) + iaux = 8 + 4*nbcomp + 2 + call gmaloj ( obcham//'.Nom_Comp', ' ', iaux, adnocp, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.4. ==> lecture du nom du champ, du maillage associe, du type +c de champ, des noms et des unites de ses composantes, +c de l'unite du pas de temps, du nombre de sequences +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFDFDI', nompro +#endif + nomcha = blan64 + iaux = nrocha + call mfdfdi ( idfmed, iaux, + > nomcha, nomach, lmesh, typcha, + > smem(adnocp+8), smem(adnocp+8+2*nbcomp), + > smem(adnocp+8+4*nbcomp), nbsqch, codret) +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,32)) nomcha + do 241 , jaux=1,nbcomp + write(ulsort,texte(langue,54))smem(adnocp+8+2*(jaux-1))// + > smem(adnocp+8+2*jaux-1) + write(ulsort,90003) ' unite', + > smem(adnocp+8+2*nbcomp+2*(jaux-1))// + > smem(adnocp+8+2*nbcomp+2*(jaux-1)+1) + 241 continue + write(ulsort,90003) 'nomach', nomach + write(ulsort,90002) 'lmesh ', lmesh + write(ulsort,90002) 'typcha', typcha + write(ulsort,90003) 'dtunit', smem(adnocp+8+4*nbcomp)// + > smem(adnocp+8+4*nbcomp+1) + write(ulsort,90002) 'nbsqch', nbsqch +#endif +c + endif +c +c 2.5. ==> On ne lit le champ que si le nombre de sequences +c est non nul. Logique. +c + if ( codret.eq.0 ) then +c + if ( nbsqch.gt.0 ) then + alire = .true. + else + alire = .false. + endif +c + endif +c +c 2.6. ==> le champ est-il sur le bon maillage ? +c + if ( alire ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'Nom de ce champ (nomcha)', nomcha + write (ulsort,90003) 'Maillage du champ', nomach + write (ulsort,90003) 'Maillage courant ', nomamd +#endif +c + call utdich ( nomach, nomamd, + > ulsort, langue, codret ) +c + if ( codret.eq.1 .or. codret.eq.2 ) then + alire = .false. + codret = 0 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'Fin de 2.6. alire', alire +#endif +c + endif +c + endif +c +c 2.7. ==> le champ est-il dans la liste des sequences enregistrees ? +c + if ( alire ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'Nom de ce champ (nomcha)', nomcha +#endif +c + if ( nbseal.gt.0 ) then +c + alire = .false. + do 27 , iaux = 1 , nbseal +c + if ( codret.eq.0 ) then + call uts8ch ( cactal(8*(iaux-1)+1), 64, saux64, + > ulsort, langue, codret ) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90064) iaux, + > '-me champ que l''on veut lire : ', saux64 +#endif +c + if ( codret.eq.0 ) then +c + if ( saux64.eq.nomcha ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '..... ce champ doit etre lu' +#endif + alire = .true. + caetal(11,iaux) = 1 + else + caetal(11,iaux) = 0 + endif +c + caetal(12,iaux) = typcha +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90005) 'caetal', + > caetal(1,iaux),caetal(2,iaux),caetal(3,iaux),caetal(4,iaux), + > caetal(5,iaux),caetal(6,iaux),caetal(7,iaux), + > caetal(8,iaux),caetal(9,iaux),caetal(10,iaux), + > caetal(11,iaux),caetal(12,iaux) + write (ulsort,90004) 'cartal', cartal(iaux) +#endif + 27 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'Fin de 2.7. alire', alire +#endif +c + endif +c + endif +c +c 2.8. ==> on lira le champ, donc on le garde +c + if ( alire ) then +c + if ( codret.eq.0 ) then +c + iaux = 64 + call utchs8 ( nomcha, iaux, smem(adnocp), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.9. ==> Nombre de tableaux de valeurs de ce champ ecrits dans le +c fichier pour toutes les sequences et tous les types +c geometriques +c + if ( alire ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH1', nompro +#endif + call eslch1 ( idfmed, nomcha, nbsqch, + > nbtmed, litmed, + > iaux, + > nbtvch, numdtx, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Nombre total de tableaux de valeurs '// + > 'presents (nbtvch)', nbtvch + write (ulsort,90002) 'Dernier instant (numdtx)', numdtx +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbtvch.eq.0 ) then + alire = .false. + endif +c + endif +c + endif +c +c 2.10. ==> description des tableaux de valeurs +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) '2.10. alire', alire +#endif +c + if ( alire ) then +c +c 2.10.1. ==> allocation des tableaux decrivant les tableaux de valeurs +c pour chaque tableau du champ +c + if ( codret.eq.0 ) then +c + iaux = nbinec * nbtvch + call gmaloj ( obcham//'.Cham_Ent', ' ', iaux, adcaen, codre1 ) + call gmaloj ( obcham//'.Cham_Ree', ' ', + > nbtvch, adcare, codre2 ) + iaux = nbincc * nbtvch + call gmaloj ( obcham//'.Cham_Car', ' ', + > iaux, adcaca, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 2.10.2. ==> remplissage des caracteristiques +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH2', nompro +#endif + call eslch2 ( idfmed, nomcha, numdtx, typcha, + > nbtmed, litmed, + > nbsqch, nbtvch, nbtvlu, + > nbcham, nbseal, caetal, cartal, + > imem(adcaen), rmem(adcare), smem(adcaca), + > nbprof, liprof, + > nblopg, lilopg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... nombre total de tableaux de '// + > 'valeurs a lire (nbtvlu)', nbtvlu + call gmprsx (nompro, obcham ) + call gmprsx (nompro, obcham//'.Cham_Ent' ) + call gmprsx (nompro, obcham//'.Cham_Ree' ) + call gmprsx (nompro, obcham//'.Cham_Car' ) +#endif +c + endif +c + endif +c +c 2.11. ==> gestion de l'objet qui memorise le champ +c 2.11.1. ==> quand on garde le champ, on memorise son nom et on +c ajuste la taille des tableaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'Debut de 2.11, alire',alire + write (ulsort,90002) 'nbcham', nbcham +#endif +c + if ( alire ) then +c + if ( codret.eq.0 ) then +c + nbcham = nbcham + 1 + nocham(nbcham) = obcham +c + nbtosv = nbtosv + nbtvlu +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,21000) nbcham, nomcha + call gmprsx (nompro, obcham ) + call gmprsx (nompro, obcham//'.Nom_Comp' ) + call gmprsx (nompro, obcham//'.Cham_Ent' ) + call gmprsx (nompro, obcham//'.Cham_Ree' ) + call gmprsx (nompro, obcham//'.Cham_Car' ) + endif +#endif +c + call gmecat ( obcham, 2, nbtvlu, codre1 ) + call gmecat ( obcham, 3, typcha, codre2 ) + call gmmod ( obcham//'.Cham_Ent', + > adcaen, nbinec, nbinec, nbtvch, nbtvlu, codre3 ) + call gmmod ( obcham//'.Cham_Ree', + > adcare, 1, 1, nbtvch, nbtvlu, codre4 ) + call gmmod ( obcham//'.Cham_Car', + > adcaca, nbincc, nbincc, nbtvch, nbtvlu, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nombre cumule de tableaux de '// + > ' valeurs (nbtosv) = ',nbtosv +#endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,21000) nbcham, nomcha +21000 format(/,'Champ numero ',i3,' : ',a64,/,18('='),/) + call gmprsx (nompro, obcham ) + call gmprsx (nompro, obcham//'.Nom_Comp' ) + call gmprsx (nompro, obcham//'.Cham_Ent' ) + call gmprsx (nompro, obcham//'.Cham_Ree' ) + call gmprsx (nompro, obcham//'.Cham_Car' ) + endif +#endif +c +c 2.11.2. ==> N'etant pas lu, le champ est detruit +c + else +c + if ( codret.eq.0 ) then +c + call gmsgoj ( obcham, codret ) +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) + > nompro//', avant 20 continue, pour nrocha',nrocha + call dmflsh (iaux) +#endif +c + 20 continue +c + endif +c +c==== +c 3. On parcourt tous les champs enregistres pour memoriser les +c relations entre les champs aux points de Gauss et leurs +c homologues aux noeuds par elements +c il faut traiter dans l'ordre : +c 1. Les champs standards +c 2. Les champs aux points de Gauss +c 3. Les champs aux noeuds par element +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... Debut de 3., codret', codret +#endif +c + if ( option.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + do 33333 , iaux=1,nbtosv + write (ulsort,*) '... Champ '//cactal(8*iaux-7)// + > cactal(8*iaux-6)//cactal(8*iaux-5)//cactal(8*iaux-4)// + > cactal(8*iaux-3)// + > cactal(8*iaux-2)//cactal(8*iaux-1)//cactal(8*iaux) + write (ulsort,90005) '.. caetal', + > caetal(1,iaux),caetal(2,iaux),caetal(3,iaux),caetal(4,iaux), + > caetal(5,iaux),caetal(6,iaux),caetal(7,iaux), + > caetal(8,iaux),caetal(9,iaux),caetal(10,iaux), + > caetal(11,iaux) + write (ulsort,90004) '.. cartal',cartal(iaux) +33333 continue +#endif +c +c 3.1. ==> allocation d'un tableau auxiliaire pour memoriser les +c correspondances +c + if ( codret.eq.0 ) then + call gmalot ( ntrav1, 'entier ', nbcham, adtra1, codret ) + endif + do 30 , iaux = adtra1 , adtra1+nbcham-1 + imem(iaux) = -1 + 30 continue +c + do 3 , jaux = 1 , 3 +c +c 3.2. ==> choix du type de champ a traiter +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) '+++++++++++++++++++++++++++++++++++++++++' + write (ulsort,texte(langue,64+jaux)) +#endif + if ( jaux.eq.1 ) then + kaux = 0 + elseif ( jaux.eq.2 ) then + kaux = 2 + else + kaux = 1 + endif +c + endif +c +c 3.3. ==> parcours des champs enregistres +c + do 33 , nrocha = 1 , nbcham +c +c 3.3.1. ==> caracteristiques du champ numero nrocha +c + if ( codret.eq.0 ) then +c + obcham = nocham(nrocha) +c + call gmliat ( obcham, 2, nbtvlu, codre1 ) + call gmadoj ( obcham//'.Cham_Ent', adcaen, iaux, codre2 ) + call gmadoj ( obcham//'.Nom_Comp', adnocp, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then + iaux = 64 + call uts8ch ( smem(adnocp), iaux, nomcha, + > ulsort, langue, codret ) + endif +c +c 3.3.2. ==> appel ad-hoc +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH6', nompro +cgn call gmprsx (nompro, obcham//'.Cham_Ent' ) +#endif + iaux = nrocha + call eslch6 ( iaux, kaux, nbtvlu, imem(adcaen), nomcha, + > nbtosv, caetal, + > nbcham, imem(adtra1), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,31000) nomcha, nrocha +31000 format(/,60('='),/,'Champ ',a,', de numero ',i3,/) + call gmprsx (nompro, obcham ) + call gmprsx (nompro, obcham//'.Cham_Ent' ) + endif +#endif +c + 33 continue +c + 3 continue +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codret ) +c + endif +c + endif +c +c==== +c 4. controle de la presence des champs demandes +c on memorise le codret dans la variable jaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... Debut de 4., codret', codret +#endif +c + jaux = 0 +c + do 4 , iaux = 1 , nbseal +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90005) 'caetal', + > caetal(1,iaux),caetal(2,iaux),caetal(3,iaux),caetal(4,iaux), + > caetal(5,iaux),caetal(6,iaux),caetal(7,iaux), + > caetal(8,iaux),caetal(9,iaux),caetal(10,iaux), + > caetal(11,iaux),caetal(12,iaux) + write (ulsort,90004) 'cartal', cartal(iaux) + write (ulsort,90122) 'caetal', 9, iaux, caetal(9,iaux) +#endif +c + if ( caetal(9,iaux).eq.0 ) then +c + jaux = 1 +c + if ( codret.eq.0 ) then + call uts8ch ( cactal(8*iaux-7), 64, saux64, + > ulsort, langue, codret ) + endif + if ( codret.eq.0 ) then + write (ulsort,texte(langue,32)) saux64 + if ( caetal(2,iaux).gt.0 ) then + write (ulsort,texte(langue,113)) caetal(3,iaux) + endif + if ( caetal(4,iaux).gt.0 ) then + write (ulsort,texte(langue,114)) caetal(5,iaux) + endif + if ( caetal(6,iaux).gt.0 ) then + write (ulsort,texte(langue,115)) cartal(iaux) + endif + write (ulsort,texte(langue,92)) + endif +c + endif +c + endif +c + 4 continue +c + if ( jaux.ne.0 ) then + codret = 1 + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/ES_MED/eslsm2.F b/src/tool/ES_MED/eslsm2.F new file mode 100644 index 00000000..8ed78ab6 --- /dev/null +++ b/src/tool/ES_MED/eslsm2.F @@ -0,0 +1,301 @@ + subroutine eslsm2 ( nbcham, nocham, nbseal, + > nbfonc, defonc, nofonc, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MED - phase 2 +c - - - - - - +c En sortie, on a des tableaux caracteristiques des champs contenus +c dans le fichier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcham . e . 1 . nombre de champs a lire . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . nbfonc . s . 1 . nombre de fonctions . +c . defonc . s . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . nofonc . s .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . option . e . 1 . 1 : on controle que l'on a les couples (aux. +c . . . . noeuds par element/aux points de Gauss) . +c . . . . 0 : pas de controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM2' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbcham, nbfonc, nbseal + integer defonc(nbinec,*) + integer option +c + character*8 nofonc(3,*) + character*8 nocham(nbcham) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer iaux + integer adcaen, adcaca, adnocp + integer nrocha, nbcomp + integer nbtvch, carsup + integer nrfonc +c + character*8 obcham + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de fonctions crees :'',i8)' +c + texte(2,4) = '(''Number of existing functions :'',i8)' +c +#include "impr03.h" +c +#include "esimpr.h" +c + nbfonc = 0 +c +c==== +c 2. reperage des fonctions par champ +c==== +c + if ( codret.eq.0 ) then +c + do 20 , nrocha = 1 , nbcham +c +c 2.1. ==> structure decrivant le champ +c + obcham = nocham(nrocha) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,37)) nompro, nrocha + write (ulsort,texte(langue,51)) obcham + call gmprsx (nompro, obcham ) +cgn call gmprsx (nompro, obcham//'.Cham_Ent' ) +cgn call gmprsx (nompro, obcham//'.Cham_Car' ) + call gmprsx (nompro, obcham//'.Nom_Comp' ) +#endif +c +c 2.2. ==> informations sur le champ +c + if ( codret.eq.0 ) then +c + call gmliat ( obcham, 1, nbcomp, codre1 ) + call gmliat ( obcham, 2, nbtvch, codre2 ) + call gmadoj ( obcham//'.Cham_Ent', adcaen, iaux, codre3 ) + call gmadoj ( obcham//'.Cham_Car', adcaca, iaux, codre4 ) + call gmadoj ( obcham//'.Nom_Comp', adnocp, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + if ( codret.eq.0 ) then + iaux = 64 + call uts8ch ( smem(adnocp), iaux, nomcha, + > ulsort, langue, codret ) + endif +c +c 2.3. ==> rangement des tableaux de valeurs dans des fonctions +c + if ( codret.eq.0 ) then +c + if ( nbtvch.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH3', nompro +#endif + iaux = nrocha + call eslch3 ( iaux, nomcha, nbcomp, nbtvch, + > imem(adcaen), smem(adcaca), + > nbfonc, defonc, nofonc, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) nbfonc + endif +#endif +c + 20 continue +c + endif +c +c==== +c 3. gestion des couples (aux noeuds par elements / aux points de Gauss) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. gestion des couples ; codret', codret +#endif +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + do 30 , nrfonc = 1 , nbfonc +c +c 3.1. ==> est-elle attachee a un champ aux noeuds par elements / aux +c points de Gauss ? +c + carsup = defonc (6,nrfonc) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,65+carsup)) +#endif +c +c 3.2. ==> si oui, on recherche la fonction associee +c + if ( carsup.ge.1 .and. carsup.le.2 ) then +c +c 3.2.1. ==> recherche des caracteristiques de son champ +c + if ( codret.eq.0 ) then +c + nrocha = defonc (10,nrfonc) + obcham = nocham(nrocha) + call gmadoj ( obcham//'.Cham_Ent', adcaen, iaux, codret ) +c + endif +c +c 3.2.2. ==> recherche de la fonction associee +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH7', nompro +#endif + call eslch7 ( nbtvch, imem(adcaen), nbseal, + > carsup, nbfonc, defonc, nrfonc, + > ulsort, langue, codret ) +c + endif +c + endif +c + 30 continue +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/ES_MED/eslsm3.F b/src/tool/ES_MED/eslsm3.F new file mode 100644 index 00000000..c78642dd --- /dev/null +++ b/src/tool/ES_MED/eslsm3.F @@ -0,0 +1,256 @@ + subroutine eslsm3 ( nbfonc, defonc, + > nofonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MED - phase 3 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions . +c . defonc . e . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . nofonc . es .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM3' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer defonc(nbinec,*) +c + character*8 nofonc(3,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nrfonc + integer typcha + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas +c + character*8 obfonc +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c +c==== +c 2. creations des fonctions +c==== +c + do 20 , nrfonc = 1 , nbfonc +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '=============================================' + write (ulsort,texte(langue,36)) nompro, nrfonc + write (ulsort,texte(langue,64)) defonc(1,nrfonc) + write (ulsort,texte(langue,69)) defonc(12,nrfonc) + write (ulsort,texte(langue,64)) defonc(1,nrfonc) + write (ulsort,texte(langue,57)) defonc(2,nrfonc) + write (ulsort,texte(langue,58)) defonc(3,nrfonc) + write (ulsort,texte(langue,62)) defonc(4,nrfonc) + do 229 , iaux = 1, defonc(5,nrfonc) + write (ulsort,texte(langue,60)) defonc(20+iaux,nrfonc) + 229 continue + write (ulsort,texte(langue,65+defonc(6,nrfonc))) + write (ulsort,texte(langue,111)) defonc(7,nrfonc) + if ( defonc(11,nrfonc).ge.0 .and. defonc(11,nrfonc).le.3 ) then + write (ulsort,texte(langue,100+defonc(11,nrfonc))) + else + write (ulsort,texte(langue,104)) + endif + write (ulsort,texte(langue,61)) nofonc(1,nrfonc) + write (ulsort,*) 'numero tableau : ',defonc(9,nrfonc) + if ( defonc(2,nrfonc).eq.ednopg ) then + write (ulsort,*) 'Allocation a ', + > defonc(3,nrfonc)*defonc(7,nrfonc), ' = ', + > defonc(3,nrfonc), '*', defonc(7,nrfonc) + else + write (ulsort,*) 'Allocation a ', + > defonc(3,nrfonc)*defonc(7,nrfonc)*defonc(2,nrfonc), ' = ', + > defonc(3,nrfonc), '*', defonc(7,nrfonc), '*', defonc(2,nrfonc) + endif +#endif +c + typcha = defonc(12,nrfonc) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFO', nompro +#endif + call utalfo ( obfonc, typcha, + > defonc(1,nrfonc), defonc(2,nrfonc), + > defonc(3,nrfonc), defonc(4,nrfonc), + > defonc(5,nrfonc), defonc(6,nrfonc), + > defonc(7,nrfonc), defonc(11,nrfonc), + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obfonc ) +#endif +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1, defonc(5,nrfonc) + imem(adtyas+iaux-1) = defonc(20+iaux,nrfonc) + 21 continue + nofonc(2,nrfonc) = obfonc +c + endif +c + 20 continue +c +c==== +c 3. memorisation des fonctions associees +c==== +c + do 30 , nrfonc = 1 , nbfonc +c + iaux = defonc(9,nrfonc) +c + if ( iaux.ne.0 ) then +c +c 3.1. ==> caracteristiques de la fonction courante +c + if ( codret.eq.0 ) then +c + obfonc = nofonc(2,nrfonc) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( obfonc, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) + endif +c +c 3.2. ==> memorisation du nom de la fonction associee +c + if ( codret.eq.0 ) then +c + smem(adprpg+2) = nofonc(2,iaux) +c + endif +c + endif +c + 30 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/ES_MED/eslsm4.F b/src/tool/ES_MED/eslsm4.F new file mode 100644 index 00000000..c81c95cf --- /dev/null +++ b/src/tool/ES_MED/eslsm4.F @@ -0,0 +1,255 @@ + subroutine eslsm4 ( idfmed, + > nbcham, obcham, + > nbfonc, defonc, nofonc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MED - phase 2 +c - - - - - - +c remarque : on ne lit que les champs reels +c remarque : on part du principe que les elements externes sont +c numerotes ainsi : tetraedres, triangles, segments, +c mailles-points, quadrangles, hexaedres, pyramides, +c pentaedres. +c C'est ce qui se passe a la lecture d'un maillage med par +c le programme eslmm2, lors de la creation du tableau des +c connectivite par noeuds. +c C'est aussi le cas pour la conversion du maillage apres +c adaptation (pcmav1). +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfmed . e . 1 . identifiant du fichier med en entree . +c . nbcham . e . 1 . nombre de champs dans le fichier . +c . obcham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nbfonc . e . 1 . nombre de fonctions . +c . defonc . e . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . nofonc . e .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM4' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer*8 idfmed + integer nbcham, nbfonc + integer defonc(nbinec,nbfonc) +c + character*8 obcham(nbcham) + character*8 nofonc(3,nbfonc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer nrocha +c + integer adnocp, adcaen, adcare, adcaca + integer nbcomp, nbtvch, typcha +c + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +c==== +c 2. lecture des valeurs, champ par champ +c==== +c + if ( codret.eq.0 ) then +c + do 20 , nrocha = 1 , nbcham +c +c 2.1. ==> informations sur la structure decrivant le champ +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '+++++++++++++++++++++++++++++++++++++++++++++' + write (ulsort,texte(langue,37)) nompro, nrocha + write (ulsort,texte(langue,51)) obcham(nrocha) + call gmprsx (nompro, obcham(nrocha)//'.Cham_Ent' ) + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif +c + call utcach ( obcham(nrocha), + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +cgn call gmprsx (nompro, obcham(nrocha)//'.Cham_Ent' ) +cgn call gmprsx (nompro, obcham(nrocha)//'.Cham_Car' ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Retour de utcach avec :' + write (ulsort,texte(langue,32)) nomcha + write (ulsort,texte(langue,111)) nbtvch + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'codret', codret +#endif +c + endif +c +c 2.2. ==> on passe en revue tous les tableaux du champ +c + if ( nbtvch.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + do 2222 , iaux = 1 , nbfonc + write (ulsort,*) '.. fonction numero', iaux,' /', nbfonc + write (ulsort,2220) (defonc(jaux,iaux),jaux=1,nbinec) + write (ulsort,2221) (nofonc(jaux,iaux),jaux=1,3) + 2222 continue + 2220 format(11i10) + 2221 format(5(a8,1x)) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLCH4', nompro +#endif + iaux = nrocha + call eslch4 ( idfmed, + > iaux, nomcha, nbcomp, nbtvch, + > obcham(nrocha), imem(adcaen), smem(adcaca), + > nbfonc, defonc, nofonc, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, obcham(nrocha) ) + call gmprsx (nompro, obcham(nrocha)//'.Nom_Comp' ) + call gmprsx (nompro, obcham(nrocha)//'.Cham_Ent' ) + call gmprsx (nompro, obcham(nrocha)//'.Cham_Ree' ) + call gmprsx (nompro, obcham(nrocha)//'.Cham_Car' ) + endif +#endif +c + 20 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/eslsm5.F b/src/tool/ES_MED/eslsm5.F new file mode 100644 index 00000000..a81f9a49 --- /dev/null +++ b/src/tool/ES_MED/eslsm5.F @@ -0,0 +1,547 @@ + subroutine eslsm5 ( nbfonc, defonc, nofonc, nbseal, + > nbpafo, noinpf, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MED - phase 5 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions . +c . defonc . e . nbinec*. description des fonctions en entier . +c . . . nbfonc . 1. type de support au sens MED . +c . . . . 2. nombre de points de Gauss . +c . . . . 3. nombre de valeurs . +c . . . . 4. nombre de valeurs du profil eventuel . +c . . . . 5. nombre de supports associes . +c . . . . 6. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 7. nombre de tableaux de ce type . +c . . . . 8. numero du tableau dans la fonction . +c . . . . 9. numero de la fonction associee si champ . +c . . . . aux noeuds par element ou points de Gaus. +c . . . . 10. numero HOMARD du champ associe . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 21-nbinec. type des supports associes . +c . nofonc . e .3*nbfonc. description des fonctions en caracteres . +c . . . . 1. nom de l'objet profil, blanc sinon . +c . . . . 2. nom de l'objet fonction . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . nbseal . e . 1 . nombre de sequences a lire . +c . . . . si -1, on lit tous les champs du fichier . +c . nbpafo . s . 1 . nombre de paquets de fonctions . +c . noinpf . s . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . option . e . 1 . 1 : on controle que l'on a les couples (aux. +c . . . . noeuds par element/aux points de Gauss) . +c . . . . 0 : pas de controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSM5' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbfonc, nbpafo, nbseal + integer defonc(nbinec,*) + integer option +c + character*8 nofonc(3,nbfonc), noinpf(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux, naux + integer nrfonc, nrinpf, nbfopa, nrpafo + integer nrofon + integer typcha + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, typint, nbtafo + integer advale, advalr, adobch, adprpg, adtyas + integer typch2 + integer typge2, ngaus2, nbenm2, nbvap2, nbtya2 + integer carsu2, nbtaf2, typin2 + integer advae2, advar2, adobc2, adobp2, adtya2 + integer adobfo, adtyge + integer adobf2, adtyg2 + integer typgpf, ngaupf, carspf, typipf + integer tbiaux(nbinec) +c + character*8 nomfon, saux08 + character*8 obpafo + character*8 tbsaux(1) +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + tbsaux(1) = blan08 +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''Creation du paquet de fonctions '',i3,'' : '',a)' + texte(1,5) = + > '(''Ajout de la '',i3,''-eme fonction dans le paquet '',a)' + texte(1,6) = '(''Impossible de trouver la fonction.'')' + texte(1,7) = '(''Impossible de trouver le paquet.'')' + texte(1,8) = '(''Nombre de paquets crees :'',i8)' +c + texte(2,4) = '(''Creation of pack of functions # '',i3,'' : '',a)' + texte(2,5) = '(''Addition of '',i3,''-th function in pack '',a)' + texte(2,6) = '(''Function cannot be found.'')' + texte(2,7) = '(''Pack cannot be found.'')' + texte(2,8) = '(''Number of created packs :'',i8)' +c +#include "impr03.h" +c + nbpafo = 0 +c +c==== +c 2. regroupement des fonctions en paquets +c==== +c + do 20 , nrfonc = 1 , nbfonc +c +c 2.1. ==> caracteristiques de la fonction a ranger +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,36)) nompro, nrfonc + call gmprsx (nompro, nofonc(2,nrfonc) ) +cgn call gmprsx (nompro, nofonc(2,nrfonc)//'.InfoCham' ) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'utcafo', nompro +#endif + call utcafo ( nofonc(2,nrfonc), + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Fonction numero ', nrfonc + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbenmx', nbenmx + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90003) 'champ ', smem(adobch) + write (ulsort,*) 'Profil ', smem(adprpg) + write (ulsort,*) 'Loca PG ', smem(adprpg+1) + write (ulsort,*) 'Fonc. As.', smem(adprpg+2) +#endif +c + endif +c +c 2.2. ==> on recherche s'il existe un paquet convenable +c + nrinpf = 0 +c + do 22 , iaux = 1 , nbpafo +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Examen du paquet numero', iaux +#endif +c +c 2.2.1. ==> caracteristiques de l'iaux-eme paquet de fonction +c + if ( codret.eq.0 ) then +c + obpafo = noinpf(iaux) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngaupf, carspf, typipf, + > adobfo, adtyge, + > ulsort, langue, codret ) +cgn write (ulsort,90002) 'kaux/tnpass', kaux +cgn write (ulsort,90002) 'laux/ngauss', laux +cgn write (ulsort,90002) 'maux/carsup', maux +cgn write (ulsort,90002) 'naux/typint', naux +c + endif +c +c 2.2.2. ==> le paquet convient si le support geometrique est +c simple, tout est identique +c + if ( typgpf.gt.0 ) then +c + if ( typgeo.eq.typgpf .and. + > ngauss.eq.ngaupf .and. + > carsup.eq.carspf .and. + > typint.eq.typipf ) then + nrinpf = iaux + goto 23 + endif +c +c 2.2.3. ==> ou ... si le support est multiple, le champ est le meme +c + elseif ( typgpf.lt.0 ) then +c + do 223 , jaux = 1 , nbfopa +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'utcafo', nompro +#endif +c + call utcafo ( smem(adobfo+jaux-1), + > typch2, + > typge2, ngaus2, nbenm2, nbvap2, nbtya2, + > carsu2, nbtaf2, typin2, + > advae2, advar2, adobc2, adobp2, adtya2, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( smem(adobch).eq.smem(adobc2) ) then + nrinpf = iaux + goto 23 + endif +c + endif +c + 223 continue +c + endif +c + 22 continue +c +c 2.3. ==> creation d'un nouveau paquet +c + 23 continue +c + if ( nrinpf.eq.0 ) then +c + if ( codret.eq.0 ) then +c + nbfopa = 0 + if ( nbtyas.le.0 ) then + typgpf = typgeo + else + typgpf = -(nbtyas+1) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPF', nompro +#endif + call utalpf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - apres UTALPF', obpafo ) +#endif +c + if ( codret.eq.0 ) then +c + nbpafo = nbpafo + 1 + noinpf(nbpafo) = obpafo +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpafo, obpafo +#endif +c + endif +c + if ( nbtyas.gt.0 ) then +c + if ( codret.eq.0 ) then +c + do 231 ,iaux = 1 , nbtyas + tbiaux(iaux) = imem(adtyas+iaux-1) + 231 continue + tbiaux(nbtyas+1) = typgeo +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif +c + iaux = nbtyas+1 + jaux = 5 + call utmopf ( obpafo, jaux, + > iaux, tbsaux, tbiaux, + > nofonc(2,nrfonc), + > nbfopa, kaux, laux, maux, naux, + > adobfo, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo//'.TypeSuAs' ) +#endif +c + endif +c + endif +c + endif +c +c 2.4. ==> ajout de la fonction dans le paquet +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMOPF', nompro +#endif +c + jaux = 1 + call utmopf ( obpafo, jaux, + > nbpafo, tbsaux, tbiaux, + > nofonc(2,nrfonc), + > nbfopa, kaux, laux, maux, naux, + > adobfo, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbfopa, obpafo + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) +#endif +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,8)) nbpafo + write (ulsort,93010) (noinpf(nrpafo),nrpafo = 1 , nbpafo) + endif +#endif +c +c==== +c 3. gestion des couples (aux noeuds par element/aux points de Gauss) +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. gestion des couples, codret',codret +#endif +c + if ( option.eq.1 ) then +c + do 30 , nrpafo = 1 , nbpafo +c +c 3.1. ==> caracteristiques du paquet +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Paquet numero', nrpafo +#endif +c + if ( codret.eq.0 ) then +c + obpafo = noinpf(nrpafo) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif +c + call utcapf ( obpafo, + > nbfopa, nbtyas, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,65+carsup)) + write (ulsort,90002) 'nbfopa', nbfopa + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + write (ulsort,93010) (smem(adobfo+iaux),' ',iaux=0,nbfopa) +#endif +c + endif +c +c 3.2. ==> on poursuit si c'est un paquet aux noeuds par element ou +c aux points de Gauss +c + if ( carsup.ge.1 .and. carsup.le.2 ) then +c +c 3.2.1. ==> Recherche du numero global de la premiere des fonctions +c du paquet +c + if ( codret.eq.0 ) then +c + nomfon = smem(adobfo) + do 321 , iaux = 1 , nbfonc + if ( nofonc(2,iaux).eq.nomfon ) then + nrofon = iaux + goto 3210 + endif + 321 continue + codret = 4 + write (ulsort,texte(langue,6)) +c + 3210 continue +c + endif +c +c 3.2.2. ==> Numero global et nom de la fonction associee +c + if ( codret.eq.0 ) then +c + iaux = defonc(9,nrofon) + saux08 = nofonc(2,iaux) +c + endif +c +c 3.2.3. ==> Recherche du paquet contenant cette fonction associee +c Rearque : inutile de chercher dans le paquet courant ... +c + if ( codret.eq.0 ) then +c + do 323 , iaux = 1 , nbpafo +c + if ( iaux.ne.nrpafo ) then +c + if ( codret.eq.0 ) then +c + obpafo = noinpf(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > jaux, kaux, laux, maux, naux, + > adobf2, adtyg2, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + do 3231 , nrofon = 1 , jaux + if ( smem(adobf2+nrofon-1).eq.saux08 ) then + smem(adobfo+nbfopa) = obpafo + goto 3230 + endif + 3231 continue +c + endif +c + endif +c + 323 continue +c + if ( nbseal.gt.0 .and. carsup.eq.2 ) then + write (ulsort,texte(langue,7)) + codret = 5 + endif +c + 3230 continue +c + endif +c + endif +c + 30 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + diff --git a/src/tool/ES_MED/eslsmd.F b/src/tool/ES_MED/eslsmd.F new file mode 100644 index 00000000..3fe38845 --- /dev/null +++ b/src/tool/ES_MED/eslsmd.F @@ -0,0 +1,312 @@ + subroutine eslsmd ( nocson, nochso, + > messin, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - Lecture d'une Solution au format MeD +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocson . s . char*8 . nom de l'objet solution calcul iteration n . +c . nochso . e . char*8 . nom des champs de solution a lire . +c . . . . si la chaine est blanche, on lit tout . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . option . e . 1 . 1 : on controle que l'on a les couples (aux. +c . . . . noeuds par element/aux points de Gauss) . +c . . . . 0 : pas de controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . . . . -1 : fichier inconnu . +c . . . . -2 : nom de maillage inconnu . +c ______________________________________________________________________ +c +c HOAPLS --> ESLSMD +c /ININFM +c ESLSMD -> ESLSM0 -> ESOUVL -> ESVERI -> MFICOM +c -> MLBSTV +c -> MFIOPE +c -> MFISVR +c -> MFICLO +c -> MFIOPE +c -> ESLENT -> MFICOR +c -> ESLNOM -> MMHNMH +c -> MMHMII +c -> MFDNFD +c -> MLCNLC +c -> ESLSM1 -> MFDNFC +c -> MFDFDI +c -> ESLCH1 -> ESLCH2 -> MFDCSI +c -> MFDNPF +c -> ESLPR1 -> MPFPSN +c -> MPFPRR +c -> ESLPG1 -> ESLPG2 -> MLCNLC +c -> MLCLCI +c -> MLCLOR +c -> MFDNPN +c -> ESLCH6 +c -> ESLSM2 -> ESLCH3 +c -> ESLCH7 +c -> ESLSM3 +c -> ESLSM4 -> ESLCH4 -> MFDRPR +c -> ESLCH5 +c -> ESLSM5 +c -> MFICLO +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESLSMD' ) +c +#include "nblang.h" +c +#include "motcle.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 nocson, nochso +c + integer messin, option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lnomfi, lnomam + integer nbseal, nbtosv + integer adcact, adcaet, adcart +c + character*8 typobs + character*64 nomamd + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "esimpr.h" +c +c 1.2. ==> nom du fichier contenant la solution +c + typobs = mccson + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) 'en entree' + codret = -1 + endif +c +c 1.3. ==> nom du maillage dans ce fichier +c + if ( codret.eq.0 ) then +c + typobs = mccnmn + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomamd, lnomam, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + call utosme ( typobs, ulsort, langue ) + if ( codret.eq.4 ) then + write (ulsort,texte(langue,52)) lnomam + write (ulsort,texte(langue,53)) len(nomamd) + codret = -2 + endif + endif +c + endif +c +c==== +c 2. liste des champs a lire +c si nbseal = -1, on lira tous les champs du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. liste des champs a lire ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '... Debut de 2., codret',codret + write (ulsort,*) '... Debut de 2., nochso =',nochso + if ( nochso.ne.blan08 ) then + write (ulsort,*) '... Champs a lire :' +cgn call gmprsx (nompro,nochso) + call gmprsx (nompro, nochso//'.CarCaChp' ) + call gmprsx (nompro, nochso//'.CarEnChp' ) + call gmprsx (nompro, nochso//'.CarReChp' ) + endif + write (ulsort,texte(langue,3)) 'ESLSCH', nompro +#endif + call eslsch ( nochso, + > nbseal, adcact, adcaet, adcart, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 2, nbseal', nbseal +#endif +c +c==== +c 3. lecture vraie +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. lecture vraie ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSM0', nompro +#endif + call eslsm0 ( nocson, nomfic, lnomfi, + > nomamd, lnomam, + > nbseal, nbtosv, + > smem(adcact), imem(adcaet), rmem(adcart), + > messin, option, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,111)) nbtosv + call gmprsx (nompro, nocson) + call gmprsx (nompro, nocson//'.InfoCham') + call gmprsx (nompro, nocson//'.InfoPaFo') + call gmprsx (nompro, nocson//'.InfoProf') + call gmprsx (nompro, nocson//'.InfoLoPG') + call gmprsx (nompro, '%%%%%%%7') + call gmprsx (nompro, '%%%%%%%9') + call gmprsx (nompro, '%%Fo002o') + call gmprsx (nompro, '%%%%%%%8') + call gmprsx (nompro, '%%%%%%%8.InfoCham') + call gmprsx (nompro, '%%%%%%%8.InfoPrPG') + call gmprsx (nompro, '%%%%%%%8.ValeursR') + endif +#endif +c +c==== +c 4. message si on n'a pas trouve les champs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. message ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c + iaux = codret +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSC1', nompro +#endif + call eslsc1 ( nomfic, lnomfi, + > messin, + > ulsort, langue, codret ) +c + codret = iaux +c + endif +c +c==== +c 5. menage +c==== +c + if ( codret.eq.0 ) then +c + if ( nochso.ne.blan08 ) then +c + call gmsgoj (nochso, codret) +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.ne.-1 ) then + write (ulsort,texte(langue,8)) nomfic + endif + if ( codret.gt.0 ) then + write (ulsort,texte(langue,22)) nomamd + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esouvl.F b/src/tool/ES_MED/esouvl.F new file mode 100644 index 00000000..234273ca --- /dev/null +++ b/src/tool/ES_MED/esouvl.F @@ -0,0 +1,166 @@ + subroutine esouvl ( idfich, nomfic, messin, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - OUVerture d'un fichier MED en Lecture +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . idfich . s . 1 . identifiant du fichier . +c . nomfic . e . char* . nom du fichier a ouvrir . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESOUVL' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer*8 idfich + integer messin +c + character*(*) nomfic +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c +#include "meddc0.h" +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c +c==== +c 2. ouverture +c==== +c +c 2.1. ==> verification du fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESVERI', nompro +#endif + call esveri ( nomfic, messin, ulsort, langue, codret ) +c + endif +c +c 2.2. ==> ouverture du fichier +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFIOPE', nompro +#endif + call mfiope ( idfich, nomfic, edlect, codret) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) nomfic + write (ulsort,texte(langue,9)) + endif +c + endif +c +c 2.3. ==> information sur le fichier +c + if ( codret.eq.0 ) then +c + if ( mod(messin,3).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLENT', nompro +#endif + call eslent ( idfich, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) nomfic +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_MED/esveri.F b/src/tool/ES_MED/esveri.F new file mode 100644 index 00000000..9b73c422 --- /dev/null +++ b/src/tool/ES_MED/esveri.F @@ -0,0 +1,255 @@ + subroutine esveri ( nomfic, messin, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - VERIfication du fichier +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomfic . e . 1 . nom du fichier a examiner . +c . messin . e . 1 . message d'informations . +c . . . . impressions MED si multiple de 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : fichier inexistant . +c . . . . 2 : probleme de version HDF du fichier . +c . . . . 3 : probleme de version MED du fichier . +c . . . . 4 : impossible trouver version MED HOMARD . +c . . . . 5 : impossible trouver version MED fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ESVERI' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer messin +c + character*(*) nomfic +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer*8 idfmed + integer hdfok, medok + integer lgvhom, lgvfic +c + logical old +c + character*200 verhom, verfic +c + integer nbmess + parameter ( nbmess = 150 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "esimpr.h" +c + texte(1,4) = '(''Fichier : '',a)' + texte(1,11) = '(''Ce fichier n''''existe pas.'')' + texte(1,12) = '(''La version HDF est incompatible.'')' + texte(1,13) = '(''La version MED est incompatible.'')' + texte(1,14) = + > '(''Impossible de trouver la bibliotheque MED de HOMARD.'')' + texte(1,15) = + > '(''Impossible de trouver la bibliotheque MED du fichier.'')' + texte(1,16) = '(''Impossible de fermer le fichier.'')' +c + texte(2,4) = '(''File: '',a)' + texte(2,11) = '(''This file does not exist.'')' + texte(2,12) = '(''HDF release is uncorrect.'')' + texte(2,13) = '(''MED release is uncorrect.'')' + texte(2,14) = '(''MED library for HOMARD cannot be found.'')' + texte(2,15) = '(''MED library for file cannot be found.'')' + texte(2,16) = '(''The file cannot be closed.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomfic +#endif +c +c==== +c 2. verifications +c==== +c + codret = 0 +c +c 2.1. ==> Existence +c + if ( codret.eq.0 ) then +c + inquire ( file = nomfic, exist = old ) + if ( .not.old ) then + codret = 1 + endif +c + endif +c +c 2.2. ==> Compatibilite du fichier en version HDF et MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICOM', nompro +#endif + call mficom ( nomfic, hdfok, medok, codret ) + if ( codret.ne.0 ) then + codret = 1 + endif + if ( hdfok.ne.1 ) then + codret = 2 + endif + if ( medok.ne.1 ) then + codret = 3 + endif +c + endif +cgn print *,codret,hdfok, medok,messin +c +c 2.3. ==> Details +c + if ( ( codret.eq.0 .and. mod(messin,3).eq.0 ) .or. + > codret.eq.2 .or. + > codret.eq.3 ) then +c +c 2.4.1. ==> versions de la bibliotheque MED utilisee par HOMARD +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MLBSTV', nompro +#endif + call mlbstv ( verhom, iaux ) +c + if ( iaux.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLGUT', nompro +#endif + call utlgut ( lgvhom, verhom, + > ulsort, langue, iaux ) + if ( iaux.eq.0 ) then + write (ulsort,texte(langue,46)) 'HOMARD', verhom(1:lgvhom) + else + codret = 4 + endif + else + codret = 4 + endif +c +c 2.4.2. ==> versions de la bibliotheque MED du fichier +c + if ( iaux.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFIOPE', nompro +#endif + call mfiope ( idfmed, nomfic, edlect, iaux ) + if ( iaux.ne.0 ) then + codret = 5 + endif + endif +c + if ( iaux.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFISVR', nompro +#endif + call mfisvr ( idfmed, verfic, iaux ) + if ( iaux.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLGUT', nompro +#endif + call utlgut ( lgvfic, verfic, + > ulsort, langue, iaux ) + if ( iaux.eq.0 ) then + write (ulsort,texte(langue,46)) nomfic, verfic(1:lgvfic) + else + codret = 5 + endif + else + codret = 5 + endif + endif +c + if ( iaux.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MFICLO', nompro +#endif + call mficlo ( idfmed, iaux ) + if ( iaux.ne.0 ) then + codret = 6 + endif + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) nomfic + write (ulsort,texte(langue,codret+10)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/CMakeLists.txt b/src/tool/ES_Xfig/CMakeLists.txt new file mode 100644 index 00000000..3204ed38 --- /dev/null +++ b/src/tool/ES_Xfig/CMakeLists.txt @@ -0,0 +1,37 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de ES_Xfig + +SET(ES_Xfig_SOURCES + ./pppma1.F + ./pppma2.F + ./pppma3.F + ./pppma4.F + ./pppma5.F + ./pppxma.F + ./ppxma5.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/ES_Xfig ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (ES_Xfig ${ES_Xfig_SOURCES}) + +INSTALL(TARGETS ES_Xfig EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/ES_Xfig/pppma1.F b/src/tool/ES_Xfig/pppma1.F new file mode 100644 index 00000000..43170c90 --- /dev/null +++ b/src/tool/ES_Xfig/pppma1.F @@ -0,0 +1,429 @@ + subroutine pppma1 ( typcof, + > lgtcmx, tbcols, tbcoli, ncotbl, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - Preparation du MAillage - phase 1 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 3 : famille HOMARD, sans orientation . +c . . . . 4/5 : idem 2/3, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . lgtcmx . e . 1 . longueur maximale de la table de couleur . +c . tbcoli . e . . table de couleur entier . +c . tbcols . s .char*17 . table de couleur caracteres . +c . . . (-3: . Les immuables sont : . +c . . . lgtcmx). -3 : defaut de xfig . +c . . . . -2 : noir . +c . . . . -1 : blanc . +c . . . . lgtcmx-2 : rouge pour les aretes de bord . +c . . . . lgtcmx-1 : un gris pale pour les familles . +c . . . . libres et le triedre . +c . . . . lgtcmx : un vert pale (cadre de zoom) . +c . ncotbl . s . 1 . nombre de couleurs dans la table . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPMA1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgtcmx, typcof, ncotbl + integer nbtrvi, nbquvi + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer tbcoli(-3:lgtcmx) +c + character*17 tbcols(-2:lgtcmx) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + double precision daux +c + character*3 saux03 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c Codification Xfig : +c -1 = Default +c 0 = Black +c 1 = Blue +c 2 = Green +c 3 = Cyan +c 4 = Red +c 5 = Magenta +c 6 = Yellow +c 7 = White +c 8-11 = four shades of blue (dark to lighter) +c 12-14 = three shades of green (dark to lighter) +c 15-17 = three shades of cyan (dark to lighter) +c 18-20 = three shades of red (dark to lighter) +c 21-23 = three shades of magenta (dark to lighter) +c 24-26 = three shades of brown (dark to lighter) +c 27-30 = four shades of pink (dark to lighter) +c 31 = Gold +c_______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. les immuables +c -3 : defaut de xfig +c -2 : noir +c -1 : blanc +c lgtcmx-2 : rouge pour les aretes de bord +c lgtcmx-1 : un gris pale pour les familles libres et le triedre +c lgtcmx : un vert pale (pour la fenetre de zoom) +c==== +c + tbcols(-2) = '0.000 0.000 0.000' + tbcols(-1) = '1.000 1.000 1.000' +c + tbcols(lgtcmx-2) = '1.000 0.000 0.000' + tbcols(lgtcmx-1) = '0.800 0.800 0.800' + tbcols(lgtcmx) = '0.100 0.600 0.200' +c + tbcoli(-3) = -1 + tbcoli(-2) = 0 + tbcoli(-1) = 7 +c + tbcoli(lgtcmx-2) = 4 + tbcoli(lgtcmx-1) = 30 + tbcoli(lgtcmx) = 14 +c +c==== +c 3. pour un coloriage par valeur discrete : niveau ou famille +c typcof compris entre 1 et 5 +c==== +c 3.1. ==> en couleur ; typcof valant 2, 3 ou 10 +c 0 : bleu +c 1 : rouge +c 2 : vert +c 3 : magenta +c 4 : turquoise +c 5 : jaune +c etc +c pour xfig on est limite a 31 +c + if ( typcof.eq.2 .or. typcof.eq.3 .or. typcof.eq.10 ) then +c + tbcols(0) = '0.000 0.000 1.000' + tbcoli(0) = 1 + tbcols(1) = '1.000 0.000 0.000' + tbcoli(1) = 4 + tbcols(2) = '0.000 1.000 0.000' + tbcoli(2) = 2 + tbcols(3) = '1.000 0.000 1.000' + tbcoli(3) = 5 + tbcols(4) = '0.000 1.000 1.000' + tbcoli(4) = 3 + tbcols(5) = '1.000 1.000 0.000' + tbcoli(5) = 6 + tbcols(6) = '0.200 0.400 0.600' + tbcoli(6) = 27 + tbcols(7) = '0.400 0.600 0.200' + tbcoli(7) = 24 + tbcols(8) = '0.600 0.200 0.400' + tbcoli(8) = 21 + tbcols(9) = '0.100 0.200 0.800' + tbcoli(9) = 18 + tbcols(10) = '0.800 0.200 0.100' + tbcoli(10) = 15 + kaux = 0 + do 311 , iaux = 1 , nbtrvi + kaux = max ( kaux, nntrvi(6,iaux) ) + 311 continue + do 312 , iaux = 1 , nbquvi + kaux = max ( kaux, nnquvi(7,iaux) ) + 312 continue + if ( kaux.gt.10 ) then + do 313 , iaux = 11 , kaux + tbcols(iaux) = '0.000 0.000 0.000' + call utench ( iaux, 'g', jaux, saux03, + > ulsort, langue, codret ) + tbcols(iaux)(3:2+jaux) = saux03(1:jaux) + call utench ( 100+iaux, 'g', jaux, saux03, + > ulsort, langue, codret ) + tbcols(iaux)(9:8+jaux) = saux03(1:jaux) + call utench ( mod(iaux,100), 'g', jaux, saux03, + > ulsort, langue, codret ) + tbcols(iaux)(15:14+jaux) = saux03(1:jaux) + if ( mod(iaux-11,18).eq.0 ) then + tbcoli(iaux) = 8 + elseif ( mod(iaux-11,17).eq.1 ) then + tbcoli(iaux) = 12 + elseif ( mod(iaux-11,17).eq.2 ) then + tbcoli(iaux) = 16 + elseif ( mod(iaux-11,17).eq.3 ) then + tbcoli(iaux) = 19 + elseif ( mod(iaux-11,17).eq.4 ) then + tbcoli(iaux) = 22 + elseif ( mod(iaux-11,17).eq.5 ) then + tbcoli(iaux) = 9 + elseif ( mod(iaux-11,17).eq.6 ) then + tbcoli(iaux) = 13 + elseif ( mod(iaux-11,17).eq.7 ) then + tbcoli(iaux) = 28 + elseif ( mod(iaux-11,17).eq.8 ) then + tbcoli(iaux) = 25 + elseif ( mod(iaux-11,17).eq.9 ) then + tbcoli(iaux) = 10 + elseif ( mod(iaux-11,17).eq.10 ) then + tbcoli(iaux) = 14 + elseif ( mod(iaux-11,17).eq.11 ) then + tbcoli(iaux) = 17 + elseif ( mod(iaux-11,17).eq.12 ) then + tbcoli(iaux) = 29 + elseif ( mod(iaux-11,17).eq.13 ) then + tbcoli(iaux) = 20 + elseif ( mod(iaux-11,17).eq.14 ) then + tbcoli(iaux) = 23 + elseif ( mod(iaux-11,17).eq.15 ) then + tbcoli(iaux) = 26 + elseif ( mod(iaux-11,17).eq.16 ) then + tbcoli(iaux) = 11 + elseif ( mod(iaux-11,17).eq.17 ) then + tbcoli(iaux) = 30 + endif + 313 continue + endif +c +c 3.2. ==> en niveau de gris ; typcof compris entre 4 et 5 +c 0 : blanc +c 1 : gris tres tres clair +c 2 : gris tres clair +c etc +c + elseif ( typcof.ge.4 .and. typcof.le.5 ) then +c +c + tbcols(0) = '1.000 1.000 1.000' + tbcoli(0) = 7 + kaux = 0 + do 321 , iaux = 1 , nbtrvi + kaux = max ( kaux, nntrvi(6,iaux) ) + 321 continue + do 322 , iaux = 1 , nbquvi + kaux = max ( kaux, nnquvi(7,iaux) ) + 322 continue + daux = 999.d0/dble(kaux) + do 333 , iaux = 1 , kaux + tbcols(iaux) = '0.000 0.000 0.000' + jaux = int ( dble(iaux)*daux ) + saux03 = '000' + call utench ( jaux, '0', laux, saux03, + > ulsort, langue, codret ) + tbcols(iaux)( 3: 6) = saux03 + tbcols(iaux)( 9:12) = saux03 + tbcols(iaux)(15:17) = saux03 + tbcoli(iaux) = 0 + 333 continue +c +c==== +c 4. pour un coloriage par valeur continue : fonction +c typcof valant +-6 ou +-7 +c==== +c + elseif ( abs(typcof).eq.6 .or. abs(typcof).eq.7 ) then +c +c Pour l'ancien PostScript, pour memoire +c on fait un degrade du minimum, 0/bleu, au maximum, 22/rouge +c la progression en RGB est issue des travaux presentes sur : +c http://the-light.com/colclick.html +c + laux = 39 + daux = 1000.d0/(dble(laux+1)) +c +c bleu pur +c + tbcols(0) = '0.000 0.000 1.000' +c +c nuances de bleu a turquoise : on augmente le G +c + ncotbl = 0 + do 41 , iaux = 1, laux + kaux = nint(daux*dble(iaux)) + call utench ( kaux, '0', jaux, saux03, + > ulsort, langue, codret ) + ncotbl = ncotbl + 1 +c 12345678901234567 + tbcols(ncotbl) = '0.000 0.zzz 1.000' + tbcols(ncotbl)(9:11) = saux03 + 41 continue +c +c turquoise pur +c + ncotbl = ncotbl + 1 + tbcols(ncotbl) = '0.000 1.000 1.000' +c +c nuances de turquoise a vert : on diminue le B +c + do 42 , iaux = laux , 1, -1 + kaux = nint(daux*dble(iaux)) + call utench ( kaux, '0', jaux, saux03, + > ulsort, langue, codret ) + ncotbl = ncotbl + 1 +c 12345678901234567 + tbcols(ncotbl) = '0.000 1.000 0.zzz' + tbcols(ncotbl)(15:17) = saux03 + 42 continue +c +c vert pur +c + ncotbl = ncotbl + 1 + tbcols(ncotbl) = '0.000 1.000 0.000' +c +c nuances de vert a jaune : on augmente le R +c + do 43 , iaux = 1, laux + kaux = nint(daux*dble(iaux)) + call utench ( kaux, '0', jaux, saux03, + > ulsort, langue, codret ) + ncotbl = ncotbl + 1 +c 12345678901234567 + tbcols(ncotbl) = '0.zzz 1.000 0.000' + tbcols(ncotbl)(3:5) = saux03 + 43 continue +c +c jaune pur +c + ncotbl = ncotbl + 1 + tbcols(ncotbl) = '1.000 1.000 0.000' +c +c nuances de jaune a rouge : on diminue le G +c + do 44 , iaux = laux , 1, -1 + kaux = nint(daux*dble(iaux)) + call utench ( kaux, '0', jaux, saux03, + > ulsort, langue, codret ) + ncotbl = ncotbl + 1 +c 12345678901234567 + tbcols(ncotbl) = '1.000 0.zzz 0.000' + tbcols(ncotbl)(9:11) = saux03 + 44 continue +c +c rouge pur +c + ncotbl = ncotbl + 1 + tbcols(ncotbl) = '1.000 0.000 0.000' +c +c Pour Xfig, on fait un degrade du minimum, 0/bleu sombre, au +c maximum, 7/rouge +c + tbcoli(0) = 8 + tbcoli(1) = 1 + tbcoli(2) = 3 + tbcoli(3) = 2 + tbcoli(4) = 6 + tbcoli(5) = 31 + tbcoli(6) = 4 + tbcoli(7) = 18 +c + ncotbl = 7 +c + endif +c +cgn print 1789,(tbcols(iaux),iaux=-2,ncotbl) +cgn 1789 format(a17) +cgn print *,'ncotbl = ',ncotbl +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/pppma2.F b/src/tool/ES_Xfig/pppma2.F new file mode 100644 index 00000000..de462e62 --- /dev/null +++ b/src/tool/ES_Xfig/pppma2.F @@ -0,0 +1,246 @@ + subroutine pppma2 ( vafomi, vafoma, + > typcof, nbtrvi, nbquvi, + > fotrva, foquva, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - Preparation du MAillage - phase 2 +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . vafomi . s . 1 . minimum de l'echelle de la fonction . +c . vafoma . s . 1 . maximum de l'echelle de la fonction . +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 3 : famille HOMARD, sans orientation . +c . . . . 4/5 : idem 2/3, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . fotrva . e . nbtrvi . fonctions triangles : valeur . +c . foquva . e . nbquvi . fonctions quadrangles : valeur . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPMA2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typcof + integer nbtrvi, nbquvi + integer ulsost +c + double precision vafomi, vafoma + double precision fotrva(nbtrvi), foquva(nbquvi) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c_______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Type de coloriage :'',i6)' + texte(1,5) = '(''Fonction sur les '',a)' + texte(1,6) = '(''min = '',g12.5,'', max = '',g12.5)' +c + texte(2,4) = '(''Colouring type :'',i6)' + texte(2,5) = '(''Function over '',a)' + texte(2,6) = '(''min = '',g12.5,'', max = '',g12.5)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) typcof + write (ulsort,90002) 'nbtrvi', nbtrvi + write (ulsort,90002) 'nbquvi', nbquvi +#endif +cgn write (ulsort,*) 'fotrva' +cgn write (ulsort,92010) (fotrva(iaux), iaux = 1 , nbtrvi) +cgn write (ulsort,*) 'foquva' +cgn write (ulsort,92010) (foquva(iaux), iaux = 1 , nbquvi) +c +c==== +c 2. fonction exprimee sur les triangles +c==== +c + if ( nbtrvi.ne.0 ) then +c +c 2.1. ==> valeur brute +c + if ( typcof.gt.0 ) then +c + vafomi = fotrva(1) + vafoma = vafomi +c + do 21 , iaux = 2 , nbtrvi + vafomi = min (vafomi,fotrva(iaux)) + vafoma = max (vafoma,fotrva(iaux)) + 21 continue +c +c 2.2. ==> valeur absolue +c + else +c + vafomi = abs(fotrva(1)) + vafoma = vafomi +c + do 22 , iaux = 2 , nbtrvi + vafomi = min (vafomi,abs(fotrva(iaux))) + vafoma = max (vafoma,abs(fotrva(iaux))) + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + iaux = 2 + write (ulsort,texte(langue,5)) mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) vafomi, vafoma + if ( ulsost.ne.ulsort ) then + write (ulsost,texte(langue,5)) mess14(langue,3,iaux) + write (ulsost,texte(langue,6)) vafomi, vafoma + endif +#endif +c + endif +c +c==== +c 3. fonction exprimee sur les quadrangles +c==== +c + if ( nbquvi.ne.0 ) then +c +c 3.1. ==> valeur brute +c + if ( typcof.gt.0 ) then +c + if ( nbtrvi.eq.0 ) then + vafomi = foquva(1) + vafoma = vafomi + endif +c + do 31 , iaux = 2 , nbquvi + vafomi = min (vafomi,foquva(iaux)) + vafoma = max (vafoma,foquva(iaux)) + 31 continue +c +c 3.2. ==> valeur absolue +c + else +c + if ( nbtrvi.eq.0 ) then + vafomi = abs(foquva(1)) + vafoma = vafomi + endif +c + do 32 , iaux = 2 , nbquvi + vafomi = min (vafomi,abs(foquva(iaux))) + vafoma = max (vafoma,abs(foquva(iaux))) + 32 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( nbquvi.ne.0 ) then +c + if ( nbtrvi.eq.0 ) then + iaux = 4 + else + iaux = 8 + endif +c + write (ulsort,texte(langue,5)) mess14(langue,3,iaux) + write (ulsost,texte(langue,5)) mess14(langue,3,iaux) + write (ulsort,texte(langue,6)) vafomi, vafoma + write (ulsost,texte(langue,6)) vafomi, vafoma +c + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/pppma3.F b/src/tool/ES_Xfig/pppma3.F new file mode 100644 index 00000000..feddcd75 --- /dev/null +++ b/src/tool/ES_Xfig/pppma3.F @@ -0,0 +1,494 @@ + subroutine pppma3 ( nbtrvi, nbquvi, + > nntrvi, nnquvi, + > coopro, + > posini, xyzfac, tabaux, nivsup, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - Preparation du MAillage - phase 3 +c - - - -- - +c ______________________________________________________________________ +c +c but : recherche de l'ordre d'affichage des faces pour les cacher +c +c par defaut, on affiche les objets vus par l'observateur avec +c l'axe (oz+) dans l'oeil, donc regardant de z>0 vers z<0. +c on utilise l'algorithme dit du peintre, ou encore du z-buffer +c utilise par les affichages graphiques standards, consistant a +c imprimer les objets dans l'ordre inverse de leur eloignement, +c i.e. a imprimer en dernier, et donc par dessus le reste, les +c objets les plus proches. (donc avec les z les plus grands) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . coopro . e . 3* . coordonnees projetees de : . +c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K . +c . . . . la fenetre de zoom : de -7 a 0 en 3D ou . +c . . . . de -3 a 0 en 2D . +c . . . . les noeuds de 1 a nbnoto . +c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des . +c . . .+nbtrvi . faces en fonction de l'affichage . +c . xyzfac . / .nbtrvi+ . tableau de travail reel . +c . . .nbtrvi,9. . +c . tabaux . aux . nbquvi . tableau auxiliaire . +c . . .+nbtrvi . . +c . nivsup . e . 1 . niveau superieur present dans le maillage . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ._____________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPMA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer nivsup + integer nbtrvi, nbquvi + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer posini(nbtrvi+nbquvi) + integer tabaux(nbtrvi+nbquvi) +c + double precision coopro(3,-11:nbnoto) + double precision xyzfac(nbtrvi+nbquvi,9) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nutrvi, nuquvi + integer nbfavi + integer rangfa, rangqu + integer nbfast, nbfas0 + integer rangfd + integer iaux, jaux +c + double precision daux + double precision borne + double precision xminfa, xmaxfa + double precision yminfa, ymaxfa + double precision zminfa, zmaxfa + double precision coface(2,3) + double precision v1(3), v2(3), v3(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data borne / 1.d-8 / +c +c 0.5. ==> initialisations +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtrvi', nbtrvi + write (ulsort,90002) 'nbquvi', nbquvi + write (ulsort,90002) 'sdim ', sdim + write (ulsort,90002) 'nivsup', nivsup +#endif +c + codret = 0 +c +c==== +c 2. En dimension 2, les faces sont reclassses par niveau croissant +c A la fin de cette etape, posini(1) contient l'indice de la face a +c tracer en premier, parce que la plus loin, posini(2) contient +c l'indice de la suivante a tracer et ainsi de suite, jusqu'a +c posini(nbfavi) qui contient l'indice de la derniere face +c a tracer parce que la plus proche de l'observateur. +c Attention : posini ne contient pas les numeros des faces mais une +c indirection dans la liste des faces a traiter. +c==== +cgn do 34 , jaux = 1 , nbnoto +cgn write(*,1797)jaux,(coopro(iaux,jaux),iaux=1,sdim) +cgn 34 continue +c + if ( sdim.le.2 ) then +c + jaux = 0 +c + do 21 , iaux = 0 , nivsup+1 +c + do 211 , nutrvi = 1 , nbtrvi + if ( nntrvi(1,nutrvi).eq.iaux ) then + jaux = jaux + 1 + posini(jaux) = nutrvi + endif + 211 continue +c + do 212 , nuquvi = 1 , nbquvi + if ( nnquvi(1,nuquvi).eq.iaux ) then + jaux = jaux + 1 + posini(jaux) = nbtrvi+nuquvi + endif + 212 continue +c + 21 continue +c +c==== +c 2. En dimension 3, on applique l'algorithme du z-buffer +c==== +c + else +c +c==== +c 3. Calcul des dimensions extremes des faces et des vecteurs normaux +c==== +c 3.1. ==> Extrema pour un triangle +c + do 31 , nutrvi = 1 , nbtrvi +c + xminfa = min(coopro(1,nntrvi(3,nutrvi)), + > coopro(1,nntrvi(4,nutrvi)),coopro(1,nntrvi(5,nutrvi))) + xmaxfa = max(coopro(1,nntrvi(3,nutrvi)), + > coopro(1,nntrvi(4,nutrvi)),coopro(1,nntrvi(5,nutrvi))) + xyzfac(nutrvi,1) = xminfa + borne * (xmaxfa - xminfa) + xyzfac(nutrvi,2) = xmaxfa - borne * (xmaxfa - xminfa) +c + yminfa = min(coopro(2,nntrvi(3,nutrvi)), + > coopro(2,nntrvi(4,nutrvi)),coopro(2,nntrvi(5,nutrvi))) + ymaxfa = max(coopro(2,nntrvi(3,nutrvi)), + > coopro(2,nntrvi(4,nutrvi)),coopro(2,nntrvi(5,nutrvi))) + xyzfac(nutrvi,3) = yminfa + borne * (ymaxfa - yminfa) + xyzfac(nutrvi,4) = ymaxfa - borne * (ymaxfa - yminfa) +c + zminfa = min(coopro(3,nntrvi(3,nutrvi)), + > coopro(3,nntrvi(4,nutrvi)),coopro(3,nntrvi(5,nutrvi))) + zmaxfa = max(coopro(3,nntrvi(3,nutrvi)), + > coopro(3,nntrvi(4,nutrvi)),coopro(3,nntrvi(5,nutrvi))) + xyzfac(nutrvi,5) = zminfa + borne * (zmaxfa - zminfa) + xyzfac(nutrvi,6) = zmaxfa - borne * (zmaxfa - zminfa) +cgn write(*,1798)nutrvi,(nntrvi(iaux,nutrvi),iaux=2,5), +cgn > (xyzfac(nutrvi,iaux),iaux=1,6) +c + 31 continue +c +c 3.2. ==> Extrema pour un quadrangle +c + do 32 , nuquvi = 1 , nbquvi +c + xminfa = coopro(1,nnquvi(3,nuquvi)) + xmaxfa = xminfa + yminfa = coopro(2,nnquvi(3,nuquvi)) + ymaxfa = yminfa + zminfa = coopro(3,nnquvi(3,nuquvi)) + zmaxfa = zminfa + do 321 , iaux = 4 , 6 + daux = coopro(1,nnquvi(iaux,nuquvi)) + xminfa = min ( daux , xminfa ) + xmaxfa = max ( daux , xmaxfa ) + daux = coopro(2,nnquvi(iaux,nuquvi)) + yminfa = min ( daux , yminfa ) + ymaxfa = max ( daux , ymaxfa ) + daux = coopro(3,nnquvi(iaux,nuquvi)) + zminfa = min ( daux , zminfa ) + zmaxfa = max ( daux , zmaxfa ) + 321 continue + rangfa = nbtrvi+nuquvi + xyzfac(rangfa,1) = xminfa + borne * (xmaxfa - xminfa) + xyzfac(rangfa,2) = xmaxfa - borne * (xmaxfa - xminfa) + xyzfac(rangfa,3) = yminfa + borne * (ymaxfa - yminfa) + xyzfac(rangfa,4) = ymaxfa - borne * (ymaxfa - yminfa) + xyzfac(rangfa,5) = zminfa + borne * (zmaxfa - zminfa) + xyzfac(rangfa,6) = zmaxfa - borne * (zmaxfa - zminfa) +cgn write(*,1799)nuquvi,(nnquvi(iaux,nuquvi),iaux=2,6), +cgn > (xyzfac(nuquvi,iaux),iaux=1,6) +c + 32 continue +c +c 3.3. ==> Vecteurs normaux +c + nbfavi = nbtrvi + nbquvi +cgn write (ulsort,1795) 'nbfavi', nbfavi + do 33 , rangfa = 1 , nbfavi +c + if ( rangfa.le.nbtrvi ) then + v1(1) = coopro(1,nntrvi(3,rangfa)) + v1(2) = coopro(2,nntrvi(3,rangfa)) + v1(3) = coopro(3,nntrvi(3,rangfa)) + v2(1) = coopro(1,nntrvi(4,rangfa)) + v2(2) = coopro(2,nntrvi(4,rangfa)) + v2(3) = coopro(3,nntrvi(4,rangfa)) + v3(1) = coopro(1,nntrvi(5,rangfa)) + v3(2) = coopro(2,nntrvi(5,rangfa)) + v3(3) = coopro(3,nntrvi(5,rangfa)) + else + rangqu = rangfa - nbtrvi + v1(1) = coopro(1,nnquvi(3,rangqu)) + v1(2) = coopro(2,nnquvi(3,rangqu)) + v1(3) = coopro(3,nnquvi(3,rangqu)) + v2(1) = coopro(1,nnquvi(4,rangqu)) + v2(2) = coopro(2,nnquvi(4,rangqu)) + v2(3) = coopro(3,nnquvi(4,rangqu)) + v3(1) = coopro(1,nnquvi(5,rangqu)) + v3(2) = coopro(2,nnquvi(5,rangqu)) + v3(3) = coopro(3,nnquvi(5,rangqu)) + endif +cgn write(*,1796)'v1',v1 +cgn write(*,1796)'v2',v2 +cgn write(*,1796)'v3',v3 +c + coface(1,1) = v2(1) - v1(1) + coface(1,2) = v2(2) - v1(2) + coface(1,3) = v2(3) - v1(3) + coface(2,1) = v3(1) - v1(1) + coface(2,2) = v3(2) - v1(2) + coface(2,3) = v3(3) - v1(3) +cgn write(*,1796)'v1',v1 +cgn write(*,1796)'v2',v2 +cgn write(*,1796)'v3',v3 +c + xyzfac(rangfa,7) = coface(1,2)*coface(2,3) + > - coface(1,3)*coface(2,2) + xyzfac(rangfa,8) = coface(1,3)*coface(2,1) + > - coface(1,1)*coface(2,3) + xyzfac(rangfa,9) = coface(1,1)*coface(2,2) + > - coface(1,2)*coface(2,1) +cgn write(*,1796)'normale',(xyzfac(rangfa,iaux),iaux=7,9) +c + 33 continue +c + 1795 format(3(a,' =',i5,' , ')) + 1796 format(a,6f12.5) + 1797 format(i5,' *',6f12.5) + 1798 format(i4,' :',i5,' *',3i4,' *',6f12.5) + 1799 format(i4,' :',i5,' *',4i4,' *',6f12.5) +c +c==== +c 4. On parcourt toutes les faces a afficher et on les range de la +c plus eloignee a la plus proche du point de vue. +c Groso modo, les plus proches sont avec les z les plus grands. +c A la fin de cette etape, posini(1) contient l'indice de la face a +c tracer en premier, parce que la plus loin, posini(2) contient +c l'indice de la suivante a tracer et ainsi de suite, jusqu'a +c posini(nbfavi) qui contient l'indice de la derniere face +c a tracer parce que la plus proche de l'observateur. +c Attention : posini ne contient pas les numeros des faces mais une +c indirection dans la liste des faces a traiter. +c==== +c +c 4.1. ==> A priori, les faces ne sont en contact avec aucune autre +c + do 41 , rangfa = 1 , nbfavi + tabaux(rangfa) = 0 + 41 continue +c +c 4.2. ==> A priori, la 1ere face est en premiere position +c + nbfast = 1 + posini(nbfast) = 1 + tabaux(nbfast) = 1 +c +c 4.3. ==> On examine toutes les faces en ne classant que celles qui +c ont une partie commune avec celles deja classees +c On n'examine que les faces non encore stockees +c On boucle jusqu'a ce qu'il n'y en ait plus +c Role de tabaux : +c . tabaux(i) = 1 : la face i est stockee +c . tabaux(i) = 0 : la face i n'est pas stockee +c + rangfd = nbfast + 1 +c + 430 continue +c +cgn write (ulsort,*) '---------- NOUVELLE SERIE ---------' +cgn write (ulsort,1795) 'Depart avec rangfd', rangfd,'nbfast',nbfast +c + nbfas0 = nbfast +c + do 43 , rangfa = rangfd , nbfavi +c + if ( codret.eq.0 ) then +c + if ( tabaux(rangfa).eq.0 ) then +c + iaux = rangfa +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA4', nompro +#endif + call pppma4 ( iaux, nbfast, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > coopro, + > posini, xyzfac, tabaux, + > ulsort, langue, codret ) +c + if ( rangfa.eq.-70) stop + endif +c + endif +c + 43 continue +c +c 4.4. ==> Bilan +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,*) 'nbfas0, nbfast =', nbfas0, nbfast +cgn if ( nbfast.eq.222 ) then +cgn nbquvi=nbfast +cgn goto 45 +cgn endif +c +c . Si le nombre de faces stockees est egal au nombre de faces a +c visualiser, c'est fini +c +cgn write (ulsort,*) 'Bilan' + if ( nbfast.eq.nbfavi ) then +cgn write (ulsort,1795) 'Fin avec nbfast', nbfast + goto 45 +c +c . Si le nombre de faces stockees a change, c'est que l'on +c se trouve encore dans une suite de faces qui se superposent +c . Sinon, c'est qu'il ne reste plus de faces se superposant +c a l'une de la serie en cours. Il faut commencer une +c autre serie. +c Dans les deux cas, on va refaire un tour en partant de la +c premiere face non superposee. +c + else +cgn do 998 , iaux = 1 , nbfavi +cgn if ( iaux.le.nbtrvi ) then +cgn jaux = nntrvi(2,iaux) +cgn else +cgn jaux = -nnquvi(2,iaux-nbtrvi) +cgn endif +cgn if ( tabaux(iaux).ne.0 ) then +cgn write (*,1999) iaux,tabaux(iaux),jaux +cgn 1999 format('tabaux(',i5,') =',i5,', face',i5) +cgn endif +cgn 998 continue +c + do 44 , rangfa = rangfd , nbfavi + if ( tabaux(rangfa).eq.0 ) then + iaux = rangfa + goto 441 + endif + 44 continue + 441 continue + rangfd = iaux +c +cgn write (ulsort,1795) 'nbfas0', nbfas0, 'nbfast', nbfast, +cgn > 'rangfd', rangfd + if ( nbfast.eq.nbfas0 ) then +cgn write (ulsort,*) '---------- NOUVELLE SERIE ---------' +cgn write (ulsort,*) '---------- FACE', -nnquvi(2,rangfd-nbtrvi) + nbfast = nbfast + 1 +cgn write (ulsort,888) +cgn > (rangfa,posini(rangfa),rangfa =1,nbtrvi+nbquvi) +cgn 888 format(5(i3,i4,' * ')) + posini(nbfast) = rangfd + tabaux(rangfd) = 1 + rangfd = rangfd + 1 + endif +c +cgn write (ulsort,*) 'goto 430 goto 430 goto 430' + goto 430 +c + endif +c + endif +c +c 4.5. ==> C'est fini +c + 45 continue +c +cgn nbfavi=nbtrvi+nbquvi +cgn do 999 , iaux = 1 , nbfast +cgn if ( posini(iaux).le.nbtrvi ) then +cgn jaux = nntrvi(2,posini(iaux)) +cgn else +cgn jaux = -nnquvi(2,posini(iaux)-nbtrvi) +cgn endif +cgn write (*,*) iaux,posini(iaux),'-eme face :',jaux +cgn 999 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/pppma4.F b/src/tool/ES_Xfig/pppma4.F new file mode 100644 index 00000000..3e06b7cb --- /dev/null +++ b/src/tool/ES_Xfig/pppma4.F @@ -0,0 +1,576 @@ + subroutine pppma4 ( rangfa, nbfast, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > coopro, + > posini, xyzfac, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - Preparation du MAillage - phase 4 +c - - - -- - +c ______________________________________________________________________ +c +c On place la rangfa-ieme face par rapport aux autres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . rangfa . e . 1 . rang dans la liste initiale de la face a . +c . . . . classer . +c . nbfast . es . 1 . nombre de faces deja classees . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . coopro . e . sdim* . coordonnees projetees de : . +c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K . +c . . . . la fenetre de zoom : de -7 a 0 en 3D ou . +c . . . . de -3 a 0 en 2D . +c . . . . les noeuds de 1 a nbnoto . +c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des . +c . . .+nbtrvi . faces en fonction de l'affichage . +c . xyzfac . e .nbtrvi+ . coordonnees des noeuds des faces . +c . . .nbtrvi,9. . +c . tabaux . e/s . nbquvi . tabaux(i) = 1 : la face i est stockee . +c . . .+nbtrvi . tabaux(i) = 0 : la face i n'est pas stockee. +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ._____________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPMA4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer rangfa, nbfast + integer nbtrvi, nbquvi + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer posini(nbtrvi+nbquvi) + integer tabaux(nbtrvi+nbquvi) +c + double precision coopro(sdim,-11:nbnoto) + double precision xyzfac(nbtrvi+nbquvi,9) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer indpos, lerang + integer numfac, rangqu + integer nufast, rgfast, rgqust + integer nbnfac, nbnfst + integer iaux, jaux + integer glop, glop1 +c + double precision daux + double precision dzmini + double precision xminfa, xmaxfa + double precision yminfa, ymaxfa + double precision zvuefa, zvuefs + double precision v1(3), v2(3), v3(3), v4(3) + double precision w1(3), w2(3), w3(3), w4(3), wn(2) +c + logical prem + logical dedans +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,1795) '. nbtrvi', nbtrvi, 'nbquvi', nbquvi + write (ulsort,1795) '. rangfa', rangfa, 'nbfast', nbfast +#endif +c + dzmini = 1.0d-4 +c + codret = 0 +c + 1794 format(3(a,' =',f12.5,' , ')) + 1795 format(3(a,' =',i5,' , ')) + 1796 format(a,6f12.5) + 1797 format(i5,' *',6f12.5) +c +c 1.2. ==> Caracteristiques +c + if ( rangfa.gt.nbtrvi ) then + rangqu = rangfa - nbtrvi + endif + if ( rangfa.le.nbtrvi ) then + numfac = nntrvi(2,rangfa) + else + numfac = -nnquvi(2,rangqu) + endif +c +c 1.3. ==> A priori, on va mettre la face devant toutes les autres +c + lerang = nbfast + 1 +c +c==== +c 2. On commence par s'assurer que la face a classer n'est pas +c parallele a l'axe de vision. Si c'est le cas, on la range dans la +c place la plus eloignee car l'ordre d'affichage n'a pas +c d'importance : on ne verra qu'une tranche ! +c==== +c + daux = sqrt( abs(xyzfac(rangfa,7))**2 + > + abs(xyzfac(rangfa,8))**2 + > + abs(xyzfac(rangfa,9))**2 ) + if ( abs(xyzfac(rangfa,9))/daux.le.dzmini ) then +cgn write(*,*)'rang',rangfa,', face',numfac +cgn write(*,1794)'Nx',xyzfac(rangfa,7),'Ny',xyzfac(rangfa,8), +cgn > 'Nz',xyzfac(rangfa,9) +cgn write(*,1794)'norme',daux, +cgn > 'Nz/norme',abs(xyzfac(rangfa,9))/daux +cgn write(*,*)'La face a classer est parallele a la vision' + tabaux(rangfa) = 1 + lerang = 1 + goto 50 + endif +c +c==== +c 3. Suite des caracteristiques +c==== +c + prem = .true. +c + xminfa = xyzfac(rangfa,1) + xmaxfa = xyzfac(rangfa,2) + yminfa = xyzfac(rangfa,3) + ymaxfa = xyzfac(rangfa,4) +c + glop = 0 +cgn if ( numfac.eq.-25 .or. numfac.eq.-21 ) then +cgn glop = 1 +cgn endif + if ( glop.ne.0) then + write(*,*)'*************************************************' + write(*,*)'Examen de la face',numfac,' (rangfa =', rangfa,')' + endif + if ( glop.ne.0 ) then + write(*,*)'....... Face a classer',numfac,' ==> noeuds :' + if ( rangfa.le.nbtrvi ) then + jaux = nntrvi(3,rangfa) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + jaux = nntrvi(4,rangfa) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + jaux = nntrvi(5,rangfa) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + else + jaux = nnquvi(3,rangqu) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + jaux = nnquvi(4,rangqu) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + jaux = nnquvi(5,rangqu) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + jaux = nnquvi(6,rangqu) + write(*,1797) jaux, (coopro(iaux,jaux),iaux=1,3) + endif + write(*,1796)'normale',(xyzfac(rangfa,iaux),iaux=7,9) + endif +c +c==== +c 4. On parcourt toutes les faces deja stockees +c posini(indpos) est la position de la indpos-eme face stockee, +c dans la suite generale des faces a visualiser. +c . Si posini(indpos) est inferieur a nbtrvi, c'est que la face +c stockee est un triangle. Son indice dans les triangles a tracer +c est posini(indpos). +c . Si posini(indpos) est superieur a nbtrvi, c'est un quadrangle +c dont l'indice dans les quadrangles est posini(indpos)-nbtrvi +c Attention a ne pas comparer une face a elle-meme ! Cela peut +c arriver quand on fait une seconde passe pour replacer une face +c qui n'avait aucun point commun avec les autres. +c==== +c + do 40 , indpos = 1 , nbfast +c +c 4.1. ==> caracteristique de la face stockee +c + rgfast = posini(indpos) +c + if ( rgfast.eq.rangfa ) then + if ( glop.ne.0 ) then + write(*,*)'Ne pas tester une face par rapport a elle-meme' + endif + goto 40 + endif + if ( rgfast.le.nbtrvi ) then + nufast = nntrvi(2,rgfast) + else + rgqust = rgfast - nbtrvi + nufast = -nnquvi(2,rgqust) + endif + glop1 = 0 +cgn if ( nufast.eq.2098 ) then +cgn glop1 = 1 +cgn endif + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,*)'.... Face stockee', nufast,', (rang',rgfast,')' + endif +c +c 4.2. ==> On commence par s'assurer que la face stockee n'est pas +c parallele a l'axe de vision. Si c'est le cas, leur ordre +c de trace relatif n'a aucune importance. On passe donc a la +c face stockee suivante. +c + daux = sqrt( abs(xyzfac(rgfast,7))**2 + > + abs(xyzfac(rgfast,8))**2 + > + abs(xyzfac(rgfast,9))**2 ) + if ( abs(xyzfac(rgfast,9))/daux.le.dzmini ) then + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,1794)'Nx',xyzfac(rgfast,7),'Ny',xyzfac(rgfast,8), + > 'Nz',xyzfac(rgfast,9) + write(*,1794)'norme',daux, + > 'Nz/norme',abs(xyzfac(rgfast,9))/daux + write(*,*)'La face stockee est parallele a la vision' + endif + goto 40 + endif +c +c 4.3. ==> Si le quadrangle enveloppe de la face stockee n'a pas de +c recouvrement avec la face a classer, leur ordre de trace +c relatif n'a aucune importance. On passe donc a la face +c stockee suivante. +c + if ( xyzfac(rgfast,1).ge.xmaxfa ) then +cgn write(*,*) '==> xyzfac > xmaxfa' + goto 40 + endif + if ( xyzfac(rgfast,2).le.xminfa ) then +cgn write(*,*) '==> xyzfac < xminfa' + goto 40 + endif + if ( xyzfac(rgfast,3).ge.ymaxfa ) then +cgn write(*,*) '==> xyzfac > ymaxfa' + goto 40 + endif + if ( xyzfac(rgfast,4).le.yminfa ) then +cgn write(*,*) '==> xyzfac < yminfa' + goto 40 + endif +c +c 4.4. ==> Les deux quadrangles enveloppes des faces se recouvrent, +c mais pas forcement les faces. +c On cherche a savoir si les deux faces partagent une +c surface non vide. C'est de la methode arlequin ;=) +c On va chercher si un point interne a la face stockee est +c strictement interne a la face a classer. +c Si on en trouve un, on calculera ses distances. +c + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,*)'....... Point commun aux deux faces ?' + endif +c +c 4.4.1. ==> Transfert des coordonnees des noeuds de la face a classer +c Remarque : on ne le fait qu'une fois +c + if ( prem ) then + if ( rangfa.le.nbtrvi ) then + v1(1) = coopro(1,nntrvi(3,rangfa)) + v1(2) = coopro(2,nntrvi(3,rangfa)) + v2(1) = coopro(1,nntrvi(4,rangfa)) + v2(2) = coopro(2,nntrvi(4,rangfa)) + v3(1) = coopro(1,nntrvi(5,rangfa)) + v3(2) = coopro(2,nntrvi(5,rangfa)) + nbnfac = 3 + else + v1(1) = coopro(1,nnquvi(3,rangqu)) + v1(2) = coopro(2,nnquvi(3,rangqu)) + v2(1) = coopro(1,nnquvi(4,rangqu)) + v2(2) = coopro(2,nnquvi(4,rangqu)) + v3(1) = coopro(1,nnquvi(5,rangqu)) + v3(2) = coopro(2,nnquvi(5,rangqu)) + v4(1) = coopro(1,nnquvi(6,rangqu)) + v4(2) = coopro(2,nnquvi(6,rangqu)) + nbnfac = 4 + endif + prem = .false. + endif +c +c 4.4.2. ==> Transfert des coordonnees des noeuds de la face stockee +c + if ( rgfast.le.nbtrvi ) then + w1(1) = coopro(1,nntrvi(3,rgfast)) + w1(2) = coopro(2,nntrvi(3,rgfast)) + w2(1) = coopro(1,nntrvi(4,rgfast)) + w2(2) = coopro(2,nntrvi(4,rgfast)) + w3(1) = coopro(1,nntrvi(5,rgfast)) + w3(2) = coopro(2,nntrvi(5,rgfast)) + nbnfst = 3 + else + w1(1) = coopro(1,nnquvi(3,rgqust)) + w1(2) = coopro(2,nnquvi(3,rgqust)) + w2(1) = coopro(1,nnquvi(4,rgqust)) + w2(2) = coopro(2,nnquvi(4,rgqust)) + w3(1) = coopro(1,nnquvi(5,rgqust)) + w3(2) = coopro(2,nnquvi(5,rgqust)) + w4(1) = coopro(1,nnquvi(6,rgqust)) + w4(2) = coopro(2,nnquvi(6,rgqust)) + nbnfst = 4 + endif + if ( glop1.ne.0 ) then + write(*,*)'....... Noeuds de la face stockee' + if ( rgfast.le.nbtrvi ) then + write(*,1797) nntrvi(3,rgfast), (w1(iaux),iaux=1,2) + write(*,1797) nntrvi(4,rgfast), (w2(iaux),iaux=1,2) + write(*,1797) nntrvi(5,rgfast), (w3(iaux),iaux=1,2) + else + write(*,1797) nnquvi(3,rgqust), (w1(iaux),iaux=1,2) + write(*,1797) nnquvi(4,rgqust), (w2(iaux),iaux=1,2) + write(*,1797) nnquvi(5,rgqust), (w3(iaux),iaux=1,2) + write(*,1797) nnquvi(6,rgqust), (w4(iaux),iaux=1,2) + endif + write(*,1796)'normale',(xyzfac(rgfast,iaux),iaux=7,9) + endif +c +c 4.4.3. ==> Un point de la face a classer est-il dans la face stockee ? +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA5', nompro +#endif + call pppma5 ( dedans, wn, + > nbnfst, w1, w2, w3, w4, + > nbnfac, v1, v2, v3, v4, + > ulsort, langue, codret ) +c + if ( dedans ) then + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,*)'..... Un point de',numfac,' est dans', nufast + write(*,*)'..... modif pour',numfac,', rang', rangfa + endif + tabaux(rangfa) = 1 + goto 457 + endif +c +c 4.4.4. ==> Un point de la face stockee est-il dans la face a classer ? +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA5', nompro +#endif + call pppma5 ( dedans, wn, + > nbnfac, v1, v2, v3, v4, + > nbnfst, w1, w2, w3, w4, + > ulsort, langue, codret ) +c + if ( dedans ) then + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,*)'..... Un point de', nufast,' est dans',numfac + write(*,*)'..... modif pour',numfac,'(rangfa =', rangfa,')' + endif + tabaux(rangfa) = 1 + goto 457 + endif +c + endif +c +c 4.4.5. ==> Sortie prematuree +c + if ( codret.ne.0 ) then + goto 59 + endif +c +c 4.4.5. ==> Si on arrive ici c'est qu'on a n'a pas reussi a mettre +c un point dans la zone commune aux 2 faces. +c On passe a la suite +c + if ( glop.ne.0 .or. glop1.ne.0 ) then + write(*,*) 'Impossible de trier les faces',numfac,' et',nufast + endif +c if ( glop1.ne.0 ) then +c stop +c endif + goto 40 +c +c 4.4.7. ==> Test des profondeurs du point vis-a-vis des 2 faces +c + 457 continue +c +c 4.4.7.1. ==> Face a classer +c + if ( rangfa.le.nbtrvi ) then + zvuefa = coopro(3,nntrvi(3,rangfa)) + else + zvuefa = coopro(3,nnquvi(3,rangqu)) + endif + zvuefa = zvuefa + > - ( (wn(1)-v1(1))*xyzfac(rangfa,7) + > + (wn(2)-v1(2))*xyzfac(rangfa,8) ) / xyzfac(rangfa,9) +c +c 4.4.7.2. ==> Face stokee +c + if ( rgfast.le.nbtrvi ) then + zvuefs = coopro(3,nntrvi(3,rgfast)) + else + zvuefs = coopro(3,nnquvi(3,rgqust)) + endif + zvuefs = zvuefs + > - ( (wn(1)-w1(1))*xyzfac(rgfast,7) + > + (wn(2)-w1(2))*xyzfac(rgfast,8) ) / xyzfac(rgfast,9) +c +cgn if ( glop.ne.0 ) then +cgn write(*,1796)'... point commun', wn +cgn write(*,*)'....... zvuefs = ',zvuefs +cgn write(*,*)'....... zvuefa = ',zvuefa +cgn endif +c +c 4.4.7.3. ==> Comparaison : +c Si la face a classer est derriere la face a stocker, +c il faut l'inserer a cet endroit, sinon, on ne fait rien +c + if ( zvuefa.le.zvuefs ) then +c + lerang = indpos + if ( glop.ne.0 ) then + write(*,*)'La face',numfac,'est derriere la face', nufast + endif +c + goto 50 +#ifdef _DEBUG_HOMARD_ + else + if ( glop.ne.0 ) then + write(*,*)'La face',nufast,'est derriere la face', numfac + endif +#endif +c + endif +c + 40 continue +c + if ( tabaux(rangfa).eq.0 ) then + if ( glop.ne.0 ) then + write(*,*) 'Impossible de placer la face',numfac + endif + goto 59 + endif +c +c==== +c 5. On insere la face a la position lerang +c==== +c + 50 continue +c + if ( glop.ne.0 ) then + write(*,*) '==> On insere la face',numfac,' en', lerang + endif +c + nbfast = nbfast + 1 + do 51 , indpos = nbfast , lerang+1, -1 +cgn write(ulsort,*)'indpos =',indpos + posini(indpos) = posini(indpos-1) + 51 continue + posini(lerang) = rangfa +c + if ( glop.ne.0 ) then + do 501 , iaux = 1 , nbfast + if ( posini(iaux).le.nbtrvi ) then + jaux = nntrvi(2,posini(iaux)) + else + jaux = -nnquvi(2,posini(iaux)-nbtrvi) + endif + write (*,*) iaux,posini(iaux),'-eme face :',jaux + 501 continue + endif +c + 59 continue +c + if ( glop.ne.0 ) then + if ( posini(1).le.nbtrvi ) then + iaux = nntrvi(2,posini(1)) + else + iaux = -nnquvi(2,posini(1)-nbtrvi) + endif + write(*,*)'Face la plus eloignee :', iaux + if ( posini(nbfast).le.nbtrvi ) then + iaux = nntrvi(2,posini(nbfast)) + else + iaux = -nnquvi(2,posini(nbfast)-nbtrvi) + endif + write(*,*)'Face la plus proche :', iaux + endif +cgn stop +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/pppma5.F b/src/tool/ES_Xfig/pppma5.F new file mode 100644 index 00000000..8d2b6c3b --- /dev/null +++ b/src/tool/ES_Xfig/pppma5.F @@ -0,0 +1,256 @@ + subroutine pppma5 ( dedans, wn, + > nbnfa, vfa1, vfa2, vfa3, vfa4, + > nbnfb, vfb1, vfb2, vfb3, vfb4, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - Preparation du MAillage - phase 4 +c - - - -- - +c ______________________________________________________________________ +c +c On cherche a savoir si un point de la face B est dans la face A +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dedans . s . 1 . vrai : un point de la face A est dans la . +c . . . . face B . +c . . . . faux : aucun point commun . +c . wn . s . 2 . coordonnees du point inclus . +c . nbnfa . e . 1 . nombre de noeuds de la face A . +c . vfa1 . e . 3 . coordonnees du sommet 1 de la face A . +c . vfa2 . e . 3 . coordonnees du sommet 2 de la face A . +c . vfa3 . e . 3 . coordonnees du sommet 3 de la face A . +c . vfa4 . e . 3 . coordonnees du sommet 4 de la face A . +c . nbnfb . e . 1 . nombre de noeuds de la face B . +c . vfb1 . e . 3 . coordonnees du sommet 1 de la face B . +c . vfb2 . e . 3 . coordonnees du sommet 2 de la face B . +c . vfb3 . e . 3 . coordonnees du sommet 3 de la face B . +c . vfb4 . e . 3 . coordonnees du sommet 4 de la face B . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ._____________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPMA5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbnfa, nbnfb +c + logical dedans +c + double precision wn(2) + double precision vfa1(3), vfa2(3), vfa3(3), vfa4(3) + double precision vfb1(3), vfb2(3), vfb3(3), vfb4(3) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbnx, nbny + parameter ( nbnx = 30 , nbny = 30 ) + integer iaux, jaux + integer jdeb, jfin + integer typbor +c + double precision daux1, daux2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + typbor = 0 +c + 1796 format(a,6f12.5) + 1797 format(i5,' *',6f12.5) + 1798 format(i4,' :',i5,' *',3i4,' *',6f12.5) + 1799 format(i4,' :',i5,' *',4i4,' *',6f12.5) +c +c==== +c 2. Un sommet de la face B est-il dans la face A? +c==== +c + do 21 , iaux = 1 , nbnfb +c + if ( iaux.eq.1 ) then + wn(1) = vfb1(1) + wn(2) = vfb1(2) + elseif ( iaux.eq.2 ) then + wn(1) = vfb2(1) + wn(2) = vfb2(2) + elseif ( iaux.eq.3 ) then + wn(1) = vfb3(1) + wn(2) = vfb3(2) + elseif ( iaux.eq.4 ) then + wn(1) = vfb4(1) + wn(2) = vfb4(2) + endif +c + if ( nbnfa.eq.3 ) then + call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor ) + else + call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor ) + endif +c + if ( dedans ) then +cgn print * ,'....... Le',iaux,'-eme sommet est dedans' + goto 44 + endif +c + 21 continue +c +c==== +c 3. Un point interieur a la face B est-il dans la face A ? +c On cree des points par les methodes de maillages +c Evidemment il y a des trous, mais bon ... +c==== +c 3.1 ==> La face B est un triangle +c + if ( nbnfb.eq.3 ) then +c + jfin = nbny-1 + do 31 , iaux = 1 , nbnx +c + daux1 = dble(iaux-1) / dble(nbnx-1) + if ( iaux.eq.1 .or. iaux.eq.nbnx ) then + jdeb = 2 + else + jdeb = 1 + endif +c + do 311 , jaux = jdeb, jfin +c + daux2 = dble(jaux-1) / dble(nbny-1) + call uttfi1 ( daux1, daux2, vfb1, vfb2, vfb3, wn ) +c + if ( nbnfa.eq.3 ) then + call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor ) + else + call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor ) + endif +c + if ( dedans ) then +cgn print * ,'....... Un point interieur est dedans' + goto 44 + endif +c + 311 continue +c + 31 continue +c +c 32. ==> La face B est un quadrangle +c + else +c + do 32 , iaux = 1 , nbnx +c + daux1 = dble(iaux-1) / dble(nbnx-1) + if ( iaux.eq.1 .or. iaux.eq.nbnx ) then + jdeb = 2 + jfin = nbny-1 + else + jdeb = 1 + jfin = nbny + endif +c + do 321 , jaux = jdeb, jfin +c + daux2 = dble(jaux-1) / dble(nbny-1) + call uttfi2 ( daux1, daux2, vfb1, vfb2, vfb3, vfb4, wn ) +c + if ( nbnfa.eq.3 ) then + call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor ) + else + call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor ) + endif +c + if ( dedans ) then +cgn print * ,'....... Un point interieur est dedans' + goto 44 + endif +c + 321 continue +c + 32 continue +c + endif +c +c==== +c 4. OK ... ou pas +c==== +c + 44 continue +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/pppxma.F b/src/tool/ES_Xfig/pppxma.F new file mode 100644 index 00000000..b67115f2 --- /dev/null +++ b/src/tool/ES_Xfig/pppxma.F @@ -0,0 +1,411 @@ + subroutine pppxma ( infsup, typcof, typcop, typbor, optnoe, + > porpay, zoom, triedr, + > degre, sdim, mailet, nivsup, + > titre1, titre2, + > nbarvi, nbtrvi, nbquvi, + > nnarvi, nntrvi, nnquvi, + > coopro, posini, + > nnoeca, nareca, ntreca, nqueca, + > fotrva, foquva, vafomi, vafoma, + > ulvecs, nomflo, lnomfl, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - format Xfig - MAillage +c - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . infsup . e . 1 . information supplementaire a afficher . +c . . . . 0 : aucune . +c . . . . 1 : numero homard des noeuds . +c . . . . 2 : numero du calcul des noeuds . +c . . . . 3 : numero homard des faces . +c . . . . 4 : numero du calcul des faces . +c . . . . 5 : numero homard des aretes . +c . . . . 6 : numero du calcul des aretes . +c . . . . np : choix n et choix p simultanement . +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 3 : famille HOMARD, sans orientation . +c . . . . 4/5 : idem 2/3, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . typcop . e . 1 . type de coloriage du perimetre des faces . +c . . . . 0 : pas de trace . +c . . . . 2 : noir . +c . . . . 4 : niveau de la face . +c . typbor . e . 1 . type d'affichage du bord . +c . . . . 0 : pas de trace . +c . . . . 1 : trace en rouge . +c . . . . 2 : trace en noir . +c . optnoe . e . 1 . 0 : rien de special . +c . . . . 1 : trace d'un rond vide sur chaque noeud . +c . . . . 2 : trace d'un rond plein sur chaque noeud . +c . porpay . e . 1 . 0 : portrait/paysage selon la taille . +c . . . . 1 : portrait . +c . . . . 2 : paysage . +c . zoom . e . 1 . vrai ou faux selon zoom ou non . +c . triedr . e . 1 . 0 : pas de trace du triedre . +c . . . . 1 : trace du triedre . +c . degre . e . 1 . degre du maillage . +c . sdim . e . 1 . dimension du maillage initial . +c . mailet . e . 1 . maillage etendu . +c . nivsup . e . 1 . niveau superieur atteint dans le maillage . +c . titre1 . e . char . premiere ligne de titre . +c . titre2 . e . char . seconde ligne de titre . +c . nbarvi . e . 1 . nombre d'aretes visualisables . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nnarvi . e .6*nbarvi. numero des aretes a visualiser . +c . . . . 1 : niveau de l'arete a afficher . +c . . . . 2 : numero HOMARD de l'arete . +c . . . . 3, 4 : numero des 2 noeuds . +c . . . . 5 : 0, si isolee, 1 si bord . +c . . . . 6 : numero de l'eventuel noeud P2 . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . coopro . e . 3* . coordonnees projetees de : . +c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K . +c . . . . la fenetre de zoom : de -7 a 0 en 3D ou . +c . . . . de -3 a 0 en 2D . +c . . . . les noeuds de 1 a nbnoto . +c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des . +c . . .+nbtrvi . faces en fonction de l'affichage . +c . nnoeca . e . renoto . noeuds en entree dans le calcul . +c . nareca . e . rearto . nro des aretes dans le calcul en entree . +c . ntreca . e . retrto . nro des triangles dans le calcul en entree . +c . nqueca . e . requto . nro des quads dans le calcul en entree . +c . fotrva . e . nbtrvi . fonctions triangles : valeur . +c . foquva . e . nbquvi . fonctions quadrangles : valeur . +c . vafomi . e . 1 . minimum de l'echelle de la fonction . +c . vafoma . e . 1 . maximum de l'echelle de la fonction . +c . ulvecs . e . 1 . unite logique du fichier PostScript . +c . nomflo . e . * . nom local du fichier . +c . lnomfl . e . 1 . longueur du nom local du fichier . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPPXMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "nomber.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + character*(*) titre1, titre2 +c + integer infsup, typcof, typcop, typbor, optnoe + integer porpay, triedr + integer ulvecs, lnomfl, ulsost + integer nbarvi, nbtrvi, nbquvi + integer nnarvi(5,nbarvi) + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer posini(nbtrvi+nbquvi) + integer nnoeca(renoto) + integer nareca(rearto), ntreca(retrto), nqueca(requto) + integer degre, sdim, mailet, nivsup +c + integer codre1, codre2 + integer codre0 +c + logical zoom +c + double precision coopro(3,-11:nbnoto) + double precision vafomi, vafoma + double precision fotrva(*), foquva(*) + character*(*) nomflo +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lgtcmx + parameter ( lgtcmx = 500 ) +c + integer iaux + integer ncotbl + integer ptrav1, ptrav2 + integer tbcoli(-3:lgtcmx) +c + double precision vafodi +c + character*8 ntrav1, ntrav2 + character*17 tbcols(-2:lgtcmx) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c_______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Apres pp.ma'',i1,'', codret = '',i4)' +c + texte(2,10) = '(''After pp.ma'',i1,'', codret = '',i4)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'infsup', infsup + write (ulsort,90002) 'typcof', typcof + write (ulsort,90002) 'typcop', typcop + write (ulsort,90002) 'typbor', typbor + write (ulsort,90002) 'optnoe', optnoe + write (ulsort,90002) 'porpay', porpay + write (ulsort,90002) 'triedr', triedr +#endif +c + codret = 0 +c +c==== +c 2. la table de couleurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. table des couleurs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA1', nompro +#endif + call pppma1 ( typcof, + > lgtcmx, tbcols, tbcoli, ncotbl, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 1, codret +#endif +c + endif +c +c==== +c 3. recherche des extrema de la fonction +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. extrema ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( abs(typcof).eq.6 .or. abs(typcof).eq.8 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA2', nompro +#endif + call pppma2 ( vafomi, vafoma, + > typcof, nbtrvi, nbquvi, + > fotrva, foquva, + > ulsost, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 2, codret +#endif +c + endif +c +c remarque : si l'ecart est nul, il faut eviter la division par 0 +c on peut mettre n'importe quelle valeur pour vafodi +c car elle ne servira pas + if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then + if ( (vafoma-vafomi).ge.1.d4*zeroma ) then + vafodi = 1.d0 / ( vafoma - vafomi ) + else + vafodi = 0.d0 + endif + endif +c + endif +c +c==== +c 4. recherche de l'ordre d'affichage des faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. ordre affichage ; codret', codret + write (ulsort,90002) 'nbtrvi', nbtrvi + write (ulsort,90002) 'nbquvi', nbquvi + write (ulsort,90002) 'sdim ', sdim +#endif +c + if ( nbtrvi+nbquvi.gt.0 ) then +c + if ( sdim.eq.3 ) then +c + if ( codret.eq.0 ) then +c + iaux = 9*(nbtrvi+nbquvi) + call gmalot ( ntrav1, 'reel ', iaux, ptrav1, codre1 ) + iaux = nbtrvi+nbquvi + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPMA3', nompro +#endif + call pppma3 ( nbtrvi, nbquvi, + > nntrvi, nnquvi, + > coopro, + > posini, rmem(ptrav1), imem(ptrav2), nivsup, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 4, codret +#endif +c + endif +c + if ( sdim.eq.3 ) then +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c==== +c 5. impression du maillage sur fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. impression ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPXMA5', nompro +#endif + call ppxma5 ( lgtcmx, tbcoli, ncotbl, + > infsup, typcof, typcop, typbor, optnoe, + > porpay, zoom, triedr, + > degre, sdim, mailet, + > titre1, titre2, + > nbarvi, nbtrvi, nbquvi, + > nnarvi, nntrvi, nnquvi, + > coopro, posini, + > nnoeca, nareca, ntreca, nqueca, + > fotrva, foquva, vafomi, vafoma, vafodi, + > ulvecs, nomflo, lnomfl, + > ulsost, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 5, codret +#endif +c +c==== +c 6. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 0, codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/ES_Xfig/ppxma5.F b/src/tool/ES_Xfig/ppxma5.F new file mode 100644 index 00000000..eafe4a42 --- /dev/null +++ b/src/tool/ES_Xfig/ppxma5.F @@ -0,0 +1,1583 @@ + subroutine ppxma5 ( lgtcmx, tbcoli, ncotbl, + > infsup, typcof, typcop, typbor, optnoe, + > porpay, zoom, triedr, + > degre, sdim, mailet, + > titre1, titre2, + > nbarvi, nbtrvi, nbquvi, + > nnarvi, nntrvi, nnquvi, + > coopro, posini, + > nnoeca, nareca, ntreca, nqueca, + > fotrva, foquva, vafomi, vafoma, vafodi, + > ulvecs, nomflo, lnomfl, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Post-Processeur - format Xfig - MAillage - phase 5 +c - - - -- - +c voir http://www.xfig.org/userman/fig-format.html +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgtcmx . e . 1 . longueur maximale de la table de couleur . +c . tbcoli . e . . table de couleur . +c . . . (-3: . Les immuables sont : . +c . . . lgtcmx). -3 : defaut de xfig . +c . . . . -2 : noir . +c . . . . -1 : blanc . +c . . . . lgtcmx-2 : rouge pour les aretes de bord . +c . . . . lgtcmx-1 : un gris pale pour les familles . +c . . . . libres et le triedre . +c . . . . lgtcmx : un vert pale (cadre de zoom) . +c . ncotbl . e . 1 . nombre de couleurs dans la table . +c . infsup . e . 1 . information supplementaire a afficher . +c . . . . 0 : aucune . +c . . . . 1 : numero homard des noeuds . +c . . . . 2 : numero du calcul des noeuds . +c . . . . 3 : numero homard des faces . +c . . . . 4 : numero du calcul des faces . +c . . . . 5 : numero homard des aretes . +c . . . . 6 : numero du calcul des aretes . +c . . . . np : choix n et choix p simultanement . +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 3 : famille HOMARD, sans orientation . +c . . . . 4/5 : idem 2/3, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . typcop . e . 1 . type de coloriage du perimetre des faces . +c . . . . 0 : pas de trace . +c . . . . 2 : noir . +c . . . . 4 : niveau de la face . +c . typbor . e . 1 . type d'affichage du bord . +c . . . . 0 : pas de trace . +c . . . . 1 : trace en rouge . +c . . . . 2 : trace en noir . +c . optnoe . e . 1 . 0 : rien de special . +c . . . . 1 : trace d'un rond vide sur chaque noeud . +c . . . . 2 : trace d'un rond plein sur chaque noeud . +c . porpay . e . 1 . 0 : portrait/paysage selon la taille . +c . . . . 1 : portrait . +c . . . . 2 : paysage . +c . zoom . e . 1 . vrai ou faux selon zoom ou non . +c . triedr . e . 1 . 0 : pas de trace du triedre . +c . . . . 1 : trace du triedre . +c . degre . e . 1 . degre du maillage . +c . sdim . e . 1 . dimension du maillage initial . +c . mailet . e . 1 . maillage etendu . +c . titre1 . e . char . premiere ligne de titre . +c . titre2 . e . char . seconde ligne de titre . +c . nbarvi . e . 1 . nombre d'aretes visualisables . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nnarvi . e .6*nbarvi. numero des aretes a visualiser . +c . . . . 1 : niveau de l'arete a afficher . +c . . . . 2 : numero HOMARD de l'arete . +c . . . . 3, 4 : numero des 2 noeuds . +c . . . . 5 : 0, si isolee, 1 si bord . +c . . . . 6 : numero de l'eventuel noeud P2 . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . coopro . e . 3* . coordonnees projetees de : . +c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K . +c . . . . la fenetre de zoom : de -7 a 0 en 3D ou . +c . . . . de -3 a 0 en 2D . +c . . . . les noeuds de 1 a nbnoto . +c . posini . aux . nbquvi . tableau auxiliaire de renumerotation des . +c . . .+nbtrvi . faces en fonction de l'affichage . +c . nnoeca . e . renoto . noeuds en entree dans le calcul . +c . nareca . e . rearto . nro des aretes dans le calcul en entree . +c . ntreca . e . retrto . nro des triangles dans le calcul en entree . +c . nqueca . e . requto . nro des quads dans le calcul en entree . +c . fotrva . e . nbtrvi . fonctions triangles : valeur . +c . foquva . e . nbquvi . fonctions quadrangles : valeur . +c . vafomi . e . 1 . minimum de l'echelle de la fonction . +c . vafoma . e . 1 . maximum de l'echelle de la fonction . +c . ulvecs . e . 1 . unite logique du fichier PostScript . +c . nomflo . e . * . nom local du fichier . +c . lnomfl . e . 1 . longueur du nom local du fichier . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'PPXMA5' ) +c +#include "nblang.h" +#include "nuvers.h" +#include "fracta.h" +#include "fractb.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "impr02.h" +#include "nombno.h" +#include "nomber.h" +#include "nbutil.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + character*(*) titre1, titre2 +c + integer lgtcmx + integer tbcoli(-3:lgtcmx) + integer infsup, typcof, typcop, typbor, optnoe + integer porpay, triedr + integer ulvecs, lnomfl, ulsost + integer nbarvi, nbtrvi, nbquvi + integer nnarvi(6,nbarvi) + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer posini(nbtrvi+nbquvi) + integer nnoeca(renoto) + integer nareca(rearto), ntreca(retrto), nqueca(requto) + integer degre, sdim, mailet + integer nbface +c + logical zoom +c + double precision coopro(3,-11:nbnoto) + double precision vafomi, vafoma + double precision fotrva(*), foquva(*) + character*(*) nomflo +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nuface, nutr, nuqu + integer noeud, noeud1, noeud2 + integer iaux, jaux, kaux, laux + integer infsu1, infsu2, infsu3 + integer iaux1, iaux2, iaux3, iaux4, iaux5 + integer iaux6 + integer adtrav + integer tabaux(20) + integer lno(9), lglesn, lenoeu + integer ncotbl + integer lacoul, leremp +c + double precision vafodi + double precision daux + double precision daux1, daux2, daux3, daux4 + double precision dcotbl + double precision factx, facty + double precision decalx, decaly + double precision tabaur(20) +c + character*7 saux07 + character*8 ntrava + character*9 saux09 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c_______________________________________________________________________ +c +c==== +c 1. Messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Fonction sur les '',a)' + texte(1,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)' +c + texte(2,4) = '(''Function over '',a)' + texte(2,5) = '(a,'' : min = '',g12.5,'', max = '',g12.5)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Prealables +c==== +c 2.1. ==> Informations sur les fonctions +c + if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then + iaux = 8 + write (ulsort,texte(langue,4)) mess14(langue,3,iaux) + write (ulsort,texte(langue,5)) 'Fonction', vafomi, vafoma + if ( ulsost.ne.ulsort ) then + write (ulsost,texte(langue,4)) mess14(langue,3,iaux) + write (ulsost,texte(langue,5)) 'Fonction', vafomi, vafoma + endif +c Reajustement pour tenir compte des erreurs d'arrondi aux bornes + if ( abs(typcof).eq.6 .or. abs(typcof).eq.8 ) then + daux = vafoma - vafomi + vafomi = vafomi - daux*1.d-6 + vafoma = vafoma + daux*1.d-6 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) 'Fonction', vafomi, vafoma + if ( ulsost.ne.ulsort ) then + write (ulsost,texte(langue,5)) 'Fonction', vafomi, vafoma + endif +#endif + endif +c +c 2.2. ==> Informations supplementaires +c +cgn ulve = ulvecs +cgn do 1789 , nbface = 1,nbtrvi +cgn ulvecs = 20 +nbface + nbface = nbtrvi + nbquvi +c +cgn print *,infsup + infsu1 = mod(infsup,10) + if ( infsup.ge.10 ) then + iaux = ( infsup-infsu1 ) / 10 + infsu2 = mod(iaux,10) + if ( iaux.ge.10 ) then + infsu3 = ( iaux-infsu2 ) / 10 + else + infsu3 = 0 + endif + else + infsu2 = 0 + infsu3 = 0 + endif +cgn print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3 +c +c 2.3. ==> Extrema des coordonnees +c + daux1 = vinfpo + daux2 = vinfne + daux3 = vinfpo + daux4 = vinfne +cgn print texte(langue,5), 'X', daux1, daux2 +cgn print texte(langue,5), 'Y', daux3, daux4 +c + do 231 , jaux = 1 , nbarvi + lno(1) = nnarvi(3,jaux) + lno(2) = nnarvi(4,jaux) + do 2311 , iaux = 1 , 2 + daux1 = min(daux1, coopro(1,lno(iaux))) + daux2 = max(daux2, coopro(1,lno(iaux))) + daux3 = min(daux3, coopro(2,lno(iaux))) + daux4 = max(daux4, coopro(2,lno(iaux))) + 2311 continue + 231 continue +cgn if ( nbarvi.gt.0 ) print texte(langue,5), 'X', daux1, daux2 +cgn if ( nbarvi.gt.0 ) print texte(langue,5), 'Y', daux3, daux4 +c + do 232 , nuface = 1 , nbface + if ( nuface.le.nbtrvi ) then + lno(1) = nntrvi(3,nuface) + lno(2) = nntrvi(4,nuface) + lno(3) = nntrvi(5,nuface) + lglesn = 3 + else + nuqu = nuface - nbtrvi + lno(1) = nnquvi(3,nuqu) + lno(2) = nnquvi(4,nuqu) + lno(3) = nnquvi(5,nuqu) + lno(4) = nnquvi(5,nuqu) + lglesn = 4 + endif + do 2321 , iaux = 1 , lglesn +cgn print *,coopro(1,lno(iaux)), coopro(2,lno(iaux)) + daux1 = min(daux1, coopro(1,lno(iaux))) + daux2 = max(daux2, coopro(1,lno(iaux))) + daux3 = min(daux3, coopro(2,lno(iaux))) + daux4 = max(daux4, coopro(2,lno(iaux))) + 2321 continue + 232 continue +c +cgn if ( nuface.gt.0 ) print texte(langue,5), 'X', daux1, daux2 +cgn if ( nuface.gt.0 ) print texte(langue,5), 'Y', daux3, daux4 +c + if ( zoom ) then +c + if ( sdim.le.2 ) then + jaux = -3 + else + jaux = -7 + endif + do 2331 , iaux = jaux , 0 + daux1 = min(daux1, coopro(1,iaux)) + daux2 = max(daux2, coopro(1,iaux)) + daux3 = min(daux3, coopro(2,iaux)) + daux4 = max(daux4, coopro(2,iaux)) + 2331 continue +cgn print texte(langue,5), 'apres zoom, X', daux1, daux2 +cgn print texte(langue,5), 'apres zoom, Y', daux3, daux4 +c + endif +c + if ( triedr.eq.1 ) then +c + if ( sdim.le.2 ) then + jaux = -10 + else + jaux = -11 + endif + do 2341 , iaux = jaux , -8 + daux1 = min(daux1, coopro(1,iaux)) + daux2 = max(daux2, coopro(1,iaux)) + daux3 = min(daux3, coopro(2,iaux)) + daux4 = max(daux4, coopro(2,iaux)) + 2341 continue +cgn print texte(langue,5), 'apres triedre, X', daux1, daux2 +cgn print texte(langue,5), 'apres triedre, Y', daux3, daux4 +c + endif +c +c 2.4. ==> Facteur de proportionnalite +c Dans Xfig, un rectangle de 27x18 cm, donc imprimable au +c format A4, correspond a des coordonnees 12150x8100, soit un +c rapport de 450. +c La figure est dans le rectangle : +c daux1 <= X <= daux2 +c daux3 <= Y <= daux4 +c Si on n'a pas choisi a priori d'orientation de la page, on la +c determine en fonction de la taille de la figure. +c On privilegie le paysage ... +c +cgn print texte(langue,5), '==> X', daux1, daux2 +cgn print texte(langue,5), '==> Y', daux3, daux4 + if ( porpay.eq.0 ) then + if ( (daux4-daux3).gt.1.1d0*(daux2-daux1) ) then + porpay = 1 + else + porpay = 2 + endif + endif +c +c On ramene la figure dans le cadre 27x18, selon l'orientation +c demandee : +c Portrait : + if ( porpay.eq.1 ) then + if ( (daux2-daux1).lt.1.d-10 ) then + facty = 27.d0 / (daux4-daux3) + factx = facty + elseif ( (daux4-daux3).lt.1.d-10 ) then + factx = 18.d0 / (daux2-daux1) + else + factx = 18.d0 / (daux2-daux1) + facty = 27.d0 / (daux4-daux3) + factx = min(factx,facty) + endif +c Paysage : + else + if ( (daux2-daux1).lt.1.d-10 ) then + facty = 18.d0 / (daux4-daux3) + factx = facty + elseif ( (daux4-daux3).lt.1.d-10 ) then + factx = 27.d0 / (daux2-daux1) + else + factx = 27.d0 / (daux2-daux1) + facty = 18.d0 / (daux4-daux3) + factx = min(factx,facty) + endif + endif +cgn print *, 'factx =', factx +cgn print *, 'facty =', facty +c +c On termine par le coefficient general +c Attention : il faut symetriser en Y ... mystere xfig ... +c + factx = 450.d0*factx + facty = -factx +cgn print *, factx +c +c On cree un decalage pour que le coin soit en (0,0) +c + decalx = -daux1 + decaly = -daux4 +c +c==== +c 3. impression des en-tetes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. impression des en-tetes ; codret', codret +#endif +c + write(ulvecs,30000) nuvers +c + if ( porpay.eq.1 ) then + saux09 = 'Portrait ' + else + saux09 = 'Landscape' + endif + write(ulvecs,30010) saux09 + write(ulvecs,30020) nuvers, titre1, titre2 + write(ulvecs,30030) + write(ulvecs,30031) + > nomflo(1:lnomfl)//' > '//nomflo(1:lnomfl-3)//'png' +c +c==== +c 4. impression du maillage : les faces +c attention : on doit placer les faces dans l'ordre +c d'affichage qui a ete determine par pppma3. Il faut donc +c explorer les caracteristiques de chaque face, contenues dans +c nntrvi et/ou nnquvi, via l'indirection donnee par le tableau +c posini. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. impression des faces ; codret', codret + write (ulsort,90002) 'nbface',nbface +#endif +c + if ( nbface.ne.0 ) then +c + write(ulvecs,31002) nbface +c + dcotbl = dble(ncotbl) +c + do 41 , nuface = 1 , nbface +c +cgn write (ulsort,90112) 'posini', nuface, posini(nuface) + if ( posini(nuface).le.nbtrvi ) then + nutr = posini(nuface) + nuqu = 0 + else + nutr = 0 + nuqu = posini(nuface)-nbtrvi + endif +c +c 4.1. ==> couleur de la face +c +c de 6 a 9 ou de -9 a -6 : selon les valeurs de la fonction +c 6 ou 7 : couleur de bleu a rouge +c 8 ou 9 : niveau de gris (de blanc pour les faibles valeurs +c a noir pour les grandes) +c + if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then +c + if ( abs(typcof).le.7 ) then + leremp = 20 + else + lacoul = tbcoli(-1) + endif +c + if ( nutr.gt.0 ) then + daux1 = fotrva(nutr) + else + daux1 = foquva(nuqu) + endif +c + if ( daux1.ge.vafoma ) then + if ( abs(typcof).ge.8 ) then + leremp = 0 + else + lacoul = tbcoli(ncotbl) + endif + elseif ( daux1.le.vafomi ) then + if ( abs(typcof).ge.8 ) then + leremp = 20 + else + lacoul = tbcoli(0) + endif + else + if ( abs(typcof).ge.8 ) then + daux1 = 20.d0 * ( vafoma - daux1 ) * vafodi + leremp = nint(daux1) +cgn print *,leremp + else + daux1 = dcotbl * ( daux1 -vafomi ) * vafodi + jaux = nint(daux1) + lacoul = tbcoli(jaux) + endif + endif +c +c 2 : selon la famille, avec orientation +c 3 : selon la famille, sans orientation +c couleur -1 : famille 1 (les libres) +c couleur 0 : famille 2 et celles d'orientation autre, +c couleur 1 : famille suivante et celles d'orientation autre, +c etc +c + elseif ( typcof.ge.2 .and. typcof.le.3 ) then +c + leremp = 20 + if ( nutr.gt.0 ) then + if ( nntrvi(6,nutr).gt.lgtcmx ) then + jaux = -2 + elseif ( nntrvi(6,nutr).eq.1 ) then + jaux = lgtcmx - 1 + else + jaux = nntrvi(6,nutr) - 2 + endif + else + if ( nnquvi(7,nuqu).gt.lgtcmx ) then + jaux = -2 + elseif ( nnquvi(7,nuqu).eq.1 ) then + jaux = lgtcmx - 1 + else + jaux = nnquvi(7,nuqu) - 2 + endif + endif + lacoul = tbcoli(jaux) +c +c 4 : selon la famille, avec orientation, noir et blanc +c 5 : selon la famille, sans orientation, noir et blanc +c blanc : famille 1 (les libres) +c gris pale : famille 2 et celles d'orientation autre, +c etc +c noir au dela de la famille 20 +c + elseif ( typcof.ge.4 .and. typcof.le.5 ) then +c + lacoul = tbcoli(-1) + if ( nutr.gt.0 ) then + if ( nntrvi(6,nutr).gt.20 ) then + leremp = 0 + else + leremp = 21 - nntrvi(6,nutr) + endif + else + if ( nnquvi(7,nuqu).gt.20 ) then + leremp = 0 + else + leremp = 21 - nnquvi(7,nuqu) + endif + endif +c +c 10 : niveau de raffinement +c + elseif ( typcof.eq.10 ) then +c + if ( nutr.gt.0 ) then + jaux = nntrvi(1,nutr) + else + jaux = nnquvi(1,nuqu) + endif + lacoul = tbcoli(jaux) + leremp = 20 +c +c 1 : opaque +c + elseif ( typcof.eq.1 ) then +c + lacoul = tbcoli(-1) + leremp = 20 +c +c 0 : invisible +c + elseif ( typcof.eq.0 .) then +c + lacoul = tbcoli(-1) + leremp = -1 +c +c autre : erreur +c + else + codret = 1 + endif +c +c 4.2. ==> couleur du perimetre +c 0 : pas de trace +c 2 : noir +c 4 : niveau de la face +c autre : erreur +c + if ( typcop.eq.0 ) then + kaux = 0 + elseif ( typcop.eq.2 ) then + kaux = -2 + elseif ( typcop.eq.4 ) then + if ( nutr.gt.0 ) then + kaux = nntrvi(1,nutr) + else + kaux = nnquvi(1,nuqu) + endif + else + codret = 1 + endif +c +c 4.3. ==> trace +c + if ( codret.eq.0 ) then +c +c Les noeuds +c + if ( nutr.gt.0 ) then + lno(1) = nntrvi(3,nutr) + if ( degre.eq.1 ) then + lno(2) = nntrvi(4,nutr) + lno(3) = nntrvi(5,nutr) + lglesn = 4 + else + lno(2) = nntrvi(7,nutr) + lno(3) = nntrvi(4,nutr) + lno(4) = nntrvi(8,nutr) + lno(5) = nntrvi(5,nutr) + lno(6) = nntrvi(9,nutr) + lglesn = 7 + endif + else + lno(1) = nnquvi(3,nuqu) + if ( degre.eq.1 ) then + lno(2) = nnquvi(4,nuqu) + lno(3) = nnquvi(5,nuqu) + lno(4) = nnquvi(6,nuqu) + lglesn = 5 + else + lno(2) = nnquvi( 8,nuqu) + lno(3) = nnquvi( 4,nuqu) + lno(4) = nnquvi( 9,nuqu) + lno(5) = nnquvi( 5,nuqu) + lno(6) = nnquvi(10,nuqu) + lno(7) = nnquvi( 6,nuqu) + lno(8) = nnquvi(11,nuqu) + lglesn = 9 + endif + endif + lno(lglesn) = lno(1) +cgn write(ulsort,90015) 'face',nuface,' :', +cgn > (lno(lenoeu), lenoeu = 1, lglesn) +c +c type de polygone : iaux1 +c couleur trait : iaux2 +c couleur remplissage : iaux3 +c profondeur : iaux4 +c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %) +c fleche en fin : iaux6 +c + if ( nutr.gt.0 ) then + write(ulvecs,33001) 'triangle' + else + write(ulvecs,33001) 'quadrangle' + endif + iaux1 = 3 + iaux2 = tbcoli(kaux) + iaux3 = lacoul + if ( nutr.gt.0 ) then + iaux4 = 51 + else + iaux4 = 52 + endif + iaux5 = leremp + iaux6 = 0 + write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5, + > iaux6, lglesn +c + do 4131 , lenoeu = 1, lglesn + tabaux(2*lenoeu-1) =nint(factx*(decalx+coopro(1,lno(lenoeu)))) + tabaux(2*lenoeu ) =nint(facty*(decaly+coopro(2,lno(lenoeu)))) + 4131 continue +c + write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn) +c + endif +c + 41 continue +c + endif +c +c==== +c 5. impression du maillage : les aretes +c Quand les bords sont demandes, il faut les passer en dernier +c pour qu'ils soient clairement visibles +c En degre 2, il faut decomposer le trace des aretes de bord ou +c isolee pour pouvoir visualiser les effets de courbure +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. impression des aretes ; codret', codret + write (ulsort,90002) 'nbarvi', nbarvi +#endif +c + if ( nbarvi.ne.0 ) then +c + write(ulvecs,31001) +cgn do 1222,iaux=-11,nbnoto +cgn print 1788,iaux,coopro(1,iaux),coopro(2,iaux) +cgn1222 continue +cgn1788 format(i3,4f12.5) + if ( typbor.gt.0 ) then + laux = 1 + else + laux = 0 + endif +cgn print *, laux +cgn print *, typcof +c + do 5 , jaux = 0 , laux +cgn print *, 'eeeeeeeeeeeeee',jaux +c + do 51 , iaux = 1 , nbarvi +c +c nnarvi(5,iaux) vaut 0 pour une arete isolee, 1 pour un bord, 2 sinon +c . 1ere passe de la boucle 5 (jaux=0) : aretes isolees +c . 2nde passe (eventuelle) de la boucle 5 : aretes de bord +c +cgn print *, nnarvi(5,iaux) + if ( nnarvi(5,iaux).eq.jaux ) then +c +c Les noeuds +c + lno(1) = nnarvi(3,iaux) + if ( degre.eq.2 .and. nnarvi(5,iaux).le.1 ) then + lno(2) = nnarvi(6,iaux) + lglesn = 3 + else + lglesn = 2 + endif + lno(lglesn) = nnarvi(4,iaux) +cgn print *, (lno(lenoeu),lenoeu = 1, lglesn) +c +c type de polygone : iaux1 +c couleur trait : iaux2 +c couleur remplissage : iaux3 +c profondeur : iaux4 +c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %) +c fleche en fin : iaux6 +c +c si l'arete est un bord et que le coloriage du bord est demande, la +c couleur est celle designee par typbor +c si les faces ont ete demandees par niveau, on retient le niveau +c sinon : defaut (noir) +c + write(ulvecs,33001) 'segment' + iaux1 = 1 + if ( jaux.eq.1 ) then + if ( typbor.eq.1 ) then + kaux = -2 + else + kaux = lgtcmx-2 + endif + elseif ( typcof.eq.10 ) then + kaux = nnarvi(1,iaux) + else + kaux = -2 + endif + iaux2 = tbcoli(kaux) + iaux3 = -1 + if ( jaux.eq.1 ) then + iaux4 = 41 + else + iaux4 = 42 + endif + iaux5 = -1 + iaux6 = 0 +c + write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5, + > iaux6, lglesn +c + do 511 , lenoeu = 1, lglesn +cgn print *, coopro(1,lno(lenoeu)),coopro(2,lno(lenoeu)) + tabaux(2*lenoeu-1) = + > nint(factx*(decalx+coopro(1,lno(lenoeu)))) + tabaux(2*lenoeu ) = + > nint(facty*(decaly+coopro(2,lno(lenoeu)))) + 511 continue +c + write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn) +c + endif +c + 51 continue +c + 5 continue +c + endif +cc if ( codret.ne.1789) return +c +c==== +c 6. impression du maillage : la fenetre de zoom +c on trace les segments dans l'ordre des pseudo-noeuds : +c 0/-1; -1/-2; -2/-3; -3/0 +c pour le 3D on poursuit avec : +c -4/-5; -5/-6; -6/-7; -7/-4 +c -4/0; -5/-1; -6/-2; -7/-3 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. fenetre de zoom ; codret', codret +#endif +c + if ( zoom ) then +c + write(ulvecs,31004) +c + kaux = lgtcmx + lacoul = tbcoli(kaux) +c + if ( sdim.eq.3 ) then + iaux1 = 3 + else + iaux1 = 1 + endif +c + do 61 , iaux = 1 , iaux1 +c + if ( iaux.eq.1 ) then + noeud2 = 0 + else + noeud2 = -4 + endif +c + do 611 , jaux = 1 , 4 +c + if ( iaux.lt. 3 ) then + noeud1 = noeud2 + if ( jaux.eq.4 ) then + noeud2 = noeud1 + 3 + else + noeud2 = noeud1 - 1 + endif + else + if ( jaux.eq.1 ) then + noeud1 = noeud2 + else + noeud1 = noeud1 - 1 + endif + noeud2 = noeud1 + 4 + endif +c +c on calcule les abscisses et les ordonnees. +c + tabaux(1) = nint(factx*(decalx+coopro(1,noeud1))) + tabaux(2) = nint(facty*(decaly+coopro(2,noeud1))) + tabaux(3) = nint(factx*(decalx+coopro(1,noeud2))) + tabaux(4) = nint(facty*(decaly+coopro(2,noeud2))) +c +c type de polygone : iaux1 +c couleur trait : iaux2 +c couleur remplissage : iaux3 +c profondeur : iaux4 +c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %) +c fleche en fin : iaux6 +c + iaux1 = 1 + iaux2 = lacoul + iaux3 = -1 + iaux4 = 99 + iaux5 = -1 + iaux6 = 0 +c + write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5, + > iaux6, 2 + write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 4) +c + 611 continue +c + 61 continue +c + endif +c +c==== +c 7. impression du maillage : le triedre +c on trace les segments dans l'ordre des pseudo-noeuds : +c en 2D : O/I ; O/J +c en 3D : O/I ; O/J ; O/K +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. triedre ; codret', codret +#endif +c + if ( triedr.ne.0 ) then +c + write(ulvecs,31005) +c + kaux = -2 + lacoul = tbcoli(kaux) +c + if ( sdim.eq.3 ) then + iaux1 = 3 + else + iaux1 = 2 + endif +c + noeud2 = -8 + tabaux(1) = nint(factx*(decalx+coopro(1,noeud2))) + tabaux(2) = nint(facty*(decaly+coopro(2,noeud2))) + lglesn = 2 +c + do 71 , iaux = 1 , iaux1 +c + if ( iaux.eq.1 ) then + noeud1 = -9 +c 123456789 + saux09 = '(x) ' + elseif ( iaux.eq.2 ) then + noeud1 = -10 +c 123456789 + saux09 = '(y) ' + else + noeud1 = -11 +c 123456789 + saux09 = '(z) ' + endif +c +c type de polygone : iaux1 +c couleur trait : iaux2 +c couleur remplissage : iaux3 +c profondeur : iaux4 +c remplissage : iaux5 (-1 : rien, 0<=n<=20 : a 5n %) +c fleche en fin : iaux6 +c + iaux1 = 1 + iaux2 = lacoul + iaux3 = -1 + iaux4 = 98 + iaux5 = -1 + iaux6 = 1 +c + write(ulvecs,32001) iaux1, iaux2, iaux3, iaux4, iaux5, + > iaux6, lglesn + write(ulvecs,32003) +c + tabaux(3) = nint(factx*(decalx+coopro(1,noeud1))) + tabaux(4) = nint(facty*(decaly+coopro(2,noeud1))) +c + write(ulvecs,32002) (tabaux(lenoeu), lenoeu = 1, 2*lglesn) +c + tabaux(5) = nint(factx*(decalx+coopro(1,noeud1))) + tabaux(6) = nint(facty*(decaly+coopro(2,noeud1))) +c +c couleur texte : iaux1 +c profondeur : iaux2 +c police : iaux3 +c taille : iaux4 +c + iaux1 = lacoul + iaux2 = 97 + iaux3 = 16 + iaux4 = 10 + write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4, + > tabaux(5), tabaux(6), saux09(1:3) +c + 71 continue +c + endif +c +c==== +c 8. affichage d'informations supplementaires pour les faces +c Attention : c'est fait seulement maintenant pour ne pas etre cache +c par les faces dessinees +c En numerotation du calcul, on supprime les faces qui ne sont que +c des faces HOMARD. +c remarque : dans pcmac1, on s'est arrange pour que les elements +c externes soient numerotes par dimension decroissante : +c . les tetraedres +c . les triangles +c . les quadrangles +c . les aretes +c . les mailles-points +c on affichera ici leur numerotation locale au type d'element +c quand il s'agira de numerotation du calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. affichage suppl faces ; codret', codret +#endif +c + if ( retrto.eq.0 .and. requto.eq.0 ) then + jaux = 0 + elseif ( infsu1.ge.3 .and. infsu1.le.4 ) then + jaux = infsu1 + elseif ( infsu2.ge.3 .and. infsu2.le.4 ) then + jaux = infsu2 + elseif ( infsu3.ge.3 .and. infsu3.le.4 ) then + jaux = infsu3 + else + jaux = 0 + endif +c + if ( jaux.ne.0 ) then +c + write(ulvecs,31006) +c + kaux = nbhexa + nbtetr + laux = nbhexa + nbtetr + nbtria +c + do 81 , nuface = 1 , nbface +c + if ( posini(nuface).le.nbtrvi ) then + nutr = posini(nuface) + nuqu = 0 + else + nutr = 0 + nuqu = posini(nuface)-nbtrvi + endif +c + if ( jaux.eq.3 ) then + if ( nutr.gt.0 ) then + saux09(1:1) = 't' + tabaux(3) = nntrvi(2,nutr) + else + saux09(1:1) = 'q' + tabaux(3) = nnquvi(2,nuqu) + endif + else + if ( nutr.gt.0 ) then + saux09(1:1) = 'T' + tabaux(3) = ntreca(nntrvi(2,nutr)) - kaux + else + saux09(1:1) = 'Q' + tabaux(3) = nqueca(nnquvi(2,nuqu)) - laux + endif + endif +c + if ( tabaux(3).ne.0 ) then +c + if ( nutr.gt.0 ) then + lno(1) = nntrvi(3,nutr) + lno(2) = nntrvi(4,nutr) + lno(3) = nntrvi(5,nutr) + lglesn = 3 + else + lno(1) = nnquvi(3,nuqu) + lno(2) = nnquvi(4,nuqu) + lno(3) = nnquvi(5,nuqu) + lno(4) = nnquvi(6,nuqu) + lglesn = 4 + endif +cgn write(ulsort,90015) 'face',nuface,' :', +cgn > (lno(lenoeu), lenoeu = 1, lglesn) +c +c on calcule les abscisses et les ordonnees du centre +c + tabaur(1) = 0.d0 + tabaur(2) = 0.d0 + do 811 , lenoeu = 1, lglesn + tabaur(1) = tabaur(1) + coopro(1,lno(lenoeu)) + tabaur(2) = tabaur(2) + coopro(2,lno(lenoeu)) + 811 continue +c + if ( nutr.gt.0 ) then + daux = unstr + else + daux = unsqu + endif +c + tabaux(1) = nint( factx*(decalx+tabaur(1)*daux) ) + tabaux(2) = nint( facty*(decaly+tabaur(2)*daux) ) +c + call utench ( tabaux(3), 'g', iaux6, saux07, + > ulsort, langue, codret ) + saux09(3:9) = ' ' + if ( codret.eq.0 ) then + saux09(2:1+iaux6) = saux07(1:iaux6) + else + iaux6 = 0 + endif +c + lacoul = tbcoli(-3) +c +c couleur texte : iaux1 +c profondeur : iaux2 +c police : iaux3 +c taille : iaux4 +c + iaux1 = lacoul + iaux2 = 5 + iaux3 = 16 + iaux4 = 10 + write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4, + > tabaux(1), tabaux(2), saux09(1:1+iaux6) +c + endif +c + 81 continue +c + endif +c +c==== +c 9. affichage d'informations supplementaires pour les noeuds +c Attention : c'est fait seulement maintenant pour ne pas etre cache +c par les faces dessinees +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. affichage supp noeuds ; codret', codret + write(ulsort,90002) 'nbtrvi', nbtrvi + write(ulsort,90002) 'nbquvi', nbquvi + write(ulsort,90002) 'nbnoto', nbnoto +#endif +c + if ( infsu1.ge.1 .and. infsu1.le.2 ) then + jaux = infsu1 + elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then + jaux = infsu2 + elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then + jaux = infsu3 + else + jaux = 0 + endif +c + if ( jaux.ne.0 .or. optnoe.ne.0 ) then +c + write(ulvecs,31007) +c +c 9.1. ==> liste des noeuds a tracer +c + if ( codret.eq.0 ) then + call gmalot ( ntrava, 'entier ', nbnoto, adtrav, codret ) + endif +c + if ( codret.eq.0 ) then +c + iaux1 = adtrav + iaux2 = adtrav + nbnoto - 1 + do 911 , iaux = iaux1, iaux2 + imem(iaux) = 0 + 911 continue +c +c les noeuds des aretes +c + do 912 , iaux = 1 , nbarvi + imem(adtrav-1+nnarvi(3,iaux)) = 1 + imem(adtrav-1+nnarvi(4,iaux)) = 1 + 912 continue + if ( degre.eq.2 ) then + do 913 , iaux = 1 , nbarvi + imem(adtrav-1+nnarvi(6,iaux)) = 2 + 913 continue + endif +cgn do 3812 , iaux = 1 , nbarvi +cgn write(ulsort,90015) 'arete',iaux,' :', +cgn < nnarvi(3,iaux),nnarvi(6,iaux),nnarvi(4,iaux) +cgn 3812 continue +c +c les noeuds des faces +c + if ( degre.eq.1 ) then + iaux1 = 1 + else + iaux1 = 2 + endif +c + do 914 , laux = 1 , iaux1 + do 915 , nuface = 1 , nbface +c + iaux = posini(nuface) +c + if ( iaux.le.nbtrvi ) then +cgn if ( laux.eq.1 ) write(ulsort,90015) 'triangle',iaux,' :', +cgn < nntrvi(4*laux-1,iaux), +cgn < nntrvi(4*laux ,iaux), +cgn < nntrvi(4*laux+1,iaux) + imem(adtrav-1+nntrvi(4*laux-1,iaux)) = laux + imem(adtrav-1+nntrvi(4*laux ,iaux)) = laux + imem(adtrav-1+nntrvi(4*laux+1,iaux)) = laux + else +cgn if ( laux.eq.1 ) write(ulsort,90015) 'quadrangle',iaux,' :', +cgn < nnquvi(5*laux-2,iaux-nbtrvi), +cgn < nnquvi(5*laux-1,iaux-nbtrvi), +cgn < nnquvi(5*laux ,iaux-nbtrvi), +cgn < nnquvi(5*laux+1,iaux-nbtrvi) + imem(adtrav-1+nnquvi(5*laux-2,iaux-nbtrvi)) = laux + imem(adtrav-1+nnquvi(5*laux-1,iaux-nbtrvi)) = laux + imem(adtrav-1+nnquvi(5*laux ,iaux-nbtrvi)) = laux + imem(adtrav-1+nnquvi(5*laux+1,iaux-nbtrvi)) = laux + endif +c + 915 continue + 914 continue +c +c les noeuds internes aux faces +c +cgn write(ulsort,*) 'les noeuds internes aux faces' + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then +c + do 916 , nuface = 1 , nbface +c + iaux = posini(nuface) +c + if ( iaux.le.nbtrvi ) then +cgn write(ulsort,90015) 'triangle',iaux,' :',nntrvi(10,iaux) + imem(adtrav-1+nntrvi(10,iaux)) = 4 + else +cgn write(ulsort,90015) 'quadrangle',iaux,' :',nnquvi(12,iaux-nbtrvi) + imem(adtrav-1+nnquvi(12,iaux-nbtrvi)) = 4 + endif +cgn print *,nntrvi(10,iaux) +c + 916 continue +c + endif +c + endif +c +c 9.2. ==> affichage +c + if ( codret.eq.0 ) then +c + if ( jaux.eq.1 ) then + saux09(1:1) = 'n' + else + saux09(1:1) = 'N' + endif +c + lacoul = tbcoli(-3) +c + do 92 , noeud = 1 , nbnoto +cgn print 90002,'noeud',noeud,imem(adtrav-1+noeud) +cgn print 1780,coopro(1,noeud),coopro(2,noeud) +cgn 1780 format(2g15.7) +c + if ( imem(adtrav-1+noeud).ne.0 ) then +c + tabaux(1) = nint(factx*(decalx+coopro(1,noeud))) + tabaux(2) = nint(facty*(decaly+coopro(2,noeud))) +c +c Numero du noeud +c + if ( jaux.ne.0 ) then +c + if ( jaux.eq.1 ) then + tabaux(3) = noeud + else + tabaux(3) = nnoeca(noeud) + endif +c + call utench ( tabaux(3), 'g', iaux6, saux07, + > ulsort, langue, codret ) + saux09(3:9) = ' ' + if ( codret.eq.0 ) then + saux09(2:1+iaux6) = saux07(1:iaux6) + else + iaux6 = 0 + endif +c +c couleur texte : iaux1 +c profondeur : iaux2 +c police : iaux3 +c taille : iaux4 +c + iaux1 = lacoul + iaux2 = 1 + iaux3 = 16 + iaux4 = 10 + write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4, + > tabaux(1), tabaux(2), + > saux09(1:1+iaux6) +c + endif +c +c Affichage d'un rond +c + if ( optnoe.ne.0 ) then +c +c couleur trait : iaux1 +c profondeur : iaux2 +c remplissage : iaux3 +c rayon : iaux4 +c + iaux1 = lacoul + iaux2 = 2 + if ( optnoe.eq.1 ) then + iaux3 = -1 + else + iaux3 = 20 + endif + iaux4 = 50 + write(ulvecs,32012) iaux1, iaux1, iaux2, iaux3, + > tabaux(1), tabaux(2), + > iaux4, iaux4, + > tabaux(1), tabaux(2), + > tabaux(1)+iaux4, tabaux(2) +c + endif +c +c + endif +c + 92 continue +c + endif +c + if ( codret.eq.0 ) then + call gmlboj ( ntrava, codret ) + endif +c + endif +c +c==== +c 10. Affichage d'informations supplementaires pour les aretes +c Attention : c'est fait seulement maintenant pour ne pas etre cache +c par les faces dessinees +c En numerotation du calcul, on supprime les aretes qui ne sont que +c des aretes HOMARD. +c remarque : dans pcmac1, on s'est arrange pour que les elements +c externes soient numerotes par dimension decroissante : +c . les tetraedres +c . les triangles +c . les quadrangles +c . les aretes +c . les mailles-points +c on affichera ici leur numerotation locale au type d'element +c quand il s'agira de numerotation du calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. affichage suppl aretes ; codret', codret +#endif +c +cgn print *,'infsu1, infsu2, infsu3 = ', infsu1, infsu2, infsu3 + if ( infsu1.ge.5 .and. infsu1.le.6 ) then + jaux = infsu1 + elseif ( infsu2.ge.5 .and. infsu2.le.6 ) then + jaux = infsu2 + elseif ( infsu3.ge.5 .and. infsu3.le.6 ) then + jaux = infsu3 + else + jaux = 0 + endif + if ( jaux.eq.6 .and. rearto.eq.0 ) then + jaux = 0 + endif +c + if ( jaux.ne.0 ) then +c + write(ulvecs,31008) +c + if ( infsu1.ge.1 .and. infsu1.le.2 ) then + kaux = infsu1 + elseif ( infsu2.ge.1 .and. infsu2.le.2 ) then + kaux = infsu2 + elseif ( infsu3.ge.1 .and. infsu3.le.2 ) then + kaux = infsu3 + else + kaux = 0 + endif +c + do 101 , iaux = 1 , nbarvi +c + if ( jaux.eq.5 ) then + saux09(1:1) = 'a' + tabaux(3) = nnarvi(2,iaux) + else + saux09(1:1) = 'A' + tabaux(3) = nareca(nnarvi(2,iaux)) + endif +c + if ( tabaux(3).ne.0 ) then +c + noeud1 = nnarvi(3,iaux) + noeud2 = nnarvi(4,iaux) + tabaur(1) = coopro(1,noeud1) + coopro(1,noeud2) + tabaur(2) = coopro(2,noeud1) + coopro(2,noeud2) +c + tabaux(1) = nint( factx*(decalx+tabaur(1)*unsde) ) + tabaux(2) = nint( facty*(decaly+tabaur(2)*unsde) ) +c + call utench ( tabaux(3), 'g', iaux6, saux07, + > ulsort, langue, codret ) + saux09(3:9) = ' ' + if ( codret.eq.0 ) then + saux09(2:1+iaux6) = saux07(1:iaux6) + else + iaux6 = 0 + endif +c + lacoul = tbcoli(-3) +c +c couleur texte : iaux1 +c profondeur : iaux2 +c police : iaux3 +c taille : iaux4 +c + iaux1 = lacoul + iaux2 = 10 + iaux3 = 16 + iaux4 = 10 + write(ulvecs,32011) iaux1, iaux2, iaux3, iaux4, + > tabaux(1), tabaux(2), saux09(1:1+iaux6) +c + endif +c + 101 continue +c + endif +c +c=== +c 11. formats +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. formats ; codret', codret +#endif +c +30000 format( + > '#FIG 3.2 Produced by HOMARD ',a8) +c string orientation ("Landscape" or "Portrait") +c string justification ("Center" or "Flush Left") +c string units ("Metric" or "Inches") +c string papersize ("Letter", "Legal", "Ledger", "Tabloid", +c "A", "B", "C", "D", "E", +c "A4", "A3", "A2", "A1", "A0" and "B5") +c float magnification (export and print magnification, %) +c string multiple-page ("Single" or "multiple" pages) +c int transparent color (color number for transparent color for GIF +c export. -3=background, -2=None, -1=Default, +c 0-31 for standard colors or 32- for user colors) +30010 format( + > a9, + >/,'Center', + >/,'Metric', + >/,'A4', + >/,'100.00', + >/,'Single', + >/,'-2') +c # optional comment (An optional set of comments may be here, +c which are associated with the whole figure) +30020 format( + > '#Creator: HOMARD ',a8, + >/,'#Title:',a, + >/,'#CreationDate:',a) +c int resolution: 1200 ppi (standard) +c coord_system (Fig units/inch and coordinate system: +c 1: origin at lower left corner (NOT USED) +c 2: upper left) +30030 format( + > '1200 2') +30031 format( + > '# fig2dev -L png -D +1,5,10,41,51 -K ',a) +c +31001 format( + > '# ============', + >/,'# Les segments', + >/,'# ============') +31002 format( + > '# =======================================', + >/,'# Nombre de polygones traces : ',i10 + >/,'# =======================================') +31004 format( + > '# ==================================', + >/,'# Fenetre de zoom', + >/,'# ==================================') +31005 format( + > '# ==================================', + >/,'# Triedre', + >/,'# ==================================') +31006 format( + > '# ==================================', + >/,'# Numeros des faces', + >/,'# ==================================') +31007 format( + > '# ==================================', + >/,'# Numeros des noeuds', + >/,'# ==================================') +31008 format( + > '# ==================================', + >/,'# Numeros des segments', + >/,'# ==================================') +c +c 1 : 1: cercle/ellipse 2:polygone +c 2 : Si polygone : +c 3:courbe fermee (dernier point = premier), 1:courbe ouverte +c Si cercle/ellipse : +c 1:ellipse definie par les rayons 2:par les diametres +c 3:cercle defini par le rayon 4:par le diametre +c 3 : 0: plein, 1: pointille tiret, 2:pointille point +c 4 : epaisseur du trait +c 5 : couleur du trait (-1: defaut (noir), 0: noir, 4: rouge) +c 6 : couleur du remplissage +c 7 : profondeur (0 = devant, 100 = au fond) +c 8 : inutile +c 9 : -1 : pas de remplissage, n: remplissage a 5n% +c 10 : longueur du pointille (reel) +c Si polygone : +c 11 : type de jonction 0:pointu, 1:arrondi +c 14 : fin de trait : 0, si normal, 1 si fleche +c 15 : debut de trait : 0, si normal, 1 si fleche +c il y a une ligne de plus decrivant la fleche +c 16 (dernier) : nombre de points +c Si cercle/ellipse : +c 11 : toujours 1 +c 12 : angle avec axes des x (reel) +c 13 : centre en x +c 14 : centre en y +c 15 : rayon en x +c 16 : rayon en y +c 17 : 1er point en x = centre en x +c 18 : 1er point en y = centre en y +c 19 : dernier point en x = centre en x + rayon en x +c 20 : dernier point en y = centre en y +32001 format( + >'2 ',i2,' 0 1 ',3i3,' -1 ',i2,' 0.000 2 0 -1 ',i2,' 0 ',i2) +32002 format(10i8) +32003 format('1 1 1.00 60.00 120.00') +32011 format( + >'4 0 ',2i3,' -1 ',2i3,' 0.0000 4 135 165 ',2i8,' ',a,'\001') +32012 format( + >'1 3 0 1',3i3,' -1 ',i3,' 0.000 1 0.000 ',8i8) +33001 format('# ',a,i10) +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/FC.h b/src/tool/FC.h new file mode 100644 index 00000000..58a10956 --- /dev/null +++ b/src/tool/FC.h @@ -0,0 +1,3 @@ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ +/* Clone de l'include FC necessaire a cmake pour gerer l'interface Fortran/C */ +/* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */ diff --git a/src/tool/Gestion_MTU/CMakeLists.txt b/src/tool/Gestion_MTU/CMakeLists.txt new file mode 100644 index 00000000..fac6a3e0 --- /dev/null +++ b/src/tool/Gestion_MTU/CMakeLists.txt @@ -0,0 +1,149 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Gestion_MTU + +SET(Gestion_MTU_SOURCES + ./gagpmc.F + ./gagpmf.F + ./gasgmc.F + ./gballo.F + ./gbalme.F + ./gbaloj.F + ./gbcara.F + ./gbdnoe.F + ./gbdnof.F + ./gbdtoj.F + ./gbgeno.F + ./gbitos.F + ./gblboj.F + ./gblibe.F + ./gbminu.F + ./gbntcr.F + ./gbntde.F + ./gbobal.F + ./gbpart.F + ./gbralo.F + ./gmadoj.F + ./gmalog.F + ./gmaloi.F + ./gmaloj.F + ./gmalor.F + ./gmalos.F + ./gmalot.F + ./gmatoj.F + ./gmcata.F + ./gmcmpr.F + ./gmcpal.F + ./gmcpgp.F + ./gmcpoj.F + ./gmdesa.F + ./gmdesg.F + ./gmdesi.F + ./gmdesr.F + ./gmdess.F + ./gmdmp.F + ./gmdmpg.F + ./gmdmpi.F + ./gmdmpr.F + ./gmdmps.F + ./gmdmpt.F + ./gmdtoj.F + ./gmecat.F + ./gmecpr.F + ./gmextg.F + ./gminfo.F + ./gminge.F + ./gmitob.F + ./gmlanm.F + ./gmlboj.F + ./gmliat.F + ./gmmaxi.F + ./gmmess.F + ./gmmod.F + ./gmmodg.F + ./gmmodi.F + ./gmmodr.F + ./gmmods.F + ./gmmoge.F + ./gmnomc.F + ./gmntve.F + ./gmobal.F + ./gmprot.F + ./gmprsx.F + ./gmsgoj.F + ./gmshfi.F + ./gmshfr.F + ./gmshfs.F + ./gmstat.F + ./gmstop.F + ./gmtyoj.F + ./gtbila.F + ./gtdems.F + ./gtfims.F + ./gtinfo.F + ./gtinit.F + ./gtlanm.F + ./gtmess.F + ./gtnoms.F + ./gtstop.F + ./gttabl.F + ./gubila.F + ./gucara.F + ./guenst.F + ./gufefi.F + ./guferm.F + ./gufeul.F + ./gufiul.F + ./guinfg.F + ./guinfo.F + ./guinfu.F + ./guinit.F + ./gulanm.F + ./gumess.F + ./gumoge.F + ./guoufs.F + ./guouge.F + ./gurbbu.F + ./gusost.F + ./gustat.F + ./gustop.F + ./gutabl.F + ./ugdhco.F + ./ugdhfc.F + ./ugdhlc.F + ./ugfia3.F + ./ugfino.F + ./uginit.F + ./uglanm.F + ./ugstop.F + ./ugtabl.F + ./ugtac2.F + ./ugtaci.F + ./ugtacl.F + ./ugtacr.F + ./ugtacs.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Gestion_MTU ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Gestion_MTU ${Gestion_MTU_SOURCES}) + +INSTALL(TARGETS Gestion_MTU EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Gestion_MTU/gagpmc.F b/src/tool/Gestion_MTU/gagpmc.F new file mode 100644 index 00000000..8bf6536a --- /dev/null +++ b/src/tool/Gestion_MTU/gagpmc.F @@ -0,0 +1,147 @@ + subroutine gagpmc ( objet, + > ix, jx, chemin, lgchem, nbchem, + > impopt, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c construction du graphe d'un objet structure +c en memoire centrale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . objet . e . ch8 . nom de l'objet dont on doit construire le . +c . . . . graphe . +c . ix,jx . e . 1 . dimension du tableau chemin(.,.) . +c . chemin . s .(ix,jx) . tableau des chemins du graphe de l'objet . +c . lgchem . s . ix . longueur des chemins . +c . nbchem . s . 1 . nombre de chemins . +c . impopt . e . 1 . 1 : on imprime le graphe ; 0 : non . +c . codret . s . 1 . code de retour : . +c . . . . 0 : OK . +c . . . . -1 : dimensionnement insuffisant . +c . . . . -2 : objet non structure . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GAGPMC' ) +c +c +#include "genbla.h" +c +#include "gmmaxt.h" +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtoai.h" +#include "gmtoas.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmalrl.h" +#include "gmalen.h" +#include "gmalst.h" +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer ix,jx,nbchem, impopt, codret + integer lgchem(ix) +c + character*(*) objet + character*8 chemin(ix,jx) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer nbrobj, nbrcha +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + > '(/,''=======> graphe VTOC-MC de '',a8,'' <========'',/)' +c + texte(2,10) = + > '(/,''=======> graph VTOC-CM of '',a8,'' <========'',/)' +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro +90000 format (70('=')) +#endif +c +c==== +c 2. appel du programme generique +c==== +c + if (impopt.eq.1) then + write (ulsort,texte(langue,10)) objet + endif +c + nbrobj = iptobj-1 + nbrcha = iptchp-1 + call gagpmf ( objet, chemin, lgchem, nbchem, + > ix, jx, nbrobj, nbrcha, + > nomobj, typobj, adrdso, nomobc, + > nballi, nomali, + > nballr, nomalr, + > nballs, nomals, + > impopt, codret) +c + if (impopt.eq.1) then + write (ulsort,texte(langue,10)) objet + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gagpmf.F b/src/tool/Gestion_MTU/gagpmf.F new file mode 100644 index 00000000..7b09aed5 --- /dev/null +++ b/src/tool/Gestion_MTU/gagpmf.F @@ -0,0 +1,476 @@ + subroutine gagpmf (objet, chemin, lgchem, nbchem, + > ix, jx, nbrobj, nbrcha, + > nomob, typob, adrch, nomco, + > nballi, nomali, + > nballr, nomalr, + > nballs, nomals, + > impopt, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c construction du graphe d'un objet structure en memoire +c centrale ou sur fichier +c +c de maniere generale, on a : +c +c nbchem = nombre de chemins pour l'objet +c lgchem(i) = longueur du i-eme chemin +c chemin(i,2n-1) = nom du n-eme champ du i-eme chemin +c chemin(i,2n) = nom de l'objet associe a ce n-eme champ +c chemin(i,lgchem) = symbole pour le dernier champ : +c * pour simple alloue +c > pour structure alloue +c = pour simple non alloue +c + pour structure non alloue +c - pour simple non defini +c < pour structure non defini +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . objet . e . ch8 . nom de l'objet dont on doit construire le . +c . . . . graphe . +c . chemin . s .(ix,jx) . tableau des chemins du graphe de l'objet . +c . lgchem . s . ix . longueur des chemins . +c . nbchem . s . 1 . nombre de chemins . +c . ix,jx . e . 1 . dimension du tableau chemin(.,.) . +c . nbrobj . e . 1 . nombre d'objet enregistres . +c . nbrcha . e . 1 . nombre de champs . +c . impopt . e . 1 . 1 : on imprime le graphe ; 0 : non . +c . codret . s . 1 . code de retour : . +c . . . . 0 : OK . +c . . . . -1 : dimensionnement insuffisant . +c . . . . -2 : objet non structure . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GAGPMF' ) +c +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtors.h" +c +#include "gminds.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer ix, jx, nbrobj, nbrcha, impopt, codret + integer nballi, nballr, nballs + integer nbchem, lgchem(ix) +c + integer typob(nbrobj), adrch(nbrobj) +c + character*(*) objet + character*8 chemin(ix,jx) + character*8 nomob(nbrobj), nomco(nbrcha) + character*8 nomali(nballi) + character*8 nomalr(nballr) + character*8 nomals(nballs) +c +c 0.4. ==> variables locales +c + character*8 nomo +c + integer iaux,jaux,kaux,typo,nbch,icha,typc + integer jn,noderc,n,k + integer nroobj, posich +c + logical existc, encore, trouvc +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '('' * : objet simple alloue'')' + texte(1,5) = '('' = : objet simple defini mais non alloue'')' + texte(1,6) = '('' + : objet structure defini mais non alloue'')' + texte(1,7) = '('' - : objet simple non defini'')' + texte(1,8) = '('' < : objet structure non defini'')' + texte(1,9) = '('' '')' +c + texte(2,4) = '('' * : allocated simple object'')' + texte(2,5) = '('' = : defined but not allocated simple object'')' + texte(2,6) = + > '('' + : defined but not allocated structured object'')' + texte(2,7) = '('' - : undefined simple object'')' + texte(2,8) = '('' < : undefined structured object'')' + texte(2,9) = '('' '')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro +90000 format (70('=')) +#endif +c +c==== +c 2. initialisations +c==== +c + do 21 , iaux = 1,nbrobj + if (nomob(iaux).eq.objet) then + nroobj = iaux + codret = 0 + goto 31 + endif + 21 continue +c + codret = -2 +c +c==== +c 3. recherche de l'objet initial et de ses champs +c==== +c + 31 continue +c + if ( codret.eq.0 ) then +c +c 3.1. ==> initialisation du chemin : a priori, il est indefini +c remarque : la boucle sur ix doit etre interne pour la +c vectorisation car ix >> jx +c + do 312 , jaux = 1,jx + do 311 , iaux = 1,ix + chemin(iaux,jaux) = sindef + 311 continue + 312 continue +c +c 3.2. ==> reperage des noms et type des champs de l'objet +c + typo = typob(nroobj) + nbch = nbcham(typo) +c + do 32 , iaux = 1,nbch +c + icha = adrdst(typo)+iaux-1 + chemin(iaux,1) = nomcha(icha) +c + kaux = adrch(nroobj)+iaux-1 + chemin(iaux,2) = nomco(kaux) +c + typc = typcha(icha) +c + if (typc.lt.0) then + chemin(iaux,3) = '* ' + else + chemin(iaux,3) = '> ' + endif +c + lgchem(iaux) = 3 +c + 32 continue +c + endif +c +c==== +c 4. construction du graphe +c==== +c + if ( codret.eq.0 ) then +c +c 4.1. ==> construction de l'arborescence +c + do 41 , jn = 1,jx +c +c 4.1.1. ==> recherche du numero du dernier champ defini : noderc +c + do 411 , iaux = 1,ix + if (chemin(iaux,1).eq.sindef) then + noderc = iaux-1 + goto 412 + endif + 411 continue + write (ulsort,*) 'apres 411 continue' + codret = -1 +c + 412 continue +c + if ( codret.eq.0 ) then +c +c 4.1.2. ==> nbchem est le nombre total de chemins a decrire : +c au depart, c'est le nombre de champs de l'objet demande. +c par ailleurs on signale que tout est fait +c + nbchem = noderc + encore = .false. +c +c 4.1.3. ==> on explore chacun des champs de l'objet de depart, jusqu'a +c ce qu'il n'y ait plus que des champs simples +c + do 413 , iaux = 1,noderc +c +c 4.1.3.1. ==> recherche d'un champ de type structure dans le chemin +c s'il en existe un : +c . on repere sa position par posich +c . on signale qu'il faudra recommencer pour lui +c + do 431 , jaux = 3 , jx , 2 + if (chemin(iaux,jaux)(1:1).eq.'>') then + posich = jaux + encore = .true. + existc = .true. + goto 432 + endif + if (chemin(iaux,jaux)(1:1).eq.'*') then + existc = .false. + goto 432 + endif + 431 continue +c +c 4.1.3.2. ==> on est sur un champ de type structure +c + 432 continue +c + if ( existc ) then +c +c 4.1.3.2.1. ==> quel est le nom de ce champ ? +c . s'il n'est pas defini, on le symbolise par '< ' +c . s'il est defini on cherche son numero dans +c la liste des champs ; si on ne l'y trouve pas, on +c le symbolise par '+ ' +c + nomo = chemin(iaux,posich-1) +c + if (nomo.eq.sindef) then +c + chemin(iaux,posich) = '< ' + trouvc = .false. +c + else +c + do 433 , kaux = 1,nbrobj + if (nomob(kaux).eq.nomo) then + nroobj = kaux + trouvc = .true. + goto 434 + endif + 433 continue +c + chemin(iaux,posich) = '+ ' + trouvc = .false. +c + endif +c + 434 continue +c +c 4.1.3.2.2. ==> le champ est defini : il faut ecrire sa descendance +c en fait, on fait comme a l'etape 2 pour l'objet de depart +c . pour le premier champ, on etend le chemin existant +c . pour les eventuels champs suivants, on cree autant +c de nouveaux chemins en recopiant le debut +c + if ( trouvc ) then +c + if ( posich+2.gt.jx ) then + write (ulsort,*) 'objet = ',objet + write (ulsort,*) 'dans 4.1.3.2.2, posich+2 = ',posich+2 + write (ulsort,*) 'dans 4.1.3.2.2, jx = ',jx + do 1789 , n = 1,nbch + write (ulsort,*)(chemin(n,k),k=1,jx) + 1789 continue + codret = -1 + goto 42 + endif +c +c on commence par ecrire les trois informations +c de la fin du chemin en cours : +c nom du champ, nom de l'objet associe, symbole +c + typo = typob(nroobj) + nbch = nbcham(typo) +c + icha = adrdst(typo) + chemin(iaux,posich) = nomcha(icha) +c + kaux = adrch(nroobj) + chemin(iaux,posich+1) = nomco(kaux) +c + typc = typcha(icha) + if (typc.lt.0) then + chemin(iaux,posich+2) = '* ' + else + chemin(iaux,posich+2) = '> ' + endif +c + lgchem(iaux) = posich+2 +c +c ensuite, on cree les chemins associes aux eventuels +c champs suivants : +c . on commence par mettre le debut +c . puis on complete par les caracteristiques propres +c au champ en cours +c + do 435 , n = 1,nbch-1 +c + nbchem = nbchem+1 +c + do 436 , k = 1,posich-1 + chemin(nbchem,k) = chemin(iaux,k) + 436 continue +c + icha = adrdst(typo)+n + chemin(nbchem,posich) = nomcha(icha) +c + kaux = kaux + 1 + chemin(nbchem,posich+1) = nomco(kaux) +c + typc = typcha(icha) + if (typc.lt.0) then + chemin(nbchem,posich+2) = '* ' + else + chemin(nbchem,posich+2) = '> ' + endif +c + lgchem(nbchem) = posich+2 +c + 435 continue +c + endif +c + endif +c + 413 continue +c +c 4.1.3. ==> on a fini d'explorer une branche. on sort si c'est fini +c + if ( .not.encore ) then + goto 42 + endif +c + endif +c + 41 continue +c +c 4.2. ==> on controle les extremites des champs : celles qui +c correspondent a des objets simples definis mais non alloues +c sont signalees +c + 42 continue +c + do 421 , iaux = 1 , nbchem +c + if ( chemin(iaux,lgchem(iaux))(1:1).eq.'*' ) then +c + nomo = chemin(iaux,lgchem(iaux)-1) +c + if ( nomo.eq.sindef ) then +c + chemin(iaux,lgchem(iaux)) = '- ' +c + else +c + trouvc = .false. +c + do 422 , jaux = 1 , nballi + if (nomali(jaux).eq.nomo) then + trouvc = .true. + goto 429 + endif + 422 continue +c + do 423 , jaux = 1 , nballr + if (nomalr(jaux).eq.nomo) then + trouvc = .true. + goto 429 + endif + 423 continue +c + do 424 , jaux = 1 , nballs + if (nomals(jaux).eq.nomo) then + trouvc = .true. + goto 429 + endif + 424 continue +c + 429 continue + if ( .not.trouvc ) then + chemin(iaux,lgchem(iaux)) = '= ' + endif +c + endif +c + endif +c + 421 continue +c + endif +c +c==== +c 5. impressions +c==== +c + if (impopt.eq.1) then +c + do 51 , iaux = 4, 9 + write (ulsort,texte(langue,iaux)) + 51 continue +c + write (ulsort,*) ' ' + do 52 , iaux = 1 , nbchem + kaux = min ( 10 , lgchem(iaux) ) + write (ulsort,5000) iaux,(chemin(iaux,jaux),jaux=1,kaux) + if ( lgchem(iaux).gt.kaux ) then + write (ulsort,5001) + > (chemin(iaux,jaux),jaux=kaux+1,lgchem(iaux)) + endif + write (ulsort,*) ' ' + 52 continue +c + write (ulsort,*) ' ' +c + 5000 format(i3,'-> ',10(1x,a8)) + 5001 format(7x,10(1x,a8)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gasgmc.F b/src/tool/Gestion_MTU/gasgmc.F new file mode 100644 index 00000000..b2cbcc33 --- /dev/null +++ b/src/tool/Gestion_MTU/gasgmc.F @@ -0,0 +1,342 @@ + subroutine gasgmc ( nomemc, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c supprimer le graphe d'un objet en memoire centrale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomemc . e .char(*) . nom etendu en memoire centrale . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : nom d'objet invalide . +c . . . . -2 : Probleme dans la liberation d'un objet. +c . . . . du chemin . +c . . . . -3 : Probleme au detachement . +c . . . . -4 : L'objet n'est pas alloue. . +c . . . . -5 : L'objet est simple . +c . . . . -6 : dimensionnement insuffisant . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GASGMC' ) +c +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gminds.h" +c +#include "gmcoer.h" +#include "envex1.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer codret +c + character*(*) nomemc +c +c 0.4. ==> variables locales +c +#include "gmixjx.h" +c + character*8 chemin(ix,jx), objter + character*8 objdet(nbjx), objlib(nbjx) + character*8 obrepc, obterc, chterc + character*40 mess +c + integer iaux, jaux, kaux + integer igrp, nj1, nbojdl, nbojdd, ityc, ioal + integer impopt, nbchem, lgchem(ix) +c + logical alloue, attach +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ... juste pour ne plus avoir de messages ftnchek : +c + data objdet / nbjx * ' ' / + data objlib / nbjx * ' ' / +c +#ifdef _DEBUG_HOMARD_ + impopt = 1 +#else + impopt = 0 +#endif +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(1x,''Suppression du graphe de l''''objet '',a8)' + texte(1,4) = '(1x,''en memoire centrale.'')' + texte(1,11) = '(1x,''Le nom d''''objet est invalide.'')' + texte(1,12) = + > '(1x,''Probleme a la liberation d''''un objet du chemin.'')' + texte(1,13) = '(1x,''Probleme lors d''''un detachement.'')' + texte(1,14) = '(1x,''L''''objet n''''est pas alloue.'')' + texte(1,15) = '(1x,''L''''objet est simple.'')' + texte(1,16) = '(1x,''Dimensionnement du chemin insuffisant.'')' +c + texte(2,6) = '(1x,''Suppression of the graph of the object '',a8)' + texte(2,4) = '(1x,''in central memory.'')' + texte(2,11) = '(1x,''The name of the object is not valid.'')' + texte(2,12) = '(1x,''Problem in freeing an object of the path.'')' + texte(2,13) = '(1x,''Problem in untighting.'')' + texte(2,14) = '(1x,''The object is not allocated.'')' + texte(2,15) = '(1x,''The object is simple.'')' + texte(2,16) = '(1x,''Unsufficient path dimension.'')' +c + mess = ' ' +c +c==== +c 2. on recherche le type d'allocation +c==== +c +c 2.1. ==> decodage du nom +c + call gbdnoe(nomemc,obrepc,obterc,chterc,codret) +cgn write(1,*) nompro, codret +c + if ( codret.lt.0 .or. codret.eq.1 .or. codret.eq.2 ) then + codret = -1 + else + codret = 0 + endif +cgn write(1,*) nompro, codret, coergm +c +c 2.2. ==> l'objet "obterc" est-il alloue ? +c ioal = 0 : objet non alloue +c ioal = 1 : objet structure alloue +c ioal = 2 : objet simple alloue +c + if ( codret.eq.0 ) then +c + call gbobal ( obterc, ityc, ioal ) +c +cgn write(1,*) nompro, ioal, coergm + endif +c +c==== +c 3. si l'objet est structure +c==== +c + if ( codret.eq.0 ) then +c + if ( ioal.eq.1 ) then +c +c 3.1. ==> nbojdl : nombre d'objets deja liberes +c nbojdd : nombre d'objets deja detaches +c + nbojdl = 0 + nbojdd = 0 +c +c 3.2. ==> construction du graphe de 'nomemc' +c * pour simple alloue +c > pour structure alloue +c = pour simple non alloue +c + pour structure non alloue +c - pour simple non defini +c < pour structure non defini +c + iaux = ix + jaux = jx + call gagpmc(obterc,iaux,jaux,chemin,lgchem,nbchem,impopt,igrp) +c + if (igrp.lt.0) then + mess = ' gasgmc -> gagpmc -> codret : ' + write(mess(29:30),'(i2)') igrp + codret = -6 + goto 91 + endif +cgn write(1,*) nompro, codret, coergm +c +c 3.3. ==> liberation de tous les objets du chemin +c + do 33 , iaux = nbchem , 1 , -1 +c +c 3.3.1. ==> recherche de la profondeur du chemin +c + do 331 , jaux = 3 , jx , 2 + if ((chemin(iaux,jaux)(1:1).eq.'*').or. + > (chemin(iaux,jaux)(1:1).eq.'=').or. + > (chemin(iaux,jaux)(1:1).eq.'+').or. + > (chemin(iaux,jaux)(1:1).eq.'-').or. + > (chemin(iaux,jaux)(1:1).eq.'<')) then + nj1 = jaux-1 + goto 332 + endif + 331 continue + codret = -6 + goto 91 +c + 332 continue +c +c 3.3.2. ==> exploration des branches de ce chemin, a l'envers +c on s'interesse a tous ceux que le graphe declare comme +c etant alloues. neanmoins, il faut verifier a chaque +c fois que l'objet est encore alloue car il a pu etre +c desalloue dans un chemin precedent. +c quand on arrive au bout du chemin, il faut detacher +c le dernier objet de la racine +c + do 333 , jaux = nj1 , 2 ,-2 +c + objter = chemin(iaux,jaux) +c + alloue = .true. + if (objter.eq.sindef) then + alloue = .false. + endif + if ((chemin(iaux,jaux+1)(1:1).eq.'=').or. + > (chemin(iaux,jaux+1)(1:1).eq.'+').or. + > (chemin(iaux,jaux+1)(1:1).eq.'-').or. + > (chemin(iaux,jaux+1)(1:1).eq.'<')) then + alloue = .false. + endif + do 334 , kaux = 1,nbojdl + if (objlib(kaux).eq.objter) then + alloue = .false. + endif + 334 continue +c + if ( alloue ) then +c + call gblboj (objter) +cgn write(1,*) nompro, 'call gblboj (objter)', coergm + if ( coergm.ne.0 ) then + mess(1:8) = objter + codret = -2 + goto 91 + endif +c + nbojdl = nbojdl+1 + objlib(nbojdl) = objter +c + endif +c + if ( jaux.eq.2 .and. chemin(iaux,2).ne.sindef ) then +c + attach = .true. + do 335 , kaux = 1,nbojdd + if (objdet(kaux).eq.chemin(iaux,1)) then + attach = .false. + endif + 335 continue +c + if ( attach ) then +c + call gmdtoj ( obterc//'.'//chemin(iaux,1) , kaux ) +cgn write (ulsort,*) obterc//'.'//chemin(iaux,1) , kaux, coergm + if ( kaux.ne.0 ) then + mess(1:17) = obterc//'.'//chemin(iaux,1) + codret = -3 + goto 91 + endif +c + nbojdd = nbojdd+1 + objdet(nbojdd) = chemin(iaux,1) +c + endif +c + endif +c + 333 continue +c + 33 continue +c +c==== +c 4. si l'objet est simple : pas de chemin +c==== +c + elseif ( ioal.eq.2 ) then +c + codret = -5 +c +c==== +c 5. l'objet n'est pas alloue +c==== +c + else +c + codret = -4 +c + endif +c + endif +c +c==== +c 9. gestion des erreurs +c==== +c + 91 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '9. Gestions des erreurs ; codret = ', codret + write (ulsort,*) '9. Gestions des erreurs ; coergm = ', coergm +#endif +c + if ( codret.ne.0 ) then +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,6)) + write (ulsort,*) nomemc + write (ulsort,texte(langue,4)) + if ( abs(codret).le.6 .and. coergm.eq.0 ) then + iaux = 10+abs(codret) + write (ulsort,texte(langue,iaux)) + endif + write (ulsort,*) mess + write (ulsort,90000) +c +#include "envex2.h" +c + endif +c +90000 format (1x,70('=')) +c + end diff --git a/src/tool/Gestion_MTU/gballo.F b/src/tool/Gestion_MTU/gballo.F new file mode 100644 index 00000000..f37842ed --- /dev/null +++ b/src/tool/Gestion_MTU/gballo.F @@ -0,0 +1,393 @@ + subroutine gballo ( nom, typeob, long, adress, + > nbcain, carint, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c allocation de l'objet terminal d'un nom etendu "nom" +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . s . char*8 . nom de l'objet alloue . +c . typeob . e .char(*) . type de l'objet a allouer . +c . long . e . 1 . 0 si on veut un objet structure . +c . . . . longueur si on veut un objet simple . +c . adress . s . ent . 0 si on veut un objet structure . +c . . . . adresse de l'objet simple alloue . +c . nbcain . e . 1 . nombre de premiers caracteres interdits . +c . carint . e . char*1 . liste de caracteres interdits . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : dimensionnement des tables insuffisant. +c . . . . -2 : le type de l'objet-terminal est celui . +c . . . . d'un objet structure et long /= 0 . +c . . . . -3 : "nom" a plus d'un element et "typeob" . +c . . . . ne correspond pas au type du champ . +c . . . . terminal sauf si "typeob" = ' ' alors . +c . . . . c'est le type du champ-terminal . +c . . . . qui serait considere . +c . . . . -4 : "nom" a un seul element et "typeob" . +c . . . . n'est pas connu . +c . . . . -5 : l'objet-terminal est deja alloue . +c . . . . -6 : nom etendu invalide . +c . . . . -7 : premier caractere interdit . +c . . . . -8 : le nom doit avoir un seul element . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBALLO' ) +c +#include "gmmatc.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gmimpr.h" +c +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) nom, typeob + character*1 carint(*) +c + integer long, adress, codret, nbcain +c +c 0.4. ==> variables locales +c + character*8 objrep, objter, chater, nomloc + character*8 typem, nomt + character*60 mess +c + integer iaux + integer idec, ialo, iptr, ierr, ioal, itoc + integer iob, ityp, ityc, nbc, k, ich, ioc + integer nroobj, nrocha, nfois, ntry, kcha +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#include "alphnu.h" +c + data nfois / 0 / +c + adress = 0 + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 1. decodage du nom etendu +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GBDNOE', nompro +#endif + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + codret = -6 +c + else if (idec.eq.3) then +c +c objet-terminal alloue +c + codret = -5 +c + else if (idec.eq.0) then +c +c 'nom' n'a qu'un seul element +c +c verification du nom +c + iaux = nbcain + call gmntve ( objter, nomloc, iaux, carint, codret ) +c + if ( codret.ne.0 ) then + codret = -7 + goto 9999 + endif +c +c on alloue en structure. Si ca ne marche pas, on essaiera +c en simple +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GBALOJ', nompro +#endif + call gbaloj(nomloc,typeob,ialo) +c + if (ialo.eq.0) then + codret = 0 + adress = 0 + else if (ialo.eq.-1) then + codret = -1 + if (nfois.eq.0) then + nfois = 1 + write(ulsort,*) + > 'dimensionnement des tables gm insuffisant' + write(ulsort,*) + > 'augmenter nobjx ou nobcx' + write(ulsort,*) + > '(fichier a inclure gmmatc.h)' + codret = 5 + goto 9999 + endif + else if (ialo.eq.-2) then + codret = -5 + else +c +c 2. typeob peut etre simple : appel gmalo* +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GBMINU', nompro +#endif + call gbminu(typeob,typem) + codret = 0 + if (typem.eq.nomtyb(1)) then + call gmaloi(nomloc,iptr,long) + else if (typem.eq.nomtyb(2)) then + call gmalor(nomloc,iptr,long) + else if (typem.eq.nomtyb(3)) then + call gmalos(nomloc,iptr,long) + else + codret = -4 + goto 9999 + endif + if ( coergm.ne.0 ) then + codret = coergm + goto 9999 + endif + adress = iptr + endif +c + else +c +c 'nom' a plusieurs elements +c +c rechercher le type du champ-terminal de l'objet-repertoire +c + do 21 , iob = 1,iptobj-1 + if (nomobj(iob).eq.objrep) then + nroobj = iob + goto 20 + endif + 21 continue +c + codret = -6 + goto 9999 +c + 20 continue +c + ityp = typobj(nroobj) + nbc = nbcham(ityp) + do 22 k = 1, nbc + ich = adrdst(ityp)+k-1 + if (nomcha(ich).eq.chater) then + nrocha = ich + kcha = k + goto 40 + endif + 22 continue +c + codret = -6 + goto 9999 +c +c 3. verification la concordance de 'typeob' avec le type du +c champ-terminal +c + 40 continue +c + ityc = typcha(nrocha) +c + if (ityc.gt.0) then + if (long.ne.0) then + codret = -2 + goto 9999 + endif + nomt = nomtyp(ityc) + typem = typeob + else + if (ityc.eq.-1) then + nomt = nomtyb(1) + else if (ityc.eq.-2) then + nomt = nomtyb(2) + else if (ityc.eq.-3) then + nomt = nomtyb(3) + endif + call gbminu(typeob,typem) + endif +c + if ((typeob.ne.' ').and.(typem.ne.nomt)) then + codret = -3 + goto 9999 + endif +c +c 4. generation d'un nom si l'objet-terminal est indefini +c + if (idec.eq.1) then +c + ntry = 1 + iaux = 0 + 41 continue +c + call gbgeno(nom,' ',objter,ierr) +c +c verification du nom +c attention : on ne controle plus la premiere lettre +c car c'est la meme que celle de l'objet de tete +c + call gmntve ( objter, nomloc, iaux, carint, codret ) +c + if ( codret.ne.0 ) then + codret = -6 + goto 9999 + endif +c + if (ierr.lt.0) then + mess = ' gballo -> gbgeno -> ierr : ' + write(mess(29:30),'(i2)') ierr + write(ulsort,*) mess + write(ulsort,*) nom + codret = 42 + goto 9999 + endif +c + call gbobal(nomloc,itoc,ioal) +c + if (ioal.gt.0) then + if (ntry.lt.lgaln4) then +c +c le generateur de noms gbgeno ne sait pas generer plus de lgaln4 +c noms differents ... +c + ntry = ntry + 1 + goto 41 + else + mess = ' gballo -> nom '//nomloc//' deja utilise ' + write(ulsort,*) mess + codret = 42 + goto 9999 + endif + endif +c +c 5. attacher ce nom a sa place +c + ioc = adrdso(nroobj)+kcha-1 + nomobc(ioc) = nomloc +c + endif +c +c 6. allocation de l'objet attache +c + if (ityc.gt.0) then +c +c on alloue en structure. Si ca ne marche pas, on essaiera +c en simple +c + call gbaloj(nomloc,nomt,ialo) +c + if (ialo.lt.0) then + if (ialo.eq.-1) then + codret = -1 + if (nfois.eq.0) then + nfois = 1 + write(ulsort,*) + > 'dimensionnement des tables gm insuffisant' + write(ulsort,*) + > 'augmenter nobjx ou nobcx' + write(ulsort,*) + > '(fichier a inclure gmmatc.h)' + codret = 61 + goto 9999 + endif + else + mess = ' gballo -> gbaloj pour '//nomloc//' -> ialo : ' + write(mess(43:44),'(i2)') ialo + write(ulsort,*) mess + codret = 62 + goto 9999 + endif + endif +c + else +c +c objet de type simple +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'gmalo.', nompro + write (ulsort,*) 'ityc = ', ityc +#endif + if (ityc.eq.-1) then + call gmaloi(nomloc,iptr,long) + else if (ityc.eq.-2) then + call gmalor(nomloc,iptr,long) + else if (ityc.eq.-3) then + call gmalos(nomloc,iptr,long) + endif + if ( coergm.ne.0 ) then + codret = coergm + goto 9999 + endif +c + adress = iptr +c + endif +c + endif +c +c==== +c 4. Fin +c==== +c + 9999 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbalme.F b/src/tool/Gestion_MTU/gbalme.F new file mode 100644 index 00000000..c1406adf --- /dev/null +++ b/src/tool/Gestion_MTU/gbalme.F @@ -0,0 +1,122 @@ + subroutine gbalme ( typzon, lgzone, adress ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c allocation d'une zone de lgzone places dans le type 'typzon' +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typzon . e . char*1 . type de la zone a allouer . +c . lgzone . e . 1 . longueur de la zone . +c . adress . s . 1 . adresse du premier element de la zone . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBALME' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*1 typzon + integer lgzone, adress +c +c 0.4. ==> variables locales +c + integer ltype, taille + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. controle du type et de sa longueur +c==== +c + if ( typzon.eq.'i'.or.typzon.eq.'I') then + ltype = tentie + elseif ( typzon.eq.'s'.or.typzon.eq.'S') then + ltype = tchain + elseif ( typzon.eq.'r'.or.typzon.eq.'R') then + ltype = treel + else + write(ulsort,*) nompro, ', type inconnu ', typzon + coergm = 1 + endif +c +c==== +c 3. Allocations +c==== +c + if ( coergm.eq.0 ) then +c + taille = ltype*lgzone +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '..... taille : ', taille +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DMALME', nompro +#endif + call dmalme ( adress, taille, coergm ) +c + endif +c +c==== +c 4. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbaloj.F b/src/tool/Gestion_MTU/gbaloj.F new file mode 100644 index 00000000..3f3418ab --- /dev/null +++ b/src/tool/Gestion_MTU/gbaloj.F @@ -0,0 +1,119 @@ + subroutine gbaloj (nom,type,iret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c fonction d'allocation d'un objet "nom", structure, de type +c "type" +c ........................................................... +c +c entrees : +c nom : character*8 : nom de l'objet a allouer +c type : character*8 : nom du type de l'objet a allouer +c +c ( ou chaine de 8 caracteres au plus ) +c +c ........................................................... +c +c sorties : iret : +c -3 : erreur : type inconnu +c -2 : erreur : il existe deja un objet de ce nom +c (structure ou simple) +c -1 : erreur : allocation impossible : +c dimensionnement des tables insuffisant +c 0 : OK +c +c ........................................................... +c +c 0. declarations et dimensionnement +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +c +c 0.3. ==> arguments +c + character*(*) nom, type + integer iret +c +c 0.4. ==> variables locales +c + integer ityp, ity, ioal, ityptr +c +c 1. recherche du type +c + do 10 ity = 1, nbrtyp + if (nomtyp(ity).eq.type) then + ityptr = ity + goto 20 + endif + 10 continue +c + iret = -3 + goto 30 +c +c 2. verification si cet objet existe deja +c + 20 continue +c + call gbobal(nom,ityp,ioal) +c + if (ioal.ge.1) then + iret = -2 + goto 30 + endif +c +c 3. mise a jour des tables +c + if ( (iptobj.gt.nobjx) .or. + > (iptchp+nbcham(ity).gt.nobcx+1) .or. + > (iptatt+nbratt(ity).gt.nobcx+1) ) then + iret = -1 + else +c + nomobj(iptobj) = nom + typobj(iptobj) = ityptr + adrdso(iptobj) = iptchp + adrdsa(iptobj) = iptatt + iptobj = iptobj+1 + iptchp = iptchp + nbcham(ityptr) + iptatt = iptatt+nbratt(ityptr) +c + if ((iptobj.eq.nobjx).or.(iptchp.gt.nobcx) + > .or.(iptatt.gt.nobcx)) then + iret = -1 + else + iret = 0 + endif + endif +c + 30 continue +c + end diff --git a/src/tool/Gestion_MTU/gbcara.F b/src/tool/Gestion_MTU/gbcara.F new file mode 100644 index 00000000..0756980b --- /dev/null +++ b/src/tool/Gestion_MTU/gbcara.F @@ -0,0 +1,364 @@ + subroutine gbcara ( nomtab , nrotab, adut , ilong , type8 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . derniere modif octo 93 at prise en compte du type simple precision +c . modif octo 93 gn prise en compte du type double precision +c . modif juin 93 jyb prise en compte du type character*8 +c . modif 15/06/89 jc jyb +c ...................................................................... +c . recherche les caracteristiques d'un tableau (position,longueur +c . et type ) a partir de son nom. retourne un code d'erreur si le +c . nom n'est pas repertorie ou si il y a ambiguite. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomtab . e . ch*8 . nom du tableau a rechercher . +c . nrotab . s . 1 . numero du tableau dans sa categorie . +c . adut . s . 1 . adresse de debut de tableau dans le maxi- . +c . . . . tableau associe a son type . +c . ilong . s . 1 . dimension du tableau . +c . type8 . s . ch*8 . type de tableau ou probleme rencontre . +c . coergm . s . 1 . code de retour d'erreur . +c . . . . 0 tableau trouve . +c . . . . 1 tableau non trouve . +c . . . . 2 tableau repertorie plusieurs fois reel . +c . . . . 3 tableau repertorie plusieurs fois ent . +c . . . . 4 tableau repertorie plusieurs fois simp . +c . . . . 5 tableau repertorie plusieurs fois char . +c . . . . 6 tableau repertorie plusieurs fois comp . +c . . . . 7 tableau repertorie dans deux types . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GBCARA' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +#include "gmtyge.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmalrl.h" +#include "gmalen.h" +#include "gmalst.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*8 nomtab + character*8 type8 +c + integer nrotab, adut , ilong +c +c 0.4. ==> variables locales +c + character*8 nomvar +c + integer iaux + integer icpti, icptr, icpts + integer i, iadd + integer ltype, ad0, ad1 + integer nbcain +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c + character*1 carint(1) +c +c 0.5. ==> initialisations +c + data nbcain / 0 / +c + data carint(1) / ' ' / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + > '(''Nom de l''''objet a rechercher en memoire centrale :'')' + texte(1,11) = '(''L''''objet n''''est pas alloue.'')' + texte(1,12) = '(''Present plusieurs fois dans les reels.'')' + texte(1,13) = '(''Present plusieurs fois dans les entiers.'')' + texte(1,14) = '(''Present plusieurs fois dans les chaines.'')' + texte(1,15) = '(''Present dans deux types.'')' + texte(1,18) = '(''Mode de gestion de la memoire inconnu.'')' + texte(1,20) = '(''Le nom est incorrect.'')' +c + texte(2,10) = + > '(''Name of the wanted object in central memory :'')' + texte(2,11) = '(''The object is not allocated.'')' + texte(2,12) = '(''Present several times in reals.'')' + texte(2,13) = '(''Present several times in integers.'')' + texte(2,14) = '(''Present several times in character.'')' + texte(2,15) = '(''Present in two types.'')' + texte(2,18) = '(''Unknown memory management mode.'')' + texte(2,20) = '(''Name is uncorrect.'')' +c +#ifdef _DEBUG_HOMARD_ +c write (ulsort,90000) + write (ulsort,texte(langue,10)) + write (ulsort,*) nomtab +#endif +c +c==== +c 1. verifications +c==== +c + call gmntve ( nomtab, nomvar, nbcain, carint, coergm ) +c +cgn write (ulsort,*) coergm + if ( coergm.ne.0 ) then + coergm = 10 + endif +c +c==== +c 2. recherche du nombre d'occurences dans les tableaux +c entiers, reels et character*8 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Recherche ; coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c + nrotab = 0 +c + icpti = 0 + do 21 i = 1, nballi + if ( nomvar.eq.nomali(i) ) then + icpti = icpti + 1 + nrotab = i + endif + 21 continue +c + icptr = 0 + do 22 i = 1, nballr + if ( nomvar.eq.nomalr(i) ) then + icptr = icptr + 1 + nrotab = i + endif + 22 continue +c + icpts = 0 + do 23 i = 1, nballs + if ( nomvar.eq.nomals(i) ) then + icpts = icpts + 1 + nrotab = i + endif + 23 continue +c + endif +c +c==== +c 3. bilan de la recherche +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Bilan de la recherche ; coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c +c 3.1. ==> cas sympa : le tableau n'apparait qu'une seule fois +c + if ( (icptr + icpti + icpts).eq.1 ) then +c +c 3.1.1. ==> chez les entiers +c + if ( icpti.eq.1 ) then +c + iadd = ptalli (nrotab) + ilong = lgalli (nrotab) + type8 = 'entier ' + ltype = tentie + ad0 = adcom(1) + ad1 = admem(1) +c +c 3.1.2. ==> chez les reels double precison +c + elseif ( icptr.eq.1 ) then + iadd = ptallr (nrotab) + ilong = lgallr (nrotab) + type8 = 'reel ' + ltype = treel + ad0 = adcom(2) + ad1 = admem(2) +c +c 3.1.3. ==> chez les character*8 +c + elseif ( icpts.eq.1 ) then +c + iadd = ptalls (nrotab) + ilong = lgalls (nrotab) + type8 = 'chaine ' + ltype = tchain + ad0 = adcom(3) + ad1 = admem(3) +c + endif +c +c 3.1.6. ==> correction de l'adresse utile +c + if ( modgm.eq.0 ) then + adut = ((ad1-ad0)/ltype) + iadd + coergm = 0 + else if ( modgm.eq.1 ) then + adut = ((ad1-ad0)/ltype) + iadd + 1 + coergm = 0 + else if ( modgm.eq.2 ) then +c +c mode dynamique : +c + adut = (iadd-ad0)/ltype +c +c en particulier pour les "gros types", +c on n'a pas vraiment de garantie que la division precedente +c "tombe juste". Le fait d'avoir en fait alloue un peu plus grand +c (cf. appel a gbalme dans gmalog) permet de se mettre a l'abris +c de ce genre de probleme (entre autres). +c + if ( adut*ltype .ge. iadd-ad0 ) then + adut = adut + 1 + else + adut = adut + 2 + endif +c + coergm = 0 +c + else + coergm = 8 + endif +c + else +c +c 3.2. ==> autres cas : mise a zero des grandeurs puis messages +c +c 3.2.1. ==> mise a zero des grandeurs +c + iadd = 0 + ilong = 0 +c +c 3.2.2. ==> 1er cas : le tableau n'apparait pas +c + if ( (icpti + icptr + icpts).eq.0 ) then + type8 = 'absent ' + coergm = 1 + endif +c +c 3.2.3. ==> Cas pas sympa : ou le tableau apparait plusieurs fois +c +c 3.2.3.1. ==> dans les reels +c + if ( icptr .gt. 1 ) then + coergm = 2 + type8 = 'multip ' + endif +c +c 3.2.3.2. ==> dans les entiers +c + if ( icpti .gt. 1 ) then + coergm = 3 + type8 = 'multip ' + endif +c +c 3.2.3.3. ==> dans les character*8 +c + if ( icpts .gt. 1 ) then + coergm = 4 + type8 = 'multip ' + endif +c +c 3.2.3.4. ==> dans deux categories +c + if ( (icptr*icpti).ne.0 ) then + coergm = 5 + type8 = 'multip ' + endif +c + if ( (icptr*icpts).ne.0 ) then + coergm = 5 + type8 = 'multip ' + endif +c + if ( (icpti*icpts).ne.0 ) then + coergm = 5 + type8 = 'multip ' + endif +c + endif +c + endif +c +c==== +c 4. gestion des erreurs +c==== +c + if ( coergm.ne.0 ) then +cgn write(1,*)coergm +c + iaux = 10+abs(coergm) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,iaux)) +#endif +c + if ( iaux.eq.20 ) then +#include "envex2.h" + call ugstop('gbcara',ulsort,1,1,1) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) +90000 format (70('=')) +c +#endif +c + end diff --git a/src/tool/Gestion_MTU/gbdnoe.F b/src/tool/Gestion_MTU/gbdnoe.F new file mode 100644 index 00000000..699e6db2 --- /dev/null +++ b/src/tool/Gestion_MTU/gbdnoe.F @@ -0,0 +1,182 @@ + subroutine gbdnoe (nome,objrep,objter,chater,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c decodage d'un nom etentu 'nome' pour determiner +c l'objet-repertoire,l'objet-terminal et le champ-terminal +c (contexte MC) +c ........................................................... +c +c entrees : +c nome : character*(*) : nom etendu a decoder +c +c ........................................................... +c +c sorties : +c objrep : character*8 : objet repertoire +c objter : character*8 : objet terminal +c chater : character*8 : champ terminal +c codret : code de retour : +c -1 : erreur : nom etendu non valide +c 0 : OK : nom etendu n'a qu'un element : +c objter = nome +c objrep = ' ' +c chater = ' ' +c 1 : OK : objet-terminal non defini : +c aucun objet n'a ete attache au +c champ-terminal dans l'objet-repertoire ; +c objter = indefini +c 2 : OK : objet-terminal defini mais non alloue +c 3 : OK : objet-terminal defini et alloue +c +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBDNOE' ) +c +c 0.2. ==> communs +c +#include "gminds.h" +#include "gmcoer.h" +#ifdef _DEBUG_HOMARD_ +#include "gmimpr.h" +#endif +c +c 0.3. ==> arguments +c + character*(*) nome + character*8 objrep,objter,chater +c + integer codret +c +c 0.4. ==> variables locales +c +#include "gmnelx.h" +c + character*1 sepa(4) + character*8 nomfis + character*80 elem(nelx) +c + integer lelm(nelx),nelm,lgtot,ns + integer ipart,i,iel,codref,ityp,codrel +c +c 0.5. ==> initialisations +c + data sepa /'.' , ' ' , ' ' , ' '/ +c ______________________________________________________________________ +c +c==== +c 1. decomposition du nom-etendu +c==== +c +c 1.1. ==> recherche des differents champs du nom etendu +c seul le premier separateur, '.', est pris en compte +c + ns = 1 + call gbpart(nome,elem,lelm,nelm,lgtot,sepa,ns,ipart) +c + if (ipart.eq.-1) then + codret = -1 + goto 9999 + endif +c +c 1.2. ==> longueur des noms de chacun des champs <= 8 +c + do 12 , i = 1,nelm + if (lelm(i).gt.8) then + codret = -1 + goto 9999 + endif + 12 continue +c +c 1.3. ==> c'est une tete +c + if (nelm.eq.1) then +c + objter = elem(1)(1:8) + objrep = ' ' + chater = ' ' + codret = 0 +c + else +c +c 1.4. ==> reperage des noms des differents champs +c + objrep = elem(1)(1:8) + do 14 iel = 2,nelm-1 + call gbdnof(objrep,elem(iel),nomfis,codref) + objrep = nomfis + if (codref.lt.0) then + codret = -1 + goto 9999 + endif + 14 continue +c +c 1.5. ==> pour le dernier champ +c + chater = elem(nelm)(1:8) + call gbdnof(objrep,elem(iel),objter,codref) +c + if (codref.eq.-1) then +c + objter = sindef + codret = 1 +c + else if (codref.eq.0) then +c + call gbobal(objter,ityp,codrel) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'apres gbobal ; codrel = ', codrel +#endif + if (codrel.ge.1) then + codret = 3 + else + codret = 2 + endif +c + else +c + codret = -1 +c + endif +c + endif +c +c 1.6. ==> sortie +c + 9999 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.-1 ) then + write (ulsort,*) 'Probleme dans ', nompro, ' :' + write (ulsort,*) 'Ce nom etendu est invalide : ', nome + endif +#endif +c + end diff --git a/src/tool/Gestion_MTU/gbdnof.F b/src/tool/Gestion_MTU/gbdnof.F new file mode 100644 index 00000000..f637a177 --- /dev/null +++ b/src/tool/Gestion_MTU/gbdnof.F @@ -0,0 +1,139 @@ + subroutine gbdnof (pere,champ,nomfis,iret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c recherche le nom de l'objet attache au champ 'champ' de +c l'objet 'pere' +c version memoire centrale +c ........................................................... +c +c entrees : +c pere : character*(*) : nom de l'objet pere +c champ : character*(*) : chaine de 8 caracteres au plus +c +c sorties : +c nomfis : nom de l'objet trouve +c iret : code de retour : +c -4 : erreur : l'objet 'pere' n'existe pas +c -3 : erreur : l'objet 'pere' n'est pas un objet +c : structure +c -2 : erreur : 'champ' ne correspond pas a un champ +c : dans le type de l'objet 'pere' +c -1 : erreur : aucun objet n'a ete attache au champ +c : 'champ' de l'objet 'pere' +c 0 : OK +c +c ........................................................... +c +c 0. declarations et dimensionnement +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gminds.h" +#include "gmimpr.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) pere,champ + character*8 nomfis + integer iret +c +c 0.4. ==> variables locales +c + character*8 letype + integer iob,iadr,long + integer ity,nbc,k,ich,ioc + integer nrocha, nroobj + integer nrotab +c +c==== +c 1. recherche l'objet 'pere' +c==== +c + do 11 , iob = 1,iptobj-1 + if (nomobj(iob).eq.pere) then + nroobj = iob + goto 20 + endif + 11 continue +c + iret = -3 +c + call gbcara(pere,nrotab,iadr,long,letype) + if (coergm.gt.1) then + write(ulsort,*) ' gbdnof -> retour gbcara > 1' + call ugstop('gbdnof',ulsort,1,1,1) + endif + if (coergm.eq.1) then + iret = -4 + endif +c + goto 9999 +c +c==== +c 2. verification du champ +c==== +c + 20 continue +c + ity = typobj(nroobj) + nbc = nbcham(ity) + do 21 , k = 1,nbc + ich = adrdst(ity)+k-1 + if (nomcha(ich).eq.champ) then + nrocha = k + goto 30 + endif + 21 continue +c + iret = -2 + goto 9999 +c +c==== +c 3. recherche de l'objet attache au champ +c==== +c + 30 continue +c + ioc = adrdso(nroobj)+nrocha-1 + if (nomobc(ioc).eq.sindef) then + iret = -1 + goto 9999 + endif +c + iret = 0 + nomfis = nomobc(ioc) +c + 9999 continue +c + end diff --git a/src/tool/Gestion_MTU/gbdtoj.F b/src/tool/Gestion_MTU/gbdtoj.F new file mode 100644 index 00000000..45906c89 --- /dev/null +++ b/src/tool/Gestion_MTU/gbdtoj.F @@ -0,0 +1,165 @@ + subroutine gbdtoj ( objsup, objter ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c detacher l'objet de nom terminal 'objter' de l'objet qui le +c supporte de nom terminal 'objsup' +c si le nom terminal 'objsup' est blanc, on detache l'objet 'objter' +c de tous les objets qui le referencient. +c remarque : il n'y a pas suppression de l'objet 'objter'. il est +c simplement debranche de 'objsup' +c +c ........................................................... +c +c entrees : +c objsup : character*8 : objet support de l'attachement ou blanc +c objter : character*8 : objet a detacher +c +c sorties : coergm : code de retour : +c -2 : erreur : champ introuvable dans les tables +c -1 : erreur : objet support introuvable dans les tables +c 0 : OK +c +c ........................................................... + +c==== +c 0. declarations et dimensionnement +c==== +c +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBDTOJ' ) +c +#include "genbla.h" +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtoas.h" +c +#include "gminds.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 objsup, objter +c +c 0.4. ==> variables locales +c + integer iaux, nbc + integer nroobj, nrocha, nrotyp + integer nrobde, nrobfi +c + character*8 blanc +c + parameter ( blanc = ' ' ) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. recherche du numero de l'objet support +c==== +c + if ( objsup.eq.blanc ) then +c + nrobde = 1 + nrobfi = iptobj-1 +c + else +c + do 21 , iaux = 1 , iptobj-1 + if (nomobj(iaux).eq.objsup) then + nrobde = iaux + nrobfi = iaux + goto 22 + endif + 21 continue + coergm = -1 +c + 22 continue +c + endif +c +c==== +c 3. pour chacun des objets supports concernes, on recherche le champ +c a detacher. +c on a un code retour non nul seulement dans le cas ou on veut +c detacher un objet d'un support defini et que l'on ne le trouve pas. +c==== +c + if ( coergm.eq.0 ) then +c + do 31 , nroobj = nrobde, nrobfi +c + nrotyp = typobj(nroobj) + nbc = nbcham(nrotyp) + do 311 , iaux = 1 , nbc + nrocha = adrdso(nroobj)+iaux-1 + if (nomobc(nrocha).eq.objter) then + nomobc(nrocha) = sindef + goto 312 + endif + 311 continue +c + if ( objsup.ne.blanc ) then + coergm = -2 + endif +c + 312 continue +c + 31 continue +c + endif +c +c==== +c 4. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbgeno.F b/src/tool/Gestion_MTU/gbgeno.F new file mode 100644 index 00000000..8308b789 --- /dev/null +++ b/src/tool/Gestion_MTU/gbgeno.F @@ -0,0 +1,219 @@ + subroutine gbgeno ( nomet, champ, nomgen, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c GM - Base - GEneration d'un Nom d'Objet +c - - -- - - +c +c Le nom genere est forme par : +c - caracteres 1 et 2 : les 2 premiers du nom etendu +c - caracteres 3 et 4 : les 2 premiers du champ +c - caracteres 5, 6, 7 et 8 : un caractere alphanumerique +c +c On a le choix entre 10 chiffres, 26 lettres minuscules, +c 26 lettres majuscules, soit 62 signes pour former l'un des +c caracteres 5, 6, 7 et 8. +c Cela revient a ecrire le nombre d'appels de ce programme +c en base 62. +c Ce qui fait 62**4 - 1 = 14 776 335 possibilites. +c +c Meme si l'objet est desalloue, on ne reutilise pas sa sequence, +c donc il y a un risque d'arriver en limite pour un transitoire +c avec de nombreux pas de temps. Ce risque est tres faible +c car il faudrait environ 10 000 pas de temps pour l'atteindre. +c Si cela se produit, il faudra gerer la reutilisation des codes. +c +c Gerald NICOLAS le 12 mars 1998 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomet . e . char* . nom etendu a traduire . +c . champ . e . char8 . . si nom-etendu a plusieurs elements : . +c . . . . = ' ' ou champ-terminal . +c . . . . . si nom-etendu a un seul element : . +c . . . . = champ de l'objet 'nomet' . +c . nomgen . s . char8 . nom genere . +c . codret . s . 1 . code de retour . +c . . . . -4 : nom-etendu invalide . +c . . . . -3 : 'nomet' n'a qu'un element et n'est . +c . . . . pas un objet structure . +c . . . . -2 : 'nomet' a plusieurs elements et . +c . . . . 'champ' /= ' ' et /= champ-terminal . +c . . . . -1 : 'nomet' a un seul element et 'champ' . +c . . . . ne correspond pas a un champ de 'nomet. +c . . . . 0 : tout va bien . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gminom.h" +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*(*) nomet,champ + character*8 nomgen +c + integer codret +c +c 0.4. ==> variables locales +c + character*8 objrep, objter, chater +c + integer idec,ity,nbc + integer nroobj + integer iaux, jaux +c +c 0.5. ==> initialisations +c +#include "alphnu.h" +c ______________________________________________________________________ +c +c==== +c 1. decodage 'nomet' +c==== +c + codret = 0 +c +c 1.1. ==> prgramme de decodage +c + call gbdnoe(nomet,objrep,objter,chater,idec) +c +c 1.2. ==> le nom etendu est invalide +c + if (idec.eq.-1) then +c + codret = -4 +c +c 1.3. ==> le nom etendu n'a qu'un element +c + elseif (idec.eq.0) then +c + do 131 , iaux = 1,iptobj-1 + if (nomobj(iaux).eq.nomet) then + nroobj = iaux + goto 132 + endif + 131 continue + codret = -3 + goto 134 +c + 132 continue + ity = typobj(nroobj) + nbc = nbcham(ity) + do 133 , iaux = adrdst(ity),adrdst(ity)+nbc-1 + if (nomcha(iaux).eq.champ) then + goto 134 + endif + 133 continue + codret = -1 +c + 134 continue +c +c 1.4. ==> autres cas +c + else +c + if ( champ.ne.' ' .and. champ.ne.chater ) then + codret = -2 + endif +c + endif +c +c==== +c 2. formation du nom genere +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> 4 premiers caracteres deduits du nom etendu +c + if (champ.eq.' ') then + nomgen(1:4) = nomet(1:2)//chater(1:2) + else + nomgen(1:4) = nomet(1:2)//champ(1:2) + endif + do 21 , iaux = 1,4 + if (nomgen(iaux:iaux).eq.' ') then + nomgen(iaux:iaux) = '$' + endif + 21 continue +c +c 2.2. ==> 4 caracteres suivants +c + nomgen(5:8) = '0000' +c + indnom = indnom+1 +c + iaux = mod(indnom,lgalnu) + nomgen(8:8) = alphnu(iaux) +c + if ( indnom.ge.lgalnu ) then +c + jaux = (indnom-iaux) / lgalnu + iaux = mod(jaux,lgalnu) + nomgen(7:7) = alphnu(iaux) +c + if ( indnom.ge.lgaln2 ) then +c + jaux = (jaux-iaux) / lgalnu + iaux = mod(jaux,lgalnu) + nomgen(6:6) = alphnu(iaux) +c + if ( indnom.ge.lgaln3 ) then + jaux = (jaux-iaux) / lgalnu + iaux = mod(jaux,lgalnu) + nomgen(5:5) = alphnu(iaux) + endif +c + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then + write (ulsort,*) 'Probleme dans gbgeno' + write (ulsort,*) 'Code de retour = ',codret + endif +c + end diff --git a/src/tool/Gestion_MTU/gbitos.F b/src/tool/Gestion_MTU/gbitos.F new file mode 100644 index 00000000..9f6ee5bf --- /dev/null +++ b/src/tool/Gestion_MTU/gbitos.F @@ -0,0 +1,579 @@ + subroutine gbitos ( nfdico, lfdico, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c fonction d'initialisation des tables de description des +c types d'objet structure. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfdico . e . ch<200 . nom du fichier des objets structures . +c . lfdico . e . 1 . longueur du nom du fichier . +c . . . . si =0, on a les tables par gmitob . +c . codret . s . 1 . code de retour . +c . . . . -6 : impossible de decoder la date du . +c . . . . fichier des types . +c . . . . -5 : erreur : type interdit . +c . . . . -4 : erreur : fichier de type d'objet vide . +c . . . . -3 : erreur : erreur de format dans le . +c . . . . fichier d'entree . +c . . . . -2 : erreur : type de champ non defini . +c . . . . -1 : erreur : dimensionnement des tables . +c . . . . insuffisant . +c . . . . 0 : OK . +c . . . . 3 ou 9 : fermeture impossible du fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBITOS' ) +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gmtove.h" +c +#include "gminom.h" +#include "gmtail.h" +#include "gmindi.h" +#include "gminds.h" +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) nfdico +c + integer lfdico, codret +c +c 0.4. ==> variables locales +c +#include "gmnelx.h" +c + integer lelm(nelx), nelm, lgtot, ns + integer nftypo, ipart, ncham, ncha, iadr, it + integer jaux, nrolig + character*8 datefr, heurfr, textem + character*80 chaine,elem(nelx) +c + integer iaux +c + character*1 sepa(4) + character*8 chatyp(nchpx) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data sepa / ' ' , ',' , ';' , ' ' / +c +c ______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,17) = '(''Decodage du fichier typobj.stu :'')' + texte(1,4) = '(''Erreur a la ligne numero'',i6,'' :'')' + texte(1,5) = + > '(''Le nombre maximum de types,'',i6,'' est atteint.'',/)' + texte(1,6) = + > '(''Le nombre maximum de champs,'',i6,'' est atteint.'',/)' + texte(1,7) = '(''Fin de fichier inattendue.'',/)' + texte(1,8) = + > '(''Chaque texte doit avoir moins de 8 caracteres.'')' + texte(1,9) = '(''Aucun type n''''a ete trouve ?'')' + texte(1,10) = '(''Aucun type ne correspond au champ '',a8)' + texte(1,11) = '(''Le nom de type '',a8,'' est interdit.'')' + texte(1,12) = '(''Impossible de decoder la date '',a8)' + texte(1,13) = + > '(''ATTENTION : les deux premiers caracteres d''''un nom'')' + texte(1,14) = + > '(''de champ ne devraient pas etre deux chiffres : '',a8)' + texte(1,15) = '(''... nom du type : '',a8)' + texte(1,18) = '(/,''Dictionnaire des types d''''objets :'')' + texte(1,19) = '(''. Version : '',i11)' + texte(1,20) = '(''. Sous-version : '',i6,/,''. Date : '',a8)' +c + texte(2,17) = '(''Uncoding of file typobj.stu :'')' + texte(2,4) = '(''Error on line #'',i6,'' :'')' + texte(2,5) = + > '(''The maximum number of types,'',i6,'' is reached.'',/)' + texte(2,6) = + > '(''The maximum number of fields,'',i6,'' is reached.'',/)' + texte(2,7) = '(''Unexpected end of file.'',/)' + texte(2,8) = '(''Each text must be less than 8 characters.'')' + texte(2,9) = '(''No type was found ?'')' + texte(2,10) = '(''No type is declared as field '',a8)' + texte(2,11) = + > '(''The name of this type '',a8,'' is forbidden.'')' + texte(2,12) = '(''Date '',a8,'' cannot be uncoded.'')' + texte(2,13) = + > '(''WARNING : The first two characters of a field name'')' + texte(2,14) = + > '(''should not be both numeric : field name '',a8)' + texte(2,15) = '(''... name of the type : '',a8)' + texte(2,18) = '(/,''Object types dictionnary :'')' + texte(2,19) = '(''. Version : '',i6)' + texte(2,20) = '(''. Release : '',i6,/,''. Date : '',a8)' +c + codret = 0 +c +c==== +c 2. - noms des types de base pour les donnees +c l'ordre des types doit etre respecte +c - les tailles des types de donnees sont en octets +c==== +c +c 2.1. ==> les noms des types de bases +c + ntyb = 3 +c + nomtyb(1) = 'entier ' + nomtyb(2) = 'reel ' + nomtyb(3) = 'chaine ' + nomtyb(4) = 'struct ' +c +c 2.2. ==> mise de l'information dans les noms de types de base +c et declares +c + do 21 iaux = 1 , ntybma + nomtbp(-iaux) = nomtyb(iaux) + 21 continue +c +c 2.3. ==> les tailles des types de donnees sont en octets +c + call dmsize (tentie,treel,tchain) +c +c==== +c 3. initialisation a des valeurs non definies des differents tableaux +c decrivant les types et les champs declares et des numeros de +c version et de sous-version +c==== +c + do 31 iaux = 1 , ntypx + nomtbp(iaux) = sindef + nomtyp(iaux) = sindef + nbcham(iaux) = iindef + nbratt(iaux) = iindef + adrdst(iaux) = iindef + 31 continue +c + do 32 iaux = 1 , nchpx + chatyp(iaux) = sindef + nomcha(iaux) = sindef + typcha(iaux) = iindef + 32 continue +c + nuveto = iindef + nusvto = iindef + daheto = iindef + nuanto = iindef +c +c==== +c 4. initialisation des tables d'objets +c==== +c + if ( lfdico.eq.0 ) then +c +cgn write (ulsort,*) 'appel de gmitob' +c + call gmitob +c +c==== +c 4. lecture du fichier de declaration des types d'objets +c==== +c + else +c + call guoufs ( nfdico, lfdico, nftypo, codret ) +c + nrolig = 0 +c + ns = 3 + codret = 0 + nbrtyp = 0 + adrdst(1) = 1 +c +c 4.1. ==> boucle 41 : jusqu'a ce que la ligne demarre par le +c bon mot-cle +c + 41 continue +c + nrolig = nrolig + 1 + read (nftypo,'(a)',end=50) chaine +c + call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart) +c + if ( ipart.eq.-1 ) then + goto 41 + else + if ( elem(1)(1:6).eq.'>>TYPE' ) then + jaux = 1 + goto 42 + else if ( elem(1)(1:9).eq.'>>VERSION' ) then + jaux = 2 + goto 42 + else + goto 41 + endif + endif +c +c 4.2. ==> boucle 42 : jusqu'a ce que la ligne ne soit ni blanche, +c ni un commentaire. +c quand c'est bon, elle contient la description d'un type +c ou de la version +c + 42 continue +c +c 4.2.1 ==> lecture de la ligne suivante +c + nrolig = nrolig + 1 + read (nftypo,'(a)',end=73) chaine +c + call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart) +c + if ( (ipart.eq.-1) .or. (elem(1)(1:2).eq.'$$') ) then + goto 42 + endif +c +c 4.2.2. ==> controle de la longueur de chacun des textes +c + if ( lelm(1).gt.8 .or. + > lelm(2).gt.8 .or. + > lelm(3).gt.8 ) then + goto 74 + endif +c +c 4.2.3. ==> decodage d'un type +c + if ( jaux.eq.1 ) then +c +c 4.2.3.1. ==> les trois termes de la chaine : +c 1 : nom du type +c 2 : nombre de champs +c 3 : nombre d'attributs +c + nbrtyp = nbrtyp+1 + if (nbrtyp.gt.ntypx) then + goto 71 + endif +c + nomtyp(nbrtyp) = elem(1)(1:8) +c + read (elem(2),'(i8)') ncham + nbcham(nbrtyp) = ncham +c + read (elem(3),'(i8)') nbratt(nbrtyp) +c + if (nbrtyp.gt.1) then + adrdst(nbrtyp) = adrdst(nbrtyp-1)+nbcham(nbrtyp-1) + endif +c +c 4.2.3.2. ==> controle du nom du type +c + do 4232 iaux = 1 , ntybma + if ( nomtyp(nbrtyp).eq.nomtyb(iaux) ) then + codret = -3 + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,11)) nomtyp(nbrtyp) + endif + 4232 continue +c + nomtbp(nbrtyp) = nomtyp(nbrtyp) +c +c 4.2.3.3. ==> boucle 4233 : decodage de chacun des champs du type +c jusqu'a ce que les ncham champs aient ete lus. +c quand c'est fini, on repasse a une nouvelle ligne (goto 41) +c + ncha = 0 +c + 4233 continue +c + nrolig = nrolig + 1 + read (nftypo,'(a)',end=73) chaine +c + call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart) +c + if ( (ipart.eq.-1) .or. (elem(1)(1:2).eq.'$$') ) then + goto 4233 + endif + if ( (ncha.eq.ncham) .and. (elem(1)(1:5).eq.'>>FIN') ) then + goto 41 + endif + if ( (lelm(1).gt.8) .or. (lelm(2).gt.8) ) then + goto 74 + endif +c + iadr = adrdst(nbrtyp)+ncha + if (iadr.gt.nchpx) then + goto 72 + endif + nomcha(iadr) = elem(1)(1:8) +c +c les deux premiers caracteres d'un nom de champ ne devraient pas etre +c tous deux numeriques : risque de conflit entre generateurs de noms +c d'objets (temporaires, cf. gbntcr, et voir aussi les sous-programmes +c gbgeno). Au mieux, cela risque de ralentir l'execution ... +c ... cela dit, on ne fait qu'imprimer un avertissement. +c + if ( index('0123456789',nomcha(iadr)(1:1)).gt.0 .and. + > index('0123456789',nomcha(iadr)(2:2)).gt.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,13)) + write (ulsort,texte(langue,14)) nomcha(iadr) + write (ulsort,texte(langue,15)) nomtbp(nbrtyp) + endif +c + chatyp(iadr) = elem(2)(1:8) + ncha = ncha+1 +c + goto 4233 +c +c 4.2.4. ==> decodage de la reference de la version +c + else if ( jaux.eq.2 ) then +c +c 4.2.4.1. ==> le numero de version +c + if ( elem(1)(1:5).eq.'>>FIN' ) then + goto 41 +c + else +c + if ( elem(1)(1:7).eq.'Version' ) then + read (elem(2),'(i8)') nuveto +c + else if ( elem(1)(1:8).eq.'SousVers' ) then + read (elem(2),'(i8)') nusvto +c + else if ( elem(1)(1:4).eq.'Date' ) then + datefr = ' ' + datefr(1:2) = elem(2)(1:2) + datefr(4:5) = elem(3)(1:2) + datefr(7:8) = elem(4)(1:2) +c + endif +c + goto 42 +c + endif +c + endif +c +c==== +c 5. enregistrement des informations +c==== +c + 50 continue +c +c 5.1. ==> decodage du type de chaque champ +c + if (nbrtyp.ne.0) then +c +c 5.1.1. ==> decodage du type de chaque champ +c + do 51 iaux = 1, nbrtyp +c + do 511 jaux = adrdst(iaux), adrdst(iaux)+nbcham(iaux)-1 +c + call gbminu(chatyp(jaux),textem) +c + if (textem.eq.nomtyb(1)) then + typcha(jaux) = -1 + else if (textem.eq.nomtyb(2)) then + typcha(jaux) = -2 + else if (textem.eq.nomtyb(3)) then + typcha(jaux) = -3 + else +c + do 5111 it = 1, nbrtyp + if (nomtyp(it).eq.chatyp(jaux)) then + typcha(jaux) = it + goto 511 + endif + 5111 continue +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,10)) chatyp(jaux) + codret = -2 + goto 80 +c + endif + 511 continue +c + 51 continue +c + else +c +c 5.2. ==> probleme : aucun type n'a ete trouve dans le fichier +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,9)) + codret = -4 + goto 80 +c + endif +c +c==== +c 6. enregistrement de la date des types d'objets +c==== +c + heurfr = '00:00:00' + iaux = 0 +c + call ugdhfc ( daheto, nuanto, + > datefr, heurfr, + > iaux ) +c + if ( iaux.ne.0 ) then + goto 75 + endif +c + goto 80 +c +c==== +c 7. gestion des messages d'erreur +c==== +c + 71 continue + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,4)) nrolig + write (ulsort,*) chaine + write (ulsort,texte(langue,5)) ntypx + codret = -1 + goto 80 +c + 72 continue + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,4)) nrolig + write (ulsort,*) chaine + write (ulsort,texte(langue,6)) nchpx + codret = -1 + goto 80 +c + 73 continue + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,4)) nrolig + write (ulsort,*) chaine + write (ulsort,texte(langue,7)) + codret = -3 + goto 80 +c + 74 continue + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,4)) nrolig + write (ulsort,*) chaine + write (ulsort,texte(langue,8)) + codret = -3 + goto 80 +c + 75 continue + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,17)) + write (ulsort,*) nfdico + write (ulsort,texte(langue,12)) datefr + codret = -6 + goto 80 +c +c==== +c 8. fermer le fichier dictionnaire +c==== +c + 80 continue +c + call gufefi ( nfdico, lfdico, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,18)) + write (ulsort,texte(langue,19)) nuveto + write (ulsort,texte(langue,20)) nusvto, datefr +#endif +c +c==== +c 9. initialisation des quantites gerant les objets alloues +c les tables : nomobj , nomobc +c les pointeurs : iptobj , iptchp +c et : indnom , iptatt +c attention : il vaut mieux initialiser les attributs +c a une valeur indefinie, ca evite des surprises ... +c==== +c + do 91 iaux = 1, nobjx + typobj(iaux) = iindef + adrdso(iaux) = iindef + adrdsa(iaux) = iindef + nomobj(iaux) = sindef + 91 continue +c + do 92 iaux = 1, nobcx + nomobc(iaux) = sindef + valatt(iaux) = iindef + 92 continue +c + iptobj = 1 + iptchp = 1 + iptatt = 1 + indnom = 0 +c + end diff --git a/src/tool/Gestion_MTU/gblboj.F b/src/tool/Gestion_MTU/gblboj.F new file mode 100644 index 00000000..c6145701 --- /dev/null +++ b/src/tool/Gestion_MTU/gblboj.F @@ -0,0 +1,228 @@ + subroutine gblboj ( nomter ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c liberation d'un objet 'nomter' structure ou simple +c et suppression de tous les attachements qui le concernent +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomter . e . char*8 . nom terminal de l'objet a liberer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GBLBOJ' ) +c +#include "gmmatc.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmtoai.h" +#include "gmtoas.h" +#include "gmindi.h" +#include "gminds.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 nomter +c +c 0.4. ==> variables locales +c + integer iaux,ioc,ioa,nbc,nba + integer nroobj + integer codre1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. l'objet est-il alloue ? +c codre1 = 0 --> non alloue +c codre1 = 1 --> objet structure +c codre1 = 2 --> objet simple +c==== +c + call gbobal ( nomter , iaux , codre1 ) +c + if ( codre1.eq.0 ) then + coergm = -1 + else + coergm = 0 + endif +c +c==== +c 3. Si l'objet est simple, on le desalloue par le programme basique +c==== +c + if ( coergm.eq.0 ) then +c + if ( codre1.eq.2 ) then +c + call gmdesa (nomter) +c + endif +c + endif +c +c==== +c 4. Si l'objet est structure, on le recherche dans la liste +c==== +c + if ( coergm.eq.0 ) then +c + if ( codre1.eq.1 ) then +c +c 4.1. ==> on le recherche dans la liste +c + nroobj = 0 + do 411 , iaux = 1,iptobj-1 + if (nomobj(iaux).eq.nomter) then + nroobj = iaux + goto 412 + endif + 411 continue +c + 412 continue +c + iptobj = iptobj-1 +c +c 4.2. ==> si c'est le dernier objet enregistre : on le supprime +c . on ramene aux valeurs indefinies toutes les informations +c qui concernent ses champs. +c . on memorise les nouvelles adresses des futurs +c champs et attributs +c . on ramene aux valeurs indefinies toutes les informations +c qui le concernent. +c + if ( nroobj.eq.iptobj ) then +c + do 421 , ioc = adrdso(nroobj),iptchp-1 + nomobc(ioc) = sindef + 421 continue +c + do 422 , ioa = adrdsa(nroobj),iptatt-1 + valatt(ioa) = iindef + 422 continue +c + iptchp = adrdso(nroobj) + iptatt = adrdsa(nroobj) +c + nomobj(nroobj) = sindef + adrdsa(nroobj) = iindef + adrdso(nroobj) = iindef + typobj(nroobj) = iindef +c + else +c +c 4.3. ==> si ce n'est pas le dernier objet enregistre : +c . on comprime la liste +c +c 4.3.1 ==> les noms des champs associes aux objets, puis mise +c a jour du pointeur +c + nbc = adrdso(nroobj+1)-adrdso(nroobj) + do 431 , ioc = adrdso(nroobj),iptchp-nbc-1 + nomobc(ioc) = nomobc(ioc+nbc) + 431 continue +c + do 432 , ioc = iptchp-nbc,iptchp-1 + nomobc(ioc) = sindef + 432 continue + iptchp = iptchp-nbc +c +c 4.3.2 ==> les attributs associes aux objets, puis mise +c a jour du pointeur +c + nba = adrdsa(nroobj+1)-adrdsa(nroobj) + do 433 , ioa = adrdsa(nroobj),iptatt-nba-1 + valatt(ioa) = valatt(ioa+nba) + 433 continue +c + do 434 , ioa = iptatt-nba,iptatt-1 + valatt(ioa) = iindef + 434 continue + iptatt = iptatt-nba +c +c 4.3.3. ==> les adresses dans les tableaux des champs et des attributs +c + do 435 , iaux = nroobj+1,iptobj-1 + adrdso(iaux) = adrdso(iaux+1)-nbc + adrdsa(iaux) = adrdsa(iaux+1)-nba + 435 continue + adrdsa(iptobj) = iindef + adrdso(iptobj) = iindef +c +c 4.3.4. ==> les noms et types des objets alloues +c + do 436 , iaux = nroobj,iptobj-1 + nomobj(iaux) = nomobj(iaux+1) + typobj(iaux) = typobj(iaux+1) + 436 continue +c + nomobj(iptobj) = sindef + typobj(iptobj) = iindef +c + endif +c + endif +c + endif +c +c==== +c 5. Fin +c==== +c + if ( coergm.ne.0 ) then +c + write(ulsort,*) nompro, ', code retour ',coergm,' pour ',nomter +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gblibe.F b/src/tool/Gestion_MTU/gblibe.F new file mode 100644 index 00000000..4ef6465e --- /dev/null +++ b/src/tool/Gestion_MTU/gblibe.F @@ -0,0 +1,109 @@ + subroutine gblibe (typtab,n,iad,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c liberation +c remarque : pour l'instant la taille, n, ne sert a rien +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typtab . e . char*1 . type du tableau a allouer . +c . n . e . 1 . longueur du tableau . +c . iad . s . 1 . adresse du premier element du tableau . +c . codret . s . 1 . 0 : tout va bien . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmtail.h" +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*1 typtab + integer n, iad + integer codret +c +c 0.4. ==> variables locales +c + integer ltype +c + character*60 texte(5) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 12345678901234567890123456789012345678901234567890 + texte(3) = 'L''adresse est hors des limites de la pile (heap). ' + texte(4) = 'La zone a deja ete liberee. ' + texte(5) = 'L''adresse n''est pas au debut d''un bloc. ' +c +c==== +c 2. liberation effective +c==== +c +cgn print *,'appel de dmlibe : ',iad + call dmlibe (iad,codret) +cgn print *,'retour de dmlibe' +c +c==== +c 3. message d'erreur +c==== +c + if ( codret.ne.0) then +c + if ( typtab.eq.'i'.or.typtab.eq.'I') then + ltype = tentie + elseif ( typtab.eq.'s'.or.typtab.eq.'S') then + ltype = tchain + elseif ( typtab.eq.'r'.or.typtab.eq.'R') then + ltype = treel + else + write(ulsort,*) ' gblibe type inconnu ', typtab + call ugstop('gblibe',ulsort,0,1,1) + endif +c + write (ulsort,*) ' GBLIBE : erreur a la liberation' + write (ulsort,*) 'Code de retour de DMLIBE : ', codret + if ( codret.ge.-5 .and. codret.le.-3 ) then + write (ulsort,*) texte(abs(codret)) + endif + write (ulsort,*) 'Type : ', typtab + write (ulsort,*) 'Adresse : ', iad + write (ulsort,*) 'Taille voulue : ', n +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbminu.F b/src/tool/Gestion_MTU/gbminu.F new file mode 100644 index 00000000..f76d129c --- /dev/null +++ b/src/tool/Gestion_MTU/gbminu.F @@ -0,0 +1,86 @@ + subroutine gbminu (chaine,txminu) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c conversion d'une chaine de caracteres 'chaine' en une +c chaine 'txminu' de caracteres minuscules +c ........................................................... +c +c entrees : +c chaine : chaine a convertir +c sorties : +c txminu : chaine en minuscules +c +c=== +c 0. declarations et dimensionnement +c=== +c +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) chaine,txminu +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lgmin, lgchai, lgtmin + integer decala, amaju, zmaju + logical prem +c + data prem / .true. / +c_______________________________________________________________________ +c +c 1. initialisation au premier passage +c + if ( prem ) then + amaju = ichar('A') + zmaju = ichar('Z') + decala = ichar('a') - amaju + prem = .false. + endif +c +c 2. transformation en minuscules +c + lgchai = max(0,len(chaine)) + lgtmin = max(0,len(txminu)) +c + lgmin = min ( lgchai , lgtmin ) + do 21 , iaux = 1 , lgmin + jaux = ichar(chaine(iaux:iaux)) + if ( jaux.ge.amaju .and. jaux.le.zmaju ) then + txminu(iaux:iaux) = char(jaux+decala) + else + txminu(iaux:iaux) = chaine(iaux:iaux) + endif + 21 continue +c + jaux = lgmin + 1 + do 22 , iaux = jaux , lgtmin + txminu(iaux:iaux) = ' ' + 22 continue +c + end diff --git a/src/tool/Gestion_MTU/gbntcr.F b/src/tool/Gestion_MTU/gbntcr.F new file mode 100644 index 00000000..d993d8dc --- /dev/null +++ b/src/tool/Gestion_MTU/gbntcr.F @@ -0,0 +1,122 @@ + subroutine gbntcr ( nom ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c cree un nouveau nom d'objet temporaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . s . char*8 . nom de l'objet temporaire . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +#include "gmmatc.h" +c +#include "gmcain.h" +c +c 0.2. ==> communs +c +#include "gmtenb.h" +#include "gmteno.h" +#ifdef _DEBUG_HOMARD_ +#include "gmimpr.h" +#endif +c +c 0.3. ==> arguments +c + character*(*) nom +c +c 0.4. ==> variables locales +c + integer numero, iaux +c +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. determination d'un nouveau nom +c on lui impose de commencer par le premier caractere interdit +c on recherche un numero non utilise. il y en a forcement un +c car on s'autorise 3*maxtab+nobjx tableaux temporaires ce qui est le +c nombre maxi de tableaux en general. Or ce dernier sera +c forcement atteint avant (NB: il y a 3 types possibles pour les +c objets simples, d'ou le 3*maxtab). +c==== +c + nom = caint1//caint1//caint1//caint1//caint1//caint1//caint1//' ' +c + do 11 iaux = 1 , mxtbtp + if ( numete(iaux).eq.0 ) then + numero = iaux + goto 13 + endif + 11 continue +c + if ( mxtbtp.lt.maxtbt ) then + mxtbtp = mxtbtp + 1 + endif + numero = max( 1, min(mxtbtp,9999999) ) +c + 13 continue +c + if ( numero.lt.10 ) then + write ( nom(8:8),'(i1)') numero + elseif ( numero.lt.100 ) then + write ( nom(7:8),'(i2)') numero + elseif ( numero.lt.1000 ) then + write ( nom(6:8),'(i3)') numero + elseif ( numero.lt.10000 ) then + write ( nom(5:8),'(i4)') numero + elseif ( numero.lt.100000 ) then + write ( nom(4:8),'(i5)') numero + elseif ( numero.lt.1000000 ) then + write ( nom(3:8),'(i6)') numero + else + write ( nom(2:8),'(i7)') numero + endif +c + numete(numero) = 1 + nomalt(numero) = nom +c +#ifdef _DEBUG_HOMARD_ + jaux = 5 + write (ulsort,*) 'SP GBNTCR :' + write (ulsort,*) 'Numero et nom du dernier objet : ', + >numero,' ',nom + write (ulsort,*) 'Les ',jaux,' premiers noms sont :' + write (ulsort,10000) (iaux,nomalt(iaux),iaux=1,jaux) +10000 format(5(i5,' : ',a8,' | ')) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gbntde.F b/src/tool/Gestion_MTU/gbntde.F new file mode 100644 index 00000000..bb225ce8 --- /dev/null +++ b/src/tool/Gestion_MTU/gbntde.F @@ -0,0 +1,120 @@ + subroutine gbntde ( nom , codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c detruit un nom d'objet temporaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . e . char*8 . nom de l'objet temporaire a retirer . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . 2 : objet inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtenb.h" +#include "gmteno.h" +#include "gminds.h" +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*8 nom + integer codret +c +c 0.4. ==> variables locales +c + integer numero, iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. exploration de la liste +c==== +c + do 21 iaux = mxtbtp, 1, -1 + if ( nomalt(iaux).eq.nom ) then + numero = iaux + goto 22 + endif + 21 continue +c + codret = 2 +c + write (ulsort,*) 'SP GBNTDE :' + write (ulsort,*) 'Probleme a la destruction' + write (ulsort,*) '(nom temporaire a detruire non trouve)' + write (ulsort,*) 'Nom de l''objet detruit : ', nom + write (ulsort,*) 'Nombre maxi de noms temporaires ', maxtbt + write (ulsort,*) 'Numero maxi atteint ', mxtbtp + write (ulsort,*) 'Les 5 premiers noms sont :' + write (ulsort,10000) (iaux,nomalt(iaux),iaux=1,5) +c + goto 999 +c + 22 continue +c + numete(numero) = 0 + nomalt(numero) = sindef + codret = 0 +c + if (numero.eq.mxtbtp) then +c + do 23 iaux = numero-1, 1, -1 + if ( numete(iaux).ne.0 ) then + mxtbtp = iaux + goto 24 + endif + 23 continue + mxtbtp = 0 + 24 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c + write (ulsort,*) 'SP GBNTDE : OK' + write (ulsort,*) 'Numero tmp et nom de l''objet detruit : ', + > numero,' ',nom + write (ulsort,*) 'Les 5 premiers noms sont :' + write (ulsort,10000) (iaux,nomalt(iaux),iaux=1,5) +c +#endif +c +10000 format(5(i5,' : ',a8,' | ')) +c + 999 continue +c + end diff --git a/src/tool/Gestion_MTU/gbobal.F b/src/tool/Gestion_MTU/gbobal.F new file mode 100644 index 00000000..f9140de0 --- /dev/null +++ b/src/tool/Gestion_MTU/gbobal.F @@ -0,0 +1,130 @@ + subroutine gbobal ( nom , letype , codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c sous-programme d'interrogation si un objet "nom" (structure +c ou non) est alloue ou non en memoire centrale +c ........................................................... +c +c entrees : +c +c nom : chaine de 8 caracteres au plus ou +c : character*8 : nom de l'objet a interroger +c +c ........................................................... +c +c sorties : +c +c letype : numero du type de l'objet +c codret : +c 0 : objet non alloue +c 1 : objet structure alloue +c 2 : objet simple alloue +c +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gmindi.h" +c +#include "gmimpr.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) nom + integer letype,codret +c +c 0.4. ==> variables locales +c + character*8 typtab +c + integer iaux,iadr,long + integer nrotab +c +c==== +c 1. c'est un objet structure ? +c==== +c + codret = 0 + do 10 , iaux = 1,iptobj-1 + if (nomobj(iaux).eq.nom) then + letype = typobj(iaux) + codret = 1 + endif + 10 continue +c +c==== +c 2. c'est un objet simple ? +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> interrogation sur le type +c + call gbcara(nom,nrotab,iadr,long,typtab) +c +c 2.2. ==> l'objet est bien alloue +c + if (coergm.eq.0) then +c + codret = 0 + do 21 , iaux = 1,ntyb + if (typtab.eq.nomtyb(iaux)) then + letype = -iaux + codret = 2 + endif + 21 continue +c +c 2.3. ==> l'objet n'est pas alloue +c + elseif (coergm.eq.1) then +c + letype = iindef + coergm = 0 + codret = 0 +c +c 2.4. ==> erreur grave +c + else +c + write(ulsort,*)' gbobal -> retour gbcara > 1' + call ugstop('gbobal',ulsort,1,1,1) +c + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbpart.F b/src/tool/Gestion_MTU/gbpart.F new file mode 100644 index 00000000..742423f6 --- /dev/null +++ b/src/tool/Gestion_MTU/gbpart.F @@ -0,0 +1,162 @@ + subroutine gbpart (chaine,elem,lelm,nelm,lgtot,sepa,ns,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c partition d'une chaine de caracteres 'chaine' en differents +c elements separes par des caracteres 'sepa' +c +c on elimine les blancs en fin de ligne +c +c ........................................................... +c +c entrees : +c chaine : chaine a departager +c sepa : les caracteres separateurs +c ns : nombre de caracteres separateurs +c sorties : +c elem : tableau des elements separes +c lelm : longueurs des elements +c nelm : nombre d'elements +c lgtot : longueur totale de la chaine +c codret : +c -1 : chaine vide +c 0 : OK +c +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c +#include "gmnelx.h" +c + character*(*) chaine + character*80 elem(nelx) + character*1 sepa(4) + integer lelm(nelx), nelm, lgtot, ns, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, sepcav, sepcco, iel +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c + do 10 , iaux = 1,nelx + elem(iaux) = ' ' + lelm(iaux) = 0 + 10 continue +c +c==== +c 2. partition +c==== +c + codret = -1 +c +c 2.1. ==> longueur de la chaine, apres avoir elimine les blancs +c en fin de ligne +c + lgtot = len(chaine) +c + jaux = lgtot + do 21 , iaux = lgtot , 1 , -1 + if ( chaine(iaux:iaux).eq.' ' ) then + jaux = jaux - 1 + else + goto 22 + endif + 21 continue +c + 22 continue +c + lgtot = max(0,jaux) +c + nelm = 0 + sepcav = 1 +c +c sepcav = 1 : le caractere precedent est un separateur +c 0 : le caractere precedent n'est pas un separateur +c sepcco = 1 : le caractere courant est un separateur +c 0 : le caractere courant n'est pas un separateur +c + do 23 , iaux = 1 , lgtot +c +c 2.2. ==> le caractere courant est-il un separateur ? +c + sepcco = 0 + do 24 , jaux = 1 , ns + if (chaine(iaux:iaux).eq.sepa(jaux)) then + sepcco = 1 + endif + 24 continue +c +c 2.3. ==> le caractere courant n'est pas un separateur +c si le caractere d'avant etait un separateur, on change de mot +c on memorise le caractere +c + if (sepcco.eq.0) then +c + if (sepcav.eq.1) then + sepcav = 0 + nelm = nelm+1 + iel = 0 + endif + iel = iel+1 + elem(nelm)(iel:iel) = chaine(iaux:iaux) +c +c 2.4. ==> le caractere courant est un separateur +c + else +c + if (sepcav.eq.0) then + lelm(nelm) = iel + endif + sepcav = 1 +c + endif +c + 23 continue +c +c==== +c 3. longueur vraie du dernier troncon +c==== +c + if (nelm.ne.0) then +c + lelm(nelm) = iel +c + codret = 0 +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gbralo.F b/src/tool/Gestion_MTU/gbralo.F new file mode 100644 index 00000000..a88ef4fb --- /dev/null +++ b/src/tool/Gestion_MTU/gbralo.F @@ -0,0 +1,115 @@ + subroutine gbralo ( type1, long, iad, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Re-allocation, +c utilisee uniquement en mode gm dynamique, +c dans le sens reduction de taille, +c avec une taille finale > 0 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . type1 . e . char*1 . type du tableau a reallouer . +c . long . e . 1 . nouvelle longueur du tableau . +c . iad . es . 1 . adresse du premier element du tableau . +c . . . . (adresse memoire) . +c . codret . s . 1 . code de retour . +c . codret . s . 1 . 0 : tout va bien . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmtail.h" +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*1 type1 + integer long, iad + integer codret +c +c 0.4. ==> variables locales +c + integer ltype, size + character*60 texte(5) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + texte(3) = 'L''adresse est hors des limites de la pile (heap). ' + texte(4) = 'La zone a deja ete liberee. ' + texte(5) = 'L''adresse n''est pas au debut d''un bloc. ' +c +c==== +c 2. recherche de la taille selon le type de tableau a reallouer +c==== +c + if ( type1.eq.'i'.or.type1.eq.'I' ) then + ltype = tentie + elseif ( type1.eq.'s'.or.type1.eq.'S' ) then + ltype = tchain + elseif ( type1.eq.'r'.or.type1.eq.'R' ) then + ltype = treel + else + write(ulsort,*) ' gbralo type inconnu ', type1 + call ugstop('gbralo',ulsort,0,1,1) + endif +c +c==== +c 3. reallocation effective +c==== +c (attention: dmralo ne garantit pas que l'adresse de depart iad +c ne sera pas changee) +c + size = ltype*long +c +cgn write(ulsort,*) 'appel de dmralo avec iad = ', iad +cgn write(ulsort,*) 'appel de dmralo avec size = ', size + call dmralo ( iad, size, codret ) +cgn write(ulsort,*) 'retour de dmralo' +c + if ( codret.ne.0 ) then + write (ulsort,*) ' GBRALO : erreur a la re-allocation' + write (ulsort,*) 'Code de retour de DMRALO : ', codret + if ( codret.ge.-5 .and. codret.le.-3 ) then + write (ulsort,*) texte(abs(codret)) + endif + write (ulsort,*) 'Type : ', type1 + write (ulsort,*) 'Adresse : ', iad + write (ulsort,*) 'Taille voulue : ', long + endif +c + end diff --git a/src/tool/Gestion_MTU/gmadoj.F b/src/tool/Gestion_MTU/gmadoj.F new file mode 100644 index 00000000..90395ade --- /dev/null +++ b/src/tool/Gestion_MTU/gmadoj.F @@ -0,0 +1,141 @@ + subroutine gmadoj ( nom, iadres, long, iret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c rechercher l'adresse memoire de l' objet-terminal simple +c d'un nom etendu et la taille de cet objet +c ........................................................... +c +c entrees : +c nom : character*(*) : nom etendu +c ........................................................... +c +c sorties : +c iadres : adresse memoire de l'objet-terminal +c long : la taille de cet objet (en mots) +c iret : code de retour : +c -4 : erreur : nom etendu invalide +c -3 : erreur : objet-terminal de'nom' non defini +c -2 : erreur : objet-terminal de'nom' est un objet +c : structure +c -1 : erreur : objet-terminal de 'nom' est defini +c : mais non alloue +c 0 : OK +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmindi.h" +#include "gmimpr.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) nom + integer iadres,long,iret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + character*8 letype + integer idec,ioal,ityp,iadr + integer nrotab +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + iret = 0 + iadres = iindef + long = iindef +c +c 1. decodage du nom etendu +c + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + iret = -4 +c + else if (idec.eq.1) then +c +c objet-terminal non defini +c + iret = -3 +c + else if (idec.eq.2) then +c +c objet-terminal defini mais non alloue +c + iret = -1 +c + else +c + if (idec.eq.0) then +c +c 'nom' n'a qu'un element +c + call gbobal(objter,ityp,ioal) +c + if (ioal.eq.0) then +c +c objet non alloue +c + iret = -1 +c + endif +c + endif +c +c 2. objet-terminal defini et alloue : appel gbcara +c + if ( iret.eq.0 ) then +c + call gbcara(objter,nrotab,iadr,long,letype) +c + if (coergm.gt.1) then + write(ulsort,*) ' gmadoj -> retour gbcara > 1' + call ugstop('gmadoj',ulsort,1,1,1) + endif + if (coergm.eq.0) then + iret = 0 + iadres = iadr + else + iret = -2 + endif +c + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmadui.h b/src/tool/Gestion_MTU/gmadui.h new file mode 100644 index 00000000..02dfa7af --- /dev/null +++ b/src/tool/Gestion_MTU/gmadui.h @@ -0,0 +1,5 @@ +c +c stockage des adresses utiles pour les entiers +c + integer adui + common /gmadui/ adui(maxtab) diff --git a/src/tool/Gestion_MTU/gmadur.h b/src/tool/Gestion_MTU/gmadur.h new file mode 100644 index 00000000..aeacde59 --- /dev/null +++ b/src/tool/Gestion_MTU/gmadur.h @@ -0,0 +1,5 @@ +c +c stockage des adresses utiles pour les reels +c + integer adur + common /gmadur/ adur(maxtab) diff --git a/src/tool/Gestion_MTU/gmadus.h b/src/tool/Gestion_MTU/gmadus.h new file mode 100644 index 00000000..f4cfdc90 --- /dev/null +++ b/src/tool/Gestion_MTU/gmadus.h @@ -0,0 +1,5 @@ +c +c stockage des adresses utiles pour les ch*8 +c + integer adus + common /gmadus/ adus(maxtab) diff --git a/src/tool/Gestion_MTU/gmalen.h b/src/tool/Gestion_MTU/gmalen.h new file mode 100644 index 00000000..eaa943ed --- /dev/null +++ b/src/tool/Gestion_MTU/gmalen.h @@ -0,0 +1,3 @@ +c + character*8 nommxi, nomali + common /gmalen/ nommxi, nomali(maxtab) diff --git a/src/tool/Gestion_MTU/gmalog.F b/src/tool/Gestion_MTU/gmalog.F new file mode 100644 index 00000000..501a277d --- /dev/null +++ b/src/tool/Gestion_MTU/gmalog.F @@ -0,0 +1,688 @@ + subroutine gmalog ( nomtab, adut, nbplac, type1, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg, adug, + > nommxg, nomalg ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c memoire dynamique : +c +c adut est toujours une adresse utile : +c elle peut etre utilisee sous la forme : +c ...mem(adut)=... +c +c +c que contient ptall : +c +c En modgm 0 ( statique ) : +c decalage par rapport au debut de la zone : decal +c ptallg = decal +c adug = (ad1-ad0)/ltype+decal +c entre deux tableaux : adug1 - adug2 = ptallg1 - ptallg2 +c +c En modgm 1 ( semi-dynamique ) : +c decalage par rapport au debut de la zone : decal +c ptallg = decal +c adug = (ad1-ad0)/ltype+decal+1 +c entre deux tableaux : adug1 - adug2 = ptallg1 - ptallg2 +c +c En modgm 2 ( dynamique ) : +c retour de gbalme c.a.d. adresse absolue adabs +c ptallg = adabs +c adug = (adabs-ad0)/ltype+2 +c entre deux tableaux : adug1 - adug2 = (ptallg1 - ptallg2)/ltype +c +c cf. commentaires dans le source pour plus de details sur +c le calcul de adresses "utiles" +c (= indices dans les tableaux ...mem) en dynamique. +c +c ...................................................................... +c . +c . programme generique d'allocation d'un tableau +c . affectation du debut du premier trou memoire suffisant +c . mise a jour du tableau des trous +c . mise a jour des tableaux des variables allouees (stats) +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a allouer (8 caracteres au plus) +c . nbplac --> nombre de places demandees +c . type1 --> type du tableau :r,i,s +c .modifies minmeg <--> valeur entiere memorisant la plus petite +c . dimension du dernier trou afin de connaitre +c . le passage le plus delicat rencontre au cours +c . de l'allocation. cette valeur est calculee +c . apres compression (pour statistiques) +c . ntroug <--> valeur entiere . nombre de trous presents +c . nballg <--> nombre de tableaux deja alloues +c . totalg <--> valeur entiere cumulant les demandes +c . successives de memoire +c . ptroug <--> tableau entier contenant les pointeurs +c . repertoriant la position des trous +c . ltroug <--> tableau entier contenant la longueur des trous +c . ptallg <--> tableau entier contenant les pointeurs +c . repertoriant la position des tableaux +c . adug <--> tableau entier contenant les adresses utiles +c . des tableaux +c . lgallg <--> tableau entier contenant la longueur des +c . tableaux +c . nommxg <--> chaine de caractere(*8) contenant le nom du +c . plus grand (?) tableau associe a minmeg +c . nomalg <--> tableau de chaines de caracteres contenant +c . le nom associe a chaque tableau deja alloue +c .resultat adut <-- pointeur associe +c . la valeur renvoyee est indefinie en cas de +c . probleme +c . +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOG' ) +c +#include "gmmaxt.h" +#include "gmptrd.h" +c +#include "genbla.h" +#include "gmcain.h" +c +c 0.2. ==> communs +c +#include "gmtyge.h" +#include "gmtail.h" +#include "gmindi.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) nomtab + character*1 type1 + character*8 nommxg, nomalg(maxtab) + integer adug(maxtab) +c + integer adut , nbplac + integer minmeg, ntroug, nballg, totalg + integer ptroug(maxtrs) , ltroug(maxtrs) + integer ptallg(maxtab) , lgallg(maxtab) +c +c 0.4. ==> variables locales +c + character*16 blabla + character*8 nomvar +c + integer i, iaux, maxo, mtoto + integer pointe + integer ltype, ad0, ad1, nrotab, nrotro + integer nbcain, nfois, nentg +c + character*6 nompra +c + character*1 carint(1) +c + logical dertro +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data nfois / 0 / +c +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''La gestion de la memoire est statique.'')' + texte(1,5) ='(/,''La gestion de la memoire est semi-dynamique.'')' + texte(1,6) = '(/,''La gestion de la memoire est dynamique.'')' +c + texte(2,4) = '(/,''A static memory management is used.'')' + texte(2,5) = '(/,''A semi-dynamic memory management is used.'')' + texte(2,6) = '(/,''A dynamic memory management is used.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,modgm+4)) +#endif +c + coergm = 0 +c + adut = iindef +c + blabla = ' ' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'type1 = ', type1 +#endif + if ( type1.eq.'i' .or. type1.eq.'I' ) then + nompra = 'GMALOI' + blabla = 'entier ' + ltype = tentie + ad0 = adcom(1) + ad1 = admem(1) + else if ( type1.eq.'r' .or. type1.eq.'R' ) then + nompra = 'GMALOR' + blabla = 'reel ' + ltype = treel + ad0 = adcom(2) + ad1 = admem(2) + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + nompra = 'GMALOS' + blabla = 'caractere ' + ltype = tchain + ad0 = adcom(3) + ad1 = admem(3) + else + write(ulsort,10000) type1 + coergm = 1 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'ltype = ', ltype + write (ulsort,*) 'ad0 = ', ad0, ', ad1 = ', ad1 +#endif +10000 format (//2x,' ****** spg GMALOG *****', + > /2x,'Le type ',a1,' est inconnu.', + > /2x,'Il faut r, i ou s', + > /2x,' ===> arret dans le gestionnaire de memoire') +c +c==== +c 2. verifications +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. verifications ; coergm = ', coergm +#endif +c +c 2.1. ==> nature du nom +c aucun caractere n'est interdit, mais on met un blanc +c dans le tableau pour ne plus avoir de messages ftnchek +c + if ( coergm.eq.0 ) then +c + nbcain = 0 + carint(1) = ' ' + call gmntve ( nomtab, nomvar, nbcain, carint, coergm ) +c + if ( coergm.ne.0 ) then + write(ulsort,21100) nompra + coergm = 21 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif +c +21100 format ( 2x,'Probleme a l''appel au spg GMALOG via ',a6, + > /,4x,' ===> arret dans le gestionnaire de memoire') +c + endif +c +c 2.2. ==> verification du nombre de tableaux deja alloues +c . pour un tableau "ordinaire", on s'arrete un peu avant +c le maximum pour se garder une marge dans les impressions +c d'arret du programme +c . si c'est un tableau de nom temporaire, on controle +c sur le vrai nombre maximum de tableaux car il se peut +c que ce soit dans les impressions de deboggage, donc il ne +c faudrait pas boucler en controlant trop juste. +c + if ( coergm.eq.0 ) then +c + if ( nomvar(1:1).eq.caint1 ) then +c + iaux = 0 +c + else + iaux = 10 + if ( nballg.gt.maxtab-iaux .and. nfois.eq.0 ) then + nfois = 1 + if ( type1.eq.'r' .or. type1.eq.'R' ) then + call gmdmpr ( iaux ) + else if ( type1.eq.'i' .or. type1.eq.'I' ) then + call gmdmpi ( iaux ) + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + call gmdmps ( iaux ) + endif + write(ulsort,21100) nompra + write(ulsort,22000) nomvar, nballg, maxtab + coergm = 221 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif +c + endif +c + endif +c + if ( coergm.eq.0 ) then +c + if ( nballg.eq.maxtab-iaux .and. nfois.eq.0 ) then + nfois = 1 + if ( type1.eq.'r' .or. type1.eq.'R' ) then + call gmdmpr ( iaux ) + else if ( type1.eq.'i' .or. type1.eq.'I' ) then + call gmdmpi ( iaux ) + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + call gmdmps ( iaux ) + endif + write(ulsort,21100) nompra + write(ulsort,22000) nomvar, maxtab-iaux, maxtab + coergm = 222 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif +c + endif +c +22000 format ( 2x,'GMALOG : Allocation de ',a8, + > /,4x,'C''est le tableau numero ',i8 , + > /,4x,'Le nombre maxi de tableaux allouables vaut ',i8 , + > /,4x,'Il faut changer maxtab dans le gestionnaire', + > 1x,'(fichier a inclure gmmaxt.h)', + > /,4x,' ===> arret du au gestionnaire memoire gm') +c +c 2.3. ==> impossible d'avoir un nombre de places < 0 +c + if ( coergm.eq.0 ) then +c + if (nbplac.lt.0) then + write(ulsort,21100) nompra + write(ulsort,23000) nompra, nomvar, nbplac + coergm = 23 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif +c + endif +c +23000 format ( 2x,'Mauvais appel au spg GMALOG via ',a6, + > /,4x,' pour le tableau ',a8, + > /,4x,'Nombre de valeurs requises negatif ( ',i15,')' , + > /,4x,' ===> arret dans le gestionnaire de memoire') +c +c 2.4. ==> verif que le nom n'est pas deja utilise +c + if ( coergm.eq.0 ) then +c + do 24 i = 1 , nballg + if ( nomalg(i).eq.nomvar ) then + write(ulsort,24000) nompra, nomvar + coergm = 24 + goto 241 +cgn call ugstop( nompro, ulsort, 1, 1, 1 ) + endif + 24 continue +c + 241 continue +c + endif +c +24000 format ( 2x,'Probleme a l''appel au spg GMALOG via ',a6, + > /,4x,'Nom du tableau (',a8,') deja utilise' , + > /,4x,' ===> arret dans le gestionnaire de memoire') +c +c==== +c 3. Allocation +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. allocations ; coergm = ', coergm +#endif +c +c 3.1. ==> en mode statique ou semi-dynamique +c + if ( modgm.le.1 ) then +#ifdef _DEBUG_HOMARD_ +cgn if ( nomtab.eq.'MaEn002f' ) then + write (ulsort,*) 'nomtab = ', nomtab + write (ulsort,*) '3.1. Mode stat ou semi/dyna ; coergm = ', coergm + write (ulsort,*) 'nbplac = ', nbplac +cgn endif +#endif +c +c 3.1.1. ==> si on a demande d'allouer un tableau de longueur nulle, +c on le place en premiere position. +c l'inconvenient est que cela oblige a remanier la liste +c complete des tableaux a la fin de ce programme +c mais le gros avantage est qu'en cas de desallocation +c on ne risque pas de trouver un tableau de longueur +c nulle encadre par deux trous ; les trous sont ainsi +c toujours regroupes de maniere compacte +c + if ( nbplac.eq.0 ) then +c + if ( coergm.eq.0 ) then +c + nrotab = 1 + pointe = ptrdeb +c + endif +c + else +c +c 3.1.2. ==> allocation d'un tableau de longueur non nulle +c +c 3.1.2.1. recherche du premier trou suffisamment grand +c si aucun trou n'est disponible, impression d'un message, +c puis arret de l'execution +c + if ( coergm.eq.0 ) then +c + do 311 iaux = 1 , ntroug + if ( ltroug(iaux).ge.nbplac ) then + nrotro = iaux + go to 312 + endif + 311 continue +c + call gmmaxi ( maxo , mtoto , ntroug , ltroug ) +c + write(ulsort, 30100 ) nbplac, blabla, nomvar + write(ulsort, 30200 ) maxo, ntroug, mtoto + iaux = 10 + if ( type1.eq.'r' .or. type1.eq.'R' ) then + call gmdmpr ( iaux ) + else if ( type1.eq.'i' .or. type1.eq.'I' ) then + call gmdmpi ( iaux ) + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + call gmdmps ( iaux ) + endif +c + coergm = 312 +cgn call ugstop( nompro, ulsort, 1, 2, 1 ) +c + endif +c +c 3.1.2.2. ==> une place ayant ete trouvee, on met le tableau au debut +c de ce trou +c on memorise si c'etait le dernier trou ou non +c + 312 continue +c + if ( coergm.eq.0 ) then +c + pointe = ptroug(nrotro) +c + if ( nrotro.eq.ntroug ) then + dertro = .true. + else + dertro = .false. + endif +c + endif +c +c 3.1.2.3. ==> gestion des trous +c . si le trou a la meme taille que le tableau a allouer, +c il doit disparaitre. il faut alors decaler d'un cran +c les eventuels trous qui suivent. +c . si le trou est plus grand que le tableau a allouer, +c il est simplement decale et raccourci. +c + if ( coergm.eq.0 ) then +c + if ( ltroug(nrotro).eq.nbplac ) then +c + ntroug = ntroug - 1 + do 313 iaux = nrotro , ntroug + ptroug(iaux) = ptroug(iaux+1) + ltroug(iaux) = ltroug(iaux+1) + 313 continue + ptroug(ntroug+1) = iindef + ltroug(ntroug+1) = iindef +c + if ( dertro ) then + if ( minmeg.gt.0 ) then + nommxg = nomvar + endif + minmeg = 0 + endif +c + else +c + ptroug(nrotro) = ptroug(nrotro) + nbplac + ltroug(nrotro) = ltroug(nrotro) - nbplac +c + endif +c + endif +c +c 3.1.2.4. ==> on met a jour la longueur minimale du dernier trou. +c + if ( coergm.eq.0 ) then +c + if ( ntroug.le.0 ) then + minmeg = 0 + else if ( minmeg.gt.ltroug(ntroug) ) then + nommxg = nomvar + minmeg = ltroug(ntroug) + endif +c + endif +c +c 3.1.2.5. ==> . si le tableau est place au debut du dernier trou, +c il vient a la suite du dernier tableau enregistre. +c . si le tableau est place dans un trou qui est au milieu +c des tableaux, il faut l'inserer entre des tableaux +c deja alloues. on recherche le premier tableau dont +c l'adresse est plus grande que l'adresse du-dit trou. +c + if ( coergm.eq.0 ) then +c + if ( dertro ) then +c + nrotab = nballg + 1 +c + else +c + do 314 i = 1, nballg + if (ptallg(i).gt.pointe) then + nrotab = i + goto 315 + endif + 314 continue +c +c NB: si on passe ici, c'est bizarre +c (mauvaise gestion des trous?) +c + nrotab = nballg + 1 +c + 315 continue +c + endif +c + endif +c + endif +c +c 3.1.3. ==> calcul de l'adresse utile +c + if ( coergm.eq.0 ) then +c + adut = ((ad1-ad0)/ltype) + pointe + if ( modgm.eq.1 ) then + adut = adut + 1 + endif +c + endif +c +c 3.1.4. ==> mise a jour des listes par decalage des informations +c relatives aux tableaux qui viennent apres le tableau +c en cours d'allocation +c + if ( coergm.eq.0 ) then +c + do 316 iaux = nballg , nrotab , -1 + nomalg(iaux+1) = nomalg(iaux) + ptallg(iaux+1) = ptallg(iaux) + lgallg(iaux+1) = lgallg(iaux) + adug(iaux+1) = adug(iaux) + 316 continue +c + endif +c +c 3.2. ==> cas du mode dynamique +c le tableau alloue est toujours le dernier +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.2. Mode dynamique ; coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'appel de gbalme par gmalog, avec :' + write (ulsort,*) '... type1 : ', type1 + write (ulsort,*) '... nbplac+1 : ', nbplac+1 +#endif + call gbalme ( type1, nbplac+1, pointe ) +c + endif +c + if ( coergm.ne.0 ) then +c + write(ulsort,30100) nbplac+1, blabla, nomvar +cgn call ugstop( nompro, ulsort, 1, 2, 1 ) +c + else +c + nrotab = nballg + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'pointe = ', pointe + write (ulsort,*) 'pointe-ad0 = ', pointe-ad0 +#endif + adut = (pointe-ad0)/ltype +c +c En particulier pour les "gros types" +c on n'a pas vraiment de garantie que la division precedente +c "tombe juste". Le fait d'avoir en fait alloue nbplac+1 au lieu de +c nbplac (cf. appel a gbalme ci-dessus) permet de se mettre a l'abri +c de ce genre de probleme (en plus d'eviter de demander au systeme +c un malloc avec taille nulle, ce qui ne se passe pas toujours bien). +c +c Cette maniere d'evaluer l'adresse utile adut permet aussi de se +c premunir du cas ( extremement rare apparemment ) ou pointe-ad0 +c serait negatif (habituellement, les communs -donc ad0- sont charges +c en memoire a des adresses inferieures au "heap" -donc pointe-). +c + if ( adut*ltype .ge. pointe-ad0 ) then + adut = adut + 1 + else + adut = adut + 2 + endif +c +c gestion des grandeurs permettant d'obtenir des statistiques globales +c (meme en mode dynamique) : +c + if ( minmeg.ge.nbplac ) then + minmeg = minmeg - nbplac + if ( minmeg.eq.0 .and. nbplac.gt.0 ) then + nommxg = nomvar + endif + else + if ( type1.eq.'r' .or. type1.eq.'R' ) then + rmem(1) = rmem(1) + dble(nbplac - max( 0, minmeg )) + else if ( type1.eq.'i' .or. type1.eq.'I' ) then + imem(1) = imem(1) + nbplac - max( 0, minmeg ) + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + if (index(smem(1),'*').le.0) then + read(smem(1),'(i8)') nentg + nentg = nentg + nbplac - max( 0, minmeg ) + write(smem(1),'(i8)') nentg + endif + endif + if ( nbplac.gt.0 .or. minmeg.lt.0 ) then + nommxg = nomvar + endif + minmeg = 0 + endif +c + endif +c + endif +c +c 3.3. ==> memorisation des caracteristiques du nouveau tableau +c et statistiques globales +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.3. Memorisation ; coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c + nballg = nballg + 1 +c + nomalg(nrotab) = nomvar + ptallg(nrotab) = pointe + lgallg(nrotab) = nbplac + adug(nrotab) = adut +c + totalg = totalg + nbplac +c + endif +c +c 3.5 ==> messages +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.5. messages ; coergm = ', coergm +#endif +30100 format( + >/,78('='), + >/,'Impossible d''allouer',i15,' places en ',a16, + > ' pour ''',a8,'''', + >/,78('='),/) +30200 format( + >/,10x,'Le maximum disponible est de',i15,' places ;', + >/,10x,'Il y a',i5,' trous totalisant',i15,' places.'/) +c +c==== +c 4. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gmaloi.F b/src/tool/Gestion_MTU/gmaloi.F new file mode 100644 index 00000000..fc9e05a1 --- /dev/null +++ b/src/tool/Gestion_MTU/gmaloi.F @@ -0,0 +1,146 @@ + subroutine gmaloi( nomtab, pointe, nb ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c ...................................................................... +c . modif 15/06/89 jc jyb +c ...................................................................... +c . allocation d'un tableau dans le common gmenti +c . +c . - arguments: +c . donnees a l'appel nomtab --> nom de la variable a allouer +c . de 8 caracteres au plus +c . nb --> nombre d'entiers demandes +c . resultat pointe <-- pointeur associe +c ...................................................................... +c==== +c 0. declarations et dimensionnement +c==== +c 0.1. ==> generalites +c---- +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOI' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmadui.h" +#include "gmtren.h" +#include "gmalen.h" +#include "gmindi.h" +#include "gmindf.h" +#include "gmimpr.h" +#include "envex1.h" +#include "gmcoer.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer pointe , nb +c + character*(*) nomtab +c +c 0.4. ==> variables locales +c + integer iaux, ideb, ifin +c + character*1 typtab +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c ---- +c 2. allocation du tableau par le programme generique +c---- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Appel de gmalog par gmaloi, nb = ', nb +#endif + typtab = 'i' + call gmalog ( nomtab, pointe, nb, typtab, + > minmei, ntroui, nballi, totali, + > ptroui, ltroui, ptalli, lgalli,adui, + > nommxi, nomali ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==> pointe = ', pointe +#endif +c +c--- +c 3. au depart, le tableau sera mis a une valeur indefinie, vues +c les options de compilation. +c si on alloue apres avoir fait des desallocations, on peut +c se retrouver dans le tableau imem a un endroit qui etait occupe +c autrefois par quelque chose : on recupere alors les valeurs +c de l'epoque. +c toutefois cela n'est pas possible en compression car on risque +c de detruire le debut du tableau que l'on deplace +c tout ceci est pilote par lindef +c--- +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Etape 3 de gmaloi , coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c + if ( lindef.eq.0 ) then + ideb = pointe + ifin = pointe + nb - 1 +cgn write (ulsort,*) 'ideb , ifin = ', ideb , ifin + do 30 , iaux = ideb , ifin + imem(iaux) = iindef + 30 continue + endif +c + endif +c +c==== +c 4. Fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Fin de gmaloi' +#endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmaloj.F b/src/tool/Gestion_MTU/gmaloj.F new file mode 100644 index 00000000..bda9969e --- /dev/null +++ b/src/tool/Gestion_MTU/gmaloj.F @@ -0,0 +1,150 @@ + subroutine gmaloj (nom, typobj, long, adress, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c allocation l'objet terminal d'un nom etendu "nom" +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . e . char(*). nom etendu . +c . typobj . e .char(*) . type de l'objet a allouer . +c . long . e . 1 . 0 si on veut un objet structure . +c . . . . longueur si on veut un objet simple . +c . adress . s . ent . 0 si on veut un objet structure . +c . . . . adresse de l'objet simple alloue . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : dimensionnement des tables insuffisant. +c . . . . -2 : le type de l'objet-terminal est celui . +c . . . . d'un objet structure et long /= 0 . +c . . . . -3 : "nom" a plus d'un element et "type" ne. +c . . . . correspond pas au type du champ . +c . . . . terminal sauf si "type" = ' ' alors . +c . . . . c'est le type du champ-terminal . +c . . . . qui serait considere . +c . . . . -4 : "nom" a un seul element et "type" . +c . . . . n'est pas connu +c . . . . -5 : l'objet-terminal est deja alloue . +c . . . . -6 : nom etendu invalide . +c . . . . -7 : premier caractere interdit . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOJ' ) +c +#include "gmcain.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) nom, typobj + integer long, adress, codret +c +c 0.4. ==> variables locales +c + integer nbcain + integer iaux +c + character*1 carint(ncainx) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. Initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Objet a allouer : '', a)' + texte(1,5) = '(''. Type voulu : '',a)' + texte(1,6) = '(''. Longueur : '',i12)' +c + texte(2,4) = '(''Object : '',a)' + texte(2,5) = '(''. Type : '',a)' + texte(2,6) = '(''. Length : '',i12)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nom + write (ulsort,texte(langue,5)) typobj + write (ulsort,texte(langue,6)) long +#endif +c +c==== +c 2. on appelle le programme generique avec interdiction de certains +c caracteres en premiere position +c de plus, on autorise tous les types de noms +c==== +c + nbcain = ncainx + carint(1) = caint1 + if ( nbcain.ge.2 ) then + carint(2) = caint2 + endif + if ( nbcain.ge.3 ) then + carint(3) = caint3 + endif + if ( nbcain.ge.4 ) then + carint(4) = caint4 + endif +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de gballo par gmaloj' +#endif + call gballo ( nom, typobj, long, adress, + > nbcain, carint, codret ) +c +c==== +c 3. Fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,4)) nom + write (ulsort,texte(langue,5)) typobj + write (ulsort,texte(langue,6)) long +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmalor.F b/src/tool/Gestion_MTU/gmalor.F new file mode 100644 index 00000000..ddc04f20 --- /dev/null +++ b/src/tool/Gestion_MTU/gmalor.F @@ -0,0 +1,145 @@ + subroutine gmalor( nomtab, pointe, nb) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c ...................................................................... +c . derniere modif decembre 93 appel au programme general +c . modif juin 93 ntrour=0 + divers +c . modif 15/06/89 jc jyb +c ...................................................................... +c . +c . allocation d'un tableau dans le common gmreel +c . +c . - arguments: +c . donnees a l'appel nomtab --> nom de la variable a allouer +c . de 8 caracteres au plus +c . nb --> nombre de reels demandes +c . resultat pointe <-- pointeur associe +c ...................................................................... +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOR' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmreel.h" +#include "gmadur.h" +#include "gmtrrl.h" +#include "gmalrl.h" +#include "gmindf.h" +#include "gmindr.h" +#include "envex1.h" +#include "gmimpr.h" +#include "gmcoer.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer pointe , nb +c + character*(*) nomtab +c +c 0.4. ==> variables locales +c + integer iaux + integer i, ideb, ifin +c + character*1 typtab +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c ---- +c 2. allocation du tableau par le programme generique +c---- +c + typtab = 'r' + call gmalog ( nomtab, pointe, nb, typtab, + > minmer, ntrour, nballr, totalr, + > ptrour, ltrour, ptallr, lgallr,adur, + > nommxr, nomalr ) +c +c--- +c 3. au depart, le tableau sera mis a une valeur indefinie, vues +c les options de compilation. +c si on alloue apres avoir fait des desallocations, on peut +c se retrouver dans le tableau rmem a un endroit qui etait occupe +c autrefois par quelque chose : on recupere alors les valeurs +c de l'epoque. +c toutefois cela n'est pas possible en compression car on risque +c de detruire le debut du tableau que l'on deplace +c tout ceci est pilote par lindef +c--- +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Etape 3 de gmalor , coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c + if ( lindef.eq.0 ) then + ideb = pointe + ifin = pointe + nb - 1 +c rmem est en fait du double precision + do 30 , i = ideb , ifin + rmem(i) = rindef + 30 continue + endif +c + endif +c +c==== +c 4. Fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Fin de gmalor' +#endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmalos.F b/src/tool/Gestion_MTU/gmalos.F new file mode 100644 index 00000000..3e887203 --- /dev/null +++ b/src/tool/Gestion_MTU/gmalos.F @@ -0,0 +1,150 @@ + subroutine gmalos( nomtab, pointe, nb) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c ...................................................................... +c . creation juin 93 jyb +c ...................................................................... +c . allocation d'un tableau character*8 dans le common gmstri +c . +c . - arguments: +c . donnees a l'appel nomtab --> nom de la variable a allouer +c . de 8 caracteres au plus +c . nb --> nombre de character*8 demandes +c . resultat pointe <-- pointeur associe +c ...................................................................... +c==== +c 0. declarations et dimensionnement +c==== +c 0.1. ==> generalites +c---- +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOS' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +#include "gmadus.h" +#include "gmtrst.h" +#include "gmalst.h" +#include "gmindf.h" +#include "gminds.h" +#include "gmimpr.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer pointe , nb +c + character*(*) nomtab +c +c 0.4. ==> variables locales +c + integer iaux + integer ideb, ifin +c + character*1 typtab +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c ---- +c 2. allocation du tableau par le programme generique +c---- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Appel de gmalog par gmalos, nb = ', nb +#endif + typtab = 's' + call gmalog ( nomtab, pointe, nb, typtab, + > minmes, ntrous, nballs, totals, + > ptrous, ltrous, ptalls, lgalls,adus, + > nommxs, nomals ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '==> pointe = ', pointe +#endif +c +c--- +c 3. au depart, le tableau sera mis a une valeur indefinie, vues +c les options de compilation. +c si on alloue apres avoir fait des desallocations, on peut +c se retrouver dans le tableau smem a un endroit qui etait occupe +c autrefois par quelque chose : on recupere alors les valeurs +c de l'epoque. +c toutefois cela n'est pas possible en compression car on risque +c de detruire le debut du tableau que l'on deplace +c tout ceci est pilote par lindef +c--- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Etape 3 de gmalos , coergm = ', coergm +#endif +c + if ( coergm.eq.0 ) then +c + if ( lindef.eq.0 ) then + ideb = pointe + ifin = pointe + nb - 1 +cgn write (ulsort,*) 'ideb , ifin = ', ideb , ifin + do 30 , iaux = ideb , ifin +cgn write (ulsort,*) 'iaux = ', iaux + smem(iaux) = sindef + 30 continue + endif +c + endif +c +c==== +c 4. Fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Fin de gmalos' +#endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmalot.F b/src/tool/Gestion_MTU/gmalot.F new file mode 100644 index 00000000..2b58400f --- /dev/null +++ b/src/tool/Gestion_MTU/gmalot.F @@ -0,0 +1,168 @@ + subroutine gmalot (nom,typobj,long,adress,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c allocation d'un objet terminal temporaire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . s . char*8 . nom de l'objet alloue . +c . typobj . e .char(*) . type de l'objet a allouer . +c . long . e . 1 . 0 si on veut un objet structure . +c . . . . longueur si on veut un objet simple . +c . adress . s . ent . 0 si on veut un objet structure . +c . . . . adresse de l'objet simple alloue . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : dimensionnement des tables insuffisant. +c . . . . -2 : le type de l'objet-terminal est celui . +c . . . . d'un objet structure et long /= 0 . +c . . . . -3 : "nom" a plus d'un element et "typobj" . +c . . . . ne correspond pas au type du champ . +c . . . . terminal sauf si "typobj" = ' ' alors . +c . . . . c'est le type du champ-terminal . +c . . . . qui serait considere . +c . . . . -4 : "nom" a un seul element et "typobj" . +c . . . . est inconnu . +c . . . . -5 : l'objet-terminal est deja alloue . +c . . . . -6 : nom etendu invalide . +c . . . . -8 : le nom doit avoir un seul element . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMALOT' ) +c +#include "gmmaxt.h" +#include "gmcain.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmlang.h" +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*(*) nom + character*(*) typobj +c + integer long,adress,codret +c +c 0.4. ==> variables locales +c + integer nbcain + integer iaux +c + character*1 carint(ncainx) + character*8 nomaux, nom0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + nom0 = ' ' + nom = ' ' +c +c==== +c 2. Initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Objet a allouer : '', a)' + texte(1,5) = '(''. Type voulu : '',a)' + texte(1,6) = '(''. Longueur : '',i12)' +c + texte(2,4) = '(''Object : '',a)' + texte(2,5) = '(''. Type : '',a)' + texte(2,6) = '(''. Length : '',i12)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nom + write (ulsort,texte(langue,5)) typobj + write (ulsort,texte(langue,6)) long +#endif +c +c==== +c 2. allocation +c==== +c + 20 continue +c +c 2.1. ==> determination d'un nom d'objet temporaire +c + call gbntcr ( nomaux ) +c +c 2.2. ==> on appelle le programme generique sans interdiction +c sur le premier caractere puisque l'on vient de l'imposer +c en revanche, on interdit les noms qui ne sont pas des tetes +c + nbcain = 0 +c + call gballo ( nomaux, typobj, long, adress, + > nbcain, carint, codret ) +c + if ( codret.eq.-5 ) then +c +c un objet de ce nom existe deja : si le generateur de noms +c temporaires ne plafonne pas, on reessaie avec un nouveau nom : +c + if (nomaux.ne.nom0) then + nom0 = nomaux + goto 20 + endif + endif +c + nom(1:min(len(nom),8)) = nomaux(1:min(len(nom),8)) +c +c==== +c 3. Fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,4)) nom + write (ulsort,texte(langue,5)) typobj + write (ulsort,texte(langue,6)) long +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmalrl.h b/src/tool/Gestion_MTU/gmalrl.h new file mode 100644 index 00000000..7f49e768 --- /dev/null +++ b/src/tool/Gestion_MTU/gmalrl.h @@ -0,0 +1,3 @@ +c + character*8 nommxr, nomalr + common /gmalrl/ nommxr, nomalr(maxtab) diff --git a/src/tool/Gestion_MTU/gmalst.h b/src/tool/Gestion_MTU/gmalst.h new file mode 100644 index 00000000..1ba321e5 --- /dev/null +++ b/src/tool/Gestion_MTU/gmalst.h @@ -0,0 +1,3 @@ +c + character*8 nommxs, nomals + common /gmalst/ nommxs, nomals(maxtab) diff --git a/src/tool/Gestion_MTU/gmatoj.F b/src/tool/Gestion_MTU/gmatoj.F new file mode 100644 index 00000000..586f5548 --- /dev/null +++ b/src/tool/Gestion_MTU/gmatoj.F @@ -0,0 +1,263 @@ + subroutine gmatoj (nom1,nom2,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c attacher l'objet-terminal de 'nom2' au champ-terminal de +c 'nom1' +c ........................................................... +c +c entrees : +c +c nom1 : character*(*) : nom etendu +c nom2 : character*(*) : nom etendu +c +c ........................................................... +c +c sorties : codret : code de retour : +c +c -6 : erreur : 'nom1' n'a qu'un element +c -5 : erreur : 'nom1' : nom etendu invalide +c -4 : erreur : 'nom2' : nom etendu invalide +c -3 : erreur : objet-terminal de 'nom2' non defini +c -2 : erreur : objet-terminal de 'nom2' est d'un type +c : different de celui attendu pour +c : l'objet-terminal de 'nom1' +c -1 : erreur : 'nom1' a deja un objet-terminal +c 0 : OK +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +c +#include "gmcoer.h" +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*(*) nom1,nom2 + integer codret +c +c 0.4. ==> variables locales +c + character*8 obrep1,obter1,chter1 + character*8 obrep2,obter2,chter2 + character*8 letype +c + integer ide1,ide2 + integer iob,ich,kaux + integer itp1,nbc1,itc1,ioc1 + integer itp2,nbc2,itc2 + integer indc,iadr,long +c + integer nroobj, nrocha, nropoi + integer nrotab +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. decodage des noms etendus +c==== +c +c 1.1. ==> decodage +c + call gbdnoe(nom1,obrep1,obter1,chter1,ide1) + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) +c +c 1.2. ==> probleme sur nom1 +c + if (ide1.lt.0) then +c +c 'nom1' invalide +c + codret = -5 +c + else if (ide1.eq.0) then +c +c 'nom1' n'a qu'un element +c + codret = -6 +c + else if ((ide1.eq.2).or.(ide1.eq.3)) then +c +c 'nom1' a deja un objet-terminal +c + codret = -1 +c + else +c +c 1.3. ==> nom1 est bon mais probleme sur nom2 +c + if (ide2.lt.0) then +c +c 'nom2' invalide +c + codret = -4 +c + else if (ide2.eq.1) then +c +c objet-terminal de 'nom2' non defini +c + codret = -3 +c + else +c +c 1.4. ==> tout va bien +c + codret = 0 +c + endif +c + endif +c +c==== +c 2. recherche du type de l'objet-terminal de 'nom1' +c==== +c + if ( codret.eq.0 ) then +c + do 11 , iob = 1,iptobj-1 + if (nomobj(iob).eq.obrep1) then + nroobj = iob + goto 20 + endif + 11 continue +c + codret = -5 + goto 120 +c + 20 continue +c + itp1 = typobj(nroobj) + nbc1 = nbcham(itp1) + do 21 , kaux = 1,nbc1 + ich = adrdst(itp1)+kaux-1 + if (nomcha(ich).eq.chter1) then + nrocha = ich + nropoi = kaux + goto 40 + endif + 21 continue +c + codret = -5 + goto 120 +c + 40 continue +c + itc1 = typcha(nrocha) + ioc1 = adrdso(nroobj)+nropoi-1 +c +c==== +c 3. recherche du type de l'objet-terminal de 'nom2' +c==== +c + indc = 0 + do 51 , iob = 1,iptobj-1 + if (nomobj(iob).eq.obrep2) then + nroobj = iob + goto 60 + endif + 51 continue +c +c ici nom2 doit avoir un seul element : +c - il peut etre un objet simple alloue ou non +c - il peut etre un objet structure mais non alloue +c + call gbcara(obter2,nrotab,iadr,long,letype) + if (coergm.gt.1) then + write(ulsort,*) ' gmatoj -> retour gbcara > 1' + call ugstop('gmatoj',ulsort,1,1,1) + endif + if (coergm.eq.0) then + if (letype.eq.nomtyb(1)) then + itc2 = -1 + else if (letype.eq.nomtyb(2)) then + itc2 = -2 + else if (letype.eq.nomtyb(3)) then + itc2 = -3 + else if (letype.eq.nomtyb(4)) then + itc2 = -4 + else + itc2 = -5 + endif + else + indc = 1 + endif + goto 100 +c + 60 continue +c + itp2 = typobj(nroobj) + nbc2 = nbcham(itp2) + do 61 , kaux = 1,nbc2 + ich = adrdst(itp2)+kaux-1 + if (nomcha(ich).eq.chter2) then + nrocha = ich + goto 80 + endif + 61 continue +c + codret = -4 + goto 120 +c + 80 continue +c + itc2 = typcha(nrocha) +c +c==== +c 4. verification de la concordance de type +c==== +c + 100 continue +c + if (indc.eq.0) then + if (itc1.ne.itc2) then + codret = -2 + goto 120 + endif + endif +c +c==== +c 5. attacher obter2 au champ-terminal de 'nom1' +c==== +c + codret = 0 + nomobc(ioc1) = obter2 +c + endif +c + 120 continue +c + end diff --git a/src/tool/Gestion_MTU/gmcain.h b/src/tool/Gestion_MTU/gmcain.h new file mode 100644 index 00000000..08aa41b9 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcain.h @@ -0,0 +1,15 @@ +c +c Ceci est la liste des caracteres interdits comme premiere +c lettre pour le nom d'un objet GM defini par l'utilisateur +c +c ncainx : nombre de caracteres interdits +c + integer ncainx + parameter ( ncainx = 4 ) +c + character*1 caint1, caint2, caint3, caint4 +c + parameter ( caint1 = '%' ) + parameter ( caint2 = '$' ) + parameter ( caint3 = '&' ) + parameter ( caint4 = ' ' ) diff --git a/src/tool/Gestion_MTU/gmcata.F b/src/tool/Gestion_MTU/gmcata.F new file mode 100644 index 00000000..70ae6d95 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcata.F @@ -0,0 +1,131 @@ + subroutine gmcata( nomtab, lgallo, + > nballg, nomalg, lgallg ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 03/05 +c ...................................................................... +c . +c . - interet: +c . recuperation des carateristiques d'un tableau +c . +c . - realisation: +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a etudier (8 caracteres au plus) +c . nomalg <--> tableau de chaines de caracteres contenant +c . le nom associe a chaque tableau deja alloue +c . lgallg <--> tableau entier contenant la longueur des +c . tableaux +c .resultat lgallo <-- nombre de valeurs a l'allocation +c . +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*8 nomtab + character*8 nomalg(maxtab) +c + integer lgallo + integer nballg, lgallg(maxtab) +c +c 0.4. ==> variables locales +c + character*8 nomvar +c + integer iaux, jaux + integer codret + integer nrotab + integer nbcain +c + character*6 nompro + parameter ( nompro = 'GMCATA' ) +c + character*1 carint(1) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c ---- +c 1. preliminaires +c---- +c +c 1.1. ==> nature du nom +c aucun caractere n'est interdit, mais on met un blanc +c dans le tableau pour ne plus avoir de messages ftnchek +c + nbcain = 0 + carint(1) = ' ' + call gmntve ( nomtab, nomvar, nbcain, carint, codret ) +c + if ( codret.ne.0 ) then + write(ulsort,30001) nompro +30001 format ( 2x,'Probleme dans ',a) + call ugstop( nompro,ulsort,0,1,1) + endif +c +c==== +c 2. caracteristiques +c==== +c +c 2.1. ==> Recherche dans les tables +c + jaux = 0 + do 21 , iaux = 1 , nballg + if ( nomalg(iaux).eq.nomvar ) then + nrotab = iaux + jaux = jaux + 1 + endif + 21 continue +c + if (jaux.eq.0) then + write(ulsort,30003) nompro, nomvar +30003 format ( 2x,'Probleme dans ',a, + > /,4x,'Le tableau (',a8,') n''a pas ete alloue', + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + else if (jaux.gt.1) then + write(ulsort,30013) nompro, nomvar +30013 format ( 2x,'Probleme dans ',a, + > /,4x,'Le tableau (',a8,') a ete alloue plusieurs fois' , + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + endif +c +c 2.1. ==> Longueur d'allocation +c + lgallo = lgallg(nrotab) +c + end diff --git a/src/tool/Gestion_MTU/gmcmpr.F b/src/tool/Gestion_MTU/gmcmpr.F new file mode 100644 index 00000000..f96fbfa0 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcmpr.F @@ -0,0 +1,384 @@ + subroutine gmcmpr ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c - interet: +c . Aucun en mode dynamique de gestion de la memoire !!!!! +c . En mode statique, on elimine les trous laisses entre les +c differents tableaux entiers, reels et character*8 +c de maniere a offrir le maximum de place disponible en un seul +c trou situe en fin des tableaux de travail. +c attention la reallocation se fait sans reinitialiser la memoire +c en mettant lindef a 1. lindef est remis a 0 en fin de programme. +c +c La technique est la suivante : +c Tant qu'il reste au moins deux trous (en effet, s'il n'en reste +c qu'un, il est forcement a la fin, donc c'est gagne !) : +c a. recherche du premier tableau qui suit le premier trou. +c b. memorisation de son nom, son adresse utile, sa longueur +c c. retrait de ses references des tables de GM +c d. allocation d'un tableau de meme nom et de meme longueur : GM +c va forcement le placer au debut du premier trou et creer +c un trou a sa suite +c e. si le tableau n'est pas de longueur nulle, decalage du contenu +c +c - restriction d'utilisation +c apres cet appel, il faut prendre soin de rechercher +c les nouveaux pointeurs des tableaux toujours en usage par appel +c a gmadoj +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . 2 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtyge.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmalrl.h" +#include "gmalen.h" +#include "gmalst.h" +c +#include "gmadui.h" +#include "gmadur.h" +#include "gmadus.h" +c +#include "gmimpr.h" +c +#include "gmindf.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + character*8 nomtab + character*16 blabla +c + integer aduold, ilongr, adunew, iptfin + integer iaux, ideb, nrotab +c + logical detlg0 +c +c 0.5. ==> initialisations +c + detlg0 = .true. +c ______________________________________________________________________ +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Compression de la memoire' +#endif +c +#include "impr03.h" +c +c==== +c 1. Pas de compression en mode dynamique +c==== +c + if ( modgm.eq.2) then +c + codret = 0 +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'impossible en mode dynamique' +#endif +c + else +c + lindef = 1 +c +10000 format (//2x,' ======= spg gmcmpr ==========',/2x, + > 'Zone en ',a16,/2x, + > 'le trou debutant en ',i4,' et de longueur ',i4,/2x, + > 'n''est pas contigu a un tableau entier alloue --> probleme') +c +c==== +c 2. traitement du tableau reel +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmdmpr ( iaux ) +#endif +c + nrotab = 0 +c + 2 continue +c + if ( ntrour.gt.1 ) then +c + blabla = 'reel ' +c +c 2.1. ==> on cherche le premier tableau alloue qui suit le trou "1" +c il suffit d'explorer a partir du dernier trouve +c + iptfin = ptrour(1) + ltrour(1) +c + ideb = nrotab + 1 + do 21 , iaux = ideb , nballr + if ( ptallr(iaux).eq.iptfin ) then + nrotab = iaux + goto 22 + endif + 21 continue +c +c --> pb de consistance entre les trous et les variables allouees +c + write(ulsort,10000) blabla, ptrour(1), ltrour(1) + iaux = 3 + call gmdmpr ( iaux ) + call ugstop ( 'gmcmpr-reel', ulsort, 0, 1, 1 ) +c +c 2.2. ==> on libere ce tableau (apres avoir memorise ses +c caracteristiques) +c + 22 continue +c + aduold = adur(nrotab) + ilongr = lgallr(nrotab) + nomtab = nomalr(nrotab) +c + call gmdesr ( nomtab , ilongr , detlg0) +c +c 2.3. ==> on le realloue (--> on detruit ainsi le trou precedant +c qui se propage vers la droite ) +c attention, l'adresse renvoyee est l'adresse utile +c + call gmalor ( nomtab , adunew , ilongr ) +c +c 2.4. ==> on translate son contenu de l'ancienne position a la nouvelle +c si le tableau n'est pas de longueur nulle +c + if ( ilongr.ne.0 ) then + call gmshfr ( rmem , adunew , aduold , ilongr ) + endif +c +c 2.5. ==> on recommence jusqu'a epuisement +c + goto 2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmdmpr ( iaux ) +#endif +c +c==== +c 3. traitement du tableau entier +c on n'effectue un passage que s'il existe plusieurs trous dans +c le tableau, car quand il n'y en a qu'un, il est au bout. +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmdmpi ( iaux ) +#endif +c + nrotab = 0 +c + 3 continue +c + if ( ntroui.gt.1 ) then +c + blabla = 'entier ' +c +c 3.1. ==> on cherche le premier tableau alloue qui suit le trou "1" +c il suffit d'explorer a partir du dernier trouve +c + iptfin = ptroui(1) + ltroui(1) +c + ideb = nrotab + 1 + do 31 , iaux = ideb , nballi + if ( ptalli(iaux).eq.iptfin ) then + nrotab = iaux + goto 32 + endif + 31 continue +c +c --> pb de consistance entre les trous et les variables allouees +c + write(ulsort,10000) blabla, ptroui(1), ltroui(1) + iaux = 3 + call gmdmpi ( iaux ) + call ugstop ( 'gmcmpr_entier', ulsort, 0, 1, 1 ) +c +c 3.2. ==> on libere ce tableau (apres avoir memorise ses +c caracteristiques) +c + 32 continue +c + aduold = adui(nrotab) + ilongr = lgalli(nrotab) + nomtab = nomali(nrotab) +c + call gmdesi ( nomtab , ilongr , detlg0) +c +c 3.3. ==> on le realloue (--> on detruit ainsi le trou precedant +c qui se propage vers la droite ) +c attention, l'adresse renvoyee est l'adresse utile +c + call gmaloi ( nomtab , adunew , ilongr ) +c +c 3.4. ==> on translate son contenu de l'ancienne position a la nouvelle +c si le tableau n'est pas de longueur nulle +c + if ( ilongr.ne.0 ) then + call gmshfi ( imem , adunew , aduold , ilongr ) + endif +c +c 3.5. ==> on recommence jusqu'a epuisement +c + goto 3 +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmdmpi ( iaux ) +#endif +c +c==== +c 4. traitement du tableau character*8 +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmdmps ( iaux ) +#endif +c + nrotab = 0 +c + 4 continue +c + if ( ntrous.gt.1 ) then +c + blabla = 'caractere ' +c +c 4.1. ==> on cherche le premier tableau alloue qui suit le trou "1" +c il suffit d'explorer a partir du dernier trouve +c + iptfin = ptrous(1) + ltrous(1) +c + ideb = nrotab + 1 + do 41 , iaux = ideb , nballs + if ( ptalls(iaux).eq.iptfin ) then + nrotab = iaux + goto 42 + endif + 41 continue +c +c --> pb de consistance entre les trous et les variables allouees +c + write(ulsort,10000) blabla, ptrous(1), ltrous(1) + iaux = 3 + call gmdmps ( iaux ) + call ugstop ( 'gmcmpr-caractere', ulsort, 0, 1, 1 ) +c +c 4.2. ==> on libere ce tableau (apres avoir memorise ses +c caracteristiques) +c + 42 continue +c + aduold = adus(nrotab) + ilongr = lgalls(nrotab) + nomtab = nomals(nrotab) +c + call gmdess ( nomtab , ilongr , detlg0) +c +c 4.3. ==> on le realloue (--> on detruit ainsi le trou precedant +c qui se propage vers la droite ) +c attention, l'adresse renvoyee est l'adresse utile +c + call gmalos ( nomtab , adunew , ilongr ) +c +c 4.4. ==> on translate son contenu de l'ancienne position a la nouvelle +c si le tableau n'est pas de longueur nulle +c + if ( ilongr.ne.0 ) then + call gmshfs ( smem , adunew , aduold , ilongr ) + endif +c +c 4.5. ==> on recommence jusqu'a epuisement +c + goto 4 +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmdmps ( iaux ) +#endif +c +c==== +c 5. fin du travail +c==== +c + minler = min(minler,minmer) + if ( ntrour.ne.0 ) then + minmer = ltrour(1) + if ( nballr.ne.0 ) then + nommxr = nomalr(nballr) + endif + endif +c + minlei = min(minlei,minmei) + if ( ntroui.ne.0 ) then + minmei = ltroui(1) + if ( nballi.ne.0 ) then + nommxi = nomali(nballi) + endif + endif +c + minles = min(minles,minmes) + if ( ntrous.ne.0 ) then + minmes = ltrous(1) + if ( nballs.ne.0 ) then + nommxs = nomals(nballs) + endif + endif +c +c lindef est remis a 0 pour permettre de nouveau l'initialisation +c + lindef = 0 +c + codret = 0 +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmcoer.h b/src/tool/Gestion_MTU/gmcoer.h new file mode 100644 index 00000000..4df1dad0 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcoer.h @@ -0,0 +1,6 @@ +c +c code de retour +c + integer coergm +c + common /gmcoer/ coergm diff --git a/src/tool/Gestion_MTU/gmcpal.F b/src/tool/Gestion_MTU/gmcpal.F new file mode 100644 index 00000000..91a4e074 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcpal.F @@ -0,0 +1,170 @@ + subroutine gmcpal ( nom1, nom2, typnom, adress, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c copier l'objet 'nom1' a la place de l'objet 'nom2' +c 'nom1' et 'nom2' doivent etre de meme type +c s'ils sont de type structure : on copie les attributs +c s'ils sont de type simple : on copie le contenu +c si l'objet nom2 n'est pas alloue, on l'alloue +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom1 . e . char(*). nom etendu source . +c . nom2 . es .char(*) . nom etendu destinataire . +c . typnom . e . 1 . type du nom de l'objet maillage . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . adress . s . 1 . adresse du tableau s'il est simple . +c . codret . s . 1 . code retour de l'operation . +c . . . . 0 : OK . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + integer typnom + integer adress + integer codret +c + character*(*) nom1,nom2 +c +c 0.4. ==> variables locales +c + integer idec, iadr, long, nrotab + integer iret + integer iaux +c + character*8 objrep,objter,chater + character*8 letype +c + codret = 0 +c +c==== +c 1. la structure a copier +c==== +c 1.1. ==> decodage du nom etendu de la structure a copier +c + call gbdnoe(nom1,objrep,objter,chater,idec) +c + if ( idec.lt.0 ) then +c + codret = -1 +c + endif +c +c 1.2. ==> type de la structure a copier +c + if ( codret.eq.0 ) then +c + call gmobal ( objter, iret ) +c + if ( iret.eq.1 ) then +c +c objet structure +c + codret = -1 +c + else if ( iret.eq.2 ) then +c +c objet simple +c + call gbcara(objter,nrotab,iadr,long,letype) + codret = coergm +c + else +c + codret = -2 +c + endif +c + endif +c +c==== +c 2. Allocation +c==== +c +c 2.1. ==> on verifie que l'objet n'est pas deja alloue +c + if ( codret.eq.0 ) then +c + call gmobal ( nom2, codret ) +c + endif +c +c 2.2. ==> allocation +c + if ( codret.eq.0 ) then +c + if ( typnom.eq.0 ) then +c + call gmalot ( nom2, letype, 0, iaux, codret ) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nom2, letype, 0, iaux, codret ) +c + else +c + codret = -1 +c + endif +c + endif +c +c==== +c 3. Copie veritable +c==== +c + if ( codret.eq.0 ) then +c + call gmcpoj (nom1, nom2, codret) +c + endif +c +c==== +c 4. L'adresse pour un objet simple +c==== +c + if ( iret.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nom2, adress, iaux, codret ) +c + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmcpgp.F b/src/tool/Gestion_MTU/gmcpgp.F new file mode 100644 index 00000000..dbe76ea4 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcpgp.F @@ -0,0 +1,286 @@ + subroutine gmcpgp ( nom1, nom2, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c copier le graphe de l'objet 'nom1' simple ou structure +c a la place du graphe de l'objet 'nom2' : +c - si nom1 est un objet simple on ecrit simplement cet +c objet +c - l'ancien graphe de nom2 est supprime, un nouveau graphe +c est cree avec des noms nouveaux (sauf la racine) pour +c recevoir le graphe de nom2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom1 . e . char(*). nom etendu source . +c . nom2 . e .char(*) . nom etendu destinataire . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : 'nom1' invalide ou non alloue . +c . . . . -2 : objets destinataire et source ne sont . +c . . . . pas de meme type . +c . . . . -3 : nom etendu invalide . +c . . . . -4 : premier caractere interdit . +c . . . . -5 : dimensionnement insuffisant . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GMCPGP' ) +c +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gminds.h" +c +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer codret + character*(*) nom1, nom2 +c +c 0.4. ==> variables locales +c +#include "gmixjx.h" +c + integer iaux, jaux + integer i,nbj,ide1,ioa1,ity1,ide2,isup,igrp + integer impopt, nbchem,j,nj1,i2,iadr,long1,jc,ieco,iato + integer lgchem(ix) +c + integer nrotab + character*8 chemin(ix,jx), objet + character*8 obrep1,obter1,chter1,racine + character*8 obrep2,obter2,chter2 + character*8 obj1(nbjx), obj2(nbjx) + character*8 letype + character*90 chaine + character*40 mess +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,20) = '(1x,''Copie du graphe de l''''objet '',a8)' + texte(1,4) = '(1x,''a la place du graphe de l''''objet '',a8)' + texte(1,11) = '(1x,''Le premier objet est invalide.'')' + texte(1,12) = '(1x,''Les deux objets ne sont pas de meme type.'')' + texte(1,13) = '(1x,''Le second objet est invalide.'')' + texte(1,14) = '(1x,''Premier caractere du 2nd nom interdit.'')' + texte(1,15) = '(1x,''Dimensionnement insuffisant.'')' +c + texte(2,20) = '(1x,''Copy of the graph of the object '',a8)' + texte(2,4) = '(1x,''to the graph of the object '',a8)' + texte(2,11) = '(1x,''The first object is not valid.'')' + texte(2,12) = '(1x,''The types of 2 objects are different.'')' + texte(2,13) = '(1x,''The second object is not valid.'')' + texte(2,14) = '(1x,''1st character of 2nd name is forbidden.'')' + texte(2,15) = '(1x,''Lack of central memory.'')' +c +c 1. initialisation +c + do 10 i = 1, nbjx + obj1(i) = sindef + obj2(i) = sindef + 10 continue + nbj = 0 +c +c 2. ecrire d'abord l'objet 'nom1' +c + call gmcpoj (nom1,nom2,codret) + if (codret.lt.0) then + goto 91 + endif +c +c si objet simple : fini +c + call gbdnoe(nom1,obrep1,obter1,chter1,ide1) + call gbobal(obter1,ity1,ioa1) + if (ioa1.eq.2) then + goto 91 + endif +c +c 3. supprimer le graphe de l'objet 'nom2' s'il existe +c + if (nom2.eq.sindef) then + codret = -3 + goto 91 + endif + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) + call gasgmc(obter2,isup) + if ((isup.ne.0).and.(isup.ne.-5)) then + mess = ' gmcpgp -> gasgmc -> codret : ' + write(mess(29:30),'(i2)') isup + write(ulsort,*) mess + call ugstop('gmcpgp',ulsort,1,1,1) + endif + racine = obter2 +c +c 4 construction du graphe de 'nom1' +c +#ifdef _DEBUG_HOMARD_ + impopt = 1 +#else + impopt = 0 +#endif +c + iaux = ix + jaux = jx + call gagpmc(obter1,iaux,jaux,chemin,lgchem,nbchem,impopt,igrp) + if (igrp.lt.0) then + mess = ' gmcpgp -> gagpmc -> codret : ' + write(mess(29:30),'(i2)') igrp + write(ulsort,*) mess + call ugstop('gmcpgp',ulsort,1,1,1) + endif +c +c 5. ecrire le graphe de 'nom1' +c + do 50 i = 1, nbchem + do 51 j = 3 , jx , 2 + if ( (chemin(i,j)(1:1).eq.'*') .or. + > (chemin(i,j)(1:1).eq.'=') .or. + > (chemin(i,j)(1:1).eq.'+') .or. + > (chemin(i,j)(1:1).eq.'-') .or. + > (chemin(i,j)(1:1).eq.'<') ) then + nj1 = j-1 + goto 20 + endif + 51 continue + codret = -5 + goto 91 +c + 20 continue + i2 = 8 + chaine(1:i2) = racine +c + do 40 j = 2, nj1, 2 +c + chaine = chaine(1:i2)//'.'//chemin(i,j-1) + i2 = i2+9 + objet = chemin(i,j) +c + if (objet.eq.sindef) then + goto 40 + else if (chemin(i,j+1)(1:1).eq.'=') then + goto 40 + endif + if (chemin(i,j+1)(1:1).eq.'*') then + call gbcara(objet,nrotab,iadr,long1,letype) + if (coergm.ne.0) then + goto 40 + endif + endif +c +c recherche si objet est deja ecrit +c + do 41 jc = 1, nbj + if (obj1(jc).eq.objet) then + jaux = jc + goto 30 + endif + 41 continue +c +c si l'objet n'est pas ecrit : on l'ecrit +c + call gmcpoj (objet,chaine(1:i2),ieco) + if (ieco.lt.0) then + mess = ' gmcpgp -> gmcpoj -> codret : ' + write(mess(29:30),'(i2)') ieco + write(ulsort,*) mess + call ugstop('gmcpgp',ulsort,1,1,1) + endif +c +c mise a jour des tableaux obj1 et obj2 +c + call gbdnoe(chaine(1:i2),obrep2,obter2,chter2,ide2) + nbj = nbj+1 + obj1(nbj) = objet + obj2(nbj) = obter2 + goto 40 +c +c si l'objet est deja ecrit et si champ destinataire +c est vide : y attacher l'objet disque deja ecrit +c + 30 continue + call gmatoj(chaine(1:i2),obj2(jaux),iato) + if ((iato.ne.0).and.(iato.ne.-1)) then + mess = ' gmcpgp -> gmatoj -> codret : ' + write(mess(29:30),'(i2)') iato + write(ulsort,*) mess + call ugstop('gmcpgp',ulsort,1,1,1) + endif +c + 40 continue +c + 50 continue +c + codret = 0 +c +c==== +c 9. gestion des erreurs +c==== +c + 91 continue +c + if ( codret.ne.0 ) then +c + iaux = 10+abs(codret) +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,20)) nom1 + write (ulsort,texte(langue,4)) nom2 + write (ulsort,texte(langue,iaux)) + write (ulsort,90000) +c + endif +c +90000 format (1x,70('=')) +c + end diff --git a/src/tool/Gestion_MTU/gmcpoj.F b/src/tool/Gestion_MTU/gmcpoj.F new file mode 100644 index 00000000..2c08b273 --- /dev/null +++ b/src/tool/Gestion_MTU/gmcpoj.F @@ -0,0 +1,309 @@ + subroutine gmcpoj (nom1,nom2,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c copier l'objet 'nom1' a la place de l'objet 'nom2' +c 'nom1' et 'nom2' doivent etre de meme type +c s'ils sont de type structure : on copie les attributs +c s'ils sont de type simple : on copie le contenu +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom1 . e . char(*). nom etendu source . +c . nom2 . e .char(*) . nom etendu destinataire . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : 'nom1' invalide ou non alloue . +c . . . . -2 : objets destinataire et source ne sont . +c . . . . pas de meme type . +c . . . . -3 : nom etendu invalide . +c . . . . -4 : premier caractere interdit . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "gmimpr.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + integer codret + character*(*) nom1,nom2 +c +c 0.4. ==> variables locales +c + logical detlg0 +c + character*8 obrep1,obter1,chter1 + character*8 obrep2,obter2,chter2 + character*8 letype + character*8 typ1 + character*40 mess +c + integer ide1,ioa1,ity1,ide2,ioa2,ity2 + integer ial2,irt2,iob1,ity,nba,iob2,ia,iat1,iat2 + integer long1,iad1,long2,iad2,il,llres + integer nrotab +c +c 1. decodage du nom etendu 'nom1' +c + codret = 0 + call gbdnoe(nom1,obrep1,obter1,chter1,ide1) +c + if ((ide1.lt.0).or.(ide1.eq.1).or.(ide1.eq.2)) then +c +c 'nom1' invalide ou non alloue +c + codret = -1 + goto 9999 +c + else +c +c ide1 = 0 ou 3 +c + call gbobal(obter1,ity1,ioa1) +c + if (ioa1.eq.0) then + codret = -1 + goto 9999 + endif +c + endif +c +c 2. copie de obter1 +c + if (ioa1.eq.1) then +c +c 2.1. obter1 est un objet structure (alloue) +c +c decodage de nom2 +c + typ1 = nomtyp(ity1) + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) + if (ide2.lt.0) then + codret = -3 + goto 9999 + else if (ide2.eq.0) then + call gbobal(obter2,ity2,ioa2) + if (ioa2.eq.0) then + call gmaloj(obter2,typ1,0,ial2,irt2) + if (irt2.eq.-3) then + codret = -2 + goto 9999 + endif + if (irt2.eq.-7) then + codret = -4 + goto 9999 + endif + if ((irt2.ne.0).and.(irt2.ne.-5)) then + mess = ' gmcpoj -> gmaloj -> codret : ' + write(mess(29:30),'(i2)') irt2 + write(ulsort,*) mess + call ugstop('gmcpoj',ulsort,1,1,1) + endif + ity2 = ity1 + endif + else + if (ide2.ne.3) then + call gmaloj(nom2,typ1,0,ial2,irt2) + if (irt2.eq.-3) then + codret = -2 + goto 9999 + endif + if (irt2.eq.-7) then + codret = -4 + goto 9999 + endif + if ((irt2.ne.0).and.(irt2.ne.-5)) then + mess = ' gmcpoj -> gmaloj -> codret : ' + write(mess(29:30),'(i2)') irt2 + write(ulsort,*) mess + call ugstop('gmcpoj',ulsort,1,1,1) + endif + ity2 = ity1 + endif + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) + call gbobal(obter2,ity2,ioa2) + endif +c + if (ity1.ne.ity2) then + codret = -2 + goto 9999 + endif +c + do 10 , iob1 = 1,iptobj-1 + if (nomobj(iob1).eq.obter1) then + goto 11 + endif + 10 continue + codret = -1 + goto 9999 +c + 11 continue + ity = typobj(iob1) + nba = nbratt(ity) +c + do 12 , iob2 = 1,iptobj-1 + if (nomobj(iob2).eq.obter2) then + goto 13 + endif + 12 continue + codret = -3 + goto 9999 +c + 13 continue + do 14 , ia = 1,nba + iat1 = adrdsa(iob1)+ia-1 + iat2 = adrdsa(iob2)+ia-1 + valatt(iat2) = valatt(iat1) + 14 continue +c + else if (ioa1.eq.2) then +c +c 2.2. obter1 est un objet simple (alloue) +c + call gbcara(obter1,nrotab,iad1,long1,letype) +c + typ1 = nomtyb(-ity1) +c +c decodage de nom2 +c + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) + if (ide2.lt.0) then + codret = -3 + goto 9999 + else if (ide2.eq.0) then + call gbobal(obter2,ity2,ioa2) + if (ioa2.eq.0) then + call gmaloj(obter2,typ1,long1,ial2,irt2) + if (irt2.eq.-3) then + codret = -2 + goto 9999 + endif + if (irt2.eq.-7) then + codret = -4 + goto 9999 + endif + if ((irt2.ne.0).and.(irt2.ne.-5)) then + mess = ' gmcpoj -> gmaloj -> codret : ' + write(mess(29:30),'(i2)') irt2 + write(ulsort,*) mess + call ugstop('gmcpoj',ulsort,1,1,1) + endif + ity2 = ity1 + endif + else + if (ide2.ne.3) then + call gmaloj(nom2,typ1,long1,ial2,irt2) + if (irt2.eq.-3) then + codret = -2 + goto 9999 + endif + if (irt2.eq.-7) then + codret = -4 + goto 9999 + endif + if ((irt2.ne.0).and.(irt2.ne.-5)) then + mess = ' gmcpoj -> gmaloj -> codret : ' + write(mess(29:30),'(i2)') irt2 + write(ulsort,*) mess + call ugstop('gmcpoj',ulsort,1,1,1) + endif + ity2 = ity1 + endif + call gbdnoe(nom2,obrep2,obter2,chter2,ide2) + call gbobal(obter2,ity2,ioa2) + endif +c + if (ity1.ne.ity2) then + codret = -2 + goto 9999 + endif +c + call gbcara(obter2,nrotab,iad2,long2,letype) +c + if (long1.gt.long2) then +c + call gmdesa(obter2) + if ( coergm.ne.0 ) then + codret = coergm + goto 9999 + endif +c + if (ity1.eq.-1) then + call gmaloi(obter2,iad2,long1) + else if (ity1.eq.-2) then + call gmalor(obter2,iad2,long1) + else if (ity1.eq.-3) then + call gmalos(obter2,iad2,long1) + endif + endif +c + if (typ1.eq.nomtyb(1)) then + do 21 , il = 1,long1 + imem(iad2+il-1) = imem(iad1+il-1) + 21 continue + else if (typ1.eq.nomtyb(2)) then + do 22 , il = 1,long1 + rmem(iad2+il-1) = rmem(iad1+il-1) + 22 continue + else if (typ1.eq.nomtyb(3)) then + do 23 , il = 1,long1 + smem(iad2+il-1) = smem(iad1+il-1) + 23 continue + endif +c + if (long1.lt.long2) then + llres = long2-long1 + detlg0 = .false. + if (ity1.eq.-1) then + call gmdesi(obter2,llres,detlg0) + else if (ity1.eq.-2) then + call gmdesr(obter2,llres,detlg0) + else if (ity1.eq.-3) then + call gmdess(obter2,llres,detlg0) + endif + endif + endif +c + 9999 continue +c + end diff --git a/src/tool/Gestion_MTU/gmdesa.F b/src/tool/Gestion_MTU/gmdesa.F new file mode 100644 index 00000000..b5eb509b --- /dev/null +++ b/src/tool/Gestion_MTU/gmdesa.F @@ -0,0 +1,239 @@ + subroutine gmdesa ( nomtab ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . derniere modif octo 93 gn double precision +c . modif juin 93 jyb prise en compte du type character*8 +c . modif 15/06/89 jc jyb +c ...................................................................... +c . +c . - interet: +c . permet de liberer la place occupee par un tableau reel, entier +c . ou caractere*8 en indiquant simplement +c . le nom sous lequel il a ete cree. +c . 'attention' : ceci suppose que le nom apparaisse une fois +c . et une seule +c . +c . - arguments: +c . nomtab --> chaine de 8 car. maxi contenant le nom du tableau +c . (reel ou entier) a liberer +c ...................................................................... +c . +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDESA' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +#include "gmalrl.h" +#include "gmalen.h" +#include "gmalst.h" +#include "gmimpr.h" +#include "gmcoer.h" +#include "envex1.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character *(*) nomtab +c +c 0.4. ==> variables locales +c + character*1 carint(1) + character*8 nomvar +c + integer ilong + integer iaux +c + integer icptr, numr, icpti, numi, icpts, nums + integer nbcain +c + logical detlg0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. recherche des caracteristiques associe au tableau demande +c==== +c +c 2.1. ==> nature du nom +c aucun caractere n'est interdit, mais on met un blanc +c dans le tableau pour ne plus avoir de messages ftnchek +c + nbcain = 0 + carint(1) = ' ' + call gmntve ( nomtab, nomvar, nbcain, carint, coergm ) +c + if ( coergm.ne.0 ) then + write(ulsort,20000) nomtab +20000 format( 2x,' mauvais appel au spg gmdesa', + > /,4x,' ===> arret dans le gestionnaire de memoire') + goto 9999 + endif +c + ilong = 0 +c +c 2.1. ==> controle de nom donne en double dans une categorie +c + icptr = 0 + do 21 iaux = 1, nballr + if ( nomvar.eq.nomalr(iaux) ) then + icptr = icptr + 1 + numr = iaux + endif + 21 continue + if ( icptr.gt.1) then + coergm = 1 + write(ulsort,21000) nomvar +21000 format(//2x,' ===== spg gmdesa ======',/2x,' le tableau ', + > a8,' apparait plusieurs fois dans les reels') + endif +c + icpti = 0 + do 23 iaux = 1, nballi + if ( nomvar.eq.nomali(iaux) ) then + icpti = icpti + 1 + numi = iaux + endif + 23 continue + if ( icpti.gt.1) then + coergm = 1 + write(ulsort,23000) nomvar +23000 format(//2x,' ===== spg gmdesa ======',/2x,'le tableau ', + > a8,' apparait plusieurs fois dans les entiers') + endif +c + icpts = 0 + do 24 iaux = 1, nballs + if ( nomvar.eq.nomals(iaux) ) then + icpts = icpts + 1 + nums = iaux + endif + 24 continue + if ( icpts.gt.1) then + coergm = 1 + write(ulsort,24000) nomvar +24000 format(//2x,' ===== spg gmdesa ======',/2x,'le tableau ', + > a8,' apparait plusieurs fois dans les character*8') + endif +c + if ( coergm.eq.0 ) then + iaux = icptr + icpti + icpts + if ( iaux.eq.0 ) then + write(ulsort,26001) nomvar +26001 format(//2x,' ===== spg gmdesa ======',/2x,'le tableau ', + > a8,' est inconnu') + coergm = 1 + endif + if ( iaux.gt.1 ) then + write(ulsort,26002) nomvar +26002 format(//2x,' ===== spg gmdesa ======',/2x,'le tableau ', + > a8,' apparait dans plusieurs types simples.') + coergm = 1 + endif + endif +c +c verification globale du code retour +c + if ( coergm. ne .0) then + write(ulsort,20001) nomvar , coergm +20001 format(/2x,' ======= spg gmdesa =======',/2x, + > 'la recherche du tableau ', a8,' s''est mal passee ',i2) + goto 9999 + endif +c +c==== +c 3.la demande etant valide, on desalloue le tableau en fonction du type +c on precise que l'on supprime la memoire +c==== +c +c 3.1. ==> on precise que l'on supprime la memoire +c + detlg0 = .true. +c +c 3.2. ==> c'est parti +c +c reel +c + if ( icptr . ne . 0 ) then +c + ilong = lgallr(numr) + call gmdesr ( nomtab , ilong, detlg0 ) +c + endif +c +c entier +c + if ( icpti . ne . 0 ) then +c + ilong = lgalli(numi) + call gmdesi ( nomtab , ilong, detlg0 ) +c + endif +c +c character*8 +c + if ( icpts . ne . 0 ) then +c + ilong = lgalls(nums) + call gmdess ( nomtab , ilong, detlg0 ) +c + endif +c +c==== +c 3. Fin +c==== +c + 9999 continue +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdesg.F b/src/tool/Gestion_MTU/gmdesg.F new file mode 100644 index 00000000..4a90b3f4 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdesg.F @@ -0,0 +1,450 @@ + subroutine gmdesg ( nomtab, nbplac, type1, detlg0, + > ntroug, nballg, ptroug, ltroug, + > ptallg, lgallg, adug, nomalg ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . creation octobre 93 gn +c ...................................................................... +c +c le programme libere nbplac mots de memoire a partir de la fin +c pour le tableau nomtab ================== +c +c ...................................................................... +c . +c . - fonction : +c . programme generique de desallocation d'un emplacement memoire +c . 'attention' le contenu du tableau est inchange +c . +c . - realisation: +c . recherche du premier trou memoire suivant +c . mise a jour du tableau des trous (rallonge ou creation) +c . mise a jour des tableaux des variables allouees (stats) +c . +c . - arguments: +c . donnees nomtab --> nom du tableau concerne +c . nbplac --> nombre de mots liberes a partir de la fin +c . type1 --> type du tableau :r,i,s,d, ou c +c . detlg0 --> vrai/faux pour la destruction du tableau s'il +c . devient de longueur nulle +c .modifies ntroug <--> valeur entiere . nombre de trous presents +c . nballg <--> nombre de tableaux deja alloues +c . ptroug <--> tableau entier contenant les pointeurs +c . repertoriant la position des trous +c . ltroug <--> tableau entier contenant la longueur des trous +c . ptallg <--> tableau entier contenant les pointeurs +c . repertoriant la position des tableaux +c . adug <--> adresses utiles des tableaux +c . telles que retournees par gbcara +c . lgallg <--> tableau entier contenant la longueur des +c . tableaux +c . nomalg <--> tableau de chaines de caracteres contenant +c . le nom associe a chaque tableau deja alloue +c . - restriction d' usage +c . le spg n'accepte de desallouer la zone prescrite que si celle +c . ci est integralement contenue dans un tableau effectivement +c . alloue precedemment. cela autorise une desallocation partielle. +c . il ne desalloue jamais un tableau de longueur nulle. en effet +c . meme si pointe coincide avec l'adresse d'un tableau de longueur +c . nulle il n'est pas possible de savoir si l'on a voulu +c . desallouer la fin du tableau precedent mais il se trouve que +c . nbplac est nul ou le tableau de longueur nulle qui se trouve a +c . l'adresse pointe +c . +c ...................................................................... +c . +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDESG' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +#include "gmtyge.h" +c +#include "gmindi.h" +#include "gminds.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*1 type1 + character*8 nomtab, nomalg(maxtab) +c + integer nbplac, ntroug, nballg + integer ptroug(maxtrs) , ltroug(maxtrs) + integer ptallg(maxtab) , lgallg(maxtab) + integer adug(maxtab) +c + logical detlg0 +c +c 0.4. ==> variables locales +c + integer adut +c + integer ltype +c decal : decalage / au debut de la zone +c uniquement en mode statique ou semi-dynamique +c + integer decal +c +c adabs : adressr absolue +c + integer adabs, ad0 +c + character*8 typobs +c + integer iaux, jaux, nrotab, nrotro +c + character*6 nompra +c + logical jointb, jointh +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 1. preliminaires +c==== +c + coergm = 0 +c + if ( type1.eq.'i' .or. type1.eq.'I' ) then + nompra = 'GMDESI' + ltype = tentie + ad0 = adcom(1) + elseif ( type1.eq.'r' .or. type1.eq.'R' ) then + nompra = 'GMDESR' + ltype = treel + ad0 = adcom(2) + elseif ( type1.eq.'s' .or. type1.eq.'S' ) then + nompra = 'GMDESS' + ltype = tchain + ad0 = adcom(3) + else + write(ulsort,10000) type1 + coergm = 1 + endif +c +10000 format(/2x,'Le type ',a1,' est inconnu.', + > /2x,'Il faut r, i ou s') +c +c==== +c 2. verifications +c==== +c + if ( coergm.eq.0 ) then +c + if ( nbplac .lt. 0 ) then + write(ulsort,20001) nbplac + coergm = 1 + endif +c + endif +c +20001 format(/2x,'On demande a liberer ',i8,' places.') +c +c==== +c 3. recherche du tableau +c==== +c + if ( coergm.eq.0 ) then +c +c 3.1.1. ==> recherche du numero du tableau concerne +c + call gbcara ( nomtab , nrotab, adut , iaux , typobs ) +c +c 3.1.2. ==> il ne faut pas enlever plus de places qu'il n'y en a deja +c + if ( coergm.eq.0 ) then + if ( nbplac.gt.lgallg(nrotab) ) then + write(ulsort,20001) nbplac + write(ulsort,30001) lgallg(nrotab) + coergm = 1 + endif + endif +c +30001 format(2x,'Or le tableau est alloue avec ',i8,' places.') +c +c 3.1.3. ==> si c'est bon, on repere les adresses de la zone a liberer +c si aucun tableau trouve --> messages d'erreur et arret +c + if ( coergm.eq.0 ) then + if ( modgm.le.1 ) then + decal = ptallg(nrotab) + lgallg(nrotab) - nbplac + else + adabs = ptallg(nrotab) + endif + endif +c + endif +c +c==== +c 4. en mode statique ou semi-dynamique, il faut gerer les trous +c quand on desalloue un nombre non nul de places +c==== +c + if ( coergm.eq.0 .and. modgm.le.1 .and. nbplac.ne.0 ) then +c +c 4.1. ==> localisation de l'adresse donnee par rapport aux trous +c + nrotro = 0 + do 41 iaux = 1, ntroug + if ( ptroug(iaux).gt.decal ) then + nrotro = iaux + go to 42 + endif + 41 continue +c +c 4.2. ==> gestion du nouveau trou +c + 42 continue +c + if ( nrotro.eq.0 ) then +c +c 4.2.1. ==> la zone liberee se situe apres tous les trous existants +c --> cela constitue un nouveau trou en fin de tableau +c + ntroug = ntroug + 1 + ptroug(ntroug) = decal + ltroug(ntroug) = nbplac +c + else +c +c 4.2.2. ==> on a trouve un trou qui est place apres la zone a liberer +c Si ce n'est pas le premier, y en a-t-il un autre avant ? +c + if ( nrotro.eq.1 ) then + jointb = .false. + else + jointb = ((ptroug(nrotro-1)+ltroug(nrotro-1)).ge.decal) + endif +c + jointh = ( (decal+nbplac).ge.ptroug(nrotro) ) +c +c ---> action suivant les 4 cas possibles +c + if (jointb.and.jointh) then +c +c fusion par le bas et le haut (elimination d'un trou) +c + ltroug(nrotro-1) = ltroug(nrotro) + + > ptroug(nrotro)-ptroug(nrotro-1) + ntroug = ntroug-1 + do 43 iaux = nrotro, ntroug + ptroug(iaux) = ptroug(iaux+1) + ltroug(iaux) = ltroug(iaux+1) + 43 continue + ptroug(ntroug+1) = iindef + ltroug(ntroug+1) = iindef +c + else if (jointb) then +c +c fusion par le bas + ltroug(nrotro-1) = decal + nbplac - ptroug(nrotro-1) +c + else if (jointh) then +c +c fusion par le haut + ltroug(nrotro) = ptroug(nrotro) + ltroug(nrotro) - decal + ptroug(nrotro) = decal +c + else +c +c creation d'un nouveau trou au milieu + ntroug = ntroug + 1 + jaux = ntroug + do 44 iaux = nrotro+1, ntroug + ptroug(jaux) = ptroug(jaux-1) + ltroug(jaux) = ltroug(jaux-1) + jaux=jaux-1 + 44 continue + ptroug(nrotro) = decal + ltroug(nrotro) = nbplac +c + endif +c + endif +c + endif +c +c==== +c 5. raccourcissement effectif +c==== +c + if ( coergm.eq.0 ) then +c +c 5.1. ==> si tout est bon, on raccourcit +c + lgallg(nrotab) = lgallg(nrotab) - nbplac +c +c 5.2. ==> si la longueur finale est nulle et que l'on ne garde +c pas un tableau de longueur nulle, on desalloue totalement +c + if ( detlg0 .and. lgallg(nrotab).eq.0 ) then +c +c 5.2.1. ==> on supprime le tableau des tables +c + nballg = nballg - 1 +c + do 52 iaux = nrotab, nballg + nomalg(iaux) = nomalg(iaux+1) + ptallg(iaux) = ptallg(iaux+1) + lgallg(iaux) = lgallg(iaux+1) + adug(iaux) = adug(iaux+1) + 52 continue +c + nomalg(nballg+1) = sindef + ptallg(nballg+1) = iindef + lgallg(nballg+1) = iindef + adug(nballg+1) = iindef +c +c 5.2.2. ==> en mode dynamique, on libere la memoire +c + if ( modgm.eq.2 ) then +c + call gblibe( type1, nbplac, adabs, coergm ) +c + if ( coergm.ne.0 ) then + write(ulsort,*) nompro, ' modgm 2 erreur au free' + endif +c + endif +c + else if ( modgm.eq.2 .and. nbplac.gt.0 ) then +c +c Raccourcissement "partiel" en mode dynamique: +c +c (noter que ce raccourcissement partiel, ou re-allocation, +c n'est pas vital au fonctionnement de gm) +c +cgn write(ulsort,*) 'appel de gbralo' + call gbralo( type1, lgallg(nrotab)+1, + > ptallg(nrotab), coergm ) +cgn write(ulsort,*) 'retour de gbralo' +c + if ( coergm.ne.0 ) then +c + write(ulsort,*) nompro, ' modgm 2 erreur au realloc' + ptallg(nrotab) = adabs +c + else if ( ptallg(nrotab).ne.adabs ) then +c +c cas ou l'adresse memoire du tableau a ete changee : +c on recalcule l'adresse "utile" adug(nrotab) +c + adabs = (ptallg(nrotab)-ad0)/ltype +c + if ( adabs*ltype .ge. ptallg(nrotab)-ad0 ) then + adug(nrotab) = adabs + 1 + else + adug(nrotab) = adabs + 2 + endif + endif +c + endif +c + if (coergm.eq.0 .and. modgm.eq.2 .and. nbplac.gt.0) then +c +c gestion des grandeurs permettant d'obtenir des statistiques globales +c (meme en mode dynamique) : +c + if ( type1.eq.'r' .or. type1.eq.'R' ) then + minmer = minmer + nbplac + else if ( type1.eq.'i' .or. type1.eq.'I' ) then + minmei = minmei + nbplac + else if ( type1.eq.'s' .or. type1.eq.'S' ) then + minmes = minmes + nbplac + endif +c + endif +c + endif +c +c==== +c 5. arret si erreur +c==== +c + if ( coergm.ne.0 ) then +c + write(ulsort,50000) nompro, nompra, nomtab +c + if ( type1.eq.'r' .or. type1.eq.'R' ) then + call gmdmpr ( iaux ) + elseif ( type1.eq.'i' .or. type1.eq.'I' ) then + call gmdmpi ( iaux ) + elseif ( type1.eq.'s' .or. type1.eq.'S' ) then + call gmdmps ( iaux ) + endif +c + call ugstop ( nompro, ulsort, 0, 1, 1 ) +c + endif +c +50000 format(/2x,' ****** spg ',a,' via ',a6,' *****', + > /2x,' probleme pour le tableau ',a8, + > /2x,' ===> arret a cause du gestionnaire de memoire', + > /2x ,'Verifier votre appel a l''aide des infos suivantes') +c +c==== +c 3. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdesi.F b/src/tool/Gestion_MTU/gmdesi.F new file mode 100644 index 00000000..57b7ad32 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdesi.F @@ -0,0 +1,113 @@ + subroutine gmdesi (nomtab,nbplac, detlg0) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . derniere modif decembre 93 gn appel au programme generique gmdesg +c ...................................................................... +c . +c . - fonction : +c . desallocation d'un emplacement memoire dans le tableau des entier +c . 'attention' le contenu du tableau est inchange +c . +c . - realisation: +c . appel au programme generique gmdesg +c . +c . - arguments: +c . donnees: nomtab --> nom du tableau +c . detlg0 --> vrai si le tableau est supprime +c . s'il devient vide +c . nbplac --> nombre de mots memoire liberes +c ...................................................................... +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDESI' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmadui.h" +#include "gmtren.h" +#include "gmalen.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 nomtab +c + integer nbplac +c + logical detlg0 +c +c 0.4. ==> variables locales +c + integer iaux +c + character*1 typtab +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c---- +c 2. appel au programme generique +c---- +c + typtab = 'i' + call gmdesg ( nomtab, nbplac, typtab, detlg0, + > ntroui, nballi, ptroui, ltroui, + > ptalli, lgalli,adui, nomali ) +c +c==== +c 3. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdesr.F b/src/tool/Gestion_MTU/gmdesr.F new file mode 100644 index 00000000..e6f13d49 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdesr.F @@ -0,0 +1,113 @@ + subroutine gmdesr (nomtab,nbplac, detlg0) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c . derniere modif decembre 93 gn appel au programme generique gmdesg +c ...................................................................... +c . +c . - fonction : +c . desallocation d'un emplacement memoire dans le tableau des reels +c . 'attention' le contenu du tableau est inchange +c . +c . - realisation: +c . appel au programme generique gmdesg +c . +c . - arguments: +c . donnees: nomtab --> nom du tableau +c . detlg0 --> vrai si le tableau est supprime +c . s'il devient vide +c . nbplac --> nombre de mots memoire liberes +c ...................................................................... +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDESR' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmadur.h" +#include "gmtrrl.h" +#include "gmalrl.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 nomtab +c + integer nbplac +c + logical detlg0 +c +c 0.4. ==> variables locales +c + integer iaux +c + character*1 typtab +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c---- +c 2. appel au programme generique +c---- +c + typtab = 'r' + call gmdesg ( nomtab, nbplac, typtab, detlg0, + > ntrour, nballr, ptrour, ltrour, + > ptallr, lgallr,adur, nomalr ) +c +c==== +c 3. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdess.F b/src/tool/Gestion_MTU/gmdess.F new file mode 100644 index 00000000..31297d28 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdess.F @@ -0,0 +1,116 @@ + subroutine gmdess (nomtab,nbplac, detlg0) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c . derniere modif decembre 93 gn appel au programme generique gmdesg +c . creation juin 93 jyb +c ...................................................................... +c . +c . - fonction : +c . desallocation d'un emplacement memoire dans le tableau des +c . character*8 +c . 'attention' le contenu du tableau est inchange +c . +c . - realisation: +c . appel au programme generique gmdesg +c . +c . - arguments: +c . donnees: nomtab --> nom du tableau +c . detlg0 --> vrai si le tableau est supprime +c . s'il devient vide +c . nbplac --> nombre de mots memoire liberes +c ...................................................................... +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDESS' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmadus.h" +#include "gmtrst.h" +#include "gmalst.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 nomtab +c + integer nbplac +c + logical detlg0 +c +c 0.4. ==> variables locales +c + integer iaux +c + character*1 typtab +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. appel au programme generique +c==== +c + typtab = 's' + call gmdesg ( nomtab, nbplac, typtab, detlg0, + > ntrous, nballs, ptrous, ltrous, + > ptalls, lgalls,adus, nomals ) +c +c==== +c 3. Fin +c==== +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdmp.F b/src/tool/Gestion_MTU/gmdmp.F new file mode 100644 index 00000000..c1622560 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmp.F @@ -0,0 +1,85 @@ + subroutine gmdmp (letype, gmimp) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : gere l'impression generale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letype . e . char8 . type des structures a imprimer . +c . . . . 'entier ' -> appel gmdmpi : entier . +c . . . . 'reel ' -> appel gmdmpr : reel . +c . . . . 'chaine ' -> appel gmdmps : chaine . +c . . . . 'struct ' -> appel gmdmpt : structure . +c . . . . 'dicosdgm' -> appel gmdmpt : dictionnaire . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtors.h" +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*8 letype + integer gmimp +c +c 0.4. ==> variables locales +c + character*8 typem +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. appel du programme specialise ad-hoc +c==== +c +cgn print *,'letype =',letype + call gbminu(letype,typem) +c + if ( typem.eq.nomtyb(1) ) then + call gmdmpi ( gmimp ) + else if ( typem.eq.nomtyb(2) ) then + call gmdmpr ( gmimp ) + else if ( typem.eq.nomtyb(3) ) then + call gmdmps ( gmimp ) + else if ( typem.eq.nomtyb(4) ) then + call gmdmpt( 2, gmimp ) + else if ( typem.eq.'dicosdgm' ) then + call gmdmpt( 1, gmimp ) + else + write(ulsort,*) 'GMDMP -> type : ',letype,' inconnu' + call dmabor + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdmpg.F b/src/tool/Gestion_MTU/gmdmpg.F new file mode 100644 index 00000000..89638939 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmpg.F @@ -0,0 +1,378 @@ + subroutine gmdmpg ( minmeg, ntroug, nballg, ptroug, ltroug, + > ptallg, lgallg, adug, nommxg, nomalg, jgen, typtab, + > gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c . - interet: +c . impression detaillee du contenu d'un tableau de travail +c . ( caracteristiques des trous et des zones allouees) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . minmeg . e . . valeur entiere memorisant la plus petite . +c . . . . dimension du dernier trou afin de connaitre. +c . . . . le passage le plus delicat rencontre au . +c . . . . cours de l'allocation. cette valeur est . +c . . . . calculee apres compression . +c . ntroug . e . . valeur entiere . nombre de trous present . +c . nballg . e . . nombre de tableaux deja alloues . +c . ptroug . e . . tableau entier contenant les pointeurs . +c . . . . repertoriant la position des trous . +c . ltroug . e . . tableau entier contenant la long. des trous. +c . ptallg . e . . tableau entier contenant les pointeurs . +c . . . . repertoriant la position des tableaux . +c . lgallg . e . . tableau entier contenant la longueur des . +c . . . . tableaux . +c . nommxg . e . . chaine de caractere(*8) contenant le nom du. +c . . . . plus grand tableau associe a minmeg . +c . nomalg . e . . tableau de chaines de caracteres contenant . +c . . e . . le nom associe a chaque tableau deja alloue. +c . jgen . e . . dimension reservee au depart +c . typtab . e . . type du tableau :r,i,s,d,c . +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . <=2 => impression simple . +c . . . . >2 => impression etendue . +c ______________________________________________________________________ +c +c ...................................................................... +c . creation gn octobre 1993 a partir des versions specifiques +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDMPG' ) +c +#include "genbla.h" +#include "gmmaxt.h" +#include "gmptrd.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +#include "gmtyge.h" +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*1 typtab + character*8 nommxg, nomalg(maxtab) + integer adug(maxtab) +c + integer minmeg, ntroug, nballg, jgen + integer ptroug(maxtrs) , ltroug(maxtrs) + integer ptallg(maxtab) , lgallg(maxtab) + integer gmimp +c +c 0.4. ==> variables locales +c + integer maxg , mtot , ilgmax , maxiut, numtyp + integer iaux , jaux , kaux , kaux1 + integer nbrreg , iall , ideb , ifin + integer tabaux(0:maxtab) +c + character*14 saux14 + character*17 blabla(nblang,3) + character*50 texte1 +c + integer nbmess + parameter ( nbmess = 21 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/18(''=''),'' Etat de la memoire en '',a17,17(''=''))' + texte(1,5) = + > '(/,''Nombre d''''objets alloues . . . . . . . :'',i12)' + texte(1,6) = '(''Longueur totale en mots . . . . . . . :'',i12)' + texte(1,7) = '(''Longueur totale en octets . . . . . . :'',i12)' + texte(1,8) = '(''Maximum reserve a la compilation . . :'',i12)' + texte(1,9) = '(''Maximum reserve . . . . . . . . . . . :'',i12)' + texte(1,10) ='(''Plus grand trou disponible. . . . . . :'',i12)' + texte(1,11) ='(''Nombre de trous . . . . . . . . . . . :'',i12)' + texte(1,12) = + > '(''Maximum disponible actuel (cumul) . . :'',i12)' + texte1 = '(''Plus grande zone deja allouee . : apres '',a8,'', ' +c 12 34567890123456789012345678901234567890123 45678 90 + texte(1,13) = texte1//'de taille '',i12)' + texte(1,14) = + > '(''- Trou no'',i5,'' adresse :'',i12,'', longueur :'',i12)' + texte1 = '(/,''Region occupee no'',i5,/,''. Adresse :'',i12' +c 1234 567890123456789012 3456789 012345678901234567 890 + texte(1,15) = texte1//''' . Longueur :'',i12)' + texte1 = '(11(''=''),'' Fin de la gestion de la memoire en '', ' +c 12345 67 890 1234567890123456789012345678901234567 890 + texte(1,19) = texte1//'a17,11(''='')/)' + texte(1,20) = + >'(''Type '''',a1,'''' inconnu. Il faut r, i, d, s ou c.'')' + texte(1,21) = '(''La memoire est geree dynamiquement.'')' +c + texte(2,4) = + > '(/18(''=''),'' Status of memory in '',a17,17(''=''))' + texte(2,5) = + > '(/,''Number of allocated objects . . . . . :'',i12)' + texte(2,6) = '(''Total length in words . . . . . . . . :'',i12)' + texte(2,7) = '(''Total length in bits . . . . . . . . :'',i12)' + texte(2,8) = '(''Maximum reserved in compilation . . . :'',i12)' + texte(2,9) = '(''Maximum reserved . . . . . . . . . . :'',i12)' + texte(2,10) ='(''Greatest available hole . . . . . . . :'',i12)' + texte(2,11) ='(''Number of holes . . . . . . . . . . . :'',i12)' + texte(2,12) = + > '(''Current available maximum (total) . . :'',i12)' + texte1 = '(''Greatest zone already allocated : after '',a8, ' +c 12 345678901234567890123456789012345678901234567890 + texte(2,13) = texte1//''', of size '',i12)' + texte1 ='(''- Hole #'',i5,'' adress :'',i12,'', length :''' +c 12 345678901 23456 7890123456789012 34567 89012345678 90 + texte(2,14) = texte1//',i12)' + texte1 = '(/,''Occupied region #'',i5,/,''. Adress:'',i12,' +c 1234 567890123456789012 3456789 01234567890123456 7890 + texte(2,15) = texte1//''' . Length:'',i12)' + texte(2,17) = '(65(''-''))' + texte1 = '(14(''=''),'' End of the memory gestion in '',' +c 12 34567890123456789012 3456789 012345678901234567890 + texte(2,19) = texte1//'a17,13(''='')/)' + texte(2,20) = + >'(''Type '''',a1,'''' unknown. Only r, i, d, s or c.'')' + texte(2,21) = '(''Memory is used dynamically.'')' +c + blabla(1,1) = 'reel ============' + blabla(1,2) = 'entier ==========' + blabla(1,3) = 'caractere =======' +c + blabla(2,1) = 'real ============' + blabla(2,2) = 'integer =========' + blabla(2,3) = 'character =======' +c + 1001 format (74('-')) + 1002 format ('! Tableau ! Taille',a,'Adresse ', + >a,'Adresse utile !') + 1003 format ('! ',a8,' !',i14,' !',i21,' !',i21,' !') + saux14 = ' ! ' +c +c Pour eviter un message de ftnchek : + tabaux(0) = 0 +c +c==== +c 2. preliminaires +c==== +c + if ( typtab.eq.'r' .or. typtab.eq.'R' ) then + numtyp = 1 + elseif ( typtab.eq.'i' .or. typtab.eq.'I' ) then + numtyp = 2 + elseif ( typtab.eq.'s' .or. typtab.eq.'S' ) then + numtyp = 3 + else + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,20)) typtab + call ugstop( nompro,ulsort,1,0,1) + endif +c +c==== +c 3. bilan de l'etat de la memoire +c==== +c +c 3.1. ==> generalites +c + write (ulsort,texte(langue,4)) blabla(langue,numtyp) + write (ulsort,texte(langue,5)) nballg +c + iaux = 0 + do 31 , kaux = 1 , nballg + iaux = iaux + lgallg(kaux) + 31 continue + write (ulsort,texte(langue,6)) iaux +c + if ( typtab.eq.'i'.or.typtab.eq.'I') then + kaux = tentie + elseif ( typtab.eq.'s'.or.typtab.eq.'S') then + kaux = tchain + elseif ( typtab.eq.'r'.or.typtab.eq.'R') then + kaux = treel + endif + iaux = kaux*iaux + write (ulsort,texte(langue,7)) iaux +c + call gmmaxi( maxg , mtot , ntroug, ltroug ) +c + ilgmax = jgen + maxiut = ilgmax - minmeg +c + if ( modgm.le.1 ) then + if ( modgm.eq.0 ) then + write (ulsort,texte(langue,8)) ilgmax + else + write (ulsort,texte(langue,9)) ilgmax + endif + write (ulsort,texte(langue,10)) maxg + write (ulsort,texte(langue,11)) ntroug + write (ulsort,texte(langue,12)) mtot + if ( maxiut.ne.1 ) then + write (ulsort,texte(langue,13)) nommxg, maxiut + endif + if (ntroug.ne.0) then + write (ulsort,texte(langue,14)) + > (iaux,ptroug(iaux),ltroug(iaux),iaux=1,ntroug) + endif + else + write (ulsort,texte(langue,21)) + endif +c +c 3.2. ==> chaque region precedant un trou, sauf la derniere +c remarque : en dynamique, la notion de region n'existe pas. +c Il n'y a pas de trou. +c +c ideb = position de la fin du trou precedent +c = position du debut de la region +c ifin = position du debut du trou +c = position de la fin de la region +c iall = numero du premier tableau de la region +c kaux1 = numero du premier tableau de la region suivante +c + if ( gmimp.gt.2 ) then +c + nbrreg = 1 + ideb = ptrdeb + iall = 1 +c + do 32 , iaux = 1 , ntroug +c + ifin = ptroug(iaux) +c +c 3.2.1. ==> recherche du numero du premier tableau de la region +c suivante, eventuellement fictif si on arrive au bout +c + do 321, kaux = iall , nballg + if ( ptallg(kaux).gt.ifin ) then + kaux1 = kaux + go to 322 + endif + 321 continue +c + kaux1 = nballg + 1 +c + 322 continue +c +c 3.2.2. ==> impression des caracteristiques de la region, si elle +c n'est pas vide +c + if ( kaux1-1.ge.iall ) then +c + write (ulsort,texte(langue,15)) nbrreg, ideb, ifin-ideb + write (ulsort,1001) + write (ulsort,1002) saux14, saux14 + write (ulsort,1001) + do 323, kaux = iall , kaux1-1 + write (ulsort,1003) nomalg(kaux), lgallg(kaux), + > ptallg(kaux), adug(kaux) + 323 continue + write (ulsort,1001) + write (ulsort,*) ' ' +c + endif +c +c 3.2.3. ==> reactualisation des grandeurs pour la region suivante +c + iall = kaux1 + ideb = ifin + ltroug(iaux) + nbrreg = nbrreg + 1 +c + 32 continue +c +c 3.3. ==> on imprime la fin +c . l'integralite, s'il n'y a pas de trou +c . ce qui suit le dernier trou, s'il y en a +c + if ( iall.le.nballg ) then +c +c 3.3.1. ==> tri par valeur d'adresse croissante +c + kaux = 0 + do 331 , iaux = iall , nballg + do 3311 , jaux = 1 , kaux + if ( adug(tabaux(jaux)).gt.adug(iaux) ) then + kaux1 = jaux + goto 3312 + endif + 3311 continue + kaux1 = kaux + 1 + 3312 continue + do 3313 , jaux = kaux , kaux1 , -1 + tabaux(jaux+1) = tabaux(jaux) + 3313 continue + tabaux(kaux1) = iaux + kaux = kaux + 1 + 331 continue +c +c 3.3.2. ==> affichage +c + if ( modgm.le.1 ) then + write (ulsort,texte(langue,15)) nbrreg, ideb, + > ilgmax+ptrdeb-ideb + endif + write (ulsort,1001) + write (ulsort,1002) saux14, saux14 + write (ulsort,1001) + do 33, kaux = 1, kaux + kaux1 = tabaux(kaux) + write (ulsort,1003) nomalg(kaux1), lgallg(kaux1), + > ptallg(kaux1), adug(kaux1) + 33 continue + write (ulsort,1001) + write (ulsort,*) ' ' +c + endif +c + endif +c +c 3.4. ==> fin +c + write (ulsort,texte(langue,19)) blabla(langue,numtyp) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gmdmpi.F b/src/tool/Gestion_MTU/gmdmpi.F new file mode 100644 index 00000000..10e1dc11 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmpi.F @@ -0,0 +1,81 @@ + subroutine gmdmpi ( gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . derniere modif octo 93 gn programme generique +c . modif juin 93 jyb (ntroui=0) +c . modif 15/06/89 jc jyb +c ...................................................................... +c . +c . - interet: +c . impression detaillee du contenu du tableau de travail entier +c . ( caracteristiques des trous et des zones allouees) +c_______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . <=2 => impression simple . +c . . . . >2 => impression etendue . +c ______________________________________________________________________ +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "gmadui.h" +#include "gmtren.h" +#include "gmalen.h" +c +c 0.3. ==> arguments +c + integer gmimp +c +c 0.4. ==> variables locales +c + character*1 typtab +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c--- +c 2. appel du programme generique +c--- +c + iaux = imem(1) + typtab = 'i' + call gmdmpg ( minmei, ntroui, nballi, ptroui, ltroui, + > ptalli, lgalli, adui, nommxi, nomali, iaux, typtab, + > gmimp ) +c + end diff --git a/src/tool/Gestion_MTU/gmdmpr.F b/src/tool/Gestion_MTU/gmdmpr.F new file mode 100644 index 00000000..4f22d683 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmpr.F @@ -0,0 +1,81 @@ + subroutine gmdmpr ( gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c . derniere modif octo 93 gn programme generique +c . modif juin 93 jyb (ntrour=0) +c . 15/06/89 jc jyb +c ...................................................................... +c . +c . - interet: +c . impression detaillee du contenu du tableau de travail reel +c . ( caracteristiques des trous et des zones allouees) +c_______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . <=2 => impression simple . +c . . . . >2 => impression etendue . +c ______________________________________________________________________ +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmreel.h" +c +#include "gmadur.h" +#include "gmtrrl.h" +c +#include "gmalrl.h" +c +c 0.3. ==> arguments +c + integer gmimp +c +c 0.4. ==> variables locales +c + character*1 typtab +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c--- +c 2. appel du programme generique +c--- +c + iaux = int(rmem(1)) + typtab = 'r' + call gmdmpg ( minmer, ntrour, nballr, ptrour, ltrour, + > ptallr, lgallr, adur, nommxr, nomalr, iaux, typtab, + > gmimp ) +c + end diff --git a/src/tool/Gestion_MTU/gmdmps.F b/src/tool/Gestion_MTU/gmdmps.F new file mode 100644 index 00000000..c176b19d --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmps.F @@ -0,0 +1,81 @@ + subroutine gmdmps ( gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c . derniere modif octo 93 gn programme generique +c . creation juin 93 jyb +c ...................................................................... +c . +c . - interet: +c . impression detaillee du contenu du tableau de travail +c . character*8 +c . ( caracteristiques des trous et des zones allouees) +c_______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . <=2 => impression simple . +c . . . . >2 => impression etendue . +c ______________________________________________________________________ +c---- +c 0. declarations et dimensionnement +c---- +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +c +#include "gmadus.h" +#include "gmtrst.h" +#include "gmalst.h" +c +c 0.3. ==> arguments +c + integer gmimp +c +c 0.4. ==> variables locales +c + character*1 typtab +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c--- +c 2. appel du programme generique +c--- +c + read(smem(1),'(i8)') iaux + typtab = 's' + call gmdmpg ( minmes, ntrous, nballs, ptrous, ltrous, + > ptalls, lgalls, adus, nommxs, nomals, iaux, typtab, + > gmimp ) +c + end diff --git a/src/tool/Gestion_MTU/gmdmpt.F b/src/tool/Gestion_MTU/gmdmpt.F new file mode 100644 index 00000000..6b4f82b1 --- /dev/null +++ b/src/tool/Gestion_MTU/gmdmpt.F @@ -0,0 +1,200 @@ + subroutine gmdmpt ( choix, gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c sous programme d'impression de toutes les tables servant +c a la gestion des objets structures en memoire centrale +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ent . type d'impression . +c . . . . 1 : le dictionnaire des structures . +c . . . . 2 : les objets structures presents . +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . <=2 => impression simple . +c . . . . >2 => impression etendue . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtors.h" +#include "gmtoas.h" +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + integer choix + integer gmimp +c +c 0.4. ==> variables locales +c + character*8 nomf + integer i,j,ityp,ity,nba,iat,nbc,iad,k,l +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. les structures declarees +c==== +c + if ( gmimp.gt.0 ) then +c + if ( choix.eq.1 ) then +c + write(ulsort,*) ' ' + write(ulsort,*) ' ' + write(ulsort,*) ' ' + write(ulsort,*) ' * Impression des tables des objets structures *' + write(ulsort,*) ' ===============================================' + write(ulsort,*) ' ' + write(ulsort,*) ' Etat des tables des structures declarees ' + write(ulsort,*) ' ---------------------------------------- ' + write(ulsort,*) ' ' +c + 1 format(1x,i3,a,a8) + 2 format(4x,a,i8) + 3 format(4x,a,a8,' -> ',i8) + 4 format(4x,a,a8) +c + write(ulsort,*) ' Nombre de types de structure = ',nbrtyp + write(ulsort,*) ' ' + do 10 , i = 1,nbrtyp + write(ulsort,*) ' ' + write(ulsort,1) i,' -> nom du type = ',nomtyp(i) + write(ulsort,*) ' ' + write(ulsort,2) ' nombre de attri = ',nbratt(i) + write(ulsort,2) ' nombre de champ = ',nbcham(i) + write(ulsort,2) ' adresse de champ = ',adrdst(i) + write(ulsort,*) ' ' + if ( gmimp.gt.2 ) then + do 11 , j = adrdst(i),adrdst(i)+nbcham(i)-1 + write(ulsort,3) ' -> -> nom de champ = ',nomcha(j) + ityp = typcha(j) + if ( ityp.gt.0) then + nomf = nomtyp(ityp) + else if (ityp.eq.-1) then + nomf = nomtyb(1) + else if (ityp.eq.-2) then + nomf = nomtyb(2) + else if (ityp.eq.-3) then + nomf = nomtyb(3) + endif + write(ulsort,3) ' type de champ = ',nomf,ityp + write(ulsort,*) ' ' + 11 continue + endif + write(ulsort,*) ' ' + 10 continue + write(ulsort,*) ' -----------------------------------------------' +c + endif +c + endif +c +c==== +c 2. les objets structures presents +c==== +c + if ( gmimp.gt.0 ) then +c + if ( choix.eq.2 ) then +c + write(ulsort,*) ' ' + write(ulsort,*) ' ' + write(ulsort,*) ' Etat des tables des objets structures - VTOC-MC' + write(ulsort,*) ' -----------------------------------------------' + write(ulsort,*) ' ' +c + write(ulsort,*) ' Nombre objets structures presents : ',iptobj-1 + write(ulsort,*) ' ' + do 20 , i = 1,iptobj-1 + write(ulsort,*) ' ' + write(ulsort,1) i,' -> nom objet = ',nomobj(i) + write(ulsort,*) ' ' + ity = typobj(i) + nba = nbratt(ity) + iat = adrdsa(i) + nbc = nbcham(ity) + iad = adrdso(i) + write(ulsort,3) ' typ objet = ',nomtyp(ity),ity + write(ulsort,*) ' ' + write(ulsort,2) ' nbr-attri = ',nba + if ( gmimp.gt.2 ) then + write(ulsort,2) ' adr attri = ',iat + write(ulsort,*) ' ' + do 21 , j = 1,nba + k = iat+j-1 + write(ulsort,2) ' -> -> numero-attr = ',j + write(ulsort,2) ' valeur-attr = ',valatt(k) + write(ulsort,*) ' ' + 21 continue + endif + write(ulsort,2) ' nbr-champ = ',nbc + if ( gmimp.gt.2 ) then + write(ulsort,2) ' adr objet = ',iad + write(ulsort,*) ' ' + do 22 , j = 1,nbc + k = iad+j-1 + l = adrdst(ity)+j-1 + ityp = typcha(l) + if ( ityp.gt.0) then + nomf = nomtyp(ityp) + else if (ityp.eq.-1) then + nomf = nomtyb(1) + else if (ityp.eq.-2) then + nomf = nomtyb(2) + else if (ityp.eq.-3) then + nomf = nomtyb(3) + endif + write(ulsort,4) ' -> -> objet-champ = ',nomobc(k) + write(ulsort,4) ' nom -champ = ',nomcha(l) + write(ulsort,3) ' type -champ = ',nomf,ityp + write(ulsort,*) ' ' + 22 continue + endif + 20 continue +c + write(ulsort,*) ' ' + write(ulsort,*) ' pointeur -> iptchp = ',iptchp + write(ulsort,*) ' ' + write(ulsort,*) ' ' + write(ulsort,*) ' ===============================================' +c + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmdtoj.F b/src/tool/Gestion_MTU/gmdtoj.F new file mode 100644 index 00000000..f26c8a2d --- /dev/null +++ b/src/tool/Gestion_MTU/gmdtoj.F @@ -0,0 +1,146 @@ + subroutine gmdtoj ( nom, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c detacher l'objet terminal d'un nom etendu "nom" de son +c support (sans suppression de cet objet) +c ........................................................... +c +c entrees : +c nom : character*(*) : nom etendu +c +c sorties : codret : code de retour : +c -5 : erreur : champ introuvable dans les tables +c -4 : erreur : support introuvable dans les tables +c -3 : erreur : nom etendu invalide +c -2 : erreur : objet-terminal non defini +c -1 : erreur : nom a un seul element +c 0 : OK +c ........................................................... +c +c 0. declarations et dimensionnement +c +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMDTOJ' ) +c +#include "genbla.h" +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) nom +c + integer codret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + integer idec + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. decodage du nom etendu +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. decodage du nom etendu ; coergm = ', coergm +#endif +c +c 2.1. ==> decodage du nom etendu +c + call gbdnoe(nom,objrep,objter,chater,idec) +c +c 2.2. ==> nom etendu invalide +c + if (idec.lt.0) then +c + codret = -3 +c +c 2.3. ==> objet-terminal non defini +c + else if (idec.eq.1) then +c + codret = -2 +c +c 2.4. ==> nom etendu a un seul element +c + else if (idec.eq.0) then +c + codret = -1 +c + else +c + codret = 0 +c + endif +c +c==== +c 3. appel du programme generique +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. programme generique ; codret = ', codret + write (ulsort,*) '3. programme generique ; coergm = ', coergm +#endif +c + if ( codret.eq.0 ) then +c + call gbdtoj ( objrep, objter ) + codret = coergm +c + endif +c +c==== +c 4. Fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmecat.F b/src/tool/Gestion_MTU/gmecat.F new file mode 100644 index 00000000..174b04d9 --- /dev/null +++ b/src/tool/Gestion_MTU/gmecat.F @@ -0,0 +1,130 @@ + subroutine gmecat (nom,numero,valeur,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c attribuer une valeur entiere a l'attribut numero 'numero' +c de l'objet-terminal du nom etendu "nom" +c ........................................................... +c +c entrees : +c +c nom : character*(*) : nom etendu +c numero : integer : numero de l'attribut +c valeur : integer : valeur a attribuer +c +c ........................................................... +c +c sorties : +c codret : code de retour : +c -5 : erreur : nom etendu invalide +c -4 : erreur : objet-terminal pas defini +c -3 : erreur : objet-terminal defini mais pas alloue +c -2 : erreur : objet-terminal n'est pas structure +c -1 : erreur : numero < 1 ou +c : numero > nombre d'attributs de objet-terminal +c 0 : OK +c +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtoas.h" +c +c 0.3. ==> arguments +c + character*(*) nom + integer numero,valeur,codret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + integer idec,iob,ity,nba,iat,nroobj +c +c 1. decodage du nom etendu +c + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + codret = -5 +c + else if (idec.eq.1) then +c +c objet-terminal non defini +c + codret = -4 +c + else if (idec.eq.2) then +c +c objet-terminal defini mais non alloue +c + codret = -3 +c + else +c +c objet-terminal est defini et eventuellement alloue +c + do 10 , iob = 1,iptobj-1 + if (nomobj(iob).eq.objter) then + nroobj = iob + codret = 0 + goto 20 + endif + 10 continue +c + codret = -2 +c + endif +c +c==== +c 2. objet structure : ecriture de l'attribut +c==== +c + 20 continue +c + if ( codret.eq.0 ) then +c + ity = typobj(nroobj) + nba = nbratt(ity) + codret = -1 + if ( numero.le.nba.and.numero.gt.0 ) then + codret = 0 + iat = adrdsa(nroobj)+numero-1 + valatt(iat) = valeur + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmecpr.F b/src/tool/Gestion_MTU/gmecpr.F new file mode 100644 index 00000000..679a0a14 --- /dev/null +++ b/src/tool/Gestion_MTU/gmecpr.F @@ -0,0 +1,215 @@ + subroutine gmecpr ( nuroul, numann ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestionnaire de la Memoire : ECriture du PRogramme +c - - -- -- +c ______________________________________________________________________ +c +c ecrit un programme qui realise l'initialisation des tables +c de description des types d'objet structure. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numann . e . 1 . numero de l'annee . +c . nuroul . e . 1 . numero de l'unite logique ou on ecrit . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1 ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMECPR' ) +c +#include "genbla.h" +c +#include "gmmatc.h" +c +#include "nuvers.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtors.h" +#include "gmtove.h" +c +#ifdef _DEBUG_HOMARD_ +#include "gmimpr.h" +#include "gmlang.h" +#endif +c +c 0.3. ==> arguments +c + integer nuroul + integer numann +c + character*48 ladate +c +c 0.4. ==> variables locales +c +#include "gmnelx.h" +c + integer iaux, jaux, jdeb, jfin +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. ecriture du fichier +c==== +c +c 2.1. ==> en-tete +c + write (nuroul,21001) nuvers + write (nuroul,21002) numann + write (nuroul,21003) + write (nuroul,21004) +c +21001 format ( + > ' subroutine gmitob', + >/,'c ',70('_'), + >/,'c', + >/,'c',25x,'H O M A R D ',a8, + >/,'c') +c +21002 format ( + > 'c Outil de Maillage Adaptatif par Raffinement', + > ' et Deraffinement d''EDF R&D', + >/,'c', + >/,'c Version originale enregistree le 18 juin 1996', + > ' sous le numero 96036', + >/,'c aupres des huissiers de justice Simart et Lavoir a Clamart', + >/,'c Version 11.2 enregistree le 13 fevrier 2015', + > ' sous le numero 2015/014', + >/,'c aupres des huissiers de justice', + >/,'c Lavoir, Silinski & Cherqui-Abrahmi a Clamart', + >/,'c', + >/,'c', + >/,'c Copyright EDF 1996, ',i4, + >/,'c ',70('_'), + >/,'c') +21003 format ( + > 'c Gestionnaire de la Memoire :', + >/,'c - -', + >/,'c Initialisation des Tables d''OBjets', + >/,'c - - --', + >/,'c', + >/,' save', + >/,'c') +c +21004 format ( + > '#include "gmmatc.h"', + >/,'c', + >/,'#include "gmtoas.h"', + >/,'#include "gmtori.h"', + >/,'#include "gmtors.h"', + >/,'#include "gmtove.h"', + >/,'c', + >/,' integer iaux', + >/,'c') +c +c 2.2. ==> numeros de version +c + write (nuroul,22001) nuveto, nusvto, daheto, nuanto +c +22001 format ( + > 'c numeros de version des tables d''objets', + >/,'c', + >/,' nuveto = ',i12, + >/,' nusvto = ',i12, + >/,' daheto = ',i12, + >/,' nuanto = ',i12, + >/,'c') +c +c 2.3. ==> tables +c + write (nuroul,23001) nbrtyp + do 23 , iaux = 1 , nbrtyp + write (nuroul,23002) iaux, nomtyp(iaux), + > iaux, nbratt(iaux), + > iaux, nbcham(iaux), + > iaux, adrdst(iaux) + jdeb = adrdst(iaux) + jfin = jdeb + nbcham(iaux) - 1 + do 231 , jaux = jdeb , jfin + write (nuroul,23003) jaux, nomcha(jaux), + > jaux, typcha(jaux) + 231 continue + 23 continue +c +23001 format ( + > 'c objets structures', + >/,'c', + >/,' nbrtyp = ',i12) +23002 format ( + > 'c', + >/,'c--------------------------------------------------', + >/,'c', + >/,' nomtyp(',i10,') = ''',a8,'''', + >/,' nbratt(',i10,') = ',i12, + >/,' nbcham(',i10,') = ',i12, + >/,' adrdst(',i10,') = ',i12, + >/,'c') +23003 format ( + > ' nomcha(',i10,') = ''',a8,'''', + >/,' typcha(',i10,') = ',i12) +c +c 2.4. ==> transfert +c + write (nuroul,24001) +c +24001 format ( + > 'c', + >/,' do 24 , iaux = 1 , nbrtyp', + >/,' nomtbp(iaux) = nomtyp(iaux)', + >/,' 24 continue', + >/,'c') +c +c 2.5. ==> la fin +c + write (nuroul,25001) +c +25001 format ( + > ' end') +c + end diff --git a/src/tool/Gestion_MTU/gmextg.F b/src/tool/Gestion_MTU/gmextg.F new file mode 100644 index 00000000..c105912d --- /dev/null +++ b/src/tool/Gestion_MTU/gmextg.F @@ -0,0 +1,341 @@ + subroutine gmextg( nomtab, adunew, lgnew, aduold, lgold, typtab, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg, adug, + > nommxg, nomalg, satien, tablte ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 09/93 +c ...................................................................... +c . +c . - interet: +c . programme generique d'extension d'un tableau +c . +c . - realisation: +c . tentative d'extension a l'extremite du tableau. +c . sinon reallocation recopie des donnees, +c . suppression de l'original, reaffectation du nom original +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a etendre (8 caracteres au plus) +c . lgnew --> nombre de valeurs demandees +c . typtab --> type du tableau :r,i,s,d, ou c +c .modifies minmeg <--> valeur entiere memorisant la plus petite +c . dimension du dernier trou afin de connaitre +c . le passage le plus delicat rencontre au cours +c . de l'allocation. cette valeur est calculee +c . apres compression (pour statistiques) +c . ntroug <--> valeur entiere . nombre de trous presents +c . nballg <--> nombre de tableaux deja alloues +c . totalg <--> valeur entiere cumulant les demandes +c . successives de memoire +c . ptroug <--> tableau entier contenant les pointeurs +c . repertoriant la position des trous +c . ltroug <--> tableau entier contenant la longueur des trous +c . ptallg <--> tableau entier contenant les pointeurs +c . repertoriant la position des tableaux +c . adug <--> adresse utile des tableaux ( telles que +c . revenant de gbcara ) +c . lgallg <--> tableau entier contenant la longueur des +c . tableaux +c . nommxg <--> chaine de caractere(*8) contenant le nom du +c . plus grand tableau associe a minmeg +c . nomalg <--> tableau de chaines de caracteres contenant +c . le nom associe a chaque tableau deja alloue +c .resultat adunew <-- pointeur associe apres extension +c . aduold <-- pointeur avant extension +c . lgold <-- nombre de valeurs avant extension +c . satien <-- vrai si le complement tient apres le tableau, +c . faux s'il a fallu le recreer plus loin +c . tablte --> nom du tableau temporaire si creation +c . +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtyge.h" +c +#include "gmimpr.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*8 nomtab + character*1 typtab + character*8 nommxg, nomalg(maxtab) + integer adug(maxtab) +c + integer adunew, lgnew, aduold, lgold + integer minmeg, ntroug, nballg, totalg + integer ptroug(maxtrs) , ltroug(maxtrs) + integer ptallg(maxtab) , lgallg(maxtab) +c + logical satien +c + character*8 tablte +c +c 0.4. ==> variables locales +c + character*8 nomvar + character*8 tycara +c + integer i + integer icptg, iold, indtrg, iptold + integer lcara + integer nrotab + integer nbcain +c + character*6 nompra + character*6 nompro + parameter ( nompro = 'GMEXTG' ) +c + character*1 carint(1) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c ---- +c 2. preliminaires +c---- +c + if ( typtab.eq.'r' .or. typtab.eq.'R' ) then + nompra = 'GMMODR' + elseif ( typtab.eq.'i' .or. typtab.eq.'I' ) then + nompra = 'GMMODI' +c +c ATTENTION : 'd' ou 'D' veut dire simple precision +c + elseif ( typtab.eq.'d' .or. typtab.eq.'D' ) then + nompra = 'GMMODD' + elseif ( typtab.eq.'s' .or. typtab.eq.'S' ) then + nompra = 'GMMODS' + elseif ( typtab.eq.'c' .or. typtab.eq.'C' ) then + nompra = 'GMMODC' + else + write(ulsort,20000) typtab + call ugstop( nompro,ulsort,1,1,1) + endif +c +20000 format (//2x,' ****** spg GMEXTG *****', + > /2x,'Le type ',a1,' est inconnu.', + > /2x,'Il faut r, i, d, s ou c', + > /2x,' ===> arret dans le gestionnaire de memoire') +c +c==== +c 3. verifications +c==== +c +c 3.1. ==> nature du nom +c aucun caractere n'est interdit, mais on met un blanc +c dans le tableau pour ne plus avoir de messages ftnchek +c + nbcain = 0 + carint(1) = ' ' + call gmntve ( nomtab, nomvar, nbcain, carint, coergm ) +c + if ( coergm.ne.0 ) then + write(ulsort,30001) nompra +30001 format ( 2x,'Probleme a l''appel au spg GMEXTG via ',a6, + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,0,1,1) + endif +c +c--- impossible d'avoir une longueur < 0 +c + if (lgnew.lt.0) then + write(ulsort,30002) nompra, nomvar, lgnew +30002 format ( 2x,'Mauvais appel au spg GMEXTG via ',a6, + > /,4x,' pour le tableau ',a8, + > /,4x,'Nombre de valeurs requises negatif ( ',i10,')' , + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + endif +c +c--- verif que le nom n'est utilise qu'une fois est une seule +c + icptg = 0 + do 33 i = 1 , nballg + if ( nomalg(i).eq.nomvar ) then + iold = i + icptg = icptg + 1 + endif + 33 continue +c + if (icptg.eq.0) then + write(ulsort,30003) nompra, nomvar +30003 format ( 2x,'Probleme a l''appel au spg GMEXTG via ',a6, + > /,4x,'Le tableau (',a8,') n''a pas ete alloue', + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + else if (icptg.gt.1) then + write(ulsort,30013) nompra, nomvar +30013 format ( 2x,'Probleme a l''appel au spg GMEXTG via ',a6, + > /,4x,'Le tableau (',a8,') a ete alloue plusieurs fois' , + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + endif +c +c---- verif que la nouvelle taille est superieure a l'ancienne +c mais si la nouvelle taille est egale a l'ancienne on renvoie +c le pointeur +c + iptold = ptallg(iold) + lgold = lgallg(iold) +c + call gbcara(nomtab, nrotab,aduold, lcara , tycara ) + if ( coergm.ne.0 ) then + goto 999 + endif +c + if (lgnew.lt.lgold) then + write(ulsort,30004) nompra, lgnew,lgold +30004 format ( 2x,'Probleme a l''appel au spg GMEXTG via ',a6, + > /,4x,'La taille demandee ',i10, + > /,4x,'est inferieure a l''ancienne ',i10, + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,1,1,1) + else if (lgnew.eq.lgold) then + adunew = aduold + satien = .true. + goto 999 + endif + if ( modgm.eq.2 ) then + satien = .false. + call gbntcr ( tablte ) + call gmalog ( tablte, adunew, lgnew, typtab, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg, adug, + > nommxg, nomalg ) + goto 999 + endif +c +c---- s'il n'y a plus de trou : erreur +c + if (ntroug.le.0) then + write(ulsort,30005) nompra +30005 format ( 2x,'Probleme a l''appel au spg GMEXTG via ',a6, + > /,4x,'Il n''y a plus de place') + call ugstop( nompro,ulsort,1,1,1) + endif +c +c---- +c 4. extension proprement dite +c---- +c +c---- on recherche le premier trou qui suit le tableau actuel +c + do 41 i = 1 , ntroug + if ( iptold+lgold .le. ptroug(i) ) then + indtrg = i + goto 42 + endif + 41 continue +c + indtrg = 0 +c + 42 continue +c +c---- une fois le trou suivant connu, deux cas sont a envisager : +c . soit ce trou suivant commence juste apres le tableau actuel ; +c il faut alors savoir si le complement au tableau peut tenir +c dans ce trou. +c . soit ce trou commence plus loin. +c + if ( indtrg.ne.0 .and. iptold+lgold.eq.ptroug(indtrg) ) then + if ( ltroug(indtrg).gt.lgnew-lgold ) then + satien = .true. + else + satien = .false. + endif + else + satien = .false. + endif +c +c---- si le trou peut contenir le complement au tableau, il y a deux cas +c . soit le tableau ne le remplit pas completement ; +c le trou est raccourci. +c . soit il le remplit exactement ; dans ce cas, il faut faire +c disparaitre ce trou vide (= de longueur nulle). +c + if ( satien ) then +c + adunew = aduold + lgallg(iold) = lgnew +c + if (ltroug(indtrg).gt.lgnew-lgold) then +c + ptroug(indtrg) = iptold + lgnew + ltroug(indtrg) = ltroug(indtrg) - (lgnew-lgold) +c +c si c'est ajoute dans le dernier trou, il faut modifier les stats: +c + if ( indtrg.eq.ntroug .and. minmeg.gt.ltroug(ntroug) ) then + nommxg = nomvar + minmeg = ltroug(ntroug) + endif +c + else +c + if ( indtrg.eq.ntroug ) then + if ( minmeg.gt.0 ) then + nommxg = nomvar + endif + minmeg = 0 + endif +c + ntroug = ntroug - 1 + do 43 i = indtrg, ntroug + ptroug(i) = ptroug(i+1) + ltroug(i) = ltroug(i+1) + 43 continue +c + endif +c + totalg = totalg + (lgnew-lgold) +c + else +c +c le trou ne peut pas contenir le tableau, +c ou bien le tableau n'est pas suivi d'un trou. +c on alloue un nouveau tableau avec un nom barbare provisoire +c + call gbntcr ( tablte ) +c + call gmalog ( tablte, adunew, lgnew, typtab, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg, adug, + > nommxg, nomalg ) +c + endif +c + 999 continue +c + end diff --git a/src/tool/Gestion_MTU/gmfmat.h b/src/tool/Gestion_MTU/gmfmat.h new file mode 100644 index 00000000..058ff51d --- /dev/null +++ b/src/tool/Gestion_MTU/gmfmat.h @@ -0,0 +1,15 @@ +c copyright edf 1999 +c +c valeurs des formats pour les fichiers en ascii +c + character*20 fmts, fmti, fmtr, fmtc, fmtd +c + parameter ( fmts = '( 8 (1x, a8) ) ' ) +c + parameter ( fmti = '( 8 (1x, i15) ) ' ) +c + parameter ( fmtr = '( 4 (1x, g23.16) ) ' ) +c + parameter ( fmtc = '( 4 (1x, g23.16) ) ' ) +c + parameter ( fmtd = '( 2 (1x, g39.32) ) ' ) diff --git a/src/tool/Gestion_MTU/gmgmve.h b/src/tool/Gestion_MTU/gmgmve.h new file mode 100644 index 00000000..11b36133 --- /dev/null +++ b/src/tool/Gestion_MTU/gmgmve.h @@ -0,0 +1,6 @@ +c +c nuvegm : numero de version des programmes de gm +c nusvgm : numero de sous-version des programmes de gm +c + integer nuvegm, nusvgm + parameter ( nuvegm = 1 , nusvgm = 0 ) diff --git a/src/tool/Gestion_MTU/gmimpr.h b/src/tool/Gestion_MTU/gmimpr.h new file mode 100644 index 00000000..47da5ca8 --- /dev/null +++ b/src/tool/Gestion_MTU/gmimpr.h @@ -0,0 +1,5 @@ +c +c ulsort : unite logique des messsages du gestionnaire de memoire +c + integer ulsort + common /gmimpr/ ulsort diff --git a/src/tool/Gestion_MTU/gmindf.h b/src/tool/Gestion_MTU/gmindf.h new file mode 100644 index 00000000..44b012fd --- /dev/null +++ b/src/tool/Gestion_MTU/gmindf.h @@ -0,0 +1,5 @@ +c +c lindef : indicateur pour savoir si on initialise ou non les tableaux +c + integer lindef + common /gmindf/ lindef diff --git a/src/tool/Gestion_MTU/gmindi.h b/src/tool/Gestion_MTU/gmindi.h new file mode 100644 index 00000000..55c04346 --- /dev/null +++ b/src/tool/Gestion_MTU/gmindi.h @@ -0,0 +1,5 @@ +c +c iindef : valeur non definie pour les entiers +c + integer iindef + common /gmindi/ iindef diff --git a/src/tool/Gestion_MTU/gmindr.h b/src/tool/Gestion_MTU/gmindr.h new file mode 100644 index 00000000..0e7d48d5 --- /dev/null +++ b/src/tool/Gestion_MTU/gmindr.h @@ -0,0 +1,5 @@ +c +c rindef : valeur non definie pour les reels double precision +c + double precision rindef + common /gmindr/ rindef diff --git a/src/tool/Gestion_MTU/gminds.h b/src/tool/Gestion_MTU/gminds.h new file mode 100644 index 00000000..a5c4266f --- /dev/null +++ b/src/tool/Gestion_MTU/gminds.h @@ -0,0 +1,5 @@ +c +c sindef : valeur non definie pour les caracteres +c + character*8 sindef + common /gminds/ sindef diff --git a/src/tool/Gestion_MTU/gminfo.F b/src/tool/Gestion_MTU/gminfo.F new file mode 100644 index 00000000..be996b22 --- /dev/null +++ b/src/tool/Gestion_MTU/gminfo.F @@ -0,0 +1,110 @@ + subroutine gminfo ( imprg0 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion des mesures de Temps : INFOrmations' +c - - ---- +c ______________________________________________________________________ +c +c but : modifie la consigne d'impression des messages du gestionnaire +c de memoire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . imprg0 . e . 1 . pilotage des impressions . +c . . . . 1 : le standard . +c . . . . 5 : le bilan . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMINFO' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#ifdef _DEBUG_HOMARD_ +#include "gmimpr.h" +#include "gmlang.h" +#endif +#include "gmopim.h" +c +c 0.3. ==> arguments +c + integer imprg0 +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Dans '',a,'', imprgm ='',i8)' +c + texte(2,4) = '(''In '',a,'', imprgm ='',i8)' +c +c==== +c 2. archivage +c==== +c + if ( mod(imprg0,5).eq.0 ) then + imprgm = 5 + else + imprgm = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nompro, imprgm +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gminge.F b/src/tool/Gestion_MTU/gminge.F new file mode 100644 index 00000000..5cb495ae --- /dev/null +++ b/src/tool/Gestion_MTU/gminge.F @@ -0,0 +1,614 @@ + subroutine gminge ( ulmess, langdf, nfconf, lfconf ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestion de la Memoire : INitialiation de la GEstion +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulmess . e . 1 . unite logique des messages . +c . langdf . e . 1 . langue des messages par defaut . +c . . . . 1 : francais . +c . . . . 2 : anglais . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c ______________________________________________________________________ +c +c . - interet: +c . initialisation de la gestion de la memoire des tableaux +c . entiers, reels et character*8. +c . +c ...................................................................... +c . +c . - description des commons - +c . la structure des communs est identique pour les reels, les +c . entiers et les character*8. +c . seul l'intitule rappele le type : +c . reel ( "r") entier ("i") character*8 ("s") +c . +c . commun gmreel +c . rmem : tableau de travail reel dans lequel seront gerees les +c . allocations. +c . commun gmenti +c . imem : tableau de travail entier dans lequel seront gerees les +c . allocations. +c . commun gmstri +c . smem : tableau de travail character*8 dans lequel seront gerees +c . les allocations. +c . +c . commun gmtrrl +c . minmer: valeur entiere memorisant la plus petite dimension +c . du dernier trou afin de connaitre le passage le plus +c . delicat rencontre au cours de l'allocation. cette valeur +c . est calculee apres compression (voir minler) +c . ntrour: valeur entiere . nombre de trous present dans le tableau +c . reel +c . ptrour: tableau entier contenant les pointeurs repertoriant la +c . position des trous. +c . ltrour: tableau entier contenant la longueur des differents trous +c . nballr: valeur entiere contenant le nombre de tableaux deja alloue +c . ptallr: tableau entier contenant les pointeurs repertoriant la +c . position des tableaux deja alloues +c . lgallr: tableau entier contenant la longueur des differents +c tableaux deja alloues +c . totalr: valeur entiere cumulant les demandes successives de +c . memoire pour les tableaux reels +c . minler: valeur entiere memorisant la plus petite dimension +c . du dernier trou. en cas de compression cette valeur +c . qui sera en general differente de celle de minmer +c . permettra de connaitre la plus petite taille atteinte +c . par le dernier trou et donc la taille maximum que peut +c . atteindre le common (voir gmfin) +c . +c . commun gmtren +c . structure rigoureusement identique a celle de gmtrrl, sa fonction +c . etant de gerer les trous et les tableaux presents dans le tableau +c . entier. ses elements se terminent par un "i" au lieu d'un "r". +c . +c . commun gmtrst +c . structure rigoureusement identique a celle de gmtrrl, sa fonction +c . etant de gerer les trous et les tableaux presents dans le tableau +c . character*8. ses elements se terminent par un "s" au lieu d'un "r" +c . +c . commun gmalrl +c . nommxr: chaine de caractere(*8) contenant le nom du plus grand +c . tableau associe a minmer +c . nomalr: tableau de chaines de caracteres contenant le nom associe +c . a chaque tableau deja alloue. +c . +c . commun gmalen +c . structure rigoureusement identique a celle de gmalrl, sa fonction +c . etant de gerer les chaines de caracteres associees au tableau +c . entier. ses elements se terminent par un "i" au lieu d'un "r". +c . +c . commun gmalst +c . structure rigoureusement identique a celle de gmalrl, sa fonction +c . etant de gerer les chaines de caracteres associees au tableau +c . character*8. ses elements se terminent par un "s" au lieu d'un "r" +c . +c . commun gmindf +c . memorise un indicateur d'utilisation : 0 on initialise, +c . 1 on n'initialise pas +c . +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMINGE' ) +c +#include "genbla.h" +#include "gelggt.h" +c +#include "gmgmve.h" +c +#include "gmmaxt.h" +#include "gmptrd.h" +#include "gmmatc.h" +#include "gmlgen.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +#include "gmtyge.h" +#include "gmtyar.h" +#include "gmindf.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +#include "gmopim.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmalrl.h" +#include "gmalen.h" +#include "gmalst.h" +c +#include "gmadui.h" +#include "gmadur.h" +#include "gmadus.h" +c +#include "gmindi.h" +#include "gmindr.h" +#include "gminds.h" +c +#include "gmtenb.h" +#include "gmteno.h" +c +c 0.3. ==> arguments +c + character *(*) nfconf +c + integer ulmess, langdf, lfconf +c +c 0.4. ==> variables locales +c +#include "gedita.h" +c + integer iaux, code +c + integer ad0, ad1, ntrou0, i + integer nenti, nreel, nch08 + integer guimp, gmimp, raison + integer codret +c + character *200 nfdico +c + integer lfdico, nfois +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +#include "motcle.h" +c +c 0.5. ==> initialisations +c + data nfois / 1 / +c ______________________________________________________________________ +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + if ( langdf.ge.1 .and. langdf.le.nblang ) then + langue = langdf + else + langue = 1 + endif + write (ulmess,texte(langue,1)) 'Entree', nompro +#endif +c + texte(1,4) = '(/,''La gestion de la memoire est statique.'')' + texte(1,5) = + > '(/,''La gestion de la memoire est semi-dynamique.'')' + texte(1,6) = '(/,''La gestion de la memoire est dynamique.'')' + texte(1,7) = '(/,a12,/,''... Adresse du commun : '',i19)' + texte(1,8) = '(''... Adresse de la memoire : '',i15)' + texte(1,9) = '(''... Place reservee : '',i15)' + texte(1,10) = '(/,''Programmes du gestionnaire de memoire :'')' + texte(1,11) = + > '(''. Version : '',i11,/,''. Sous-version : '',i6)' +c + texte(2,4) = '(/,''A static memory management is used.'')' + texte(2,5) = + > '(/,''A semi-dynamic memory management is used.'')' + texte(2,6) = '(/,''A dynamic memory management is used.'')' + texte(2,7) = '(/,a12,/,''... Common address : '',i19)' + texte(2,8) = '(''... Memory address : '',i15)' + texte(2,9) = '(''... Reserved space : '',i15)' + texte(2,10) = '(/,''Programms of memory manager :'')' + texte(2,11) = '(''. Version : '',i11,/,''. Release : '',i6)' +c +c==== +c 1. mise en place +c==== +cgn write (*,*) 'nfois = ', nfois +c +c 1.1. ==> On commence par arreter brutalement s'il y a une erreur +c avant la connaissance de l'option retenue +c + typarr = 0 +c + if ( nfois.le.1 ) then + nfois = nfois + 1 +c +c pour les cas ou tout se passe mal, on initialise +c pour entrer dans ugstop dans des conditions moins catastrophiques: +c + modgm = 1 + ntroui = 0 + nballi = 0 + totali = 0 + imem(1) = 0 + ntrour = 0 + nballr = 0 + totalr = 0 + rmem(1) = 0.0d0 + ntrous = 0 + nballs = 0 + totals = 0 + write(smem(1),'(i8)') 0 + endif +c +c 1.2. ==> initialisation du numero d'unite logique associee aux +c messages du gestionnaire de memoire et de la langue associee +c par defaut +c + call gmmess (ulmess) +c + call gmlanm (langdf) +c +c 1.3. ==> initialisation de l'option supplementaire d'impression : +c rien par defaut +c + imprgm = 1 +c +c 1.4. ==> recuperation du nom du fichier qui contient le +c dictionnaire des objets structures +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'UGFINO', nompro +#endif + call ugfino ( mcdico, nfdico, lfdico, + > nfconf, lfconf, + > ulsort , langdf, coergm ) +c + if ( coergm.ne.0 .and. lfdico.gt.0 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop( nompro, ulsort, guimp, gmimp, raison) + endif +c +c 1.5. ==> mode de gestion de la memoire +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'GMMOGE', nompro +#endif +c + call gmmoge ( modgm, typarr, + > nenti, nreel, nch08, + > nfconf, lfconf, + > coergm ) +c + if ( coergm.ne.0 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop( nompro, ulsort, guimp, gmimp, raison) + endif +c +c 1.6. ==> initialisations et memorisation +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'DMSIZE', nompro +#endif + call dmsize(tentie,treel,tchain) +c + if (modgm.eq.2) then + ntrou0 = 0 + do 16 , i = 1 , 8 + admem(i) = 0 + 16 continue + else + ntrou0 = 1 + endif +c +c==== +c 2. valeurs non definies +c==== +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'DMINDF', nompro +#endif + call dmindf ( iindef, rindef, sindef ) +c + lindef = 0 +c +c==== +c 3. initialisations globales +c==== +c +c 3.1. ==> aucun tableau n'est encore alloue +c + do 31 , iaux = 1 , maxtab +c + nomali(iaux) = sindef + ptalli(iaux) = iindef + lgalli(iaux) = iindef + adui(iaux) = iindef +c + nomalr(iaux) = sindef + ptallr(iaux) = iindef + lgallr(iaux) = iindef + adur(iaux) = iindef +c + nomals(iaux) = sindef + ptalls(iaux) = iindef + lgalls(iaux) = iindef + adus(iaux) = iindef +c + 31 continue +c +c 3.2. ==> aucun trou n'est encore present +c + do 32 , iaux = 1 , maxtrs +c + ptroui(iaux) = iindef + ltroui(iaux) = iindef +c + ptrour(iaux) = iindef + ltrour(iaux) = iindef +c + ptrous(iaux) = iindef + ltrous(iaux) = iindef +c + 32 continue +c +c 3.3. ==> initialisation du nombre de tableaux temporaires alloues +c + mxtbtp = 0 +c +c NB: il y a 3 types possibles d'objets simples, et maxtab objets +c simples au maximum dans chaque type. Par ailleurs, il y a +c au maximum nobjx objets structures. +c + do 33 iaux = 1 , (3*maxtab) + nobjx + numete(iaux) = 0 + nomalt(iaux) = sindef + 33 continue +c +c==== +c 4. initialisation associee aux grandeurs entieres +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Etape 4 ; entier' +#endif +c + call dmloci (imem,ad0) +c + if ( modgm.eq.0) then + ad1 = ad0 + coergm = 0 + iaux = nenti - ptrdeb + 1 + elseif ( modgm.eq.1) then + call gbalme('i',nenti+ptrdeb,ad1) + iaux = nenti + else + ad1 = 0 + coergm = 0 + iaux = nenti - ptrdeb + 1 + endif +c + if ( coergm.ne.0) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) + write (ulsort,*) ' allocation de ',nenti,' entiers' + write (ulsort,*) ' impossible ' + call ugstop( nompro,ulsort,1,1,1) + endif +c + adcom(1) = ad0 + admem(1) = ad1 +CGN imem(0) = iindef + imem(1) = nenti + ntroui = ntrou0 + ptroui(1) = ptrdeb + ltroui(1) = iaux +c + minmei = ltroui(1) + minlei = ltroui(1) + nommxi = ' ' + nballi = 0 + totali = nenti - iaux +c +c==== +c 5. initialisation des grandeurs reelles +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Etape 5 ; reel' +#endif +c + call dmlocr (rmem,ad0) +c + if ( modgm.eq.0) then + ad1 = ad0 + coergm = 0 + iaux = nreel - ptrdeb + 1 + elseif ( modgm.eq.1) then + call gbalme('r',nreel+ptrdeb,ad1) + iaux = nreel + else + ad1 = 0 + coergm = 0 + iaux = nreel - ptrdeb + 1 + endif +c + if ( coergm.ne.0) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,*) ' allocation de ',nreel,' reels' + write (ulsort,*) ' impossible ' + call ugstop( nompro,ulsort,1,1,1) + endif +c + adcom(2) = ad0 + admem(2) = ad1 +CGN rmem(0) = rindef + rmem(1) = dble(nreel) + ntrour = ntrou0 + ptrour(1) = ptrdeb + ltrour(1) = iaux +c + minmer = ltrour(1) + minler = ltrour(1) + nommxr = ' ' + nballr = 0 + totalr = nreel - iaux +c +c==== +c 6. initialisation associee aux grandeurs character*8 +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Etape 6 ; caracteres' +#endif +c + call dmlocs (smem,ad0) +c + if ( modgm.eq.0) then + ad1 = ad0 + coergm = 0 + iaux = nch08 - ptrdeb + 1 + elseif ( modgm.eq.1) then + call gbalme('s',nch08+ptrdeb,ad1) + iaux = nch08 + else + ad1 = 0 + coergm = 0 + iaux = nch08 - ptrdeb + 1 + endif +c + if ( coergm.ne.0) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,*) ' allocation de ',nch08,' ch*8' + write (ulsort,*) ' impossible ' + call ugstop( nompro,ulsort,1,1,1) + endif +c + adcom(3) = ad0 + admem(3) = ad1 +CGN write(smem(0),'(i8)') sindef + write(smem(1),'(i8)') nch08 + ntrous = ntrou0 + ptrous(1) = ptrdeb + ltrous(1) = iaux +c + minmes = ltrous(1) + minles = ltrous(1) + nommxs = ' ' + nballs = 0 + totals = nch08 - iaux +c +c==== +c 8. initialisation des tables des types d'objet structure +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Etape 8 ; objet structure' +#endif +c + call gbitos ( nfdico, lfdico, coergm) +c + if (coergm.ne.0) then + write (ulsort,*) nompro,' -> gbitos -> coergm : ',coergm + call ugstop( nompro,ulsort,1,1,1) + endif +c +c==== +c 9. on archive l'information pour le gestionnaire global +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Etape 9 ; archivage' +#endif +c + code = 1 + call ugtabl ( code, tabges, ulsort) +c + tabges(3) = 1 +c + code = 0 + call ugtabl ( code, tabges, ulsort) +c +c==== +c 10. Impression recapitulative +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,modgm+4)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) + write (ulsort,texte(langue,11)) nuvegm, nusvgm +c + if ( modgm.le.1 ) then +c + iaux = imem(1) + write (ulsort,texte(langue,7)) 'Entiers ', adcom(1) + write (ulsort,texte(langue,8)) admem(1) + write (ulsort,texte(langue,9)) iaux +c + iaux = int(rmem(1)) + write (ulsort,texte(langue,7)) 'Reels ', adcom(2) + write (ulsort,texte(langue,8)) admem(2) + write (ulsort,texte(langue,9)) iaux +c + read(smem(1),'(i8)') iaux + write (ulsort,texte(langue,7)) 'Caracteres*8', adcom(3) + write (ulsort,texte(langue,8)) admem(3) + write (ulsort,texte(langue,9)) iaux +c + else +c + write (ulsort,texte(langue,7)) 'Entiers ', adcom(1) +c + write (ulsort,texte(langue,7)) 'Reels ', adcom(2) +c + write (ulsort,texte(langue,7)) 'Caracteres*8', adcom(3) +c + endif +#endif +c +c==== +c 11. la fin +c==== +c + codret = coergm +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gminom.h b/src/tool/Gestion_MTU/gminom.h new file mode 100644 index 00000000..094204cf --- /dev/null +++ b/src/tool/Gestion_MTU/gminom.h @@ -0,0 +1,3 @@ +c + integer indnom + common /gminom/ indnom diff --git a/src/tool/Gestion_MTU/gmitob.F b/src/tool/Gestion_MTU/gmitob.F new file mode 100644 index 00000000..725f8d15 --- /dev/null +++ b/src/tool/Gestion_MTU/gmitob.F @@ -0,0 +1,903 @@ + subroutine gmitob +c ______________________________________________________________________ +c +c H O M A R D V11.n +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c Copyright EDF 1996, 2020 +c ______________________________________________________________________ +c +c Gestionnaire de la Memoire : +c - - +c Initialisation des Tables d'OBjets +c - - -- +c + save +c +#include "gmmatc.h" +c +#include "gmtoas.h" +#include "gmtori.h" +#include "gmtors.h" +#include "gmtove.h" +c + integer iaux +c +c numeros de version des tables d'objets +c + nuveto = 11 + nusvto = 9 + daheto = 30585600 + nuanto = 2016 +c +c objets structures +c + nbrtyp = 43 +c +c-------------------------------------------------- +c + nomtyp( 1) = 'HOM_Mail' + nbratt( 1) = 11 + nbcham( 1) = 10 + adrdst( 1) = 1 +c + nomcha( 1) = 'Noeud ' + typcha( 1) = 3 + nomcha( 2) = 'Ma_Point' + typcha( 2) = 7 + nomcha( 3) = 'Arete ' + typcha( 3) = 4 + nomcha( 4) = 'Face ' + typcha( 4) = 5 + nomcha( 5) = 'Volume ' + typcha( 5) = 6 + nomcha( 6) = 'ElemIgno' + typcha( 6) = 8 + nomcha( 7) = 'Voisins ' + typcha( 7) = 11 + nomcha( 8) = 'RenuMail' + typcha( 8) = 2 + nomcha( 9) = 'InfoSupE' + typcha( 9) = 41 + nomcha( 10) = 'InfoSupS' + typcha( 10) = 43 +c +c-------------------------------------------------- +c + nomtyp( 2) = 'RenuMail' + nbratt( 2) = 19 + nbcham( 2) = 20 + adrdst( 2) = 11 +c + nomcha( 11) = 'NoHOMARD' + typcha( 11) = -1 + nomcha( 12) = 'NoCalcul' + typcha( 12) = -1 + nomcha( 13) = 'MPHOMARD' + typcha( 13) = -1 + nomcha( 14) = 'MPCalcul' + typcha( 14) = -1 + nomcha( 15) = 'ArHOMARD' + typcha( 15) = -1 + nomcha( 16) = 'ArCalcul' + typcha( 16) = -1 + nomcha( 17) = 'TrHOMARD' + typcha( 17) = -1 + nomcha( 18) = 'TrCalcul' + typcha( 18) = -1 + nomcha( 19) = 'TeHOMARD' + typcha( 19) = -1 + nomcha( 20) = 'TeCalcul' + typcha( 20) = -1 + nomcha( 21) = 'QuHOMARD' + typcha( 21) = -1 + nomcha( 22) = 'QuCalcul' + typcha( 22) = -1 + nomcha( 23) = 'PyHOMARD' + typcha( 23) = -1 + nomcha( 24) = 'PyCalcul' + typcha( 24) = -1 + nomcha( 25) = 'HeHOMARD' + typcha( 25) = -1 + nomcha( 26) = 'HeCalcul' + typcha( 26) = -1 + nomcha( 27) = 'PeHOMARD' + typcha( 27) = -1 + nomcha( 28) = 'PeCalcul' + typcha( 28) = -1 + nomcha( 29) = 'Nombres ' + typcha( 29) = -1 + nomcha( 30) = 'InfoSupE' + typcha( 30) = 41 +c +c-------------------------------------------------- +c + nomtyp( 3) = 'HOM_Noeu' + nbratt( 3) = 4 + nbcham( 3) = 10 + adrdst( 3) = 31 +c + nomcha( 31) = 'Coor ' + typcha( 31) = -2 + nomcha( 32) = 'HistEtat' + typcha( 32) = -1 + nomcha( 33) = 'AretSupp' + typcha( 33) = -1 + nomcha( 34) = 'Homologu' + typcha( 34) = -1 + nomcha( 35) = 'Deraffin' + typcha( 35) = -1 + nomcha( 36) = 'CoorCons' + typcha( 36) = -2 + nomcha( 37) = 'InfoGene' + typcha( 37) = -3 + nomcha( 38) = 'Recollem' + typcha( 38) = -1 + nomcha( 39) = 'Famille ' + typcha( 39) = 9 + nomcha( 40) = 'Frontier' + typcha( 40) = 39 +c +c-------------------------------------------------- +c + nomtyp( 4) = 'HOM_Aret' + nbratt( 4) = 0 + nbcham( 4) = 2 + adrdst( 4) = 41 +c + nomcha( 41) = 'HOM_Se02' + typcha( 41) = 7 + nomcha( 42) = 'HOM_Se03' + typcha( 42) = 7 +c +c-------------------------------------------------- +c + nomtyp( 5) = 'HOM_Face' + nbratt( 5) = 0 + nbcham( 5) = 6 + adrdst( 5) = 43 +c + nomcha( 43) = 'HOM_Tr03' + typcha( 43) = 7 + nomcha( 44) = 'HOM_Tr06' + typcha( 44) = 7 + nomcha( 45) = 'HOM_Tr07' + typcha( 45) = 7 + nomcha( 46) = 'HOM_Qu04' + typcha( 46) = 7 + nomcha( 47) = 'HOM_Qu08' + typcha( 47) = 7 + nomcha( 48) = 'HOM_Qu09' + typcha( 48) = 7 +c +c-------------------------------------------------- +c + nomtyp( 6) = 'HOM_Volu' + nbratt( 6) = 0 + nbcham( 6) = 9 + adrdst( 6) = 49 +c + nomcha( 49) = 'HOM_Te04' + typcha( 49) = 7 + nomcha( 50) = 'HOM_Te10' + typcha( 50) = 7 + nomcha( 51) = 'HOM_Py05' + typcha( 51) = 7 + nomcha( 52) = 'HOM_Py13' + typcha( 52) = 7 + nomcha( 53) = 'HOM_He08' + typcha( 53) = 7 + nomcha( 54) = 'HOM_He20' + typcha( 54) = 7 + nomcha( 55) = 'HOM_He27' + typcha( 55) = 7 + nomcha( 56) = 'HOM_Pe06' + typcha( 56) = 7 + nomcha( 57) = 'HOM_Pe15' + typcha( 57) = 7 +c +c-------------------------------------------------- +c + nomtyp( 7) = 'HOM_Enti' + nbratt( 7) = 2 + nbcham( 7) = 14 + adrdst( 7) = 58 +c + nomcha( 58) = 'ConnDesc' + typcha( 58) = -1 + nomcha( 59) = 'ConnAret' + typcha( 59) = -1 + nomcha( 60) = 'HistEtat' + typcha( 60) = -1 + nomcha( 61) = 'Niveau ' + typcha( 61) = -1 + nomcha( 62) = 'Mere ' + typcha( 62) = -1 + nomcha( 63) = 'Fille ' + typcha( 63) = -1 + nomcha( 64) = 'Homologu' + typcha( 64) = -1 + nomcha( 65) = 'InfoSupp' + typcha( 65) = -1 + nomcha( 66) = 'InfoSup2' + typcha( 66) = -1 + nomcha( 67) = 'NoeuInMa' + typcha( 67) = -1 + nomcha( 68) = 'Deraffin' + typcha( 68) = -1 + nomcha( 69) = 'InfoGene' + typcha( 69) = -3 + nomcha( 70) = 'Recollem' + typcha( 70) = 10 + nomcha( 71) = 'Famille ' + typcha( 71) = 9 +c +c-------------------------------------------------- +c + nomtyp( 8) = 'HOM_Elig' + nbratt( 8) = 1 + nbcham( 8) = 2 + adrdst( 8) = 72 +c + nomcha( 72) = 'ConnNoeu' + typcha( 72) = -1 + nomcha( 73) = 'FamilMED' + typcha( 73) = -1 +c +c-------------------------------------------------- +c + nomtyp( 9) = 'HOM_Fami' + nbratt( 9) = 2 + nbcham( 9) = 2 + adrdst( 9) = 74 +c + nomcha( 74) = 'EntiFamm' + typcha( 74) = -1 + nomcha( 75) = 'Codes ' + typcha( 75) = -1 +c +c-------------------------------------------------- +c + nomtyp( 10) = 'HOM_Reco' + nbratt( 10) = 3 + nbcham( 10) = 2 + adrdst( 10) = 76 +c + nomcha( 76) = 'ListeA ' + typcha( 76) = -1 + nomcha( 77) = 'ListeB ' + typcha( 77) = -1 +c +c-------------------------------------------------- +c + nomtyp( 11) = 'Voisins ' + nbratt( 11) = 2 + nbcham( 11) = 10 + adrdst( 11) = 78 +c + nomcha( 78) = '0D/1D ' + typcha( 78) = 32 + nomcha( 79) = '1D/2D ' + typcha( 79) = 32 + nomcha( 80) = 'Vol/Tri ' + typcha( 80) = -1 + nomcha( 81) = 'Vol/Qua ' + typcha( 81) = -1 + nomcha( 82) = 'PyPe/Tri' + typcha( 82) = -1 + nomcha( 83) = 'PyPe/Qua' + typcha( 83) = -1 + nomcha( 84) = 'Tet/Are ' + typcha( 84) = 32 + nomcha( 85) = 'Hex/Are ' + typcha( 85) = 32 + nomcha( 86) = 'Pen/Are ' + typcha( 86) = 32 + nomcha( 87) = 'Pyr/Are ' + typcha( 87) = 32 +c +c-------------------------------------------------- +c + nomtyp( 12) = 'Sauve_HM' + nbratt( 12) = 7 + nbcham( 12) = 18 + adrdst( 12) = 88 +c + nomcha( 88) = 'Fille_Ar' + typcha( 88) = -1 + nomcha( 89) = 'HEtat_Ar' + typcha( 89) = -1 + nomcha( 90) = 'Fille_Tr' + typcha( 90) = -1 + nomcha( 91) = 'HEtat_Tr' + typcha( 91) = -1 + nomcha( 92) = 'Famil_Tr' + typcha( 92) = -1 + nomcha( 93) = 'Fille_Qu' + typcha( 93) = -1 + nomcha( 94) = 'HEtat_Qu' + typcha( 94) = -1 + nomcha( 95) = 'Fille_Te' + typcha( 95) = -1 + nomcha( 96) = 'HEtat_Te' + typcha( 96) = -1 + nomcha( 97) = 'Fille_Py' + typcha( 97) = -1 + nomcha( 98) = 'HEtat_Py' + typcha( 98) = -1 + nomcha( 99) = 'Fille_He' + typcha( 99) = -1 + nomcha( 100) = 'HEtat_He' + typcha( 100) = -1 + nomcha( 101) = 'Insu2_He' + typcha( 101) = -1 + nomcha( 102) = 'Fille_Pe' + typcha( 102) = -1 + nomcha( 103) = 'HEtat_Pe' + typcha( 103) = -1 + nomcha( 104) = 'Insu2_Pe' + typcha( 104) = -1 + nomcha( 105) = 'RenuMail' + typcha( 105) = 2 +c +c-------------------------------------------------- +c + nomtyp( 13) = 'HOM_Indi' + nbratt( 13) = 0 + nbcham( 13) = 9 + adrdst( 13) = 106 +c + nomcha( 106) = 'Noeud ' + typcha( 106) = 14 + nomcha( 107) = 'Point ' + typcha( 107) = 14 + nomcha( 108) = 'Arete ' + typcha( 108) = 14 + nomcha( 109) = 'Trian ' + typcha( 109) = 14 + nomcha( 110) = 'Quadr ' + typcha( 110) = 14 + nomcha( 111) = 'Tetra ' + typcha( 111) = 14 + nomcha( 112) = 'Hexae ' + typcha( 112) = 14 + nomcha( 113) = 'Pyram ' + typcha( 113) = 14 + nomcha( 114) = 'Penta ' + typcha( 114) = 14 +c +c-------------------------------------------------- +c + nomtyp( 14) = 'Indicate' + nbratt( 14) = 3 + nbcham( 14) = 3 + adrdst( 14) = 115 +c + nomcha( 115) = 'Support ' + typcha( 115) = -1 + nomcha( 116) = 'ValeursE' + typcha( 116) = -1 + nomcha( 117) = 'ValeursR' + typcha( 117) = -2 +c +c-------------------------------------------------- +c + nomtyp( 15) = 'Cal_Mail' + nbratt( 15) = 8 + nbcham( 15) = 9 + adrdst( 15) = 118 +c + nomcha( 118) = 'InfoGene' + typcha( 118) = 34 + nomcha( 119) = 'Noeud ' + typcha( 119) = 16 + nomcha( 120) = 'ConnNoeu' + typcha( 120) = 17 + nomcha( 121) = 'ConnDesc' + typcha( 121) = 18 + nomcha( 122) = 'Famille ' + typcha( 122) = 19 + nomcha( 123) = 'Equivalt' + typcha( 123) = 20 + nomcha( 124) = 'Frontier' + typcha( 124) = -1 + nomcha( 125) = 'CodeExte' + typcha( 125) = 21 + nomcha( 126) = 'Nombres ' + typcha( 126) = -1 +c +c-------------------------------------------------- +c + nomtyp( 16) = 'MC_Noe ' + nbratt( 16) = 3 + nbcham( 16) = 4 + adrdst( 16) = 127 +c + nomcha( 127) = 'NumeExte' + typcha( 127) = -1 + nomcha( 128) = 'Coor ' + typcha( 128) = -2 + nomcha( 129) = 'FamilMED' + typcha( 129) = -1 + nomcha( 130) = 'CoorCons' + typcha( 130) = -2 +c +c-------------------------------------------------- +c + nomtyp( 17) = 'MC_CNo ' + nbratt( 17) = 3 + nbcham( 17) = 4 + adrdst( 17) = 131 +c + nomcha( 131) = 'NumeExte' + typcha( 131) = -1 + nomcha( 132) = 'FamilMED' + typcha( 132) = -1 + nomcha( 133) = 'Type ' + typcha( 133) = -1 + nomcha( 134) = 'Noeuds ' + typcha( 134) = -1 +c +c-------------------------------------------------- +c + nomtyp( 18) = 'MC_CDe ' + nbratt( 18) = 2 + nbcham( 18) = 4 + adrdst( 18) = 135 +c + nomcha( 135) = 'NumeExte' + typcha( 135) = -1 + nomcha( 136) = 'FamilMED' + typcha( 136) = -1 + nomcha( 137) = 'Type ' + typcha( 137) = -1 + nomcha( 138) = 'Entites ' + typcha( 138) = -1 +c +c-------------------------------------------------- +c + nomtyp( 19) = 'MC_Fam ' + nbratt( 19) = 3 + nbcham( 19) = 3 + adrdst( 19) = 139 +c + nomcha( 139) = 'Numero ' + typcha( 139) = -1 + nomcha( 140) = 'Nom ' + typcha( 140) = -3 + nomcha( 141) = 'Groupe ' + typcha( 141) = 34 +c +c-------------------------------------------------- +c + nomtyp( 20) = 'MC_Equ ' + nbratt( 20) = 8 + nbcham( 20) = 9 + adrdst( 20) = 142 +c + nomcha( 142) = 'Pointeur' + typcha( 142) = -1 + nomcha( 143) = 'InfoGene' + typcha( 143) = -3 + nomcha( 144) = 'Noeud ' + typcha( 144) = -1 + nomcha( 145) = 'Point ' + typcha( 145) = -1 + nomcha( 146) = 'Arete ' + typcha( 146) = -1 + nomcha( 147) = 'Trian ' + typcha( 147) = -1 + nomcha( 148) = 'Quadr ' + typcha( 148) = -1 + nomcha( 149) = 'Tetra ' + typcha( 149) = -1 + nomcha( 150) = 'Hexae ' + typcha( 150) = -1 +c +c-------------------------------------------------- +c + nomtyp( 21) = 'MC_CEx ' + nbratt( 21) = 10 + nbcham( 21) = 10 + adrdst( 21) = 151 +c + nomcha( 151) = 'Noeud ' + typcha( 151) = -1 + nomcha( 152) = 'Point ' + typcha( 152) = -1 + nomcha( 153) = 'Arete ' + typcha( 153) = -1 + nomcha( 154) = 'Trian ' + typcha( 154) = -1 + nomcha( 155) = 'Quadr ' + typcha( 155) = -1 + nomcha( 156) = 'Tetra ' + typcha( 156) = -1 + nomcha( 157) = 'Pyram ' + typcha( 157) = -1 + nomcha( 158) = 'Hexae ' + typcha( 158) = -1 + nomcha( 159) = 'Penta ' + typcha( 159) = -1 + nomcha( 160) = 'ElemBord' + typcha( 160) = -1 +c +c-------------------------------------------------- +c + nomtyp( 22) = 'Solution' + nbratt( 22) = 4 + nbcham( 22) = 4 + adrdst( 22) = 161 +c + nomcha( 161) = 'InfoCham' + typcha( 161) = -3 + nomcha( 162) = 'InfoPaFo' + typcha( 162) = -3 + nomcha( 163) = 'InfoProf' + typcha( 163) = -3 + nomcha( 164) = 'InfoLoPG' + typcha( 164) = -3 +c +c-------------------------------------------------- +c + nomtyp( 23) = 'InfoCham' + nbratt( 23) = 3 + nbcham( 23) = 4 + adrdst( 23) = 165 +c + nomcha( 165) = 'Nom_Comp' + typcha( 165) = -3 + nomcha( 166) = 'Cham_Ent' + typcha( 166) = -1 + nomcha( 167) = 'Cham_Ree' + typcha( 167) = -2 + nomcha( 168) = 'Cham_Car' + typcha( 168) = -3 +c +c-------------------------------------------------- +c + nomtyp( 24) = 'PackFonc' + nbratt( 24) = 5 + nbcham( 24) = 2 + adrdst( 24) = 169 +c + nomcha( 169) = 'Fonction' + typcha( 169) = -3 + nomcha( 170) = 'TypeSuAs' + typcha( 170) = -1 +c +c-------------------------------------------------- +c + nomtyp( 25) = 'Profil ' + nbratt( 25) = 2 + nbcham( 25) = 2 + adrdst( 25) = 171 +c + nomcha( 171) = 'NomProfi' + typcha( 171) = -3 + nomcha( 172) = 'ListEnti' + typcha( 172) = -1 +c +c-------------------------------------------------- +c + nomtyp( 26) = 'LocaPG ' + nbratt( 26) = 4 + nbcham( 26) = 4 + adrdst( 26) = 173 +c + nomcha( 173) = 'NomLocPG' + typcha( 173) = -3 + nomcha( 174) = 'CoorNoeu' + typcha( 174) = -2 + nomcha( 175) = 'CoorPtGa' + typcha( 175) = -2 + nomcha( 176) = 'PoidPtGa' + typcha( 176) = -2 +c +c-------------------------------------------------- +c + nomtyp( 27) = 'Fonction' + nbratt( 27) = 8 + nbcham( 27) = 5 + adrdst( 27) = 177 +c + nomcha( 177) = 'ValeursE' + typcha( 177) = -1 + nomcha( 178) = 'ValeursR' + typcha( 178) = -2 + nomcha( 179) = 'InfoCham' + typcha( 179) = -3 + nomcha( 180) = 'InfoPrPG' + typcha( 180) = -3 + nomcha( 181) = 'TypeSuAs' + typcha( 181) = -1 +c +c-------------------------------------------------- +c + nomtyp( 28) = 'DonnHOMA' + nbratt( 28) = 5 + nbcham( 28) = 4 + adrdst( 28) = 182 +c + nomcha( 182) = 'OptEnt ' + typcha( 182) = -1 + nomcha( 183) = 'OptRee ' + typcha( 183) = -2 + nomcha( 184) = 'OptCar ' + typcha( 184) = -3 + nomcha( 185) = 'EtatCour' + typcha( 185) = -1 +c +c-------------------------------------------------- +c + nomtyp( 29) = 'FichExec' + nbratt( 29) = 2 + nbcham( 29) = 6 + adrdst( 29) = 186 +c + nomcha( 186) = 'NomRefer' + typcha( 186) = -3 + nomcha( 187) = 'LongNomF' + typcha( 187) = -1 + nomcha( 188) = 'PosiNomF' + typcha( 188) = -1 + nomcha( 189) = 'NomUFich' + typcha( 189) = -3 + nomcha( 190) = 'NomObjSt' + typcha( 190) = -3 + nomcha( 191) = 'InfoSupp' + typcha( 191) = -3 +c +c-------------------------------------------------- +c + nomtyp( 30) = 'ChampMAJ' + nbratt( 30) = 1 + nbcham( 30) = 3 + adrdst( 30) = 192 +c + nomcha( 192) = 'CarCaChp' + typcha( 192) = -3 + nomcha( 193) = 'CarEnChp' + typcha( 193) = -1 + nomcha( 194) = 'CarReChp' + typcha( 194) = -2 +c +c-------------------------------------------------- +c + nomtyp( 31) = 'Cal_Fron' + nbratt( 31) = 5 + nbcham( 31) = 7 + adrdst( 31) = 195 +c + nomcha( 195) = 'CoorNoeu' + typcha( 195) = -2 + nomcha( 196) = 'NumeLign' + typcha( 196) = -1 + nomcha( 197) = 'TypeLign' + typcha( 197) = -1 + nomcha( 198) = 'PtrSomLi' + typcha( 198) = -1 + nomcha( 199) = 'SommSegm' + typcha( 199) = -1 + nomcha( 200) = 'AbsCurvi' + typcha( 200) = -2 + nomcha( 201) = 'Groupes ' + typcha( 201) = 34 +c +c-------------------------------------------------- +c + nomtyp( 32) = 'PtTabEnt' + nbratt( 32) = 2 + nbcham( 32) = 2 + adrdst( 32) = 202 +c + nomcha( 202) = 'Pointeur' + typcha( 202) = -1 + nomcha( 203) = 'Table ' + typcha( 203) = -1 +c +c-------------------------------------------------- +c + nomtyp( 33) = 'PtTabRee' + nbratt( 33) = 2 + nbcham( 33) = 2 + adrdst( 33) = 204 +c + nomcha( 204) = 'Pointeur' + typcha( 204) = -1 + nomcha( 205) = 'Table ' + typcha( 205) = -2 +c +c-------------------------------------------------- +c + nomtyp( 34) = 'PtTabC08' + nbratt( 34) = 2 + nbcham( 34) = 3 + adrdst( 34) = 206 +c + nomcha( 206) = 'Pointeur' + typcha( 206) = -1 + nomcha( 207) = 'Taille ' + typcha( 207) = -1 + nomcha( 208) = 'Table ' + typcha( 208) = -3 +c +c-------------------------------------------------- +c + nomtyp( 35) = 'Pt2TbEnt' + nbratt( 35) = 2 + nbcham( 35) = 3 + adrdst( 35) = 209 +c + nomcha( 209) = 'Pointeur' + typcha( 209) = -1 + nomcha( 210) = 'ListeA ' + typcha( 210) = -1 + nomcha( 211) = 'ListeB ' + typcha( 211) = -1 +c +c-------------------------------------------------- +c + nomtyp( 36) = 'PtPtTEnt' + nbratt( 36) = 3 + nbcham( 36) = 3 + adrdst( 36) = 212 +c + nomcha( 212) = 'Pointer1' + typcha( 212) = -1 + nomcha( 213) = 'Pointer2' + typcha( 213) = -1 + nomcha( 214) = 'Table ' + typcha( 214) = -1 +c +c-------------------------------------------------- +c + nomtyp( 37) = '2ListEnt' + nbratt( 37) = 1 + nbcham( 37) = 2 + adrdst( 37) = 215 +c + nomcha( 215) = 'ListeA ' + typcha( 215) = -1 + nomcha( 216) = 'ListeB ' + typcha( 216) = -1 +c +c-------------------------------------------------- +c + nomtyp( 38) = '3ListEnt' + nbratt( 38) = 1 + nbcham( 38) = 3 + adrdst( 38) = 217 +c + nomcha( 217) = 'ListeA ' + typcha( 217) = -1 + nomcha( 218) = 'ListeB ' + typcha( 218) = -1 + nomcha( 219) = 'ListeC ' + typcha( 219) = -1 +c +c-------------------------------------------------- +c + nomtyp( 39) = '2ListeER' + nbratt( 39) = 1 + nbcham( 39) = 2 + adrdst( 39) = 220 +c + nomcha( 220) = 'ListeA ' + typcha( 220) = -1 + nomcha( 221) = 'ListeB ' + typcha( 221) = -1 +c +c-------------------------------------------------- +c + nomtyp( 40) = 'EntCarRe' + nbratt( 40) = 1 + nbcham( 40) = 4 + adrdst( 40) = 222 +c + nomcha( 222) = 'ValeursE' + typcha( 222) = -1 + nomcha( 223) = 'ValeursS' + typcha( 223) = -3 + nomcha( 224) = 'ValeursR' + typcha( 224) = -2 + nomcha( 225) = 'Suivant ' + typcha( 225) = 40 +c +c-------------------------------------------------- +c + nomtyp( 41) = '10TabEnt' + nbratt( 41) = 10 + nbcham( 41) = 10 + adrdst( 41) = 226 +c + nomcha( 226) = 'Tab1 ' + typcha( 226) = -1 + nomcha( 227) = 'Tab2 ' + typcha( 227) = -1 + nomcha( 228) = 'Tab3 ' + typcha( 228) = -1 + nomcha( 229) = 'Tab4 ' + typcha( 229) = -1 + nomcha( 230) = 'Tab5 ' + typcha( 230) = -1 + nomcha( 231) = 'Tab6 ' + typcha( 231) = -1 + nomcha( 232) = 'Tab7 ' + typcha( 232) = -1 + nomcha( 233) = 'Tab8 ' + typcha( 233) = -1 + nomcha( 234) = 'Tab9 ' + typcha( 234) = -1 + nomcha( 235) = 'Tab10 ' + typcha( 235) = -1 +c +c-------------------------------------------------- +c + nomtyp( 42) = '10TabRee' + nbratt( 42) = 10 + nbcham( 42) = 10 + adrdst( 42) = 236 +c + nomcha( 236) = 'Tab1 ' + typcha( 236) = -2 + nomcha( 237) = 'Tab2 ' + typcha( 237) = -2 + nomcha( 238) = 'Tab3 ' + typcha( 238) = -2 + nomcha( 239) = 'Tab4 ' + typcha( 239) = -2 + nomcha( 240) = 'Tab5 ' + typcha( 240) = -2 + nomcha( 241) = 'Tab6 ' + typcha( 241) = -2 + nomcha( 242) = 'Tab7 ' + typcha( 242) = -2 + nomcha( 243) = 'Tab8 ' + typcha( 243) = -2 + nomcha( 244) = 'Tab9 ' + typcha( 244) = -2 + nomcha( 245) = 'Tab10 ' + typcha( 245) = -2 +c +c-------------------------------------------------- +c + nomtyp( 43) = '10TabC08' + nbratt( 43) = 10 + nbcham( 43) = 10 + adrdst( 43) = 246 +c + nomcha( 246) = 'Tab1 ' + typcha( 246) = -3 + nomcha( 247) = 'Tab2 ' + typcha( 247) = -3 + nomcha( 248) = 'Tab3 ' + typcha( 248) = -3 + nomcha( 249) = 'Tab4 ' + typcha( 249) = -3 + nomcha( 250) = 'Tab5 ' + typcha( 250) = -3 + nomcha( 251) = 'Tab6 ' + typcha( 251) = -3 + nomcha( 252) = 'Tab7 ' + typcha( 252) = -3 + nomcha( 253) = 'Tab8 ' + typcha( 253) = -3 + nomcha( 254) = 'Tab9 ' + typcha( 254) = -3 + nomcha( 255) = 'Tab10 ' + typcha( 255) = -3 +c + do 24 , iaux = 1 , nbrtyp + nomtbp(iaux) = nomtyp(iaux) + 24 continue +c + end diff --git a/src/tool/Gestion_MTU/gmixjx.h b/src/tool/Gestion_MTU/gmixjx.h new file mode 100644 index 00000000..68ef0ea7 --- /dev/null +++ b/src/tool/Gestion_MTU/gmixjx.h @@ -0,0 +1,3 @@ +c + integer ix,jx,nbjx + parameter(ix=1000,jx=20,nbjx=2000) diff --git a/src/tool/Gestion_MTU/gmlang.h b/src/tool/Gestion_MTU/gmlang.h new file mode 100644 index 00000000..4f243bef --- /dev/null +++ b/src/tool/Gestion_MTU/gmlang.h @@ -0,0 +1,9 @@ +c +c Le parametre entier "langue" repere la langue d'affichage des +c messages, selon la codification suivante : +c +c 1 : francais +c 2 : anglais +c + integer langue + common / gmlang / langue diff --git a/src/tool/Gestion_MTU/gmlanm.F b/src/tool/Gestion_MTU/gmlanm.F new file mode 100644 index 00000000..5fcfb9f5 --- /dev/null +++ b/src/tool/Gestion_MTU/gmlanm.F @@ -0,0 +1,134 @@ + subroutine gmlanm ( lang ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion de la Memoire : LANgue des Messages' +c - - --- - +c ______________________________________________________________________ +c +c but : modifie le numero de l'unite logique des messages du +c gestionnaire de memoire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lang . e . 1 . code de la langue souhaitee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GMLANM' ) +c +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer lang +c +c 0.4. ==> variables locales +c + logical dejavu +c + integer guimp, gmimp, raison + integer lgimpr, ulimpr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data dejavu / .false. / +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c remarque : on doit faire qqe chose pour prevenir des cas ou le +c numero de l'unite logique ou de la langue serait nul. +c==== +c + if ( ulsort.gt.0 ) then + ulimpr = ulsort + else + call gusost ( ulimpr ) + endif +c + if ( dejavu ) then + lgimpr = langue + else + lgimpr = 1 + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulimpr,texte(lgimpr,1)) nompro +#endif +c + texte(1,10) = '(1x,''Le numero de langue '',i2,'' voulu'')' + texte(1,4) = '(1x,''pour les sorties GM est incorrect.'')' + texte(1,5) = '(1x,''Il doit etre compris entre 1 et '',i8)' +c + texte(2,10) = '(1x,''The language code # '',i2,'' wanted for'')' + texte(2,4) = '(1x,''GM messages is not correct.'')' + texte(2,5) = '(1x,''It must be included between 1 and '',i8)' +c +c==== +c 2. verification de la validite du numero. +c Il faut que le numero soit compris entre 1 et le nombre maximal +c de langue. +c==== +c + if ( lang.lt.1 .or. lang.gt.nblang ) then +c + write (ulimpr,texte(lgimpr,1)) + write (ulimpr,texte(lgimpr,10)) lang + write (ulimpr,texte(lgimpr,4)) + write (ulimpr,texte(lgimpr,5)) nblang +c + guimp = 1 + gmimp = 1 + raison = 1 + call ugstop (nompro,ulimpr,guimp, gmimp, raison) +c + endif +c +c==== +c 3. archivage du numero +c==== +c + langue = lang +c + dejavu = .true. +c + end diff --git a/src/tool/Gestion_MTU/gmlboj.F b/src/tool/Gestion_MTU/gmlboj.F new file mode 100644 index 00000000..f539d90e --- /dev/null +++ b/src/tool/Gestion_MTU/gmlboj.F @@ -0,0 +1,180 @@ + subroutine gmlboj ( nom, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c liberation de l'objet terminal de nom etendu "nom" +c tous les attachements de l'objet sont supprimes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . e .char(*) . nom etendu de l'objet a liberer . +c . codret . s . ent . code retour de l'operation . +c . . . . 1 : nom d'objet temporaire inconnu . +c . . . . 0 : OK . +c . . . . -1 : objet-terminal non alloue . +c . . . . -2 : objet-terminal non defini . +c . . . . -3 : nom etendu invalide . +c . . . . -4 : support introuvable dans les tables . +c . . . . -5 : champ introuvable dans les tables . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMLBOJ' ) +c +#include "genbla.h" +#include "gmcain.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + character*(*) nom +c + integer codret +c +c 0.4. ==> variables locales +c + character*8 nomaux + character*8 objrep, objter, chater +c + integer iaux + integer idec + integer icar, imin, imax +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c==== +c 1. decodage du nom etendu +c==== +c + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + codret = -3 +c + else if (idec.eq.1) then +c +c objet-terminal non defini +c + codret = -2 +c + else if (idec.eq.2) then +c +c objet-terminal defini mais non alloue +c + codret = -1 +c + else +c +c==== +c 2. liberation de l'objet alloue +c detachement de l'objet de tous ses supports +c si c'est un objet temporaire et que c'est une tete, on le raye +c de la liste +c==== +c + call gblboj ( objter ) +c + if ( coergm.eq.0 ) then +c + nomaux = ' ' + call gbdtoj ( nomaux, objter ) + codret = coergm +c + else +c + codret = coergm +c + endif +c + if ( idec.eq.0 .and. codret.eq.0 ) then +c + if ( nom(1:1).eq.caint1 ) then +c +c avant de supprimer le nom de la liste des noms d'objets temporaires, +c on verifie que le nom (terminal) a bien la structure d'un nom +c temporaire : un certain nombre (>0) de caracteres caint1 (% a priori), +c suivis d'un entier (le tout, code sur 8 caracteres). +c + imin = 2 + imax = 11 + do 20 icar = 2, 8 + iaux = index('0123456789'//caint1, objter(icar:icar)) + if (iaux.lt.imin.or.iaux.gt.imax) then + goto 21 + else + if (iaux.ne.11) then + imin = 1 + imax = 10 + endif + endif + 20 continue + if (imax.ne.11) then + call gbntde ( objter , iaux ) + endif + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 4. Fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmlgen.h b/src/tool/Gestion_MTU/gmlgen.h new file mode 100644 index 00000000..5b4423ff --- /dev/null +++ b/src/tool/Gestion_MTU/gmlgen.h @@ -0,0 +1,5 @@ +c +c longueur d'enregistrement pour les fichiers a acces direct de GM +c + integer lgenre + parameter ( lgenre = 256 ) diff --git a/src/tool/Gestion_MTU/gmliat.F b/src/tool/Gestion_MTU/gmliat.F new file mode 100644 index 00000000..731cc6cb --- /dev/null +++ b/src/tool/Gestion_MTU/gmliat.F @@ -0,0 +1,142 @@ + subroutine gmliat (nom,numero,valeur,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c lire la valeur de l'attribut numero 'numero' de +c l'objet-terminal du nom etendu "nom" +c ........................................................... +c +c entrees : +c +c nom : character*(*) : nom etendu +c numero : integer : numero de l'attribut +c +c ........................................................... +c +c sorties : +c valeur : valeur de l'attribut lue +c codret : code de retour : +c -5 : erreur : nom etendu invalide +c -4 : erreur : objet-terminal pas defini +c -3 : erreur : objet-terminal defini mais pas alloue +c -2 : erreur : objet-terminal n'est pas structure +c -1 : erreur : numero < 1 ou +c : numero > nombre d'attributs de objet-terminal +c 0 : OK +c +c ........................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtoas.h" +c +#include "gmindi.h" +c +c 0.3. ==> arguments +c + character*(*) nom + integer numero,valeur,codret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + integer idec,iob,ity,nba,iat,nroobj +c +c==== +c 1. decodage du nom etendu +c==== +c + valeur = 0 + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + codret = -5 +c + else if (idec.eq.1) then +c +c objet-terminal non defini +c + codret = -4 +c + else if (idec.eq.2) then +c +c objet-terminal defini mais non alloue +c + codret = -3 +c + else +c +c objet-terminal est defini et eventuellement alloue +c + do 10 , iob = 1,iptobj-1 + if (nomobj(iob).eq.objter) then + nroobj = iob + codret = 0 + goto 20 + endif + 10 continue +c +c objet-terminal n'est pas structure +c + codret = -2 +c + endif +c +c==== +c 2. objet structure : lecture de l'attribut +c en cas d'echec, on met une valeur indefinie +c==== +c + 20 continue +c + if ( codret.eq.0 ) then +c + ity = typobj(nroobj) + nba = nbratt(ity) + codret = -1 + if ((numero.le.nba).and.(numero.gt.0)) then + codret = 0 + iat = adrdsa(iob)+numero-1 + valeur = valatt(iat) + endif +c + endif +c + if ( codret.ne.0 ) then + valeur = iindef + endif +c + end diff --git a/src/tool/Gestion_MTU/gmmatc.h b/src/tool/Gestion_MTU/gmmatc.h new file mode 100644 index 00000000..ffbec25d --- /dev/null +++ b/src/tool/Gestion_MTU/gmmatc.h @@ -0,0 +1,5 @@ +c + integer ntypx, nchpx, nobjx, nobcx, ntybma + parameter (ntypx = 500, nchpx = 1500, + > nobjx = 2000, nobcx = 5000, + > ntybma = 4 ) diff --git a/src/tool/Gestion_MTU/gmmaxi.F b/src/tool/Gestion_MTU/gmmaxi.F new file mode 100644 index 00000000..4f5211c3 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmaxi.F @@ -0,0 +1,82 @@ + subroutine gmmaxi (maxtro , mtotro , ntrou , ltrou) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c . derniere modif 15/06/89 jc jyb +c ...................................................................... +c . +c . - fonction +c . calcule a partir des communs gerant les pointeurs, la taille +c . des plus gros trous disponibles et la place potentiellement +c . utilisable si on compactait +c . +c . - realisation: +c . examen du common trous +c . +c . - arguments: +c . donnees ntrou --> nbre de trous existants +c . ltrou --> tab des longueurs de trous +c . resultats +c . maxtro <-- taille du + gd trou existant +c . mtotro <-- cumul de la place restante +c . dans le tableau +c ...................................................................... +c +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ntrou , ltrou (ntrou) + integer maxtro , mtotro +c +c 0.4. ==> variables locales +c + integer i +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c--- +c 2. etude du tableau +c--- +c + maxtro = 0 + mtotro = 0 +c + do 20 i=1,ntrou + mtotro = mtotro + ltrou(i) + maxtro = max(maxtro,ltrou(i)) + 20 continue +c +ctst write ( 6, 2000 ) maxtro,mtotro +c2000 format(//2x,'**** spg gmmaxi *****',/5x, +ctst * ' taille du plus gd trou disponible :',i9,/5x, +ctst * ' taille totale potentiellement disponible :',i9) +c + end diff --git a/src/tool/Gestion_MTU/gmmaxt.h b/src/tool/Gestion_MTU/gmmaxt.h new file mode 100644 index 00000000..05887347 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmaxt.h @@ -0,0 +1,12 @@ +c +c maxtab = nombre maximum de tableaux elementaires geres +c dans chaque categorie +c maxtrs = nombre maximum de trous. +c +c le nombre de trous ne peut pas depasser le nombre de tableaux + 1. +c l'initialiser a maxtab + 2 assure, dans les sous-programmes de +c desallocation, que l'on peut toujours calculer +c ntrou (r,i,d,s ou c) + 1 +c + integer maxtab , maxtrs + parameter (maxtab=1000,maxtrs=maxtab+2) diff --git a/src/tool/Gestion_MTU/gmmess.F b/src/tool/Gestion_MTU/gmmess.F new file mode 100644 index 00000000..ba032b78 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmess.F @@ -0,0 +1,137 @@ + subroutine gmmess (ulmess) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion de la Memoire : unite de sortie des MESSages' +c - - ---- +c ______________________________________________________________________ +c +c but : modifie le numero de l'unite logique des messages du +c gestionnaire de memoire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulmess . e . 1 . unite logique voulue pour les messages . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMESS' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer ulmess +c +c 0.4. ==> variables locales +c + logical imprim, dejavu +c + integer lgimpr, ulimpr +c + integer guimp, gmimp, raison + integer codret +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data dejavu / .false. / +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c remarque : on doit faire qqe chose pour prevenir des cas ou le +c numero de l'unite logique ou de la langue serait nul. +c==== +c + if ( dejavu ) then + ulimpr = ulsort + else + call gusost ( ulimpr ) + endif +c + if ( langue.le.0 ) then + lgimpr = 1 + else + lgimpr = langue + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulimpr,texte(lgimpr,1)) nompro +#endif +c + texte(1,10) = '(''Le numero d''''unite logique '',i2,'' voulu'')' + texte(1,4) = + >'(''pour les sorties GM n''''a pas le bon statut GU.'')' +c + texte(2,10) = '(''The logical unit # '',i2,'' wanted for'')' + texte(2,4) = '(''GM messages has not the right status in GU.'')' +c +c==== +c 2. verification de la validite du numero. il faut que le statut soit : +c 2 : Sortie standard (sequentiel formate) +c 3 : Ouvert en acces sequentiel formate +c==== +c + imprim = .false. + call guinfu ( ulmess, codret, imprim ) +c + if ( codret.ne.2 .and. codret.ne.3 ) then +c + write (ulimpr,texte(lgimpr,1)) nompro + write (ulimpr,texte(lgimpr,10)) ulmess + write (ulimpr,texte(lgimpr,4)) +c + guimp = 1 + gmimp = 1 + raison = 1 + call ugstop(nompro,ulimpr,guimp, gmimp, raison) +c + endif +c +c==== +c 3. archivage du numero +c==== +c + ulsort = ulmess +c + dejavu = .true. +c + end diff --git a/src/tool/Gestion_MTU/gmmod.F b/src/tool/Gestion_MTU/gmmod.F new file mode 100644 index 00000000..3847d648 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmod.F @@ -0,0 +1,644 @@ + subroutine gmmod ( nomet, point, + > d1old, d1new, d2old, d2new, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c modification des tailles d'un objet terminal connu +c par son nom etendu +c +c . si les tailles sont les memes : on se contente de retourner le +c pointeur associe +c . si les tailles sont toutes positives : +c on passe de tab(d1old,d2old) a tab(d1new,d2new) +c . si les tailles d1x sont negatives et les tailles d2x positives : +c on passe de tab(d1old:d2old) a tab(d1new:d2new) +c . sinon : probleme ... +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomet . e . char(*). nom etendu en memoire centrale . +c . point . es . ent . pointeur associe . +c . d1old . e . ent . premiere dimension avant . +c . d1new . e . ent . premiere dimension apres . +c . d2old . e . ent . seconde dimension avant . +c . d2new . e . ent . seconde dimension apres . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : objet-terminal pas simple . +c . . . . -2 : objet-terminal non defini ou non alloue +c . . . . -3 : nom etendu invalide . +c . . . . x : cas non prevu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMOD' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) nomet +c + integer point, d1old, d1new, d2old, d2new + integer codret +c +c 0.4. ==> variables locales +c + character*8 objrep, objter, chater + character*8 type8 +c + integer idec, letype, codre0, ilong + integer iaux + integer typmod, lgold, lgnew +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Objet a modifier : '',a)' + texte(1,5) = + > '(''Passage de ( d1old = '',i10,'' , d2old = '',i10,'')'')' + texte(1,6) = + > '('' a ( d1new = '',i10,'' , d2new = '',i10,'')'')' + texte(1,11) = '(''L''''objet n''''est pas simple.'')' + texte(1,12) = '(''Objet non defini ou non alloue.'')' + texte(1,13) = '(''Nom etendu invalide.'')' + texte(1,14) = '(''Mauvaises dimensions'')' + texte(1,15) = '(''Cas imprevu.'')' + texte(1,16) = '(''Nom incorrect.'')' + texte(1,17) = '(''Tableau introuvable.'')' +c + texte(2,4) = '(''Object to modidy: '',a)' + texte(2,5) = + > '(''Passage from ( d1old = '',i10,'' , d2old = '',i10,'')'')' + texte(2,6) = + > '('' to ( d1new = '',i10,'' , d2new = '',i10,'')'')' + texte(2,11) = '(''The object is not simple.'')' + texte(2,12) = '(''Object not defined or not allocated.'')' + texte(2,13) = '(''Not valid name.'')' + texte(2,14) = '(''Bad array sizes.'')' + texte(2,15) = '(''Impossible case.'')' + texte(2,16) = '(''Uncorrect name.'')' + texte(2,17) = '(''Array cannot be found.'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ +cgn if ( nomet.eq.'MaEn002f' ) then + write (ulsort,texte(langue,4)) nomet + write (ulsort,texte(langue,5)) d1old, d2old + write (ulsort,texte(langue,6)) d1new, d2new +cgn endif +#endif +c +c==== +c 2. controle des dimensions +c==== +c + lgold = d1old*d2old + lgnew = d1new*d2new +c +c 2.1. ==> pas de changement +c + if ( d1old.eq.d1new .and. d2old.eq.d2new ) then +c +cgn write (ulsort,*) '2.1. ==> pas de changement' + typmod = 0 +c +c 2.2. ==> De longeur non nulle devenant de longueur nulle +c + elseif ( lgold.gt.0 .and. lgnew.eq.0 ) then +c +cgn write (ulsort,*) '2.2. ==> devenant de longueur nulle' + typmod = 61 +c +c 2.3. ==> la 1ere dimension est toujours nulle, la 2nde est positive : +c tab(0:d2) +c + elseif ( d1old.eq.0 .and. d1new.eq.0 .and. + > d2old.ge.0 .and. d2new.ge.0 ) then +c +cgn write (ulsort,*) '2.2. ==> la 1ere dim est =0, la 2nde >=0' +c + lgold = d2old + 1 + lgnew = d2new + 1 +c +c 2.3.1. ==> 2nde dimension : allongement +c + if ( d2old.lt.d2new ) then + typmod = 31 +c +c 2.3.2. ==> 2nde dimension : raccourcissemement +c + elseif ( d2old.gt.d2new ) then + typmod = 32 +c +c 2.3.3. ==> autres cas impossibles +c + else +c + codret = 4 +c + endif +c +c 2.4. ==> la 1ere dimension est positive ou nulle, la 2nde vaut 1 : +c tab(d1,1) +C + elseif ( d1old.ge.0 .and. d1new.ge.0 .and. + > d2old.eq.1 .and. d2new.eq.1 ) then +c +cgn write (ulsort,*) '2.3. ==> la 1ere dim est >=0, la 2nde =1' +c + lgold = d1old + lgnew = d1new +c +c 2.4.1. ==> 1ere dimension : allongement +c + if ( d1old.lt.d1new ) then + typmod = 11 +c +c 2.4.2. ==> 1ere dimension : raccourcissemement +c + elseif ( d1old.gt.d1new ) then + typmod = 12 +c +c 2.4.3. ==> autres cas impossibles +c + else +c + codret = 4 +c + endif +c +c 2.5. ==> la 1ere vaut 1, la 2nde dimension est positive ou nulle : +c tab(1,d2) +C + elseif ( d1old.eq.1 .and. d1new.eq.1 .and. + > d2old.ge.0 .and. d2new.ge.0 ) then +c +cgn write (ulsort,*) '2.5. ==> la 1ere dim est =1, la 2nde >=0' +c + lgold = d2old + lgnew = d2new +c +c 2.5.1. ==> 2nde dimension : allongement +c + if ( d2old.lt.d2new ) then + typmod = 21 +c +c 2.5.2. ==> 2nde dimension : raccourcissemement +c + elseif ( d2old.gt.d2new ) then + typmod = 22 +c +c 2.5.3. ==> autres cas impossibles +c + else + codret = 4 +c + endif +c +c 2.6. ==> la premiere dimension est strictement positive : tab(d1,d2) +c et la seconde etait ou devient nulle +c + elseif ( d1old.gt.0 .and. d1new.gt.0 .and. + > d2old.ge.0 .and. d2new.ge.0 ) then +c +cgn write (ulsort,*) '2.6. ==> la 1ere dimension est >0' + lgold = d1old*d2old + lgnew = d1new*d2new +c +c 2.6.1. ==> 2nde dimension : creation +c + if ( d2old.eq.0 ) then + typmod = 1 +c +c 2.6.2. ==> 2nde dimension : destruction +c + elseif ( d2new.eq.0 ) then + typmod = 2 +c +c 2.6.3. ==> pas de particularites +c + else + typmod = 5 + endif +c +c 2.7. ==> la seconde dimension est strictement positive : tab(d1,d2) +c et la premiere etait ou devient nulle +c + elseif ( d1old.ge.0 .and. d1new.ge.0 .and. + > d2old.gt.0 .and. d2new.gt.0 ) then +c +cgn write (ulsort,*) '2.7. ==> la 2nde dimension est >0' + lgold = d1old*d2old + lgnew = d1new*d2new +c +c 2.7.1. ==> 1ere dimension : creation +c + if ( d1old.eq.0 ) then + typmod = 3 +c +c 2.7.2. ==> 1ere dimension : destruction +c + elseif ( d1new.eq.0 ) then + typmod = 4 +c +c 2.7.3. ==> pas de particularites +c + else + typmod = 5 + endif +c +c 2.8. ==> la 1ere dimension est negative, la 2nde positive : tab(d1:d2) +C + elseif ( d1old.le.0 .and. d1new.le.0 .and. + > d2old.ge.0 .and. d2new.ge.0 ) then +c +cgn write (ulsort,*) '2.8. ==> la 1ere dim est <=0, la 2nde >=0' +c + lgold = d2old + 1 - d1old + lgnew = d2new + 1 - d1new +c +c 2.8.1. ==> 1ere dimension : allongement +c 2nde dimension : constante +c + if ( d1old.gt.d1new .and. d2old.eq.d2new ) then + typmod = -1 +c +c 2.8.2. ==> 1ere dimension : raccourcissemement +c 2nde dimension : constante +c + elseif ( d1old.lt.d1new .and. d2old.eq.d2new ) then + typmod = -3 +c +c 2.8.3. ==> 1ere dimension : constante < 0 +c 2nde dimension : allongement +c + elseif ( d1old.eq.d1new .and. d2old.lt.d2new ) then + typmod = -2 +c +c 2.8.4. ==> 1ere dimension : constante < 0 +c 2nde dimension : raccourcissemement +c + elseif ( d1old.eq.d1new .and. d2old.gt.d2new ) then + typmod = -4 +c +c 2.8.5. ==> pas de particularites +c + else + typmod = -5 + endif +cgn write (ulsort,*) '==> typmod = ', typmod +c +c 2.9. ==> le tableau de depart est de longueur nulle +c la 1ere dimension devient strcitement positive, la 2nde +c vaut 1, ou l'inverse : tab(d1,1) ou tab(1,d2) +c + elseif ( d1old.eq.0 .and. d1new.gt.0 .and. + > d2old.eq.0 .and. d2new.gt.0 ) then +c +cgn write (ulsort,*) '2.9. le tableau initial est de longueur 0' +c + lgold = 0 +c +c 2.9.1. ==> 1ere dimension valant 1 +c + if ( d1new.eq.1 ) then + lgnew = d2new + typmod = 41 +c +c 2.9.2. ==> 2nde dimension valant 1 +c + elseif ( d2new.eq.1 ) then + lgnew = d1new + typmod = 51 +c +c 2.9.3. ==> autres cas impossibles +c + else +c + codret = 4 +c + endif +c +c 2.10. ==> autres cas impossibles +c + else +c + write (ulsort,*) 'Ce cas est imprevu ???? ' +c + codret = 5 +c + endif +c +c==== +c 3. decodage du nom etendu +c determination du type du champ terminal +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Decodage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gbdnoe(nomet,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + codret = -3 +c + else if (idec.eq.1.or.idec.eq.2) then +c +c objet-terminal indefini ou non aloue +c + codret = -2 +c + else +c + call gbobal(objter,letype,codre0) + if ( codre0.ne.2) then +c +c objet-terminal non simple +c + codret = -1 + endif +c + endif +c + endif +c +c==== +c 4. appel aux fonctions de plus bas niveau, mais +c seulement si au moins une des dimensions a bouge. +c sinon, on ne fait rien ! +c +c letype -1 'entier' +c letype -2 'reel' +c letype -3 'chaine' +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Appel fonctions ; codret = ', codret +#endif +c +cgn if ( objter.eq.'MaCo002n')then +cgn print *,'typmod = ',typmod +cgn print *,'d1old, d1new, d2old, d2new = ', +cgn > d1old, d1new, d2old, d2new +cgn print *,'lgold, lgnew = ',lgold, lgnew +cgn endif + if ( codret.eq.0 ) then +c +c 4.1. ==> taille identique : recuperation du pointeur +c + if ( typmod.eq.0 ) then +c + call gbcara ( objter, iaux, point, ilong, type8 ) +c + codret = coergm +c +c 4.2. ==> changement de taille +c + else +c + if ( letype.eq.-1) then + call gmmodi ( objter, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c + elseif ( letype.eq.-2) then + call gmmodr ( objter, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c + elseif ( letype.eq.-3) then + call gmmods ( objter, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c + endif +c + codret = coergm +c + endif +c + else +c + objter = " " +c + endif +c +c==== +c 5. gestion des erreurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Gestions des erreurs ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) nomet//' ('//objter//')' + write (ulsort,texte(langue,5)) d1old, d2old + write (ulsort,texte(langue,6)) d1new, d2new + if ( abs(codret).le.7 .and. coergm.eq.0 ) then + iaux = 10+abs(codret) + write (ulsort,texte(langue,iaux)) + endif + write (ulsort,90000) +c +#include "envex2.h" +c + endif +c +90000 format (70('=')) +c + end +c +ctest integer ul, ptr, d1old, d1new, d2old, d2new +ctest character*8 obj +ctest ul = 6 +ctest ul = ulsort +ctest call gmmess(ul) +ctest write(ul,*)'init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'idem' +ctest d1new = -6 +ctest d2new = 8 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d2 monte' +ctest d1new = -6 +ctest d2new = 10 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d2 baisse' +ctest d1new = -6 +ctest d2new = 6 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +ctest write(ul,*)'d1 bouge' +c +ctest write(ul,*)'re init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 monte' +ctest d1new = -8 +ctest d2new = 8 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 baisse' +ctest d1new = -4 +ctest d2new = 8 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'re init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 monte & d2 monte' +ctest d1new = -8 +ctest d2new = 10 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'re init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 baisse & d2 baisse' +ctest d1new = -4 +ctest d2new = 6 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'re init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 monte & d2 baisse' +ctest d1new = -8 +ctest d2new = 6 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'re init' +ctest d1old=-6 +ctest d2old=8 +ctest codre1 = -d1old+d2old+1 +ctest call gmalot ( obj, 'entier ', codre1, ptr, codret ) +ctest call zzz(d1old,d2old,imem(ptr),0,ul) +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +c +ctest write(ul,*)'d1 baisse & d2 monte' +ctest d1new = -4 +ctest d2new = 10 +ctest call gmmod(obj,ptr, d1old, d1new, d2old, d2new, codret) +ctest d1old=d1new +ctest d2old=d2new +ctest call zzz(d1old,d2old,imem(ptr),1,ul) +ctest subroutine zzz(d1,d2,tab,opt,ulsort) +ctest integer d1, d2, opt,ulsort +ctest integer tab(d1:d2) +ctest if ( opt.eq.0 ) then +ctest do 1 , iaux = d1 , d2 +ctest tab(iaux) = iaux +ctest 1 continue +ctest else +ctest do 2 , iaux = d1 , d2 +ctest write(ulsort,20) iaux, tab(iaux) +ctest 2 continue +ctest endif +ctest 20 format(i4,' : ',i12) +ctest end diff --git a/src/tool/Gestion_MTU/gmmodg.F b/src/tool/Gestion_MTU/gmmodg.F new file mode 100644 index 00000000..165461ea --- /dev/null +++ b/src/tool/Gestion_MTU/gmmodg.F @@ -0,0 +1,334 @@ + subroutine gmmodg ( nomtab, lgold, lgnew, + > d1old, d1new, d2old, d2new, + > adunew, aduold, type8, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg, adug, + > nommxg, nomalg, tablte ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 09/93 +c ...................................................................... +c . +c . - interet: +c . si les tailles sont toutes positives : +c on passe de tab(d1old,d2old) a tab(d1new,d2new) +c . si les tailles d1x sont negatives et les tailles d2x positives : +c on passe de tab(d1old:d2old) a tab(d1new:d2new) +c . sinon : probleme ... +c . remarque : on peut aussi bien etendre que raccourcir +c . remarque : ceci marche meme si une des dimensions reste egale +c . a 1 mais ce n'est pas optimal ; il vaut mieux utiliser +c . le programme prevu pour les monodimensionnels, gmextg +c . +c . - realisation: +c . reallocation, recopie des donnees, +c . suppression de l'original, reaffectation du nom original +c . +c . - arguments: +c . donnees nomtab --> nom du tableau concerne (8 caracteres maxi) +c . lgold --> longueur avant +c . lgnew --> longueur apres +c . d1old --> premiere dimension avant +c . d1new --> premiere dimension apres +c . d2old --> seconde dimension avant +c . d2new --> seconde dimension apres +c . type8 --> type du tableau :r,i,s,d +c .modifies minmeg <--> valeur entiere memorisant la plus petite +c . dimension du dernier trou afin de connaitre +c . le passage le plus delicat rencontre au cours +c . de l'allocation. cette valeur est calculee +c . apres compression +c . ntroug <--> valeur entiere . nombre de trous present +c . nballg <--> nombre de tableaux deja alloues +c . totalg <--> valeur entiere cumulant les demandes +c . successives de memoire +c . ptroug <--> tableau entier contenant les pointeurs +c . repertoriant la position des trous +c . ltroug <--> tableau entier contenant la longueur des trous +c . ptallg <--> tableau entier contenant les pointeurs +c . repertoriant la position des tableaux +c . adug <--> adresses utiles des tableaux (retour de gbcara) +c . lgallg <--> tableau entier contenant la longueur des +c . tableaux +c . nommxg <--> chaine de caractere(*8) contenant le nom du +c . plus grand tableau associe a minmeg +c . nomalg <--> tableau de chaines de caracteres contenant +c . le nom associe a chaque tableau deja alloue +c .resultat adunew <-- pointeur associe apres extension +c . aduold <-- pointeur avant extension +c . tablte <-- nom du tableau temporaire +c . +c ...................................................................... +c . +c . +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMODG' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtail.h" +#include "gmtyge.h" +c +#include "gmimpr.h" +#include "envex1.h" +#include "gmlang.h" +#include "gmcoer.h" +c +c 0.3. ==> arguments +c + integer lgold, lgnew + integer d1old, d1new, d2old, d2new + integer adug(maxtab) +c + integer adunew, aduold + integer minmeg, ntroug, nballg, totalg + integer ptroug(maxtrs) , ltroug(maxtrs) + integer ptallg(maxtab) , lgallg(maxtab) +c + character*(*) nomtab + character*1 type8 + character*8 nommxg, nomalg(maxtab) + character*8 tablte +c +c 0.4. ==> variables locales +c + character*8 nomvar +c + integer iaux + integer i, icptg, iold + integer iptold + integer ltype, ad0, ad1 + integer nbcain +c + character*6 nompra +c + character*1 carint(1) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) + +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 1. preliminaires +c==== +c + coergm = 0 +c + if ( type8.eq.'i' .or. type8.eq.'I' ) then + ltype = tentie + ad0 = adcom(1) + ad1 = admem(1) + nompra = 'GMMODI' + elseif ( type8.eq.'r' .or. type8.eq.'R' ) then + nompra = 'GMMODR' + ltype = treel + ad0 = adcom(2) + ad1 = admem(2) + elseif ( type8.eq.'s' .or. type8.eq.'S' ) then + ltype = tchain + ad0 = adcom(3) + ad1 = admem(3) + nompra = 'GMMODS' + else + write(ulsort,20000) nompro, type8 + coergm = 5 + endif +c +20000 format (//2x,' ****** spg ',a6,' *****', + > /2x,'Le type ',a1,' est inconnu.', + > /2x,'Il faut r, i ou s', + > /2x,' ===> arret dans le gestionnaire de memoire') +c +c==== +c 2. verifications +c==== +c +c 2.1. ==> nature du nom +c aucun caractere n'est interdit, mais on met un blanc +c dans le tableau pour ne plus avoir de messages ftnchek +c + if ( coergm.eq.0 ) then +c + nbcain = 0 + carint(1) = ' ' + call gmntve ( nomtab, nomvar, nbcain, carint, coergm ) +c + if ( coergm.ne.0 ) then + write(ulsort,21100) nompro, nompra +21100 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6, + > /,4x,' ===> arret dans le gestionnaire de memoire') + coergm = 6 + endif +c + endif +c + if ( coergm.eq.0 ) then +c +c--- verif que le nom n'est utilise qu'une fois et une seule +c + icptg = 0 + do 22 i = 1 , nballg + if ( nomalg(i).eq.nomvar ) then + iold = i + icptg = icptg + 1 + endif + 22 continue +c + if ( icptg.eq.0 ) then + write(ulsort,20003) nompro, nompra, nomvar +20003 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6, + > /,4x,'Le tableau (',a8,') n''a pas ete alloue', + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,0,1,1) + elseif (icptg.gt.1) then + write(ulsort,20013) nompro, nompra, nomvar +20013 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6, + > /,4x,'Le tableau (',a8,') a ete alloue plusieurs fois' , + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,0,1,1) + endif +c + endif +c +c==== +c 3. traitement +c==== +c + if ( coergm.eq.0 ) then +c +c---- verif que l'ancienne taille correspond bien aux dimensions +c annoncees +c + if ( lgallg(iold).ne.lgold ) then + write(ulsort,30001) nompro, nompra, nomvar + if ( d1old.gt.0 ) then + write(ulsort,30002) d1old, d2old, lgold + else + write(ulsort,30003) -d1old, d2old, lgold + endif + write(ulsort,30004) lgallg(iold), d1old, d2old, d1new, d2new +30001 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6, + > /,4x,' pour le tableau ',a) +30002 format ( + > 4x,'L''ancienne taille annoncee ',i10,' x ',i10,' = ',i10) +30003 format ( + > 4x,'L''ancienne taille annoncee ',i10,' + ',i10,' = ',i10) +30004 format ( 4x,'ne correspond pas a la longueur en memoire ',i10, + > /,4x,'Pour memoire, on veut passer de ', + > /,4x,'(',i10,' ,',i10,' ) a (',i10,' ,',i10,' )', + > /,4x,' ===> arret dans le gestionnaire de memoire') + call ugstop( nompro,ulsort,0,1,1) + endif +c + iptold = ptallg(iold) +c + if ( modgm.eq.2 ) then +c +c mode dynamique : +c + aduold = (iptold-ad0)/ltype +c +c en particulier pour les "gros types", +c on n'a pas vraiment de garantie que la division precedente +c "tombe juste". Le fait d'avoir en fait alloue un peu plus grand +c (cf. appel a gbalme dans gmalog) permet de se mettre a l'abris +c de ce genre de probleme (entre autres). +c + if ( aduold*ltype .ge. iptold-ad0 ) then + aduold = aduold + 1 + else + aduold = aduold + 2 + endif +c + else if ( modgm.eq.1 ) then + aduold = ((ad1-ad0)/ltype) + iptold + 1 + else + aduold = ((ad1-ad0)/ltype) + iptold + endif +c +c---- en mode non dynamique, s'il n'y a plus de trou : erreur +c + if ( modgm.ne.2 ) then +c + if (ntroug.eq.0) then + write(ulsort,30005) nompro, nompra, nomvar +30005 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6, + > /,4x,' pour le tableau ',a8, + > /,4x,'Il n''y a plus de place') + call ugstop( nompro,ulsort,0,1,1) + endif +c + endif +c + endif +c +c---- +c 4. contrairement au cas monodimensionnel, +c on est oblige de creer un tableau different +c ailleurs car le rangement est tel que les memes valeurs ne sont +c plus a la meme place +c ex a(1,1)=1 a(1,2)=2 a(1,3)=3 +c a(2,1)=4 a(2,2)=5 a(2,3)=6 +c le tableau a(2x3) est range ainsi : 1 4 2 5 3 6 +c s'il devient un tableau a(3x3), les anciennes valeurs seront +c mises ainsi : 1 4 x 2 5 x 3 6 x +c---- +c + if ( coergm.eq.0 ) then +c + call gbntcr ( tablte ) + call gmalog ( tablte, adunew, lgnew, type8, + > minmeg, ntroug, nballg, totalg, + > ptroug, ltroug, ptallg, lgallg,adug, + > nommxg, nomalg ) +c + endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmmodi.F b/src/tool/Gestion_MTU/gmmodi.F new file mode 100644 index 00000000..1d6314af --- /dev/null +++ b/src/tool/Gestion_MTU/gmmodi.F @@ -0,0 +1,456 @@ + subroutine gmmodi ( nomtab, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 09/93 +c ...................................................................... +c . +c . si les tailles sont toutes positives : +c on passe de tab(d1old,d2old) a tab(d1new,d2new) +c . si les tailles d1x sont negatives et les tailles d2x positives : +c on passe de tab(d1old:d2old) a tab(d1new:d2new) +c . sinon : probleme ... +c . +c . - realisation: +c . tentative d'extension a l'extremite du tableau. +c . sinon reallocation recopie des donnees, +c . suppression de l'original, reaffectation du nom original +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a etendre (8 caracteres au plus) +c . typmod --> A. tableau de type tab(d1,1), d1>=0 +c . 11 : d1 : allongement, d2 : constant a 1 +c . 12 : d1 : raccourcissemement, d2 : constant a 1 +c . B. tableau de type tab(1,d2), d2>=0 +c . 21 : d1 : constant a 1, d2 : allongement +c . 22 : d1 : constant a 1, d2 : raccourcissemement +c . C. tableau de type tab(d1,d2) avec d1>0 et d2>=0 +c . 1 : d1 : pas de particularite, d2 : de 0 a >=0 +c . 2 : d1 : pas de particularite, d2 : de >=0 a 0 +c . 5 : pas de particularites +c . D. tableau de type tab(d1,d2) avec d1>0 et d2>0 +c . 3 : d1 : de 0 a >=0, d2 : pas de particularite +c . 4 : d1 : de >=0 a 0, d2 : pas de particularite +c . 5 : pas de particularites +c . E. tableau de type tab(0:d2) +c . 31 : d1 : constant a 0, d2 : allongement +c . 32 : d1 : constant a 0, d2 : raccourcissemement +c . F. tableau de type tab(d1:d2) d1<=0 et d2>=0 +c . -1 : d1 : allongement, d2 : constante +c . -2 : d1 : constante, d2 : allongement +c . -3 : d1 : raccourcissemement, d2 : constante +c . -4 : d1 : constante, d2 : raccourcissemement +c . -5 : pas de particularites +c . G. tableau de longueur nulle passant au +c . type tab(1:d2) ou tab(d1:1) +c . 41 : tab(1:d2) +c . 51 : tab(d1:1) +c . H. tableau devenant de longueur nulle +c . 61 : +c . lgold --> longueur avant +c . lgnew --> longueur apres +c . d1old --> premiere dimension avant +c . d1new --> premiere dimension apres +c . d2old --> seconde dimension avant +c . d2new --> seconde dimension apres +c .resultat point <-- pointeur associe +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMODI' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmadui.h" +#include "gmtren.h" +#include "gmalen.h" +#include "gmindi.h" +#include "gmindf.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character *(*) nomtab +c + integer typmod, lgold, lgnew + integer d1old, d1new, d2old, d2new + integer point +c +c 0.4. ==> variables locales +c + integer iaux + integer i, ideb, ifin, j, d1min, d2min + integer kdeb, kfin, k, kaux + integer iptold + integer lgallo +c + character*8 nomvar, tablte + character*1 type1 +c + logical detlg0 + logical satien +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'typmod =', typmod + write (ulsort,*) 'lgold =', lgold + write (ulsort,*) 'lgnew=', lgnew +#endif +c + coergm = 0 +c +c==== +c 2. verifications initiales +c==== +c + call gmcata ( nomtab, lgallo, + > nballi, nomali, lgalli ) +c + if ( lgallo.ne.lgold ) then + write(ulsort,20000) nompro, nomtab, lgallo, lgold +20000 format ( 2x,'Probleme dans ',a6,' pour le tableau ',a, + > /,4x,'. Longueur d''allocation : ',i10 , + > /,4x,'. Longueur ''ancienne'' : ',i10 , + > /,4x,' ===> arret dans le gestionnaire de memoire') + coergm = 4 + endif +c +c==== +c 3. appel aux programmes generiques +c==== +c + if ( coergm.eq.0 ) then +c + type1 = 'i' +c +c 3.1. ==> allongement d'un tableau conceptuellement 1D +c . 1 : tableau tab(d1,0) passant a tab(d1,d2) +c . 3 : tableau tab(0,d2) passant a tab(d1,d2) +c . 11, 21 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre augmente +c . 31 : tableau tab(0:d2) dont d2 augmente +c . 41 : tableau tab(0,0) passant a tab(1:d2) et d2>=0 +c . 51 : tableau tab(0,0) passant a tab(d1:1) et d1>=0 +c +cgn if (typmod.eq.32 .or. typmod.eq.31 ) then +cgn if ( nomtab.eq.'MaEn002f' ) then +cgn write (ulsort,*) 'nomtab = ', nomtab +cgn write(ulsort,*) 'typmod = ',typmod +cgn write(ulsort,*) 'lgold, lgnew = ',lgold, lgnew +cgn write(ulsort,*) 'd1old, d1new = ',d1old, d1new +cgn write(ulsort,*) 'd2old, d2new = ',d2old, d2new +cgn endif +cgn endif + if ( typmod.eq.1 .or. typmod.eq.3 .or. + > typmod.eq.11 .or. typmod.eq.21 .or. typmod.eq.31 .or. + > typmod.eq.41 .or. typmod.eq.51 ) then +c + call gmextg + > ( nomtab, point, lgnew, iptold, lgold, type1, + > minmei, ntroui, nballi, totali, + > ptroui, ltroui, ptalli, lgalli, adui, + > nommxi, nomali, satien, tablte ) +c +c 3.2. ==> raccourcissement d'un tableau conceptuellement 1D +c . 12, 22 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre diminue +c . 32 : tableau tab(0:d2) dont d2 diminue +c attention : il ne faut pas traiter ici des diminutions +c qui conduisent a un tableau de taille nulle +c sinon on risque de creer une zone complete de +c taille nulle, ce qui pose des problemes a la +c compression. on passera donc par le cas general +c ce qui permettra de regrouper ces tableaux de +c taille nulle en tete de memoire. +c + elseif ( typmod.eq.12 .or. typmod.eq.22 .or. typmod.eq.32 ) then +c + detlg0 = .false. +c + call gmdesi ( nomtab, lgold-lgnew , detlg0 ) + satien = .true. +c +c rafraichissement eventuel du pointeur point +c (dont la valeur a pu changer, en mode gm "dynamique") +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif + do 321 , i = 1, nballi + if ( nomali(i).eq.nomvar ) then + point = adui(i) + goto 322 + endif + 321 continue +c + write(ulsort,30000) nompro, nomvar + coergm = 7 +c +30000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau a modifier ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + 322 continue +c +c 3.3. ==> . 2 : tableau tab(d1,d2) passant a tab(d1,0) +c . 4 : tableau tab(d1,d2) passant a tab(0,d2) +c . 5 : pas de particularites +c . negatif : tableau de type tab(d1:d2) d1<=0 et d2>=0 +c + else +c + satien = .false. +c +cgn if ( nomtab.eq.'MaCo002n' ) then +cgn write(ulsort,*) 'appel de gmmodg' +cgn endif + call gmmodg + > ( nomtab, lgold, lgnew, + > d1old, d1new, d2old, d2new, + > point, iptold, type1, + > minmei, ntroui, nballi, totali, + > ptroui, ltroui, ptalli, lgalli, adui, + > nommxi, nomali, tablte ) +c +cgn if ( nomtab.eq.'MaCo002n' ) then +cgn write(ulsort,*) 'retour de gmmodg' +cgn endif + endif +c + endif +c +c==== +c 4. remplissage correct du tableau +c==== +c + if ( coergm.eq.0 ) then +c +c 4.1. ==> si le tableau a pu etre etendu sur sa fin, il faut +c initialiser a la valeur indefinie le complement +c + if ( satien ) then +c + if ( lindef.eq.0 ) then + ideb = point+lgold + ifin = point+lgnew-1 + do 41 , i= ideb ,ifin + imem(i) = iindef + 41 continue + endif +c +c 4.2. ==> si le tableau a du etre recree ailleurs, il faut recopier +c + else +c +c 4.2.1. ==> on commence eventuellement a mettre une valeur par defaut +c partout +c + if ( lindef.eq.0 ) then + ideb = point + ifin = point+lgnew-1 + do 42 , i= ideb ,ifin + imem(i) = iindef + 42 continue + endif +c +c 4.2.2. ==> copie des valeurs +c 4.2.2.1. ==> tableau 1D : +c avant indice : 1 2 3 4 +c valeur : 6 1 0 5 +c Il y a 2 cas de figure : +c . allongement : +c indice : 1 2 3 4 5 6 +c valeur : 6 1 0 5 x x +c . raccourcissement : +c indice : 1 2 +c valeur : 6 1 +c +c il suffit de recopier les premieres valeurs aux premieres places. +c le nombre de valeurs a copier est le min entre le nombre qui etait +c present et le nombre qu'on veut +c + if ( typmod.ge.11 .and. typmod.le.32 ) then +c + kdeb = iptold + kfin = kdeb + min(lgold,lgnew) - 1 + kaux = point - kdeb + do 431 , k = kdeb , kfin + imem(kaux+k) = imem(k) + 431 continue +c +c 4.2.2.2. ==> tableau tab(d1,d2) : +c il faut recopier les anciennes valeurs a leurs places : +c ex. a(1,1)=1 a(1,2)=2 a(1,3)=3 +c a(2,1)=4 a(2,2)=5 a(2,3)=6 +c le tableau a(2x3) est range ainsi : 1 4 2 5 3 6 +c s'il devient un tableau a(3x3), les anciennes valeurs seront +c mises ainsi : 1 4 x 2 5 x 3 6 x +c new(i,j) = old(i,j) +c <==> new (d1new*(j-1)+i) = old (d1old*(j-1)+i) +c <==> mem (point-1+d1new*(j-1)+i) = mem (iptold-1+d1old*(j-1)+i) +c +c remarque : rien n'est a faire pour les cas 1 et 2 car l'un des +c deux tableaux (avant ou apres) est de longueur nulle. +c + elseif ( typmod.eq.5 ) then +c + d2min = min(d2old,d2new) + d1min = min(d1old,d1new) +cgn if ( nomtab.eq.'MaCo002n' ) then +cgn write(ulsort,*) 'd1min, d2min = ', d1min, d2min +cgn endif + do 432 , j = 1 , d2min + kdeb = iptold + d1old*(j-1) + kfin = kdeb + d1min - 1 + kaux = point - iptold + (d1new-d1old)*(j-1) + do 4321 , k = kdeb , kfin + imem(kaux+k) = imem(k) + 4321 continue + 432 continue +cgn if ( nomtab.eq.'MaCo002n' ) then +cgn write(ulsort,*) 'fin de 432' +cgn endif +c +c 4.2.2.3. ==> tableau tab(d1:d2) : +c il faut recopier les anciennes valeurs a leurs places : +c avant indice : -6 -5 -4 -3 -2 -1 0 1 2 3 4 +c valeur : 3 2 8 2 7 9 6 1 0 5 3 +c Il y a 4 cas de figure : +c . allongement des deux cotes : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,6) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : x x 3 2 8 2 7 9 6 1 0 5 3 x x +c . raccourcissement des deux cotes : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,2) +c indice : -4 -3 -2 -1 0 1 2 +c valeur : 8 2 7 9 6 1 0 +c . allongement vers les negatifs, raccourcissement vers les positifs : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,2) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 +c valeur : x x 3 2 8 2 7 9 6 1 0 +c . raccourcissement vers les negatifs, allongement vers les positifs : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,6) +c indice : -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : 8 2 7 9 6 1 0 5 3 x x +c +c On doit donc transferer la partie correspondant a l'intervalle +c commun autour du point central. Ce point central correspond a ce +c qui est vu de l'exterieur comme tab(0). +c Son adresse memoire est : +c . dans l'ancien tableau : iptold - d1old +c . dans le nouveau tableau : point - d1new +c On doit transferer : +c . min(-d1old,-d1new) cases avant ce point central +c . min(d2old,d2new) cases apres ce point central +c + elseif ( typmod.le.0 ) then +c + kdeb = iptold - d1old - min(-d1old,-d1new) + kfin = iptold - d1old + min(d2old,d2new) + kaux = point - d1new - iptold + d1old + do 4331 , k = kdeb , kfin + imem(kaux+k) = imem(k) + 4331 continue +c + endif +c +c 4.2.3. ==> renommage du tableau +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif +c + call gmdesa (nomvar) + if ( coergm.ne.0 ) then + write(ulsort,40001) nompro, nomvar + call ugstop(nompro,ulsort,1,1,1) + endif +c + do 4231 , i=1,nballi + if ( nomali(i).eq.tablte ) then + nomali(i) = nomvar + goto 4232 + endif + 4231 continue +c + write(ulsort,40000) nompro, tablte + call ugstop(nompro,ulsort,1,1,1) +c + 4232 continue + if ( nommxi.eq.tablte ) then + nommxi = nomvar + endif +c + call gbntde ( tablte, coergm ) +c + endif +c +40000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau temporaire ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c +40001 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Desallocation temporaire du ', + > /4x,'tableau a modifier ',a8,' impossible', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmmodr.F b/src/tool/Gestion_MTU/gmmodr.F new file mode 100644 index 00000000..ed6ca689 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmodr.F @@ -0,0 +1,435 @@ + subroutine gmmodr ( nomtab, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 09/93 +c ...................................................................... +c . +c . si les tailles sont toutes positives : +c on passe de tab(d1old,d2old) a tab(d1new,d2new) +c . si les tailles d1x sont negatives et les tailles d2x positives : +c on passe de tab(d1old:d2old) a tab(d1new:d2new) +c . sinon : probleme ... +c . +c . - realisation: +c . tentative d'extension a l'extremite du tableau. +c . sinon reallocation recopie des donnees, +c . suppression de l'original, reaffectation du nom original +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a etendre (8 caracteres au plus) +c . typmod --> A. tableau de type tab(d1,1), d1>=0 +c . 11 : d1 : allongement, d2 : constant a 1 +c . 12 : d1 : raccourcissemement, d2 : constant a 1 +c . B. tableau de type tab(1,d2), d2>=0 +c . 21 : d1 : constant a 1, d2 : allongement +c . 22 : d1 : constant a 1, d2 : raccourcissemement +c . C. tableau de type tab(d1,d2) avec d1>0 et d2>=0 +c . 1 : d1 : pas de particularite, d2 : de 0 a >=0 +c . 2 : d1 : pas de particularite, d2 : de >=0 a 0 +c . 5 : pas de particularites +c . D. tableau de type tab(d1,d2) avec d1>0 et d2>0 +c . 3 : d1 : de 0 a >=0, d2 : pas de particularite +c . 4 : d1 : de >=0 a 0, d2 : pas de particularite +c . 5 : pas de particularites +c . E. tableau de type tab(0:d2) +c . 31 : d1 : constant a 0, d2 : allongement +c . 32 : d1 : constant a 0, d2 : raccourcissemement +c . F. tableau de type tab(d1:d2) d1<=0 et d2>=0 +c . -1 : d1 : allongement, d2 : constante +c . -2 : d1 : constante, d2 : allongement +c . -3 : d1 : raccourcissemement, d2 : constante +c . -4 : d1 : constante, d2 : raccourcissemement +c . -5 : pas de particularites +c . G. tableau de longueur nulle passant au +c . type tab(1:d2) ou tab(d1:1) +c . 41 : tab(1:d2) +c . 51 : tab(d1:1) +c . H. tableau devenant de longueur nulle +c . 61 : +c . lgold --> longueur avant +c . lgnew --> longueur apres +c . d1old --> premiere dimension avant +c . d1new --> premiere dimension apres +c . d2old --> seconde dimension avant +c . d2new --> seconde dimension apres +c .resultat point <-- pointeur associe +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMODR' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmreel.h" +#include "gmadur.h" +#include "gmtrrl.h" +#include "gmalrl.h" +#include "gmindf.h" +#include "gmindr.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character *(*) nomtab +c + integer typmod, lgold, lgnew + integer d1old, d1new, d2old, d2new + integer point +c +c 0.4. ==> variables locales +c + integer iaux + integer i, ideb, ifin, j, d1min, d2min + integer kdeb, kfin, k, kaux + integer iptold + integer lgallo +c + character*8 nomvar, tablte + character*1 type1 +c + logical detlg0 + logical satien +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'typmod =', typmod +#endif +c + coergm = 0 +c +c==== +c 2. verifications initiales +c==== +c + call gmcata ( nomtab, lgallo, + > nballr, nomalr, lgallr ) +c + if ( lgallo.ne.lgold ) then + write(ulsort,20000) nompro, nomtab, lgallo, lgold +20000 format ( 2x,'Probleme dans ',a6,' pour le tableau ',a, + > /,4x,'. Longueur d''allocation : ',i10 , + > /,4x,'. Longueur ''ancienne'' : ',i10 , + > /,4x,' ===> arret dans le gestionnaire de memoire') + coergm = 4 + endif +c +c==== +c 3. appel aux programmes generiques +c==== +c + if ( coergm.eq.0 ) then +c + type1 = 'r' +c +c 3.1. ==> allongement d'un tableau conceptuellement 1D +c . 1 : tableau tab(d1,0) passant a tab(d1,d2) +c . 3 : tableau tab(0,d2) passant a tab(d1,d2) +c . 11, 21 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre augmente +c . 31 : tableau tab(0:d2) dont d2 augmente +c . 41 : tableau tab(0,0) passant a tab(1:d2) et d2>=0 +c . 51 : tableau tab(0,0) passant a tab(d1:1) et d1>=0 +c +cgn write(ulsort,*) typmod, lgold, lgnew + if ( typmod.eq.1 .or. typmod.eq.3 .or. + > typmod.eq.11 .or. typmod.eq.21 .or. typmod.eq.31 .or. + > typmod.eq.41 .or. typmod.eq.51 ) then +c + call gmextg + > ( nomtab, point, lgnew, iptold, lgold, type1, + > minmer, ntrour, nballr, totalr, + > ptrour, ltrour, ptallr, lgallr, adur, + > nommxr, nomalr, satien, tablte ) +c +c 1.2. ==> raccourcissement d'un tableau conceptuellement 1D +c . 12, 22 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre diminue +c . 32 : tableau tab(0:d2) dont d2 diminue +c attention : il ne faut pas traiter ici des diminutions +c qui conduisent a un tableau de taille nulle +c sinon on risque de creer une zone complete de +c taille nulle, ce qui pose des problemes a la +c compression. on passera donc par le cas general +c ce qui permettra de regrouper ces tableaux de +c taille nulle en tete de memoire. +c + elseif ( typmod.eq.12 .or. typmod.eq.22 .or.typmod.eq.32 ) then +c + detlg0 = .false. +c + call gmdesr ( nomtab, lgold-lgnew , detlg0 ) +c + satien = .true. +c +c rafraichissement eventuel du pointeur point +c (dont la valeur a pu changer, en mode gm "dynamique") +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif + do 321 , i = 1, nballr + if ( nomalr(i).eq.nomvar ) then + point = adur(i) + goto 322 + endif + 321 continue +c + write(ulsort,30000) nompro, nomvar + coergm = 7 +c +30000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau a modifier ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + 322 continue +c +c 3.3. ==> . 2 : tableau tab(d1,d2) passant a tab(d1,0) +c . 4 : tableau tab(d1,d2) passant a tab(0,d2) +c . 5 : pas de particularites +c . negatif : tableau de type tab(d1:d2) d1<=0 et d2>=0 +c + else +c + satien = .false. +c + call gmmodg + > ( nomtab, lgold, lgnew, + > d1old, d1new, d2old, d2new, + > point, iptold, type1, + > minmer, ntrour, nballr, totalr, + > ptrour, ltrour, ptallr, lgallr, adur, + > nommxr, nomalr, tablte ) +c + endif +c + endif +c +c==== +c 4. remplissage correct du tableau +c==== +c + if ( coergm.eq.0 ) then +c +c 4.1. ==> si le tableau a pu etre etendu sur sa fin, il faut +c initialiser a la valeur indefinie le complement +c + if ( satien ) then +c + if ( lindef.eq.0 ) then + ideb = point+lgold + ifin = point+lgnew-1 + do 41 , i= ideb ,ifin + rmem(i) = rindef + 41 continue + endif +c +c 4.2. ==> si le tableau a du etre recree ailleurs, il faut recopier +c + else +c +c 4.2.1. ==> on commence eventuellement a mettre une valeur par defaut +c partout +c + if ( lindef.eq.0 ) then + ideb = point + ifin = point+lgnew-1 + do 42 , i= ideb ,ifin + rmem(i) = rindef + 42 continue + endif +c +c 4.2.2. ==> copie des valeurs +c 4.2.2.1. ==> tableau 1D : +c avant indice : 1 2 3 4 +c valeur : 6 1 0 5 +c Il y a 2 cas de figure : +c . allongement : +c indice : 1 2 3 4 5 6 +c valeur : 6 1 0 5 x x +c . raccourcissement : +c indice : 1 2 +c valeur : 6 1 +c +c il suffit de recopier les premieres valeurs aux premieres places. +c le nombre de valeurs a copier est le min entre le nombre qui etait +c present et le nombre qu'on veut +c + if ( typmod.ge.11 .and. typmod.le.32 ) then +c + kdeb = iptold + kfin = kdeb + min(lgold,lgnew) - 1 + kaux = point - kdeb + do 431 , k = kdeb , kfin + rmem(kaux+k) = rmem(k) + 431 continue +c +c 4.2.2.2. ==> tableau tab(d1,d2) : +c il faut recopier les anciennes valeurs a leurs places : +c ex. a(1,1)=1 a(1,2)=2 a(1,3)=3 +c a(2,1)=4 a(2,2)=5 a(2,3)=6 +c le tableau a(2x3) est range ainsi : 1 4 2 5 3 6 +c s'il devient un tableau a(3x3), les anciennes valeurs seront +c mises ainsi : 1 4 x 2 5 x 3 6 x +c new(i,j) = old(i,j) +c <==> new (d1new*(j-1)+i) = old (d1old*(j-1)+i) +c <==> mem (point-1+d1new*(j-1)+i) = mem (iptold-1+d1old*(j-1)+i) +c +c remarque : rien n'est a faire pour les cas 1 et 2 car l'un des +c deux tableaux (avant ou apres) est de longueur nulle. +c + elseif ( typmod.eq.5 ) then +c + d2min = min(d2old,d2new) + d1min = min(d1old,d1new) + do 432 , j = 1 , d2min + kdeb = iptold + d1old*(j-1) + kfin = kdeb + d1min - 1 + kaux = point - iptold + (d1new-d1old)*(j-1) + do 4321 , k = kdeb , kfin + rmem(kaux+k) = rmem(k) + 4321 continue + 432 continue +c +c 4.2.2.3. ==> tableau tab(d1:d2) : +c il faut recopier les anciennes valeurs a leurs places : +c avant indice : -6 -5 -4 -3 -2 -1 0 1 2 3 4 +c valeur : 3 2 8 2 7 9 6 1 0 5 3 +c Il y a 4 cas de figure : +c . allongement des deux cotes : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,6) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : x x 3 2 8 2 7 9 6 1 0 5 3 x x +c . raccourcissement des deux cotes : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,2) +c indice : -4 -3 -2 -1 0 1 2 +c valeur : 8 2 7 9 6 1 0 +c . allongement vers les negatifs, raccourcissement vers les positifs : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,2) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 +c valeur : x x 3 2 8 2 7 9 6 1 0 +c . raccourcissement vers les negatifs, allongement vers les positifs : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,6) +c indice : -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : 8 2 7 9 6 1 0 5 3 x x +c +c On doit donc transferer la partie correspondant a l'intervalle +c commun autour du point central. Ce point central correspond a ce +c qui est vu de l'exterieur comme tab(0). +c Son adresse memoire est : +c . dans l'ancien tableau : iptold - d1old +c . dans le nouveau tableau : point - d1new +c On doit transferer : +c . min(-d1old,-d1new) cases avant ce point central +c . min(d2old,d2new) cases apres ce point central +c + elseif ( typmod.le.0 ) then +c + kdeb = iptold - d1old - min(-d1old,-d1new) + kfin = iptold - d1old + min(d2old,d2new) + kaux = point - d1new - iptold + d1old + do 4331 , k = kdeb , kfin + rmem(kaux+k) = rmem(k) + 4331 continue +c + endif +c +c 4.2.3. ==> renommage du tableau +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif +c + call gmdesa (nomvar) + if ( coergm.ne.0 ) then + write(ulsort,40001) nompro, nomvar + call ugstop(nompro,ulsort,1,1,1) + endif +c + do 4231 , i=1,nballr + if ( nomalr(i).eq.tablte ) then + nomalr(i) = nomvar + goto 4232 + endif + 4231 continue +c + write(ulsort,40000) nompro, tablte + call ugstop(nompro,ulsort,1,1,1) +c + 4232 continue + if ( nommxr.eq.tablte ) then + nommxr = nomvar + endif +c + call gbntde ( tablte, coergm ) +c + endif +c +40000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau temporaire ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c +40001 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Desallocation temporaire du ', + > /4x,'tableau a modifier ',a8,' impossible', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmmods.F b/src/tool/Gestion_MTU/gmmods.F new file mode 100644 index 00000000..155175d9 --- /dev/null +++ b/src/tool/Gestion_MTU/gmmods.F @@ -0,0 +1,435 @@ + subroutine gmmods ( nomtab, typmod, lgold, lgnew, + > point, d1old, d1new, d2old, d2new ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c ...................................................................... +c . auteur : gn 09/93 +c ...................................................................... +c . +c . si les tailles sont toutes positives : +c on passe de tab(d1old,d2old) a tab(d1new,d2new) +c . si les tailles d1x sont negatives et les tailles d2x positives : +c on passe de tab(d1old:d2old) a tab(d1new:d2new) +c . sinon : probleme ... +c . +c . - realisation: +c . tentative d'extension a l'extremite du tableau. +c . sinon reallocation recopie des donnees, +c . suppression de l'original, reaffectation du nom original +c . +c . - arguments: +c . donnees nomtab --> nom du tableau a etendre (8 caracteres au plus) +c . typmod --> A. tableau de type tab(d1,1), d1>=0 +c . 11 : d1 : allongement, d2 : constant a 1 +c . 12 : d1 : raccourcissemement, d2 : constant a 1 +c . B. tableau de type tab(1,d2), d2>=0 +c . 21 : d1 : constant a 1, d2 : allongement +c . 22 : d1 : constant a 1, d2 : raccourcissemement +c . C. tableau de type tab(d1,d2) avec d1>0 et d2>=0 +c . 1 : d1 : pas de particularite, d2 : de 0 a >=0 +c . 2 : d1 : pas de particularite, d2 : de >=0 a 0 +c . 5 : pas de particularites +c . D. tableau de type tab(d1,d2) avec d1>0 et d2>0 +c . 3 : d1 : de 0 a >=0, d2 : pas de particularite +c . 4 : d1 : de >=0 a 0, d2 : pas de particularite +c . 5 : pas de particularites +c . E. tableau de type tab(0:d2) +c . 31 : d1 : constant a 0, d2 : allongement +c . 32 : d1 : constant a 0, d2 : raccourcissemement +c . F. tableau de type tab(d1:d2) d1<=0 et d2>=0 +c . -1 : d1 : allongement, d2 : constante +c . -2 : d1 : constante, d2 : allongement +c . -3 : d1 : raccourcissemement, d2 : constante +c . -4 : d1 : constante, d2 : raccourcissemement +c . -5 : pas de particularites +c . G. tableau de longueur nulle passant au +c . type tab(1:d2) ou tab(d1:1) +c . 41 : tab(1:d2) +c . 51 : tab(d1:1) +c . H. tableau devenant de longueur nulle +c . 61 : +c . lgold --> longueur avant +c . lgnew --> longueur apres +c . d1old --> premiere dimension avant +c . d1new --> premiere dimension apres +c . d2old --> seconde dimension avant +c . d2new --> seconde dimension apres +c .resultat point <-- pointeur associe +c ...................................................................... +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMODS' ) +c +#include "genbla.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +#include "gmadus.h" +#include "gmtrst.h" +#include "gmalst.h" +#include "gminds.h" +#include "gmindf.h" +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character *(*) nomtab +c + integer typmod, lgold, lgnew + integer d1old, d1new, d2old, d2new + integer point +c +c 0.4. ==> variables locales +c + integer iaux + integer i, ideb, ifin, j, d1min, d2min + integer kdeb, kfin, k, kaux + integer iptold + integer lgallo +c + character*8 nomvar, tablte + character*1 type1 +c + logical detlg0 + logical satien +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'typmod =', typmod +#endif +c + coergm = 0 +c +c==== +c 2. verifications initiales +c==== +c + call gmcata ( nomtab, lgallo, + > nballs, nomals, lgalls ) +c + if ( lgallo.ne.lgold ) then + write(ulsort,20000) nompro, nomtab, lgallo, lgold +20000 format ( 2x,'Probleme dans ',a6,' pour le tableau ',a, + > /,4x,'. Longueur d''allocation : ',i10 , + > /,4x,'. Longueur ''ancienne'' : ',i10 , + > /,4x,' ===> arret dans le gestionnaire de memoire') + coergm = 4 + endif +c +c==== +c 3. appel aux programmes generiques +c==== +c + if ( coergm.eq.0 ) then +c + type1 = 's' +c +c 3.1. ==> allongement d'un tableau conceptuellement 1D +c . 1 : tableau tab(d1,0) passant a tab(d1,d2) +c . 3 : tableau tab(0,d2) passant a tab(d1,d2) +c . 11, 21 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre augmente +c . 31 : tableau tab(0:d2) dont d2 augmente +c . 41 : tableau tab(0,0) passant a tab(1:d2) et d2>=0 +c . 51 : tableau tab(0,0) passant a tab(d1:1) et d1>=0 +c +cgn write(ulsort,*) typmod, lgold, lgnew + if ( typmod.eq.1 .or. typmod.eq.3 .or. + > typmod.eq.11 .or. typmod.eq.21 .or. typmod.eq.31 .or. + > typmod.eq.41 .or. typmod.eq.51 ) then +c + call gmextg + > ( nomtab, point, lgnew, iptold, lgold, type1, + > minmes, ntrous, nballs, totals, + > ptrous, ltrous, ptalls, lgalls, adus, + > nommxs, nomals, satien, tablte ) +c +c 3.2. ==> raccourcissement d'un tableau conceptuellement 1D +c . 12, 22 : tableau tab(d1,d2), dont l'une des dimensions +c vaut toujours 1 et dont l'autre diminue +c . 32 : tableau tab(0:d2) dont d2 diminue +c attention : il ne faut pas traiter ici des diminutions +c qui conduisent a un tableau de taille nulle +c sinon on risque de creer une zone complete de +c taille nulle, ce qui pose des problemes a la +c compression. on passera donc par le cas general +c ce qui permettra de regrouper ces tableaux de +c taille nulle en tete de memoire. +c + elseif ( typmod.eq.12 .or. typmod.eq.22 .or.typmod.eq.32 ) then +c + detlg0 = .false. +c + call gmdess ( nomtab, lgold-lgnew , detlg0 ) +c + satien = .true. +c +c rafraichissement eventuel du pointeur point +c (dont la valeur a pu changer, en mode gm "dynamique") +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif + do 321 , i = 1, nballs + if ( nomals(i).eq.nomvar ) then + point = adus(i) + goto 322 + endif + 321 continue +c + write(ulsort,30000) nompro, nomvar + coergm = 7 +c +30000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau a modifier ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + 322 continue +c +c 3.3. ==> . 2 : tableau tab(d1,d2) passant a tab(d1,0) +c . 4 : tableau tab(d1,d2) passant a tab(0,d2) +c . 5 : pas de particularites +c . negatif : tableau de type tab(d1:d2) d1<=0 et d2>=0 +c + else +c + satien = .false. +c + call gmmodg + > ( nomtab, lgold, lgnew, + > d1old, d1new, d2old, d2new, + > point, iptold, type1, + > minmes, ntrous, nballs, totals, + > ptrous, ltrous, ptalls, lgalls, adus, + > nommxs, nomals, tablte ) +c + endif +c + endif +c +c==== +c 4. remplissage correct du tableau +c==== +c + if ( coergm.eq.0 ) then +c +c 4.1. ==> si le tableau a pu etre etendu sur sa fin, il faut +c initialiser a la valeur indefinie le complement +c + if ( satien ) then +c + if ( lindef.eq.0 ) then + ideb = point+lgold + ifin = point+lgnew-1 + do 41 , i= ideb ,ifin + smem(i) = sindef + 41 continue + endif +c +c 4.2. ==> si le tableau a du etre recree ailleurs, il faut recopier +c + else +c +c 4.2.1. ==> on commence eventuellement a mettre une valeur par defaut +c partout +c + if ( lindef.eq.0 ) then + ideb = point + ifin = point+lgnew-1 + do 42 , i= ideb ,ifin + smem(i) = sindef + 42 continue + endif +c +c 4.2.2. ==> copie des valeurs +c 4.2.2.1. ==> tableau 1D : +c avant indice : 1 2 3 4 +c valeur : 6 1 0 5 +c Il y a 2 cas de figure : +c . allongement : +c indice : 1 2 3 4 5 6 +c valeur : 6 1 0 5 x x +c . raccourcissement : +c indice : 1 2 +c valeur : 6 1 +c +c il suffit de recopier les premieres valeurs aux premieres places. +c le nombre de valeurs a copier est le min entre le nombre qui etait +c present et le nombre qu'on veut +c + if ( typmod.ge.11 .and. typmod.le.32 ) then +c + kdeb = iptold + kfin = kdeb + min(lgold,lgnew) - 1 + kaux = point - kdeb + do 431 , k = kdeb , kfin + smem(kaux+k) = smem(k) + 431 continue +c +c 4.2.2.2. ==> tableau tab(d1,d2) : +c il faut recopier les anciennes valeurs a leurs places : +c ex. a(1,1)=1 a(1,2)=2 a(1,3)=3 +c a(2,1)=4 a(2,2)=5 a(2,3)=6 +c le tableau a(2x3) est range ainsi : 1 4 2 5 3 6 +c s'il devient un tableau a(3x3), les anciennes valeurs seront +c mises ainsi : 1 4 x 2 5 x 3 6 x +c new(i,j) = old(i,j) +c <==> new (d1new*(j-1)+i) = old (d1old*(j-1)+i) +c <==> mem (point-1+d1new*(j-1)+i) = mem (iptold-1+d1old*(j-1)+i) +c +c remarque : rien n'est a faire pour les cas 1 et 2 car l'un des +c deux tableaux (avant ou apres) est de longueur nulle. +c + elseif ( typmod.eq.5 ) then +c + d2min = min(d2old,d2new) + d1min = min(d1old,d1new) + do 432 , j = 1 , d2min + kdeb = iptold + d1old*(j-1) + kfin = kdeb + d1min - 1 + kaux = point - iptold + (d1new-d1old)*(j-1) + do 4321 , k = kdeb , kfin + smem(kaux+k) = smem(k) + 4321 continue + 432 continue +c +c 4.2.2.3. ==> tableau tab(d1:d2) : +c il faut recopier les anciennes valeurs a leurs places : +c avant indice : -6 -5 -4 -3 -2 -1 0 1 2 3 4 +c valeur : 3 2 8 2 7 9 6 1 0 5 3 +c Il y a 4 cas de figure : +c . allongement des deux cotes : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,6) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : x x 3 2 8 2 7 9 6 1 0 5 3 x x +c . raccourcissement des deux cotes : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,2) +c indice : -4 -3 -2 -1 0 1 2 +c valeur : 8 2 7 9 6 1 0 +c . allongement vers les negatifs, raccourcissement vers les positifs : +c (d1old,d2old) = (-6,-8) et (d2old,d2new) = (3,2) +c indice : -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 +c valeur : x x 3 2 8 2 7 9 6 1 0 +c . raccourcissement vers les negatifs, allongement vers les positifs : +c (d1old,d2old) = (-6,-4) et (d2old,d2new) = (3,6) +c indice : -4 -3 -2 -1 0 1 2 3 4 5 6 +c valeur : 8 2 7 9 6 1 0 5 3 x x +c +c On doit donc transferer la partie correspondant a l'intervalle +c commun autour du point central. Ce point central correspond a ce +c qui est vu de l'exterieur comme tab(0). +c Son adresse memoire est : +c . dans l'ancien tableau : iptold - d1old +c . dans le nouveau tableau : point - d1new +c On doit transferer : +c . min(-d1old,-d1new) cases avant ce point central +c . min(d2old,d2new) cases apres ce point central +c + elseif ( typmod.le.0 ) then +c + kdeb = iptold - d1old - min(-d1old,-d1new) + kfin = iptold - d1old + min(d2old,d2new) + kaux = point - d1new - iptold + d1old + do 4331 , k = kdeb , kfin + smem(kaux+k) = smem(k) + 4331 continue +c + endif +c +c 4.2.3. ==> renommage du tableau +c + nomvar = ' ' + if ( len(nomtab).gt.0 ) then + nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab))) + endif +c + call gmdesa (nomvar) + if ( coergm.ne.0 ) then + write(ulsort,40001) nompro, nomvar + call ugstop(nompro,ulsort,1,1,1) + endif +c + do 4231 , i=1,nballs + if ( nomals(i).eq.tablte ) then + nomals(i) = nomvar + goto 4232 + endif + 4231 continue +c + write(ulsort,40000) nompro, tablte + call ugstop(nompro,ulsort,1,1,1) +c + 4232 continue + if ( nommxs.eq.tablte ) then + nommxs = nomvar + endif +c + call gbntde ( tablte, coergm ) +c + endif +c +40000 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Le tableau temporaire ',a8,' n''a pas ete retrouve', + > /4x,' ===> arret dans le gestionnaire de memoire') +c +40001 format( 2x,'Anomalie dans le sp ',a6, + > /4x,'Desallocation temporaire du ', + > /4x,'tableau a modifier ',a8,' impossible', + > /4x,' ===> arret dans le gestionnaire de memoire') +c + endif +c + if ( coergm.ne.0 ) then +c +#include "envex2.h" +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmmoge.F b/src/tool/Gestion_MTU/gmmoge.F new file mode 100644 index 00000000..e94574be --- /dev/null +++ b/src/tool/Gestion_MTU/gmmoge.F @@ -0,0 +1,402 @@ + subroutine gmmoge ( modgm, typarr, + > nenti, nreel, nch08, + > nfconf, lfconf, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestion de la Memoire : MOde de GEstion +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modgm . s . 1 . 0 : mode statique . +c . . . . 1 : mode semi-dynamique . +c . . . . 2 : mode dynamique . +c . typarr . s . 1 . gere les arrets de gm en cas de probleme . +c . . . . 0 : arret par le programme ad-hoc . +c . . . . 1 : code de retour non nul . +c . nenti . s . 1 . nombre d'entiers . +c . nreel . s . 1 . nombre de reels . +c . nresp . s . 1 . nombre de reels simple precision . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMMOGE' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gmimpr.h" +#include "gmlang.h" +c +c les communs qui suivent sont ici pour declarer les variables lgxxxx +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf + integer modgm + integer typarr + integer nenti, nreel, nch08 + integer codret +c +c 0.4. ==> variables locales +c + integer iaux, nbaux, codre0 + integer lfmode +c + integer nbtype + parameter ( nbtype = 3 ) +c + character*8 motcle + character*200 nfmode +c + character*5 fmtent +c +#include "motcle.h" +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + >'(''L''''option de la memoire '',a8,'' est absente.'')' + texte(1,4) = '(''On impose un mode de gestion dynamique.'')' + texte(1,5) = + >'(''L''''option de la memoire '',a8,'' est illisible.'')' + texte(1,6) = '(''On impose 0 valeurs.'')' + texte(1,7) = '(''Le type '',i8,'' ne convient pas.'')' + texte(1,8) = '(''Il faut 0 ou 1.'')' +c + texte(2,10) = '(''The option '',a8,'' is missing.'')' + texte(2,4) = '(''A dynamic memory management is imposed.'')' + texte(2,5) = '(''The option '',a8,'' cannot be read.'')' + texte(2,6) = '(''0 values are imposed.'')' + texte(2,7) = '(''Type '',i8,'' is not correct.'')' + texte(2,8) = '(''0 or 1 is needed.'')' +c +c==== +c 2. recuperation du mode de gestion de la memoire +c==== +c +c 2.1. ==> recherche de l'option de pilotage qui contient le +c le mode de gestion de la memoire +c + motcle = mcmogm + call ugfino ( motcle, nfmode, lfmode, + > nfconf, lfconf, + > ulsort , langue, codret ) +c +c 2.2. ==> si aucune option n'a ete precisee, on passe en mode dynamique +c + if ( codret.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,4)) +#endif +c + modgm = 2 + codret = 0 +c +c 2.3. ==> probleme de lecture +c + elseif ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,5)) motcle +c + codret = 1 +c +c 2.3. ==> si l'option est dynamique, on y va ! +c + elseif ( nfmode(1:lfmode).eq.'Dynamique' .or. + > nfmode(1:lfmode).eq.'DYNAMIQUE' .or. + > nfmode(1:lfmode).eq.'dynamique' ) then +c + modgm = 2 +c +c 2.4. ==> si l'option est semi-dynamique, on y va ! +c + elseif ( nfmode(1:lfmode).eq.'Semi-Dynamique' .or. + > nfmode(1:lfmode).eq.'SEMI-DYNAMIQUE' .or. + > nfmode(1:lfmode).eq.'semi-dynamique' ) then +c + modgm = 1 +c +c 2.5. ==> si l'option est statique, on y va ! +c + elseif ( nfmode(1:lfmode).eq.'Statique' .or. + > nfmode(1:lfmode).eq.'STATIQUE' .or. + > nfmode(1:lfmode).eq.'statique' ) then +c + modgm = 0 +c +c 2.6. ==> sinon, il y a un probleme +c + else +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,5)) motcle + if ( lfmode.gt.0 ) then + write (ulsort,*) nfmode(1:lfmode) + else + write (ulsort,*) + endif +c + codret = 1 +c + endif +c +c==== +c 3. determination des tailles +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> en mode statique, on met les tailles des parameter +c + if ( modgm.eq.0 ) then +c + nenti = lgcomi + nreel = lgcomr + nch08 = lgcoms +c +c 3.2. ==> en mode semi-dynamique, on lit les tailles +c + elseif ( modgm.eq.1 ) then +c + do 32 , iaux = 1 , nbtype +c +c 3.2.1. ==> recherche du motcle dans le fichier de configuration +c + if ( iaux.eq.1 ) then + motcle = mcgmen + elseif ( iaux.eq.2 ) then + motcle = mcgmre + elseif ( iaux.eq.3 ) then + motcle = mcgmc8 + endif +c + call ugfino ( motcle, nfmode, lfmode, + > nfconf, lfconf, + > ulsort , langue, codre0 ) +c +c 3.2.2. ==> si aucune taille n'a ete precisee, on met 0 +c + if ( codre0.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,6)) +#endif +c + nbaux = 0 + codre0 = 0 +c +c 3.2.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,5)) motcle +c + nbaux = 0 +c +c 3.2.4. ==> decodage +c + else +c + if ( lfmode.gt.0 .and. lfmode.lt.100 ) then +c + fmtent = '(I )' + if ( lfmode.lt.10 ) then + write(fmtent(3:3),'(i1)') lfmode + else + write(fmtent(3:4),'(i2)') lfmode + endif + read ( nfmode,fmtent) nbaux +c + else + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,5)) motcle + codre0 = 3 + nbaux = 0 + endif +c + endif +c +c 3.2.5. ==> bilan +c + if ( iaux.eq.1 ) then + nenti = max(0, nbaux ) + elseif ( iaux.eq.2 ) then + nreel = max(0, nbaux ) + elseif ( iaux.eq.3 ) then + nch08 = max(0, nbaux ) + endif +c + codret = max ( codret, abs(codre0) ) +c + 32 continue +c +c 3.3. ==> en mode dynamique, on met des tailles nulles +c + else +c + nenti = 0 + nreel = 0 + nch08 = 0 +c + endif +c + endif +c +c==== +c 4. type d'arret +c==== +c + if ( codret.eq.0 ) then +c +c 4.1. ==> recherche de l'option de pilotage qui contient le +c le type d'arret de la gestion de la memoire +c + motcle = mcgmta + call ugfino ( motcle, nfmode, lfmode, + > nfconf, lfconf, + > ulsort , langue, codre0 ) +c +c 4.2. ==> si aucune option n'a ete precisee, on arretera brutalement +c + if ( codre0.eq.1 ) then +c + typarr = 0 +c +c 4.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,5)) +c + typarr = 0 + codret = 1 +c +c 4.4. ==> decodage +c + else +c + if ( lfmode.gt.0 .and. lfmode.lt.100 ) then +c + fmtent = '(I )' + if ( lfmode.lt.10 ) then + write(fmtent(3:3),'(i1)') lfmode + else + write(fmtent(3:4),'(i2)') lfmode + endif + read ( nfmode,fmtent) typarr +c + else + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) motcle + if ( lfmode.gt.0 ) then + write (ulsort,*) nfmode(1:lfmode) + else + write (ulsort,*) + endif + write (ulsort,texte(langue,8)) + typarr = 0 + codret = 1 + endif +c + endif +c +c 4.5. ==> verification +c + if ( typarr.lt.0 .or. typarr.gt.1 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,7)) typarr + write (ulsort,texte(langue,8)) + typarr = 0 + codret = 1 + endif +c + endif +c +c==== +c 5. en mode semi-dynamique : le mode de gestion passe en dynamique +c si toutes les valeurs sont nulles +c==== +c + if ( codret.eq.0 ) then +c + if ( modgm.eq.1 ) then +c + if ( (nenti.eq.0) .and. + > (nreel.eq.0) .and. + > (nch08.eq.0) ) then +c + modgm = 2 +c + endif +c + endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmnelx.h b/src/tool/Gestion_MTU/gmnelx.h new file mode 100644 index 00000000..d764af7b --- /dev/null +++ b/src/tool/Gestion_MTU/gmnelx.h @@ -0,0 +1,6 @@ +c +c nelx = nombre maximum d'elements dans une ligne de +c description des objets structures +c + integer nelx + parameter ( nelx = 20 ) diff --git a/src/tool/Gestion_MTU/gmnomc.F b/src/tool/Gestion_MTU/gmnomc.F new file mode 100644 index 00000000..b7cd4051 --- /dev/null +++ b/src/tool/Gestion_MTU/gmnomc.F @@ -0,0 +1,161 @@ + subroutine gmnomc (nom,nomter,codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : rechercher le nom de l'objet-terminal du nom etendu "nom" +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . e . char* . nom etendu dont on veut le nom terminal . +c . nomter . s . ch8 . nom terminal du nom etendu nom . +c . codret . s . 1 . 0 : tout va bien . +c . . . . -1 : objet-terminal non defini : aucun . +c . . . . objet n'a ete attache au champ . +c . . . . terminal de l'objet-repertoire . +c . . . . -3 : nom etendu invalide . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMNOMC' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gminds.h" +c +#ifdef _DEBUG_HOMARD_ +#include "envex1.h" +#include "gmimpr.h" +#include "gmlang.h" +#endif +c +c 0.3. ==> arguments +c + character*(*) nom + character*8 nomter +c + integer codret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Objet : '',a)' + texte(1,5) = '(''Le nom etendu est invalide.'')' + texte(1,6) = '(''L''''objet terminal est indefini.'')' +c + texte(2,4) = '(''Object : '',a)' + texte(2,5) = '(''Extended name is not valid.'')' + texte(2,6) = '(''Final object is not defined.'')' +c +c==== +c 2. decodage du nom etendu +c==== +c + call gbdnoe(nom,objrep,objter,chater,iaux) +c + if (iaux.lt.0) then +c +c nom etendu invalide +c + nomter = sindef + codret = -3 +c + else if (iaux.eq.0) then +c +c 'nom' n'a qu'un element +c + nomter = nom + codret = 0 +c + else if (iaux.eq.1) then +c +c objet-terminal non defini +c + nomter = sindef + codret = -1 +c + else +c +c objet-terminal est defini et (eventuellement alloue) +c + nomter = objter + codret = 0 +c + endif +c +c==== +c 4. Fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) nom + if ( codret.eq.-3 ) then + write (ulsort,texte(langue,5)) + else + write (ulsort,texte(langue,6)) + endif +c + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gmntve.F b/src/tool/Gestion_MTU/gmntve.F new file mode 100644 index 00000000..c26f4692 --- /dev/null +++ b/src/tool/Gestion_MTU/gmntve.F @@ -0,0 +1,183 @@ + subroutine gmntve ( nomtab, nomvar, nbcain, carint, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c verifie que le nom demande pour un objet terminal est plausible +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomtab . e .char*(*). nom terminal a verifier . +c . nomvar . s . char*8 . nom controle . +c . nbcain . e . 1 . nombre de premiers caracteres interdits . +c . carint . e . char*1 . liste de caracteres interdits . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . 1 : longueur nulle . +c . . . . 2 : longueur superieure a 8 . +c . . . . 3 : nom blanc . +c . . . . 4 : nom indefini . +c . . . . 5 : premier caractere non valable . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GMNTVE' ) +c +c +#include "genbla.h" +c +c 0.2. ==> communs +c +#include "gminds.h" +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) nomtab + character*8 nomvar + character*1 carint(*) +c + integer nbcain, codret +c +c 0.4. ==> variables locales +c + character*1 saux + character*8 blan08 +c + integer iaux, laux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data blan08 / ' ' / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Nom de l''''objet simple a verifier :'')' + texte(1,11) = '(''Le nom est de longueur nulle.'')' + texte(1,12) = '(''Le nom est de longueur superieure a 8.'')' + texte(1,13) = '(''Le nom est blanc.'')' + texte(1,14) = '(''Ce nom est interdit.'')' + texte(1,15) = + > '(''Le caractere '',a1,'' est interdit comme 1ere lettre.'')' +c + texte(2,10) = '(''Name of the object to check :'')' + texte(2,11) = '(''The length of the name is 0.'')' + texte(2,12) = '(''The length of the name is greater than 8.'')' + texte(2,13) = '(''The name is blank.'')' + texte(2,14) = '(''This name is forbidden.'')' + texte(2,15) = + > '(''The character '',a1,'' is forbidden as 1st lettre.'')' +c +c==== +c 2. verification du nom +c==== +c + codret = 0 +c + laux = len(nomtab) +c +c 2.1. ==> verification de la longueur du nom : de 1 a 8 +c + if ( laux.lt.1 ) then + codret = 1 +c + elseif(laux.gt.8) then + codret = 2 +c +c 2.2. ==> on refuse les noms blancs +c + elseif ( blan08(1:laux).eq.nomtab(1:laux) ) then + codret = 3 +c +c 2.3. ==> on refuse les noms indefinis +c + elseif ( sindef.eq.nomtab(1:laux) ) then + codret = 4 +c +c 2.4. ==> on refuse les caracteres interdits +c + else + do 24 , iaux = 1 , nbcain + if ( nomtab(1:1).eq.carint(iaux) ) then + saux = carint(iaux) + codret = 5 + endif + 24 continue + endif +c +c==== +c 3. c'est bon. on etend eventuellement a 8 par des blancs +c==== +c + if ( codret.eq.0 ) then +c + nomvar = ' ' + nomvar(1:laux) = nomtab(1:laux) +c + endif +c +c==== +c 4. gestion des erreurs +c==== +c + if ( codret.ne.0 ) then +c + iaux = 10+abs(codret) +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) + write (ulsort,*) nomtab + if ( codret.eq.5 ) then + write (ulsort,texte(langue,iaux)) saux + else + write (ulsort,texte(langue,iaux)) + endif + write (ulsort,90000) +c + endif +c +90000 format (70('=')) +c + end diff --git a/src/tool/Gestion_MTU/gmobal.F b/src/tool/Gestion_MTU/gmobal.F new file mode 100644 index 00000000..2328e278 --- /dev/null +++ b/src/tool/Gestion_MTU/gmobal.F @@ -0,0 +1,91 @@ + subroutine gmobal (nom,iret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c sous programme d'interrogation si l'objet de nom etendu "nom" +c est alloue ou non +c ........................................................... +c +c entrees : +c +c nom : character*(*) : nom etendu +c +c ........................................................... +c +c sorties : iret : code de retour : +c +c -1 : erreur : nom etendu invalide +c 0 : objet non alloue +c 1 : objet structure alloue +c 2 : objet simple alloue +c ........................................................... +c +c 0. declarations et dimensionnement +c +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c +c 0.3. ==> arguments +c + character*(*) nom + integer iret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater + integer idec,ityp +c +c 1. decodage du nom etendu +c + call gbdnoe(nom,objrep,objter,chater,idec) +c + if (idec.lt.0) then +c +c nom etendu invalide +c + iret = -1 +c + else if (idec.eq.0) then +c +c 'nom' n'a qu'un element +c + call gbobal(objter,ityp,iret) +c + else if (idec.eq.3) then +c +c objet-terminal defini et alloue +c + call gbobal(objter,ityp,iret) +c + else +c +c objet-terminal non alloue +c + iret = 0 +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmopim.h b/src/tool/Gestion_MTU/gmopim.h new file mode 100644 index 00000000..fde9391c --- /dev/null +++ b/src/tool/Gestion_MTU/gmopim.h @@ -0,0 +1,7 @@ +c +c Option d'impression +c imprgm : si multiple de 5, impression des bilans du gestionnaire +c de memoire +c + integer imprgm + common /gmopim/ imprgm diff --git a/src/tool/Gestion_MTU/gmprot.F b/src/tool/Gestion_MTU/gmprot.F new file mode 100644 index 00000000..0b9afc70 --- /dev/null +++ b/src/tool/Gestion_MTU/gmprot.F @@ -0,0 +1,366 @@ + subroutine gmprot ( chaine, nom, ideb, ifin ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : imprime le contenu de l'objet terminal de nom "nom" +c entre les indices locaux ideb et ifin compris +c si les deux indices sont nuls, on imprime tout +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chaine . e . char* . chaine de commentaire a imprimer . +c . nom . e . char* . nom de la structure a imprimer . +c . ideb . e . 1 . indice local de debut d'impression . +c . ifin . e . 1 . indice local de fin d'impression . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMPROT' ) +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "gmtail.h" +c +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) chaine + character*(*) nom +c + integer ideb, ifin +c +c 0.4. ==> variables locales +c + character*2 saux02 + character*8 typtab + character*8 nomter + character*45 fmtstr + character*45 fmtent + character*45 fmt131, fmt132 + character*45 fmt141, fmt142 + character*45 fmt151, fmt152 + character*80 saux80 +c + integer iaux, jaux + integer lgent + integer iadr, codret, lgtabl, entmax, entmin + integer ledebu, lafin, nrotab +c + logical partie +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Cet objet est de longueur '',i10,/)' + texte(1,5) = '(''Objet '',a8,'' :'',/,16(''=''))' + texte(1,8) = '(''Impression demandee entre'',i10,'' et'',i10)' + texte(1,9) = + >'(''=== Structure '',a8,'', type '',a8,'' ==='')' + texte(1,10) = + >'(''=== Structure '',a8,'' / '',a,'', type '',a8,'' ==='')' + texte(1,15) = + > '(''Impression partielle entre les indices '',i10,'' et '',i10)' + texte(1,16) = '(''Cet objet est introuvable.'',/)' + texte(1,17) = '(''Mauvais nom d''''objet.'',/)' + texte(1,18) = + > '(''Cet objet est structure ? ou n''''existe pas ?'')' + texte(1,19) = '(''Cet objet est defini plusieurs fois.'')' + texte(1,20) = '(''Impression impossible entre'',i10,'' et'',i10)' +c + texte(2,4) = '(''The length of this object is '',i10,/)' + texte(2,5) = '(''Object '',a8,'' :'',/,17(''=''))' + texte(2,8) = '(''Output is requested between'',i10,'' et'',i10)' + texte(2,9) = texte(1,9) + texte(2,10) = texte(1,10) + texte(2,15) = + > '(''Partial impression between indices '',i10,'' et '',i10)' + texte(2,16) = '(''This object is not available.'',/)' + texte(2,17) = '(''Bad object name.'',/)' + texte(2,18) = + > '(''This object is structured ? or is not available ?'')' + texte(2,19) = '(''This object is defined several times.'')' + texte(2,20) = + > '(''Output cannot be done between'',i10,'' et'',i10)' +c + 1000 format(a) + 1100 format(a,/) +c +c 12345678901234567890123456789012345678901234567890 + fmtstr = '( y(ixx,'' : '',a8)) ' + fmtent = '( y(ixx,'' : '',iz )) ' + fmt131 = '(2(i6 ,'' : ( '', g14.7,'' ; '', g14.7,'' )'')) ' + fmt132 = '(2(i6 ,'' : ( '',g23.16,'' ; '',g23.16,'' )'')) ' + fmt141 = '(3(i6 ,'' : '', g14.7)) ' + fmt142 = '(3(i6 ,'' : '',g23.16)) ' + fmt151 = '(3(i6 ,'' : '',g23.16)) ' + fmt152 = '(2(i6 ,'' : '',g39.32)) ' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) ideb, ifin +#endif +c +c==== +c 2. caracteristiques du tableau +c==== +c +c 2.1. ==> recherche du nom terminal de l'objet +c + call gmnomc ( nom, nomter, codret ) +c + if ( codret.eq.-3 ) then + codret = -2 + elseif ( codret.eq.-1 ) then + codret = -1 + else + codret = 0 + endif +c +c 2.3. ==> reperage du pointeur +c le code de retour est non nul si le tableau n'est pas +c un objet simple alloue +c + if ( codret.eq.0 ) then +c + call gbcara ( nomter, nrotab, iadr, lgtabl, typtab ) +c + if ( coergm.eq.0 ) then +c + if ( lgtabl.gt.0 ) then +c + if ( ideb.le.1 .and. + > ( ifin.eq.0 .or. ifin.ge.lgtabl ) ) then + ledebu = 1 + lafin = lgtabl + partie = .false. +c + elseif ( ifin.lt.ideb ) then + codret = -5 +c + elseif ( ideb.gt.lgtabl .or. ifin.lt.1 ) then + codret = -6 +c + else + ledebu = max(ideb,1) + lafin = min(ifin,lgtabl) + partie = .true. +c + endif +c + endif +c + elseif ( coergm.eq.1 ) then + codret = -3 +c + else + codret = -4 +c + endif +c + endif +c +c==== +c 3. impression +c pour les entiers, on optimise la longueur de l'impression +c . on cherche la plus grande valeur, entmax. +c on a l'encadrement 10**(n-1) <= entmax < 10**n, donc on utilisera +c n chiffres significatifs. +c . si l'une des valeurs du tableau est negative, il faut ajouter +c une case pour le signe "-". +c==== +c +c 3.1. ==> format des indices +c + if ( codret.eq.0 ) then +c + if ( lgtabl.gt.0 ) then +c + saux02 = '3' + do 31 , iaux = 11 , 0 , -1 + if ( lafin.gt.10**iaux ) then + if ( iaux.le.6 ) then + write(saux02(1:1),'(i1)') iaux+3 + else + write(saux02(1:2),'(i2)') iaux+3 + endif + lgent = iaux+3 + goto 311 + endif + 31 continue +c + 311 continue +cgn print *,lafin ,' = ',saux02 +c + endif +c + endif +c +c 3.2. ==> format des valeurs et impressions +c + if ( codret.eq.0 ) then +c + if ( nomter.eq.nom ) then + write (ulsort,texte(langue,9)) nomter, typtab + else + write (ulsort,texte(langue,10)) nomter, nom, typtab + endif + if ( len(chaine).gt.0 ) then + write (ulsort,1000) chaine + endif +c + if ( lgtabl.eq.0 ) then + write (ulsort,texte(langue,4)) lgtabl +c + else +c + if ( partie ) then + write (ulsort,texte(langue,15)) ledebu , lafin + endif +c + iadr = iadr - 1 +c + if ( typtab.eq.'entier ' ) then + entmax = 0 + entmin = 0 + do 312 , iaux = ledebu , lafin + entmax = max (entmax,abs(imem(iadr+iaux))) + entmin = min (entmin,imem(iadr+iaux)) + 312 continue + jaux = 10 + do 322 , iaux = 9 , 1 , -1 + if ( entmax.lt.10**iaux ) then + jaux = iaux + endif + 322 continue + if ( entmin.ne.0 ) then + jaux = min(jaux+1,15) + endif + iaux = lgent + 3 + jaux + iaux = (120-mod(120,iaux))/iaux + if ( iaux.le.9 ) then + write(fmtent(3:3),'(i1)') iaux + else + write(fmtent(2:3),'(i2)') iaux + endif + fmtent(6:7) = saux02 + if ( jaux.le.9 ) then + write(fmtent(16:16),'(i1)') jaux + else + write(fmtent(16:17),'(i2)') jaux + endif + write (ulsort,fmtent) + > (iaux,imem(iadr+iaux),iaux=ledebu,lafin) +c + elseif ( typtab.eq.'chaine ' ) then + iaux = lgent + 3 + 8 + iaux = max(10,(120-mod(120,iaux))/iaux) + write(fmtstr(2:3),'(i2)') iaux + fmtstr(6:7) = saux02 + write (ulsort,fmtstr) + > (iaux,smem(iadr+iaux),iaux=ledebu,lafin) +c + elseif ( typtab.eq.'reel ' ) then + if (treel.eq.4) then + fmt141(5:6) = saux02 + write (ulsort,fmt141) + > (iaux,rmem(iadr+iaux),iaux=ledebu,lafin) + else + fmt142(5:6) = saux02 + write (ulsort,fmt142) + > (iaux,rmem(iadr+iaux),iaux=ledebu,lafin) + endif +c + endif +c +c 1234567890123456789012345678901234567890 + saux80( 1:40) = '=== === === === === === === ' + saux80(41:80) = ' === === === === === === ==' + iaux = 16 + len(nom) + 3 + len(nomter) + 19 + write (ulsort,1100) saux80(1:min(80,iaux)) +c + endif +c + endif +c +c==== +c 4. gestion des erreurs +c==== +c + if ( codret.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif + write (ulsort,texte(langue,5)) nomter + write (ulsort,*) nom + if ( codret.eq.-6 ) then + write (ulsort,texte(langue,4)) lgtabl + endif + if ( codret.eq.-5 .or. codret.eq.-6 ) then + write (ulsort,texte(langue,20)) ideb, ifin + else + iaux = 15+abs(codret) + write (ulsort,texte(langue,iaux)) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) +90000 format (70('=')) +#endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmprsx.F b/src/tool/Gestion_MTU/gmprsx.F new file mode 100644 index 00000000..8bd03ece --- /dev/null +++ b/src/tool/Gestion_MTU/gmprsx.F @@ -0,0 +1,202 @@ + subroutine gmprsx ( chaine, nom ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : imprime le contenu d'un objet +c . si l'objet est structure, on imprime ses attributs +c . si l'objet est simple, on imprime son contenu complet +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chaine . e . char* . chaine de commentaire a imprimer . +c . nom . e . char* . nom de la structure a imprimer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMPRSX' ) +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +#include "gmtoas.h" +#include "gmtors.h" +c +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + character*(*) chaine + character*(*) nom +c +c 0.4. ==> variables locales +c + integer nba, nbc, letype + integer adsa, adso, adst + integer iaux, jaux, ideb, ifin + integer codret +c + character*8 nomter, typtab, nocham +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(a)' + texte(1,4) = + > '(/,''=== Structure '',a8,'' de type '',a8,'' ==='',/)' + texte(1,6) = '(''Attribut numero'',i6,'' : '',i15)' + texte(1,7) = '(''Champ numero '',i6,'' : '',a8)' + texte(1,8) = '('' Type : '',a8,'' --> objet associe : '',a8)' + texte(1,9) = '(''==> le nom de cette structure est invalide.'',/)' + texte(1,10) = '(''==> cette structure n''''est pas allouee.'',/)' +c + texte(2,5) = '(a)' + texte(2,4) ='(/,''=== Structure '',a8,'' : Type '',a8,'' ==='',/)' + texte(2,6) = '(''Attribute #'',i6,'' : '',i15)' + texte(2,7) = '(''Field # '',i6,'' : '',a8)' + texte(2,8) = '('' Type : '',a8,'' --> related object : '',a8)' + texte(2,9) = '(''The name of this structure is not valid.'',/)' + texte(2,10) = '(''==> this structure is not allocated.'',/)' +c +c==== +c 2. etat de l'objet en memoire +c==== +c + call gmobal ( nom, codret ) +c +c==== +c 3. si objet non alloue +c==== +c + if ( codret.eq.0 ) then +c + write (ulsort,*) ' ' + write (ulsort,*) nom + write (ulsort,texte(langue,10)) +c +c==== +c 4. decodage des attributs pour un objet structure +c==== +c + elseif ( codret.eq.1 ) then +c +c 4.1. ==> recherche du nom terminal de l'objet et de son type +c + call gmtyoj ( nom, typtab, iaux, codret ) +c + call gmnomc ( nom, nomter, codret ) +c +c 4.2. ==> recherche du numero de l'objet +c + do 42 , iaux = 1 , iptobj-1 + if ( nomobj(iaux).eq.nomter ) then + letype = iaux + nba = nbratt(typobj(letype)) + nbc = nbcham(typobj(letype)) + adsa = adrdsa(letype) + adso = adrdso(letype) + adst = adrdst(typobj(letype)) + goto 431 + endif + 42 continue +c + goto 440 +c +c 4.3. ==> ecriture des attributs +c + 431 continue +c + write (ulsort,texte(langue,4)) nomter, typtab + if ( len(chaine).gt.0 ) then + write (ulsort,texte(1,5)) chaine + endif + write (ulsort,*) nom + write (ulsort,*) ' ' +c + do 432 , iaux = 1 , nba + write(ulsort,texte(langue,6)) iaux, valatt(adsa+iaux-1) + 432 continue +c + do 433 , iaux = 1 , nbc + jaux = typcha(adst+iaux-1) + if ( jaux.gt.0 ) then + nocham = nomtyp(jaux) + else + nocham = nomtyb(abs(jaux)) + endif + write(ulsort,texte(langue,7)) iaux, nomcha(adst+iaux-1) + write(ulsort,texte(langue,8)) nocham, nomobc(adso+iaux-1) + 433 continue +c + 440 continue +c +c==== +c 5. appel du programme generique pour un objet simple +c==== +c + elseif ( codret.eq.2 ) then +c + ideb = 0 + ifin = 0 + call gmprot ( chaine, nom, ideb, ifin ) +c +c==== +c 6. si objet non defini +c==== +c + else +c + write (ulsort,*) ' ' + write (ulsort,*) nom + write (ulsort,texte(langue,9)) +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gmptrd.h b/src/tool/Gestion_MTU/gmptrd.h new file mode 100644 index 00000000..579a4eb6 --- /dev/null +++ b/src/tool/Gestion_MTU/gmptrd.h @@ -0,0 +1,5 @@ +c +c ptrdeb = pointeur du debut de la zone memoire +c + integer ptrdeb + parameter ( ptrdeb = 2 ) diff --git a/src/tool/Gestion_MTU/gmsgoj.F b/src/tool/Gestion_MTU/gmsgoj.F new file mode 100644 index 00000000..332beab2 --- /dev/null +++ b/src/tool/Gestion_MTU/gmsgoj.F @@ -0,0 +1,202 @@ + subroutine gmsgoj ( nomemc, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c supprimer le graphe d'un objet en memoire centrale +c et le detruire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomemc . e .char(*) . nom etendu en memoire centrale . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : Probleme dans la suppression du graphe. +c . . . . -2 : Probleme dans la liberation de l'objet. +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMSGOJ' ) +c +c +#include "genbla.h" +c +#include "gmcain.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmcoer.h" +#include "gmimpr.h" +#include "gmlang.h" +c +c 0.3. ==> arguments +c + integer codret +c + character*(*) nomemc +c +c 0.4. ==> variables locales +c + integer iaux + integer icar, imin, imax +c + character*8 nomter, nomaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Suppression du graphe de l''''objet '',a8)' + texte(1,4) = '(''en memoire centrale.'')' + texte(1,11) = '(''Probleme a la suppression du graphe.'')' + texte(1,12) = '(''Probleme a la liberation de l''''objet.'')' +c + texte(2,10) = '(''Suppression of the graph of the object '',a8)' + texte(2,4) = '(''in central memory.'')' + texte(2,11) = '(''Problem in freeing the graph.'')' + texte(2,12) = '(''Problem in freeing the object.'')' +c +c==== +c 2. on supprime le graphe seul +c==== +c + call gasgmc (nomemc,codret) +c +c==== +c 3. si l'objet est structure et que la suppression du graphe +c s'est bien passe +c ou : si l'objet est simple +c detachement de l'objet de tous ses supports +c si c'est un objet temporaire et que c'est une tete, on le raye +c de la liste +c==== +c + if ( codret.eq.0 .or. codret.eq.-5 ) then +c + call gmnomc (nomemc, nomter, codret) +c + if ( codret.eq.0 ) then +c + call gblboj ( nomter ) + codret = coergm +c + endif +c + if ( codret.eq.0 ) then +c + nomaux = ' ' + call gbdtoj ( nomaux, nomter ) + codret = coergm +c + endif +c + if ( codret.ne.0 ) then + codret = -2 + endif +c + else +c + codret = - 1 +c + endif +c + if ( codret.eq.0 .and. len(nomemc).ge.8 ) then +c +c avant de supprimer le nom de la liste des noms d'objets temporaires, +c on verifie que le nom (terminal) a bien la structure d'un nom +c temporaire : un certain nombre (>0) de caracteres caint1 (% a priori), +c suivis d'un entier (le tout, code sur 8 caracteres). +c + if ( nomter(1:1).eq.caint1 .and. + > nomter.eq.nomemc(1:8) ) then + imin = 2 + imax = 11 + do 80 icar = 2, 8 + iaux = index('0123456789'//caint1, nomter(icar:icar)) + if (iaux.lt.imin.or.iaux.gt.imax) then + goto 91 + else + if (iaux.ne.11) then + imin = 1 + imax = 10 + endif + endif + 80 continue + if (imax.ne.11) then + call gbntde ( nomter , iaux ) + endif + endif +c + endif +c +c==== +c 9. gestion des erreurs +c==== +c + 91 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '9. Gestions des erreurs ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) + write (ulsort,*) nomemc + write (ulsort,texte(langue,4)) + if ( abs(codret).le.2 .and. coergm.eq.0 ) then + iaux = 10+abs(codret) + write (ulsort,texte(langue,iaux)) + endif + write (ulsort,90000) +c +#include "envex2.h" +c + endif +c +90000 format (70('=')) +c + end diff --git a/src/tool/Gestion_MTU/gmshfi.F b/src/tool/Gestion_MTU/gmshfi.F new file mode 100644 index 00000000..c06dd90c --- /dev/null +++ b/src/tool/Gestion_MTU/gmshfi.F @@ -0,0 +1,85 @@ + subroutine gmshfi ( tab , adnew , adold , nbval ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c translate le contenu du tableau entier tab +c de l'adresse adold a l'adresse adnew et cela pour nbval valeurs. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab . es . * . tableau dans lequel on decale . +c . . . . sa longueur est a priori inconnue . +c . adnew . e . 1 . adresse a laquelle on placera les valeurs . +c . adold . e . 1 . adresse a laquelle sont les valeurs . +c . nbval . e . 1 . nombre de valeurs a transferer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + integer tab(*) +c + integer adnew , adold , nbval +c +c 0.4. ==> variables locales +c + integer iaux, ifin, decal +c +c==== +c 1. decalage des valeur au sein du tableau tab +c a condition que adnew <= adold +c remarque : cette programmation de la boucle est celle qui entraine +c le moins de calculs sur machine scalaire. +c sur CRAY, les options de compilation vectorisent +c totalement le traitement. +c==== +c + decal = adold - adnew + if ( decal.lt.0 ) then +c + write(ulsort,1000) adnew, adold + 1000 format(//2x,' ====== spg gmshfi ========',/2x, + > ' le decalage d''indice ne peut s''effectuer car le nouvel', + > /2x,' indice (',i6,') est superieur a l''ancien (',i6,') .') + call ugstop('gmshfi',ulsort,0,1,1) +c + endif + +c + ifin = adnew + nbval - 1 +c + do 10 , iaux = adnew , ifin + tab(iaux) = tab(decal+iaux) + 10 continue +c + end diff --git a/src/tool/Gestion_MTU/gmshfr.F b/src/tool/Gestion_MTU/gmshfr.F new file mode 100644 index 00000000..015cafaf --- /dev/null +++ b/src/tool/Gestion_MTU/gmshfr.F @@ -0,0 +1,85 @@ + subroutine gmshfr ( tab , adnew , adold , nbval ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c translate le contenu du tableau reel tab +c de l'adresse adold a l'adresse adnew et cela pour nbval valeurs. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab . es . * . tableau dans lequel on decale . +c . . . . sa longueur est a priori inconnue . +c . adnew . e . 1 . adresse a laquelle on placera les valeurs . +c . adold . e . 1 . adresse a laquelle sont les valeurs . +c . nbval . e . 1 . nombre de valeurs a transferer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + double precision tab(*) +c + integer adnew , adold , nbval +c +c 0.4. ==> variables locales +c + integer iaux, ifin, decal +c +c==== +c 1. decalage des valeur au sein du tableau tab +c a condition que adnew <= adold +c remarque : cette programmation de la boucle est celle qui entraine +c le moins de calculs sur machine scalaire. +c sur CRAY, les options de compilation vectorisent +c totalement le traitement. +c==== +c + decal = adold - adnew + if ( decal.lt.0 ) then +c + write(ulsort,1000) adnew, adold + 1000 format(//2x,' ====== spg gmshfr ========',/2x, + > ' le decalage d''indice ne peut s''effectuer car le nouvel', + > /2x,' indice (',i6,') est superieur a l''ancien (',i6,') .') + call ugstop('gmshfr',ulsort,0,1,1) +c + endif + +c + ifin = adnew + nbval - 1 +c + do 10 , iaux = adnew , ifin + tab(iaux) = tab(decal+iaux) + 10 continue +c + end diff --git a/src/tool/Gestion_MTU/gmshfs.F b/src/tool/Gestion_MTU/gmshfs.F new file mode 100644 index 00000000..eee40782 --- /dev/null +++ b/src/tool/Gestion_MTU/gmshfs.F @@ -0,0 +1,85 @@ + subroutine gmshfs ( tab , adnew , adold , nbval ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c translate le contenu du tableau caracteres 8 tab +c de l'adresse adold a l'adresse adnew et cela pour nbval valeurs. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab . es . * . tableau dans lequel on decale . +c . . . . sa longueur est a priori inconnue . +c . adnew . e . 1 . adresse a laquelle on placera les valeurs . +c . adold . e . 1 . adresse a laquelle sont les valeurs . +c . nbval . e . 1 . nombre de valeurs a transferer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + character*8 tab(*) +c + integer adnew , adold , nbval +c +c 0.4. ==> variables locales +c + integer iaux, ifin, decal +c +c==== +c 1. decalage des valeur au sein du tableau tab +c a condition que adnew <= adold +c remarque : cette programmation de la boucle est celle qui entraine +c le moins de calculs sur machine scalaire. +c sur CRAY, les options de compilation vectorisent +c totalement le traitement. +c==== +c + decal = adold - adnew + if ( decal.lt.0 ) then +c + write(ulsort,1000) adnew, adold + 1000 format(//2x,' ====== spg gmshfs ========',/2x, + > ' le decalage d''indice ne peut s''effectuer car le nouvel', + > /2x,' indice (',i6,') est superieur a l''ancien (',i6,') .') + call ugstop('gmshfs',ulsort,0,1,1) +c + endif + +c + ifin = adnew + nbval - 1 +c + do 10 , iaux = adnew , ifin + tab(iaux) = tab(decal+iaux) + 10 continue +c + end diff --git a/src/tool/Gestion_MTU/gmstat.F b/src/tool/Gestion_MTU/gmstat.F new file mode 100644 index 00000000..00a3f9c9 --- /dev/null +++ b/src/tool/Gestion_MTU/gmstat.F @@ -0,0 +1,397 @@ + subroutine gmstat ( gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c fonction impression des statistiques du gestionnaire de memoire +c_______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gmimp . e . 1 . Pour le mode dynamique : . +c . . . . 0 => pas d'impression . +c . . . . 1 => impression . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GMSTAT' ) +c +#include "genbla.h" +c +#include "gmmatc.h" +c +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtori.h" +#include "gmtoai.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "gmtrrl.h" +#include "gmtren.h" +#include "gmtrst.h" +c +#include "gmimpr.h" +#include "gmlang.h" +#include "gmopim.h" +#include "gmtail.h" +#include "gmtyge.h" +c +c 0.3. ==> arguments +c + integer gmimp +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ltypei, ltyper, ltypes + integer ecrire +c + character*2 saux02 + character*16 typtab(nblang,4) +c + double precision daux +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +cgn print *,'dans gmstat, gmimp = ', gmimp +c +c==== +c 1. Niveau d'impression +c==== +c +#ifdef _DEBUG_HOMARD_ + ecrire = 1 +#else + if ( modgm.eq.2 ) then + if ( mod(imprgm,5).eq.0 ) then + ecrire = 1 + else + ecrire = 0 + endif + else + ecrire = 1 + endif +#endif +c + if ( ecrire.ge.1 ) then + write (ulsort,10000) + endif +c +10000 format (//) +c +cgn print *,'dans gmstat, ecrire = ', ecrire +c +c==== +c 2. statistiques concernant les objets structures +c==== +c + if ( ecrire.ge.1 ) then +c + texte(1,4) = '(15x,'': Gestion de la memoire :'')' + texte(1,5) = '(5x,''Nombre de types de structure : '',i14)' + texte(1,6) = + > '(5x,''Nombre d''''objets structures presents : '',i14)' +c + texte(2,4) = '(15x,'': Memory management :'')' + texte(2,5) = + > '(5x,''Number of types of structures : '',i14)' + texte(2,6) = + > '(5x,''Number of present structured objects : '',i14)' +c +10001 format (/, + > /,15x,'......................................', + > /,15x,': :') +10002 format ( + > 15x,': :', + > /,15x,':....................................:',//) +c + write (ulsort,10001) + write (ulsort,texte(langue,4)) + write (ulsort,10002) + write (ulsort,texte(langue,5)) nbrtyp +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) iptobj-1 +#endif +c + endif +c +c==== +c 2. statistiques concernant les tableaux dynamiques +c==== +c + texte(1,4) = '(/,''La gestion de la memoire est statique.'')' + texte(1,5) ='(/,''La gestion de la memoire est semi-dynamique.'')' + texte(1,6) = '(/,''La gestion de la memoire est dynamique.'')' + texte(1,7) = '(/,''1 mot = '',i2,'' octets'')' + texte(1,8) = '(/,''1 mot = 1 octet'')' +c + texte(2,4) = '(/,''A static memory management is used.'')' + texte(2,5) = '(/,''A semi-dynamic memory management is used.'')' + texte(2,6) = '(/,''A dynamic memory management is used.'')' + texte(2,7) = '(/,''1 word = '',i2,'' bytes'')' + texte(2,8) = '(/,''1 word = 1 byte'')' +c +50010 format( + >/,90('.'), + >/': ',a16,14x,': ',a16,' : ',a16,' : ',a16,' :', + >/':',88('.'),':') +50011 format( + >/,71('.'), + >/': ',a16,14x,': ',a16,' : ',a16,' :', + >/':',69('.'),':') +50020 format( + > ': ',a16,14x,': ',i16,' : ',i16,' : ',i16,' :') +50021 format( + > ': ',a16,14x,': ',i16,' : ',i16,' :') +50030 format( + > 90('.'), + >/': ',2a16,36x,':',6x,f8.2,1x,a2,' :', + >/':',88('.'),':') +50031 format( + > 71('.'), + >/': ',2a16,17x,':',6x,f8.2,1x,a2,' :', + >/':',69('.'),':') +50040 format( + >/,'1 entier = ',i2,' octets,', + >/,'1 reel =',i2,' octets,', + >/,'1 character*8 =',i2,' octets') +50041 format( + >/,'1 integer = ',i2,' bytes,', + >/,'1 real =',i2,' bytes,', + >/,'1 character*8 =',i2,' bytes') +50090 format(90('.')) +50091 format(71('.')) +c +c 2.1. ==> Mode de gestion de la memoire +c + if ( ecrire.ge.1 ) then +c + write (ulsort,texte(langue,modgm+4)) +c + endif +c +c 2.2. ==> En-tete +c + if ( ecrire.ge.1 ) then +c +c 1234567890123456 + typtab(1,1) = 'Type de tableau ' + typtab(1,2) = 'Nombre demande ' + typtab(1,3) = 'Nombre totalise ' + typtab(1,4) = 'Nombre utilise ' + typtab(2,1) = ' Type of array ' + typtab(2,2) = ' Asked number ' + typtab(2,3) = ' Total number ' + typtab(2,4) = ' Used number ' +c + if ( modgm.le.1 ) then + write (ulsort,50010) (typtab(langue,iaux),iaux=1,4) + else + write (ulsort,50011) (typtab(langue,iaux),iaux=1,3) + endif +c + endif +c +c 2.3. ==> Par type +c +c 1234567890123456 + typtab(1,1) = 'Entier ' + typtab(1,2) = 'Reel ' + typtab(1,3) = 'Caracteres*8 ' + typtab(2,1) = 'Integer ' + typtab(2,2) = 'Real ' + typtab(2,3) = 'Character*8 ' +c + if ( modgm.le.1 ) then +c + minlei = min(minmei,minlei) + minler = min(minmer,minler) + minles = min(minmes,minles) +c + else +c +c en mode dynamique (modgm=2), les quantites minmex memorisent a tout +c instant l'ecart entre la taille max allouee precedemment (dans le type +c x concerne) et la taille couramment allouee. Typiquement, +c a la fin d'une execution ou tout a ete proprement desalloue, +c on doit avoir imem(1) = minmei ... +c + minlei = max(minmei,0) + minler = max(minmer,0) + minles = max(minmes,0) +c + endif +c + kaux = 0 +c +#ifdef _DEBUG_HOMARD_ + jaux = -1 +#else + jaux = 0 +#endif +c + iaux = imem(1) + ltypei = tentie + if ( iaux.gt.jaux ) then + if ( modgm.le.1 ) then + kaux = kaux + (iaux-minlei)*ltypei + else + kaux = kaux + iaux*ltypei + endif + if ( ecrire.ge.1 ) then + if ( modgm.le.1 ) then + write (ulsort,50020) typtab(langue,1), iaux, totali, + > iaux-minlei + else + write (ulsort,50021) typtab(langue,1), iaux, totali + endif + endif + endif +c + iaux = int(rmem(1)) + ltyper = treel + if ( iaux.gt.jaux ) then + if ( modgm.le.1 ) then + kaux = kaux + (iaux-minler)*ltyper + else + kaux = kaux + iaux*ltyper + endif + if ( ecrire.ge.1 ) then + if ( modgm.le.1 ) then + write (ulsort,50020) typtab(langue,2), iaux, totalr, + > iaux-minler + else + write (ulsort,50021) typtab(langue,2), iaux, totalr + endif + endif + endif +c + if (index(smem(1),'*').le.0) then + read(smem(1),'(i8)') iaux + else + iaux = 99999999 + minles + endif + ltypes = tchain + if ( iaux.gt.jaux ) then + if ( modgm.le.1 ) then + kaux = kaux + (iaux-minles)*ltypes + else + kaux = kaux + iaux*ltypes + endif + if ( ecrire.ge.1 ) then + if ( modgm.le.1 ) then + write (ulsort,50020) typtab(langue,3), iaux, totals, + > iaux-minles + else + write (ulsort,50021) typtab(langue,3), iaux, totals + endif + endif + endif +c + if ( ecrire.ge.11 ) then +c + if ( modgm.le.1 ) then + write (ulsort,50090) + else + write (ulsort,50091) + endif +c + endif +c +c 2.3. ==> Bilan +c + if ( ecrire.ge.1 ) then +c +c 1234567890123456 + typtab(1,1) = 'Memoire totale u' + typtab(1,2) = 'tilisee ' +c + typtab(2,1) = 'Total used memor' + typtab(2,2) = 'y ' +c + if ( kaux.ge.1000000000 ) then + daux = dble(kaux) / 1000000000.d0 + saux02 = 'Go' + elseif ( kaux.ge.1000000 ) then + daux = dble(kaux) / 1000000.d0 + saux02 = 'Mo' + elseif ( kaux.ge.1000 ) then + daux = dble(kaux) / 1000.d0 + saux02 = 'ko' + else + daux = dble(kaux) + saux02 = 'o ' + endif + if ( modgm.le.1 ) then + write (ulsort,50030) typtab(langue,1), typtab(langue,2), + > daux, saux02 + else + write (ulsort,50031) typtab(langue,1), typtab(langue,2), + > daux, saux02 + endif +c +#ifdef _DEBUG_HOMARD_ +c + write (ulsort,texte(langue,8)) +c + if ( langue.eq.1 ) then +c + write (ulsort,50040) ltypei, ltyper, ltypes +c + else +c + write (ulsort,50041) ltypei, ltyper, ltypes +c + endif +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gmstop.F b/src/tool/Gestion_MTU/gmstop.F new file mode 100644 index 00000000..600eb5f1 --- /dev/null +++ b/src/tool/Gestion_MTU/gmstop.F @@ -0,0 +1,238 @@ + subroutine gmstop ( gmimp ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : arrete le programme proprement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gmimp . e . 1 . 0 => pas d'impression . +c . . . . 1 => bilan d'utilisation de la memoire . +c . . . . 2 => impressions des tables des objets . +c . . . . dans l'etat courant . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "gmmatc.h" +#include "gmmaxt.h" +c +c 0.2. ==> communs +c +#include "gmtoai.h" +#include "gmtoas.h" +#include "gmtors.h" +c +#include "gmtren.h" +#include "gmtrrl.h" +#include "gmtrst.h" +c +#include "gmalen.h" +#include "gmalrl.h" +#include "gmalst.h" +c +#include "gminds.h" +c +#include "gmimpr.h" +c +c 0.3. ==> arguments +c + integer gmimp +c +c 0.4. ==> variables locales +c + integer codret + integer iaux, nbrobj, letype +c + character*8 obrepc, obterc, chterc + character*8 nomost(nobjx), nomosi(maxtab) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. impressions gm +c en deboggage, on imprime quelle que soit la valeur de gmimp +c em mode standard, on n'imprime que si gmimp est superieur a 1 +c==== +c +#ifdef _DEBUG_HOMARD_ + iaux = gmimp +#else + if ( gmimp.le.2 ) then + iaux = 2 + else + iaux = gmimp + endif +#endif +c + if ( gmimp.ge.iaux ) then +c + call dmflsh (iaux) + call gmdmp ( nomtyb(1), gmimp ) + call gmdmp ( nomtyb(2), gmimp ) + call gmdmp ( nomtyb(3), gmimp ) + call gmdmp ( nomtyb(4), gmimp ) + call dmflsh (iaux) +c + endif +c +c==== +c 2. desallocation de tous les objets presents en memoire centrale +c il est plus rapide de commencer par tous les simples. Ainsi, +c quand on desallouera les structures, il n'y aura que des problemes +c de graphes a regler +c==== +c +c 2.1. ==> liberation des objets simples +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.1' + call dmflsh (iaux) +#endif +c +c 2.1.1. ==> les entiers +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.1.1 avec nbrobj = ',nballi + call dmflsh (iaux) +#endif +c + nbrobj = nballi + do 2111 , iaux = 1 , nbrobj + nomosi(iaux) = nomali(iaux) + 2111 continue +c + do 2112 , iaux = nbrobj , 1 , -1 + call gmdesa ( nomosi(iaux) ) + 2112 continue +c +c 2.1.2. ==> les reels +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.1.2 avec nbrobj = ',nballr + call dmflsh (iaux) +#endif +c + nbrobj = nballr + do 2121 , iaux = 1 , nbrobj + nomosi(iaux) = nomalr(iaux) + 2121 continue +c + do 2122 , iaux = nbrobj , 1 , -1 + call gmdesa ( nomosi(iaux) ) + 2122 continue +c +c 2.1.3. ==> les chaines +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.1.3 avec nbrobj = ',nballs + call dmflsh (iaux) +#endif +c + nbrobj = nballs + do 2131 , iaux = 1 , nbrobj + nomosi(iaux) = nomals(iaux) + 2131 continue +c + do 2132 , iaux = nbrobj , 1 , -1 + call gmdesa ( nomosi(iaux) ) + 2132 continue +c +c 2.1.6. ==> bilan +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.1.6' + call dmflsh (iaux) +#endif +c +c 2.2. ==> les objets structures +c en fait il suffit de s'interesser aux tetes +c attention : la liberation d'un objet structure conduit au +c compactage des listes. Il faut donc boucler sur le +c nombre initial d'objets structures et s'interesser +c a la liste initiale. En effet la liste courante +c sera remaniee. +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Debut etape 2.2' + call dmflsh (iaux) +#endif +c + nbrobj = iptobj-1 + do 221 , iaux = 1 , nbrobj + nomost(iaux) = nomobj(iaux) + 221 continue +c + do 222 , iaux = nbrobj , 1 , -1 +c + call gbdnoe (nomost(iaux),obrepc,obterc,chterc,codret) +c + if ( codret.ge.0 .and. nomost(iaux).ne.sindef ) then +c + call gbobal ( nomost(iaux) , letype , codret ) +c + if ( codret.ne.0) then + call gmsgoj ( nomost(iaux) , codret ) + if ( codret.ne.0) then + write(ulsort,20000) nomost(iaux), codret + endif + endif +c + else +c + write(ulsort,*) 'gmstop --> gbdnoe : codret = ',codret +c + endif +c + 222 continue +c +20000 format(' GMSTOP pb a la suppression de l''objet ',a8, + > /,' Code retour de la suppression : ',i5) +c +#ifdef _DEBUG_HOMARD_ + call gmdmp ( nomtyb(4), gmimp ) +#endif +c +c==== +c 3. statistiques gm +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) '3. statistiques gm' + call dmflsh (iaux) +#endif +c + call gmstat ( gmimp ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Fin de gmstop' + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gmtail.h b/src/tool/Gestion_MTU/gmtail.h new file mode 100644 index 00000000..1fe1b9c3 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtail.h @@ -0,0 +1,5 @@ +c +c tailles en octet +c + integer tentie, treel, tchain + common /gmtail/ tentie, treel, tchain diff --git a/src/tool/Gestion_MTU/gmtenb.h b/src/tool/Gestion_MTU/gmtenb.h new file mode 100644 index 00000000..1d6a0ffc --- /dev/null +++ b/src/tool/Gestion_MTU/gmtenb.h @@ -0,0 +1,26 @@ +c +c numete(i) vaut : 1 si le numero i a ete utilise pour nommer +c un tableau temporaire +c 0 si le numero n'a jamais servi +c la liste des noms nomalt est contenue dans le commun gmteno. +c +c mxtbtp : numero maximum (entre 0 et 3*maxtab+nobjx) de tableau +c temporaire alloue. +c +c Rappel : il y a 3 types possibles d'objets simples, et au maximum +c maxtab objets dans chaque type. +c nobjx est le nombre maximum d'objets structures +c un objet temporaire peut etre simple ou structure. +c +c on se donne une marge au dela de 3*maxtab+nobjx pour que quelques +c allocations d'objets temporaires puissent etre faites par +c ugstop (appele lorsque le nombre d'objets simples alloues avoisine +c maxtab). De toutes facons, numete et nomalt doivent au moins +c etre de taille 3*maxtab+1 car le test de depassement du nombre max +c d'objets gm alloues est fait apres l'appel a gbntcr. +c + integer maxtbt + parameter ( maxtbt = (3*maxtab)+nobjx+10 ) +c + integer mxtbtp, numete(maxtbt) + common /gmtenb/ mxtbtp, numete diff --git a/src/tool/Gestion_MTU/gmteno.h b/src/tool/Gestion_MTU/gmteno.h new file mode 100644 index 00000000..00380abb --- /dev/null +++ b/src/tool/Gestion_MTU/gmteno.h @@ -0,0 +1,11 @@ +c +c nomalt contient la liste des noms d'objets temporaires +c qui sont alloues. +c ces noms sont etablis independamment de la categorie (structure +c ou entier, ou reel, ...) +c le nombre d'objets temporaires est contenu dans le commun gmtenb +c (plus precisement, un tableau de flags numete, +c dimensionne lui aussi avec une marge, a maxtbt > 3*maxtab+nobjx). +c + character*8 nomalt + common /gmteno/ nomalt(maxtbt) diff --git a/src/tool/Gestion_MTU/gmtoai.h b/src/tool/Gestion_MTU/gmtoai.h new file mode 100644 index 00000000..33dc9125 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtoai.h @@ -0,0 +1,30 @@ +c +c gmtoai : les Tableaux pour les Objets Alloues en Integer +c +c typobj : numero du type de chaque objet alloue. +c +c adrdso : reperage des champs associes a chaque objet alloue. +c cela sert d'indexage pour le tableau nomobc, ainsi : +c les champs relatifs a l'objet i sont stockes entre +c les indices adrdso(i) et adrdso(i)+nbcham(typobj(i))-1 inclus +c +c adrdsa : reperage des attributs associes a chaque objet alloue. +c cela sert d'indexage pour le tableau valatt, ainsi : +c les attributs relatifs a l'objet i sont stockes entre +c les indices adrdsa(i) et adrdsa(i)+nbattr(typobj(i))-1 inclus +c +c valatt : valeurs des attributs pour l'ensemble des objets alloues. +c l'indexage se fait par le pointeur adrdsa. +c +c Rappel : nobjx = nombre d'objets alloues +c nobcx = nombre cumule d'attributs pour les objets alloues +c iptobj = numero du prochain objet a allouer +c iptchp = 1er indice disponible dans le tableau nomobc +c iptatt = 1er indice disponible dans le tableau valatt +c + integer typobj,adrdso,adrdsa,valatt, + > iptobj,iptchp,iptatt +c + common /gmtoai/ typobj(nobjx), adrdso(nobjx), adrdsa(nobjx), + > valatt(nobcx), + > iptobj, iptchp, iptatt diff --git a/src/tool/Gestion_MTU/gmtoas.h b/src/tool/Gestion_MTU/gmtoas.h new file mode 100644 index 00000000..9c975c08 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtoas.h @@ -0,0 +1,12 @@ +c copyright edf 1999 +c +c gmtoas : les Tableaux pour les Objets Alloues en String +c +c nomobj : nom des objets strutures crees +c nomobc : nom des objets attaches aux champs des objets strutures crees +c nomtbp : nom des types simples de base et des types structures crees +c + character*8 nomobj(nobjx), nomobc(nobcx) + character*8 nomtbp( -ntybma : nobjx ) +c + common / gmtoas / nomobj, nomobc, nomtbp diff --git a/src/tool/Gestion_MTU/gmtori.h b/src/tool/Gestion_MTU/gmtori.h new file mode 100644 index 00000000..bfb89a04 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtori.h @@ -0,0 +1,31 @@ +c +c gmtori : les Tableaux pour les Objets de Reference en Integer +c +c nbcham : nombre de champs associes a chaque type declare dans le +c fichier de configuration de GM +c +c nbattr : nombre d'attributs associes a chaque type declare dans le +c fichier de configuration de GM +c +c adrdst : reperage des champs associes a chaque type declare dans le +c fichier de configuration de GM. cela sert d'indexage pour +c les tableaux typcha et nomcha, ainsi : +c les infos relatives aux champs du type i sont placees entre +c les indices adrdst(i) et adrdst(i)+nbcham(i)-1 inclus +c +c typcha : type des champs associes a chaque type declare dans le +c fichier de configuration de GM. l'indexage se fait par +c le pointeur adrdst. +c +c Rappel : ntypx = nombre maximum de types declarables dans +c la configuration de GM +c nchpx = nombre maximum de champs declarables dans +c la configuration de GM +c nbrtyp = nombre de type effectivement declares +c + integer nbcham,nbratt,adrdst,typcha, + > nbrtyp, ntyb +c + common /gmtori/ nbcham(ntypx), nbratt(ntypx), adrdst(ntypx), + > typcha(nchpx), + > nbrtyp, ntyb diff --git a/src/tool/Gestion_MTU/gmtors.h b/src/tool/Gestion_MTU/gmtors.h new file mode 100644 index 00000000..c59c4ff7 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtors.h @@ -0,0 +1,15 @@ +c +c gmtors : les Tableaux pour les Objets de Reference en String +c +c nomtyp : nom des types d'objet structure declares dans le +c fichier de configuration de GM +c nomcha : nom des champs declares dans la definition des types +c d'objets du fichier de configuration de GM. l'indexage se +c fait par le pointeur adrdst. +c nomtyb : nom des types simples de base (entier, reel, ...) +c + character*8 nomtyp, nomcha, + > nomtyb +c + common /gmtors/ nomtyp(ntypx), nomcha(nchpx), + > nomtyb(ntybma) diff --git a/src/tool/Gestion_MTU/gmtove.h b/src/tool/Gestion_MTU/gmtove.h new file mode 100644 index 00000000..5e58147c --- /dev/null +++ b/src/tool/Gestion_MTU/gmtove.h @@ -0,0 +1,10 @@ +c +c . version des types d'objet : +c nuveto : numero de version +c nusvto : numero de sous-version +c . date de la version des types d'objets : +c daheto : nombre de seconde depuis le debut de l'an +c nuanto : numero de l'annee (complet) +c + integer nuveto, nusvto, daheto, nuanto + common / gmtove / nuveto, nusvto, daheto, nuanto diff --git a/src/tool/Gestion_MTU/gmtren.h b/src/tool/Gestion_MTU/gmtren.h new file mode 100644 index 00000000..b0293d2e --- /dev/null +++ b/src/tool/Gestion_MTU/gmtren.h @@ -0,0 +1,8 @@ +c + integer minmei, ntroui, ptroui, ltroui, + > nballi, ptalli, lgalli, + > totali, minlei +c + common /gmtren/ minmei, ntroui, ptroui(maxtrs), ltroui(maxtrs), + > nballi, ptalli(maxtab), lgalli(maxtab), + > totali, minlei diff --git a/src/tool/Gestion_MTU/gmtrrl.h b/src/tool/Gestion_MTU/gmtrrl.h new file mode 100644 index 00000000..3262c58a --- /dev/null +++ b/src/tool/Gestion_MTU/gmtrrl.h @@ -0,0 +1,8 @@ +c + integer minmer, ntrour, ptrour, ltrour, + > nballr, ptallr, lgallr, + > totalr, minler +c + common /gmtrrl/ minmer, ntrour, ptrour(maxtrs), ltrour(maxtrs), + > nballr, ptallr(maxtab), lgallr(maxtab), + > totalr, minler diff --git a/src/tool/Gestion_MTU/gmtrst.h b/src/tool/Gestion_MTU/gmtrst.h new file mode 100644 index 00000000..13b57736 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtrst.h @@ -0,0 +1,8 @@ +c + integer minmes, ntrous, ptrous, ltrous, + > nballs, ptalls, lgalls, + > totals, minles +c + common /gmtrst/ minmes, ntrous, ptrous(maxtrs), ltrous(maxtrs), + > nballs, ptalls(maxtab), lgalls(maxtab), + > totals, minles diff --git a/src/tool/Gestion_MTU/gmtyar.h b/src/tool/Gestion_MTU/gmtyar.h new file mode 100644 index 00000000..6c27aa5b --- /dev/null +++ b/src/tool/Gestion_MTU/gmtyar.h @@ -0,0 +1,7 @@ +c +c typarr gere les arrets de gm en cas de probleme. +c 0 : un probleme dans gm conduit a un arret par le programme ad-hoc +c 1 : un probleme dans gm conduit a un code de retour non nul +c + integer typarr + common / gmtyar / typarr diff --git a/src/tool/Gestion_MTU/gmtyge.h b/src/tool/Gestion_MTU/gmtyge.h new file mode 100644 index 00000000..86d1c10a --- /dev/null +++ b/src/tool/Gestion_MTU/gmtyge.h @@ -0,0 +1,22 @@ +c +c modgm : decrit le mode de gestion de la memoire +c 0 --> statique, la place est reserve par le dimensionnement +c des communs xmem(*) a la creation de l'executable +c et ensuite les tableaux et les trous sont pris dans +c ces communs +c 1 --> semi-dynamique, pour chaque type une zone memoire est +c alloue dynamiquement avec une taille fournie en donnee +c et ensuite les tableaux et les trous sont pris dans +c cette zone. +c 2 --> dynamique, chaque tableau est alloue dynamiquement et +c il n'y a pas de gestion des trous +c +c adcom : adresse vraie en memoire du debut de chaque commun +c admem : adresse en memoire du debut de chaque zone par rapport a quoi +c sont places rellement les tableaux +c . en statique, c'est la meme valeur que adcom +c . en semi-dynamique, c'est l'adresse vraie de la zone alloue +c . en dynamique, c'est 0 +c + integer modgm,adcom,admem + common /gmtyge/ modgm,adcom(8),admem(8) diff --git a/src/tool/Gestion_MTU/gmtyoj.F b/src/tool/Gestion_MTU/gmtyoj.F new file mode 100644 index 00000000..90c072a2 --- /dev/null +++ b/src/tool/Gestion_MTU/gmtyoj.F @@ -0,0 +1,188 @@ + subroutine gmtyoj ( nom, typobj, simple, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c determine le type d'un objet +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nom . e .char*(*). nom etendu de l'objet . +c . typobj . s . char*8 . type de l'objet . +c . simple . s . ent . 1 : l'objet est simple . +c . . . . 0 : l'objet est compose . +c . codret . s . ent . code retour de l'operation . +c . . . . 0 : OK . +c . . . . -1 : objet-terminal non alloue . +c . . . . -2 : objet-terminal non defini . +c . . . . -3 : nom etendu invalide . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c +c 0.1. ==> generalites +c + implicit none + save + character*6 nompro + parameter ( nompro = 'GMTYOJ' ) +c +c +#include "genbla.h" +c +#include "gmmatc.h" +c +c 0.2. ==> communs +c +#include "gmtoas.h" +c +#include "gmimpr.h" +#include "gmlang.h" +#include "gminds.h" +c +c 0.3. ==> arguments +c + character*(*) nom + character*8 typobj +c + integer simple, codret +c +c 0.4. ==> variables locales +c + character*8 objrep,objter,chater +c + integer iaux, idec, ioal, letype +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Nom de l''''objet en memoire centrale :'')' + texte(1,11) = '(''L''''objet n''''est pas alloue.'')' + texte(1,12) = '(''L''''objet n''''est pas defini.'')' + texte(1,13) = '(''Le nom est invalide.'')' +c + texte(2,10) = '(''Name of the object in central memory :'')' + texte(2,11) = '(''The object is not allocated.'')' + texte(2,12) = '(''The object is not defined.'')' + texte(2,13) = '(''Bad name in central memory.'')' +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) + write (ulsort,*) nom +#endif +c +c==== +c 2. on se base sur le nom interne pour travailler +c==== +c + typobj = sindef +c + codret = 0 +c +c 2.1. ==> appel de la fonction generique +c + call gbdnoe ( nom, objrep, objter, chater, idec ) +c + if (idec.lt.0) then +c +c 2.2. ==> nom etendu invalide +c + codret = -3 +c + else if (idec.eq.1) then +c +c 2.3. ==> objet-terminal non defini +c + codret = -2 +c + else if (idec.eq.2) then +c +c 2.4. ==> objet-terminal non alloue +c + codret = -1 +c + else +c +c 2.5. ==> sous quel forme l'objet terminal est-il alloue ? +c + call gbobal ( objter, letype, ioal ) +c + if ( ioal.eq.1 ) then + simple = 0 + typobj = nomtbp(letype) + elseif ( ioal.eq.2 ) then + simple = 1 + typobj = nomtbp(letype) + else + codret = -1 + endif +c + endif +c +c 2.6. ==> bilan +c + if ( codret.ne.0 ) then + goto 91 + endif +c +c==== +c 9. gestion des erreurs +c==== +c + 91 continue +c + if ( codret.ne.0 ) then +c + iaux = 10+abs(codret) +c + write (ulsort,90000) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) + write (ulsort,*) nom + write (ulsort,texte(langue,iaux)) + write (ulsort,90000) +c + endif +c +90000 format (70('=')) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90000) +#endif + end diff --git a/src/tool/Gestion_MTU/gtbila.F b/src/tool/Gestion_MTU/gtbila.F new file mode 100644 index 00000000..2c4373b0 --- /dev/null +++ b/src/tool/Gestion_MTU/gtbila.F @@ -0,0 +1,449 @@ + subroutine gtbila +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion du Temps : BILAn de la mesure' +c - - ---- +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTBILA' ) +c +#include "genbla.h" +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c +#include "gtdita.h" +c + integer code +c + double precision tuser, tsyst +c + integer numan1, numan2 + integer nbsec1, nbsec2, nbseco, nbjour + integer iheure, iminut, iseco + integer iaux, ideb, ifin + integer jaux + integer ulsort, langue, imprgt +c + double precision temps(3), tpmoy, tptota + double precision xheure, xminut + double precision daux +c + character*7 blabla + character*8 saux08(nblang,2) +c + logical afaire, afair1 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. dernier appel du temps +c==== +c + call dmtemp ( tuser, tsyst ) +c +c==== +c 2. messages +c==== +c +#include "impr01.h" +c + texte(1,4) = ' Identification de la section ' + texte(1,5) = ' Temps d''execution ' + texte(1,6) = ' Nom ' + texte(1,7) = ' Nro : Nombre ' + texte(1,8) = ' Total : Moyen ' + texte(1,9) = ' : Appels ' + texte(1,10) = ' (secondes) ' + texte(1,12) = 'Temps systeme total ' + texte(1,13) = 'Temps de calcul total ' + texte(1,14) = 'Temps total en machine ' +c + texte(2,4) = ' Identification of the section ' + texte(2,5) = ' Computational time ' + texte(2,6) = ' Name ' + texte(2,7) = ' # : Number ' + texte(2,8) = ' Total : Average ' + texte(2,9) = ' : Calls ' + texte(2,10) = ' (seconds) ' + texte(2,12) = 'Total system time ' + texte(2,13) = 'Total calculation time ' + texte(2,14) = 'Total time in computer ' +c + saux08(1,1) = 'secondes' + saux08(2,1) = 'seconds ' + saux08(1,2) = 'seconde ' + saux08(2,2) = 'second ' +c +c==== +c 3. recuperation de l'information +c==== +c + code = 1 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c + imprgt = nbrapp(-4) + langue = nbrapp(-3) + ulsort = nbrapp(0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 4. fin des mesures +c on ferme ce qui aurait pu rester ouvert. +c dans une situation de fin normale, seule la section +c globale, de numero nbsep1, est encore ouverte. toutes +c les autres auraient du etre fermees au prealable. +c cependant, en cas d'arret anticipe, des sections peuvent +c ne pas avoir ete fermees. il vaut mieux le faire ici pour +c avoir un affichage des temps qui soit realiste. +c==== +c + do 4 , iaux = 1 , nbsep1 + if ( ouvert (iaux) ) then + tpscpu (iaux) = tpscpu (iaux) + tuser + ouvert (iaux) = .false. + endif + 4 continue +c + tpscpu(0) = tpscpu(0) + tsyst +c +c==== +c 5. impression eventuelle des temps de chaque section +c==== +c +#ifdef _DEBUG_HOMARD_ + afaire = .true. +#else + if ( mod(imprgt,2).eq.0 ) then + afaire = .true. + else + afaire = .false. + endif +#endif +c + if ( afaire ) then +c + do 5 , jaux = 1, 2 +c + write (ulsort,50000 ) +c + write (ulsort,50010) texte(langue,4)(1:41), + > texte(langue,5)(1:27), + > texte(langue,6)(1:26), + > texte(langue,7)(1:14), + > texte(langue,8)(1:27), + > texte(langue,9)(1:14), + > texte(langue,10)(1:13), + > texte(langue,10)(1:13) +c + do 51 , iaux = 1 , nbsect +c + afair1 = .false. + if ( nbrapp(iaux).gt.0 ) then + if ( jaux.eq.1 ) then + afair1 = .true. + else + if ( mod(iaux,10).eq.0 ) then + afair1 = .true. + endif + endif + endif + if ( afair1 ) then + daux = dble ( nbrapp (iaux) ) + tpmoy = tpscpu (iaux) / daux + daux = 100.d0 * tpscpu (iaux) / tpscpu (nbsep1) + write (ulsort,50020 ) titsec (langue,iaux), iaux, + > nbrapp (iaux), tpscpu (iaux), + > tpmoy, daux + endif +c + 51 continue +c + write (ulsort,50021 ) titsec (langue,nbsep1), tpscpu (nbsep1) +c + write (ulsort,50030 ) +c + 5 continue +c + endif +c +50000 format(//) +50010 format( 79('.'), + >/':',a41, ':',4x,a27,4x,':', + >/':',77('.'),':', + >/':',a26,':',a14,':',a27, ': % :', + >/':',26x,':',a14,':',a13,':',a13,':',7x,':', + >/':',77('.'),':') +50020 format( + > ':',26x,':',5x,':',8x,':',13x,':',13x,':',7x,':', + >/': ',a24, ' :',i4,' :',i7,' :' + > ,g12.5,' :',g12.5,' :',f6.1,' :') +50021 format( + > ':',26x,':',5x,':',8x,':',13x,':',13x,':',7x,':', + >/': ',a24, ' :',4x,' :',7x,' :' + > ,g12.5,' :',12x ,' :',6x,' :') +50030 format(':',77('.'),':') +50040 format(79('.')) +c +c==== +c 6. calcul du temps total : +c==== +c + if ( afaire ) then +c +c 6.1. ==> acquisition de la date actuelle et de depart +c + call ugdhco ( numan2, nbsec2 ) +c + numan1 = nbrapp (-2) + nbsec1 = nbrapp (-1) +c +c 6.2. ==> difference ; si l'on a change d'annee, on rajoute le nombre +c de secondes de l'annee de depart. +c + nbseco = nbsec2 - nbsec1 +c + if ( numan1.ne.numan2 ) then + if ( mod(numan1,4) .eq. 0 ) then + nbjour = 366 + else + nbjour = 365 + endif + nbseco = nbseco + 86400*nbjour + endif +c +c le temps total en machine n'est, au mieux, evalue qu'a 1 seconde pres. +c + tptota = dble ( max(0,nbseco) ) +c + endif +c +c==== +c 7. archivage des temps de calcul, systeme, d'attente et total +c si le temps systeme n'etait pas accessible sur la machine utilisee, +c le contenu de tpscpu(0) est negatif. on l'ignore donc dans les +c impressions recapitulatives. +c==== +c + if ( afaire ) then +c + if ( tpscpu(0).ge.0.0d0 ) then + temps (1) = tpscpu(0) + ideb = 1 + else + temps (1) = 0.0d0 + ideb = 2 + endif + temps (2) = max(0.0d0, tpscpu (nbsep1) ) +c +c petite correction du temps total en machine, pour les cas ou le +c temps total n'a pas pu etre evalue, et surtout les cas ou le temps +c total en machine est plus petit que 1 seconde ... +c ( meme remarque que ci-dessus, concernant le parallelisme et +c la comparaison de tptota avec temps(1)+temps(2) ). +c + if ( tptota.le.0.0d0 ) then + iseco = max(0, int(temps(1)+temps(2)) ) + if ( temps(1)+temps(2).ge.60.0d0 ) then + tptota = dble(iseco) + else if ( temps(1)+temps(2).gt.0.0d0 ) then + tptota = temps(1)+temps(2) + endif + if ( temps(1)+temps(2)-tptota.gt.0.5d0 ) then + tptota = tptota + 1.0d0 + endif + endif +c + temps (3) = tptota +c +c attention : en environnement multiprocesseur, tptota ne devrait pas +c etre compare directement a temps(1)+temps(2) (qui represente la +c somme des temps CPU consommes par les differents processeurs +c mobilises ==> attention aux eventuelles taches executees en +c parallele). +c + endif +c +c==== +c 8. conversion en heures, minutes et secondes des differents +c temps globaux et impressions recapitulatives. +c==== +c + if ( afaire ) then +c + if ( tptota.le.1.0d0 ) then + ifin = 2 + else + ifin = 3 + endif +c + do 80 , iaux = ideb , ifin +c + if ( iaux.eq.3 ) then + write (ulsort,50040 ) + endif + write (ulsort,80000 ) +c + if ( temps(iaux).ge.3600.d0 ) then +c + xheure = temps(iaux) / 3600.d0 + iheure = max(1, int ( xheure ) ) + xheure = dble ( iheure ) + temps(iaux) = max(0.0d0, temps(iaux) - 3600.d0*xheure ) +c + xminut = temps(iaux) / 60.d0 + iminut = int ( xminut ) + xminut = dble ( iminut ) + temps(iaux) = max(0.0d0, temps(iaux) - 60.d0*xminut ) + iseco = int ( temps(iaux) ) + if ( temps(iaux)-dble(iseco).gt.0.5d0 ) then + iseco = iseco + 1 + endif + if ( iseco.ge.60 ) then + iseco = iseco - 60 + iminut = iminut + 1 + endif + if ( iminut.ge.60 ) then + iminut = iminut - 60 + iheure = iheure + 1 + endif +c + if ( iheure.le.1 ) then + if (langue.ne.2) then + blabla = ' heure ' + else + blabla = ' hour ' + endif + else + if (langue.ne.2) then + blabla = ' heures' + else + blabla = ' hours ' + endif + endif +c + if (iminut.gt.1) then + write (ulsort,81010) texte(langue,11+iaux)(1:30), + > iheure , blabla , iminut , iseco + else + write (ulsort,81011) texte(langue,11+iaux)(1:30), + > iheure , blabla , iminut , iseco + endif +c + else +c + if ( temps(iaux).ge.60.d0 ) then +c + xminut = temps(iaux) / 60.d0 + iminut = max(1, int ( xminut ) ) + xminut = dble ( iminut ) + temps(iaux) = max(0.0d0, temps(iaux) - 60.d0*xminut ) + iseco = int ( temps(iaux) ) + if ( temps(iaux)-dble(iseco).gt.0.5d0 ) then + iseco = iseco + 1 + endif + if ( iseco.ge.60 ) then + iseco = iseco - 60 + iminut = iminut + 1 + endif +c + if ( iminut.le.1 ) then + blabla = 'minute ' + else + blabla = 'minutes' + endif +c + if ( iseco.gt.1 ) then + write (ulsort,81020) texte(langue,11+iaux)(1:30), iminut, + > blabla, iseco, saux08(langue,1) + else + write (ulsort,81020) texte(langue,11+iaux)(1:30), iminut, + > blabla, iseco, saux08(langue,2) + endif +c + else +c + if ( iaux.le.2 ) then + write (ulsort,81030) texte(langue,11+iaux)(1:30), + > temps(iaux), saux08(langue,1) + elseif ( nbseco.gt.1 ) then + write (ulsort,81031) texte(langue,11+iaux)(1:30), + > nbseco, saux08(langue,1) + else + write (ulsort,81031) texte(langue,11+iaux)(1:30), + > max(nbseco,1), saux08(langue,2) + endif +c + endif +c + endif +c + write (ulsort,80010 ) +c + 80 continue +c + endif +c +80000 format(':',41x,':',35x,':') +80010 format(':',41x,':',35x,':', + > /,':',77('.'),':') +c +81010 format ( + > ': ',a30,10x,':',i3,a7,i3,' minutes',i3,' s :') +81011 format ( + > ': ',a30,10x,':',i3,a7,i3,' minute ',i3,' s :') +c +81020 format ( + > ': ',a30,10x,': ',i3,' ',a7,i3,' ',a8,11x,':') +c +81030 format( ': ',a30,10x,': ',g12.5,' ',a8,11x,':') +81031 format( ': ',a30,10x,':',12x,i3,' ',a8,11x,':') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtdems.F b/src/tool/Gestion_MTU/gtdems.F new file mode 100644 index 00000000..82aa9f99 --- /dev/null +++ b/src/tool/Gestion_MTU/gtdems.F @@ -0,0 +1,171 @@ + subroutine gtdems ( numero ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 30.12.88 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : DEbut de Mesure de Section' +c - - -- - - +c ______________________________________________________________________ +c +c Remarque : en encadrant ce sous-programme par les appels a la fonction +c de base dmtemp, on ne prend pas en compte les temps +c necessaires a ce sous-programme lui-meme. Cela occasionne +c obligatoirement une erreur si on compare le temps total +c a la somme des temps particuliers, mais cela permet d'avoir +c une bonne precision dans la mesure de chaque section. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numero . e . 1 . numero de la section a mesurer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTDEMS' ) +c +#include "genbla.h" +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numero +c +c 0.4. ==> variables locales +c + double precision tuser, tsyst +c + integer iaux + integer ulsort, langue +c +#include "gtdita.h" +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c +c==== +c 2. mesure du temps ecoule depuis le dernier appel a dmtemp +c==== +c + call dmtemp ( tuser, tsyst ) +c +c==== +c 3. recuperation de l'information +c==== +c + call gttabl ( 1, nbsep1, nbrapp, ouvert, titsec, tpscpu ) +c + langue = nbrapp(-3) + ulsort = nbrapp(0) +c +c==== +c 4. cumul des temps +c==== +c +c 4.1. ==> on incremente tous les compteurs de temps de calcul +c correspondant a des sections ouvertes +c + do 4 , iaux = 1 , nbsep1 +c + if ( ouvert (iaux) ) then + tpscpu (iaux) = tpscpu (iaux) + tuser + endif +c + 4 continue +c +c 4.2. ==> on cumule le temps d'attente systeme +c + tpscpu(0) = tpscpu(0) + tsyst +c +c==== +c 5. gestion de la section +c==== +c +c 5.1. ==> verification du numero +c + if ( numero.lt.1 .or. numero.gt.nbsect ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,51000) numero, nbsect + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +51000 format( + > 'On veut demarrer la mesure de temps pour la section',i9,'.', + >/'C''est impossible. Il faut un numero entre 1 et',i9,'.',/) +c +c 5.2. ==> etait-ce deja ouvert ? +c + if ( ouvert(numero) ) then + ulsort = nbrapp(0) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,52000) numero, nbrapp(numero) + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +52000 format( + > 'On veut demarrer la mesure de temps pour la section',i8,'.', + >/'Or elle n''a pas ete close apres la ',i8,'-eme mesure ...',/) +c +c 5.3. ==> on ouvre la section de cet appel et on ajoute 1 au compteur +c + ouvert (numero) = .true. + nbrapp (numero) = nbrapp (numero) + 1 +c +c==== +c 6. on archive l'information +c==== +c + call gttabl ( 0, nbsep1, nbrapp, ouvert, titsec, tpscpu ) +c +c==== +c 7. nouvel appel a dmtemp pour ignorer le plus possible le temps +c mis par ce programme de mesure +c==== +c + call dmtemp ( tuser, tsyst ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtdita.h b/src/tool/Gestion_MTU/gtdita.h new file mode 100644 index 00000000..64b20ac8 --- /dev/null +++ b/src/tool/Gestion_MTU/gtdita.h @@ -0,0 +1,13 @@ +c copyright edf 1999 +c +c Ceci est le dimensionnement de l'ensemble des tableaux de gestion +c du gestionnaire de mesures de temps de calcul +c + double precision tpscpu (0:nbsep1) +c + integer nbrapp (-4:nbsep1) +c + character*24 titsec(nblang,nbsep1) +c + logical ouvert (nbsep1) +c diff --git a/src/tool/Gestion_MTU/gtfims.F b/src/tool/Gestion_MTU/gtfims.F new file mode 100644 index 00000000..8c1a6fa1 --- /dev/null +++ b/src/tool/Gestion_MTU/gtfims.F @@ -0,0 +1,169 @@ + subroutine gtfims ( numero ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 30.12.88 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : FIn de Mesure de Section' +c - - -- - - +c +c ______________________________________________________________________ +c +c Remarque : en encadrant ce sous-programme par les appels a la fonction +c de base dmtemp, on ne prend pas en compte les temps +c necessaires a ce sous-programme lui-meme. Cela occasionne +c obligatoirement une erreur si on compare le temps total +c a la somme des temps particuliers, mais cela permet d'avoir +c une bonne precision dans la mesure de chaque section. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numero . e . 1 . numero de la section a mesurer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTFIMS' ) +c +#include "genbla.h" +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numero +c +c 0.4. ==> variables locales +c + double precision tuser, tsyst +c + integer iaux + integer ulsort, langue +c +#include "gtdita.h" +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c +c==== +c 2. mesure du temps ecoule depuis le dernier appel a dmtemp +c==== +c + call dmtemp ( tuser, tsyst ) +c +c==== +c 3. recuperation de l'information +c==== +c + call gttabl ( 1, nbsep1, nbrapp, ouvert, titsec, tpscpu ) +c + langue = nbrapp(-3) + ulsort = nbrapp(0) +c +c==== +c 4. cumul des temps +c==== +c +c 4.1. ==> on incremente tous les compteurs de temps de calcul +c correspondants a des sections ouvertes +c + do 4 , iaux = 1 , nbsep1 +c + if ( ouvert (iaux) ) then + tpscpu (iaux) = tpscpu (iaux) + tuser + endif +c + 4 continue +c +c 4.2. ==> on cumule le temps d'attente systeme +c + tpscpu(0) = tpscpu(0) + tsyst +c +c==== +c 5. gestion de la section +c==== +c +c 5.1. ==> verification du numero +c + if ( numero.lt.1 .or. numero.gt.nbsect ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,51000) numero, nbsect + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +51000 format( + > 'On veut finir la mesure de temps pour la section',i9,'.', + >/,'C''est impossible. Il faut un numero entre 1 et',i9,'.',/) +c +c 5.2. ==> etait-ce deja ouvert ? +c + if ( .not. ouvert(numero) ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,52000) numero + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +52000 format( + > 'On veut finir la mesure de temps pour la section',i8,'.', + >/,'Or elle n''a jamais ete commencee ...',/) +c +c 5.3. ==> c'est bon, on peut fermer +c + ouvert (numero) = .false. +c +c==== +c 6. on archive l'information +c==== +c + call gttabl ( 0, nbsep1, nbrapp, ouvert, titsec, tpscpu ) +c +c==== +c 7. nouvel appel a dmtemp pour ignorer le plus possible le temps +c mis par ce programme de mesure +c==== +c + call dmtemp ( tuser, tsyst ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtinfo.F b/src/tool/Gestion_MTU/gtinfo.F new file mode 100644 index 00000000..cd76b73c --- /dev/null +++ b/src/tool/Gestion_MTU/gtinfo.F @@ -0,0 +1,117 @@ + subroutine gtinfo ( imprgt ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion des mesures de Temps : INFOrmations' +c - - ---- +c ______________________________________________________________________ +c +c but : modifie la consigne d'impression des messages du gestionnaire +c des mesures de temps +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . imprgt . e . 1 . pilotage des impressions . +c . . . . 1 : le standard . +c . . . . 2 : le detail des sections . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTINFO' ) +c +#include "genbla.h" +c +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer imprgt +c +c 0.4. ==> variables locales +c +#include "gtdita.h" +c + integer iaux, code +c + integer ulsort, langue +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c + texte(1,4) = '(''Dans '',a,'', imprgt ='',i8)' +c + texte(2,4) = '(''In '',a,'', imprgt ='',i8)' +c +c==== +c 2. recuperation de l'archivage +c==== +c + code = 1 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) + langue = nbrapp(-3) + ulsort = nbrapp(0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. archivage du code de pilotage des impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nompro, imprgt +#endif +c + nbrapp(-4) = imprgt + code = 0 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtinit.F b/src/tool/Gestion_MTU/gtinit.F new file mode 100644 index 00000000..75702638 --- /dev/null +++ b/src/tool/Gestion_MTU/gtinit.F @@ -0,0 +1,197 @@ + subroutine gtinit ( ulsort, lgmess, imprgt ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 30.12.88 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : INITialisation' +c - - ---- +c +c ______________________________________________________________________ +c +c but : initialiser la gestion des mesures de temps +c - on archive ce point de depart +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . numero de l'unite logique ou imprimer . +c . . . . les messages du gestionnaire de temps . +c . lgmess . e . 1 . langue des message de gt . +c . imprgt . e . 1 . pilotage des impressions . +c . . . . 1 : le standard . +c . . . . 2 : le detail des sections . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTINIT' ) +c +#include "genbla.h" +#include "gelggt.h" +c +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulsort, lgmess, imprgt +c +c 0.4. ==> variables locales +c +#include "gedita.h" +#include "gtdita.h" +c + integer iaux, jaux, code + integer langue +c + integer numann, datheu +c + double precision tuser, tsyst +c + character*24 blanc + parameter ( blanc = ' ' ) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + if ( lgmess.ge.1 .and. lgmess.le.nblang ) then + langue = lgmess + else + langue = 1 + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = 'Ensemble du programme ' +c + texte(2,10) = 'Total program ' +c +c==== +c 2. verification que l'initialisation n'est pas deja faite +c==== +c + code = 1 + call ugtabl ( code, tabges, ulsort) +c + if ( tabges(2).ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,20000) + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +20000 format( + >'L''initialisation du gestionnaire a deja ete faite.',/, + >'Il ne faut faire appel qu''une seule fois a GTINIT.',//) +c +c==== +c 3. initialisation de dmtemp +c==== +c + call dmtemp ( tuser, tsyst ) +c +c==== +c 4. acquisition de la date et de l'heure actuelle +c==== +c + call ugdhco ( numann, datheu ) +c +c==== +c 5. initialisation des differents tableaux +c==== +c + nbrapp (-4) = imprgt + nbrapp (-3) = lgmess + nbrapp (-2) = numann + nbrapp (-1) = datheu + nbrapp ( 0) = ulsort +c + tpscpu (0) = 0.d0 +c + do 51 , iaux = 1 , nbsect +c + nbrapp (iaux) = 0 + ouvert (iaux) = .false. + tpscpu (iaux) = 0.d0 +c + 51 continue +c + nbrapp (nbsep1) = 1 + ouvert (nbsep1) = .true. + tpscpu (nbsep1) = 0.d0 +c + do 52 , jaux = 1 , nblang + do 521 , iaux = 1 , nbsect + titsec (jaux,iaux) = blanc + 521 continue + titsec (jaux,nbsep1) = texte(lgmess,10)(1:24) + 52 continue +c +c==== +c 6. on archive l'information +c==== +c +c 6.1. ==> pour le gestionnaire des mesures de temps de calcul +c + code = 0 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c +c 6.2. ==> attention, l'initialisation de ulsort doit se faire par +c le programme gtmess, pour controler la validite du numero +c + call gtmess ( ulsort ) +c +c 6.3. ==> archivage pour le gestionnaire global +c + tabges(2) = 1 +c + code = 0 + call ugtabl ( code, tabges, ulsort) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtlanm.F b/src/tool/Gestion_MTU/gtlanm.F new file mode 100644 index 00000000..c9f62a6b --- /dev/null +++ b/src/tool/Gestion_MTU/gtlanm.F @@ -0,0 +1,132 @@ + subroutine gtlanm ( lang ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion des mesures de Temps : LANgue des Messages' +c - - --- - +c ______________________________________________________________________ +c +c but : modifie la langue des messages du gestionnaire des mesures +c de temps +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lang . e . 1 . code de la langue souhaitee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTLANM' ) +c +#include "genbla.h" +c +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lang +c +c 0.4. ==> variables locales +c +#include "gtdita.h" +c + integer iaux, code +c + integer langue + integer ulsort +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c + texte(1,4) = '(''Le numero de langue '',i2,'' voulu'')' + texte(1,5) = '(''pour les sorties GT est incorrect.'')' + texte(1,6) = '(''Il doit etre compris entre 1 et '',i8)' +c + texte(2,4) = '(''The language code # '',i2,'' wanted for'')' + texte(2,5) = '(''GT messages is not correct.'')' + texte(2,6) = '(''It must be included between 1 and '',i8)' +c +c==== +c 2. recuperation de l'archivage +c==== +c + code = 1 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) + langue = nbrapp(-3) + ulsort = nbrapp(0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. verification de la validite du numero. +c Il faut que le numero soit compris entre 1 et le nombre maximal +c de langue. +c==== +c + if ( lang.lt.1 .or. lang.gt.nblang ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) lang + write (ulsort,texte(langue,5)) + write (ulsort,texte(langue,6)) nblang +c + endif +c +c==== +c 5. archivage du numero et du nouveau message +c==== +c + nbrapp(-3) = lang +c + code = 0 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtmess.F b/src/tool/Gestion_MTU/gtmess.F new file mode 100644 index 00000000..1d86862f --- /dev/null +++ b/src/tool/Gestion_MTU/gtmess.F @@ -0,0 +1,145 @@ + subroutine gtmess ( ulmess ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 11.12.95 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : unite de sortie des MESSages' +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulmess . e . 1 . numero de l'unite logique ou imprimer . +c . . . . les messages du gestionnaire de temps . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTMESS' ) +c +#include "genbla.h" +#include "gtnbse.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulmess +c +c 0.4. ==> variables locales +c +#include "gtdita.h" +c + logical imprim, dejavu +c + integer guimp, gmimp, raison + integer codret, ulsort +c + integer langue +c + integer iaux, code +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data dejavu / .false. / + data langue / 1 / +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> initialisation des messages +c +#include "impr01.h" +c + texte(1,10) = '(''Le numero d''''unite logique '',i2,'' voulu'')' + texte(1,4) = + >'(''pour les sorties GT n''''a pas le bon statut GU.'')' +c + texte(2,10) = '(''The logical unit # '',i2,'' wanted for'')' + texte(2,4) = '(''GT messages has not the right status in GU.'')' +c +c 1.2. ==> recuperation de l'information +c + code = 1 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c + if ( dejavu ) then + ulsort = nbrapp(0) + else + call gusost ( ulsort ) + endif +c +c==== +c 2. verification de la validite du numero. il faut que le statut soit : +c 2 : Sortie standard (sequentiel formate) +c 3 : Ouvert en acces sequentiel formate +c==== +c + imprim = .false. + call guinfu ( ulmess, codret, imprim ) +c + if ( codret.ne.2 .and. codret.ne.3 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) + write (ulsort,texte(langue,10)) ulmess + write (ulsort,texte(langue,4)) +c + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop(nompro,ulsort,guimp, gmimp, raison) +c + endif +c +c==== +c 3. on archive l'information +c==== +c + nbrapp(0) = ulmess +c + code = 0 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c + dejavu = .true. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtnbse.h b/src/tool/Gestion_MTU/gtnbse.h new file mode 100644 index 00000000..c93ded6a --- /dev/null +++ b/src/tool/Gestion_MTU/gtnbse.h @@ -0,0 +1,9 @@ +c +c nbsect : nombre maximum de sections de mesures acceptees par +c le gestionnaire GT +c + integer nbsect + parameter ( nbsect = 300 ) +c + integer nbsep1 + parameter ( nbsep1 = nbsect + 1 ) diff --git a/src/tool/Gestion_MTU/gtnoms.F b/src/tool/Gestion_MTU/gtnoms.F new file mode 100644 index 00000000..60187b22 --- /dev/null +++ b/src/tool/Gestion_MTU/gtnoms.F @@ -0,0 +1,181 @@ + subroutine gtnoms ( numero, langue, titre ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 30.12.88 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : NOM de Section' +c - - --- _ +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numero . e . 1 . numero de la section a mesurer . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . titre . e . ch*24 . nom a donner a la section . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTNOMS' ) +c +#include "gtnbse.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numero, langue +c + character*(*) titre +c +c 0.4. ==> variables locales +c +#include "gtdita.h" +c + integer code, iaux, ifin, lontit + integer ulsort +c + character*24 titr2 +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c +c==== +c 2. recuperation de l'information +c==== +c + code = 1 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c + ulsort = nbrapp(0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. gestion de la section +c==== +c +c 3.1. ==> verification du numero +c + if ( numero.lt.1 .or. numero.gt.nbsect ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + lontit = min(24,len(titre)) + if (lontit.gt.0) then + write (ulsort,31000) titre(1:lontit), numero, nbsect + else + write (ulsort,31000) ' ', + > numero, nbsect + endif + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +31000 format( + > 'On veut donner le nom ''',a24,''' a la section',i8,'.', + >/'C''est impossible. Il faut un numero entre 1 et',i8,'.',/) +c +c 3.2. ==> verification du numero de la langue +c + if ( langue.lt.1 .or. langue.gt.nblang ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + lontit = min(24,len(titre)) + if (lontit.gt.0) then + write (ulsort,32000) titre(1:lontit), numero, langue, nblang + else + write (ulsort,32000) ' ', + > numero, langue, nblang + endif + iaux = 1 + call gtstop ( nompro , ulsort , iaux ) + endif +c +32000 format( + > 'On veut donner le nom ''',a24,''' a la section',i8,'.', + >/'Il est impossible de donner la langue',i8,'.', + >/'Il faut un code de langue entre 1 et',i8,'.',/) +c +c 3.3. ==> determination de la longueur de la chaine de caracteres +c de titre +c + lontit = min(24,len(titre)) +c + if ( lontit.le.0 ) then + ifin = 0 + else + ifin = 0 + do 33 , iaux = lontit , 1 , -1 + if ( titre(iaux:iaux) .ne. ' ' ) then + ifin = iaux + goto 34 + endif + 33 continue + endif +c +c 3.4. ==> affectation du titre a la section en cours +c + 34 continue +c + if ( ifin.gt.0 ) then + titr2 (1:ifin) = titre (1:ifin) + endif +c + do 341 , iaux = ifin+1 , 24 + titr2 (iaux:iaux) = ' ' + 341 continue +c + titsec (langue,numero) = titr2 +c +c==== +c 4. on archive l'information +c==== +c + code = 0 + iaux = nbsep1 + call gttabl ( code, iaux, nbrapp, ouvert, titsec, tpscpu ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Gestion_MTU/gtstop.F b/src/tool/Gestion_MTU/gtstop.F new file mode 100644 index 00000000..f05fabe4 --- /dev/null +++ b/src/tool/Gestion_MTU/gtstop.F @@ -0,0 +1,87 @@ + subroutine gtstop ( appela, ulsort, raison ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c premiere creation le 30.12.88 gn +c ______________________________________________________________________ +c +c 'Gestion du Temps : STOP du programme' +c - - ---- +c ______________________________________________________________________ +c +c but : arrete le gestionnaire de temps +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . appela . e . 1 . nom du programme appelant . +c . ulsort . e . 1 . unite logique pour les messages . +c . raison . e . 1 . raison de l'appel : . +c . . . . 0 : arret normal, sans core . +c . . . . >0 : call abort -> core . +c . . . . <0 : arret des gestionnaires, puis sortie . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTSTOP' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulsort, raison +c + character *(*) appela +c +c 0.4. ==> variables locales +c + integer guimp, gmimp +c +#ifdef _DEBUG_HOMARD_ + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +#endif +c +#include "langue.h" +c +c==== +c 1. appel du programme d'arret general +c==== +c + guimp = 0 + gmimp = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGSTOP', nompro +#endif + call ugstop ( appela, ulsort, guimp, gmimp, raison ) +c + end diff --git a/src/tool/Gestion_MTU/gttabl.F b/src/tool/Gestion_MTU/gttabl.F new file mode 100644 index 00000000..c6b9d9d7 --- /dev/null +++ b/src/tool/Gestion_MTU/gttabl.F @@ -0,0 +1,199 @@ + subroutine gttabl ( code, nbsep1, nbrapp, ouvert, titsec, tpscpu ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c 'Gestion du Temps : memorisation des TABLes' +c - - ---- +c ______________________________________________________________________ +c +c but : archiver ou redonner les listes caracteristiques de la +c gestion des mesures de temps +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . code . e . 1 . 0 : on archive les tableaux de l'appelant . +c . . . . 1 : on renvoie les tableaux vers l'appelant. +c . nbsep1 . e . 1 . nombre de sections possibles . +c . nbrapp . e/s . -4: . -4 : pilotage des impressions . +c . . . nbsep1 . -3 : numero de code de la langue des messa.. +c . . . . -2 : numero de l'annee de depart . +c . . . . -1 : nombre de secondes au depart depuis le. +c . . . . depuis le debut de l'annee . +c . . . . 0 : numero de l'unite logique ou imprimer . +c . . . . les messages du gestionnaire de temps . +c . . . . i>0 : nombre de fois ou la i-eme section a . +c . . . . ete mesuree . +c . ouvert . e/s . nbsep1 . vrai ou faux, selon que la i-eme section . +c . . . . est en cours de mesure ou non . +c . titsec . e/s . nbsep1 . titre de la i-eme section . +c . tpscpu . e/s .0:nbsep1. 0 : cumul du temps systeme . +c . . . . i>0 : cumul du temps user de la i-eme . +c . . . . section . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GTTABL' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer code, nbsep1 +c +#include "gtdita.h" +c +c 0.4. ==> variables locales +c + integer enstul + integer iaux +c + integer nbsec0 + parameter ( nbsec0 = 301 ) +c + integer ulsort, langue + integer nbrap0(-4:nbsec0) +c + double precision tpscp0(0:nbsec0) +c + logical ouver0(nbsec0) + logical initia +c + character*24 titse0(nblang,nbsec0) +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data initia / .false. / + data langue / 1 / +c +c ... juste pour ne plus avoir de messages ftnchek : +c + data nbrap0(0) / 6 / +c ______________________________________________________________________ +c +c==== +c 1. initialisation des messages +c==== +c +#include "impr01.h" +c +c==== +c 2. verifications +c==== +c +c 2.1. ==> unite pour la sortie standard +c + if ( initia ) then +c + ulsort = nbrap0(0) +c + else +c + call dmunit ( enstul, ulsort ) +c +c 2.2. ==> l'initialisation n'est pas faite +c + if ( code.ne.0 ) then + write (ulsort,texte(langue,1)) 'Entree', nompro + write (ulsort,22000) + call dmflsh (iaux) + call dmabor + else + initia = .true. + endif +c + endif +c +c 2.3. ==> la place reservee ici est trop petite +c + if ( nbsep1.gt.nbsec0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,23000) nbsec0, nbsep1 + call dmabor + endif +c +22000 format( + > 'L''initialisation du gestionnaire des mesures de temps', + >/'de calcul n''a pas ete faite.', + >/'Il faut faire appel a GTINIT.',//) +c +23000 format( + > 'Les tableaux d''archivage sont dimensionnes a nbsec0 = ',i4, + >/'Or il doit archiver des tableaux dimensionnes a nbsep1 = ',i9, + >/'C''est trop juste. Il faut augmenter nbsec0 dans GTTABL.',//) +c +c==== +c 2. on archive les informations transmises par l'appelant +c==== +c + if ( code.eq.0 ) then +c + call ugtaci (nbrap0, nbrapp, -4, nbsep1) + call ugtacr (tpscp0, tpscpu, 0, nbsep1) + call ugtacl (ouver0, ouvert, 1, nbsep1) + iaux = nblang*nbsep1 + call ugtacs (titse0, titsec, 1, iaux ) +c +c=== +c 3. on renvoie a l'appelant +c==== +c + else if ( code.eq.1 ) then +c + call ugtaci (nbrapp, nbrap0, -4, nbsep1) + call ugtacr (tpscpu, tpscp0, 0, nbsep1) + call ugtacl (ouvert, ouver0, 1, nbsep1) + iaux = nblang*nbsep1 + call ugtacs (titsec, titse0, 1, iaux ) +c +c=== +c 4. probleme +c==== +c + else +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,40000) code + call dmabor +c + endif +c +40000 format( + > 'Le choix ',i4,' pour le premier argument ne correspond ', + > 'a aucune option possible.', + >/'Il faut 0 pour archiver ou 1 pour recuperer.',/) +c + end diff --git a/src/tool/Gestion_MTU/gubila.F b/src/tool/Gestion_MTU/gubila.F new file mode 100644 index 00000000..73535e47 --- /dev/null +++ b/src/tool/Gestion_MTU/gubila.F @@ -0,0 +1,148 @@ + subroutine gubila ( codfic ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : - imprime les statistiques +c - ferme toutes les unites logiques, sauf l'entree et la sortie +c standard +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codfic . e . 1 . code pilotant le type d'info a imprimer . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'GUBILA' ) +#endif +c +#ifdef _DEBUG_HOMARD_ +#include "genbla.h" +#endif +c +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer codfic +c +c 0.4. ==> variables locales +c + integer ulsort + integer codref + integer iaux, jaux, code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +#ifdef _DEBUG_HOMARD_ + integer langue +#endif +c + character*200 nomfic(mbmxul) +c +#ifdef _DEBUG_HOMARD_ + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +#endif +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c=== +c 1. recuperation de l'information +c=== +c +#ifdef _DEBUG_HOMARD_ +#include "impr01.h" +#endif +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) +#ifdef _DEBUG_HOMARD_ + langue = gunmbr(17) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c=== +c 2. impressions recapitulatives +c=== +c +c 2.1. ==> statistiques +c + call gustat ( gunmbr ) +c +c 2.2. ==> etat des lieux au moment de l'appel +c + if ( codfic.ne.0 ) then +c + call guinfo +c + endif +c +c==== +c 3. fermeture de toutes les unites logiques, sauf les standard et +c sauf celle ou sont imprimes les messages du gestionnaire. Elle +c sera fermee tout a la fin. +c==== +c + do 3 , iaux = 1 , mbmxul +c + if ( statut(iaux).ge.3 .and. statut(iaux).le.5 .and. + > iaux.ne.ulsort ) then +c + jaux = iaux + call guferm ( nomfic(iaux), lnomfi(iaux), jaux, codref ) +c + endif +c + 3 continue +c + if ( ulsort.ge.1 .and. ulsort.le.mbmxul ) then + if ( statut(ulsort).eq.3 ) then + call gufeul ( ulsort , codref ) + else if ( statut(ulsort).ne.2 ) then + codref = 1 + else + codref = 0 + endif + else + codref = 1 + endif +c + end diff --git a/src/tool/Gestion_MTU/gucara.F b/src/tool/Gestion_MTU/gucara.F new file mode 100644 index 00000000..365eea94 --- /dev/null +++ b/src/tool/Gestion_MTU/gucara.F @@ -0,0 +1,199 @@ + subroutine gucara ( fichie, lfichi, nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : recuperer l'unite associee a un fichier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . e . ch<200 . nom du fichier a examiner . +c . lfichi . e . 1 . -1 : on recupere l'unite d'entree standard . +c . . . . 0 : on recupere l'unite de sortie standard. +c . . . . >0 : longueur du nom du fichier a examiner . +c . nuroul . s . 1 . 0 si le fichier est inconnu, sinon c'est le. +c . . . . numero de l'unite logique attribuee . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : nom de fichier trop long . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUCARA' ) +c +#include "gunbul.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, nuroul, codret + character*(*) fichie +c +c 0.4. ==> variables locales +c +#include "gulggt.h" +c + integer guimp, raison + integer iaux, code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + integer ulsort + integer langue + integer typarr +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c + texte(1,10) = '(''La longueur du nom vaut'',i4,'' curieux !'')' + texte(1,4) = '(''Il faut :'')' + texte(1,5) = '(''-1 pour le numero de l''''entree standard'')' + texte(1,6) = '(''0, pour le numero de la sortie standard'')' + texte(1,7) = '(''la vraie longueur du nom (1= '(''the real length of the name (1= cas des entrees/sorties standard +c + elseif ( lfichi.eq.-1 ) then +c + nuroul = gunmbr(14) +c + elseif ( lfichi.eq.0 ) then +c + nuroul = gunmbr(15) +c +c 3.3. ==> un fichier particulier : recherche du bon nom +c remarque : on ne recherche que parmi les unites qui sont ouvertes +c + else +c + nuroul = 0 +c + do 331 , iaux = 1 , mbmxul +c + if ( statut(iaux).ge.1 .and. statut(iaux).le.6 ) then + if ( lnomfi(iaux).eq.lfichi ) then + if ( nomfic(iaux)(1:lfichi).eq.fichie(1:lfichi) ) then + nuroul = iaux + goto 332 + endif + endif + endif +c + 331 continue +c + 332 continue +c +#ifdef _DEBUG_HOMARD_ + if ( nuroul.eq.0 ) then + write (ulsort,texte(langue,1)) + write (ulsort,texte(langue,7)) + if (lfichi.gt.0 .and. len(fichie).gt.0) then + write (ulsort,*) fichie(1:min(lfichi,len(fichie))) + else + write (ulsort,*) + endif + endif +#endif +c + endif +c + end diff --git a/src/tool/Gestion_MTU/guenst.F b/src/tool/Gestion_MTU/guenst.F new file mode 100644 index 00000000..63578c4d --- /dev/null +++ b/src/tool/Gestion_MTU/guenst.F @@ -0,0 +1,61 @@ + subroutine guenst ( nuroul ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : recuperer l'unite associee a l'entree standard +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . s . 1 . numero de l'unite logique attribuee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul +c +c 0.4. ==> variables locales +c + integer codret + integer lfichi + character*200 fichie +c ______________________________________________________________________ +c +c=== +c 1. appel du programme generique avec un nom de fichier bidon +c=== +c + fichie = ' ' + lfichi = -1 +c + call gucara ( fichie, lfichi, nuroul, codret ) +c + end diff --git a/src/tool/Gestion_MTU/gufefi.F b/src/tool/Gestion_MTU/gufefi.F new file mode 100644 index 00000000..450a20a4 --- /dev/null +++ b/src/tool/Gestion_MTU/gufefi.F @@ -0,0 +1,179 @@ + subroutine gufefi ( fichie, lfichi, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestionnaire des Unites logiques - FErmeture d'un FIchier +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . e . ch<200 . nom du fichier a fermer . +c . lfichi . e . 1 . longueur du nom du fichier a fermer . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : pas d'unite logique pour ce fichier . +c . . . . 9 : probleme a la fermeture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUFEFI' ) +c +#include "genbla.h" +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, codret +c + character*(*) fichie +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer nuroul +c + integer ulsort, langue + integer code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c + texte(1,10) = '(''Fermeture du fichier :'')' + texte(1,4) = '(''Impossible de trouver une UL associee.'')' + texte(1,5) = + > '(''Unite logique : '',i4,'' - fermeture impossible'')' + texte(1,6) = + > '(''Attention: longueur du nom : '',i4,'' caracteres'')' +c + texte(2,10) = '(''Closing of file :'')' + texte(2,4) = '(''LU cannot be found.'')' + texte(2,5) = + > '(''Logical unit # : '',i4,'' - impossible to close'')' + texte(2,6) = + > '(''Look out: lenght of name : '',i4,'' characters'')' +c +c=== +c 2. recuperation de l'information +c=== +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. recherche de l'unite logique associee a ce fichier +c==== +c + call gucara ( fichie, lfichi, nuroul, codret ) +c + if ( codret.eq.0 ) then + if ( nuroul.le.0 ) then + codret = 3 + else if ( lfichi.le.0 ) then +c +c ce programme ne peut fermer ni l'entree standard, ni la sortie +c standard, ni l'unite logique des messages (fermee par gubila) +c + codret = 9 + else if ( nuroul.eq.ulsort .or. + > nuroul.eq.gunmbr(14) .or. nuroul.eq.gunmbr(15) ) then + codret = 9 + else + codret = 0 + endif + endif +c +c==== +c 4. fermeture +c==== +c + if ( codret.eq.0 ) then + call guferm ( fichie, lfichi, nuroul, codret ) + if ( codret.ne.0 ) then + codret = 9 + endif + endif +c +c==== +c 5. bilan +c==== +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) + if ( lfichi.gt.0 .and. len(fichie).gt.0 ) then + write (ulsort,*) fichie(1:min(lfichi,len(fichie))) + if ( lfichi.le.len(fichie) ) then + if ( fichie(1:1).eq.' ' .or. + > fichie(lfichi:lfichi).eq.' ') then +c +c peut-etre un probleme avec les blancs en debut ou fin de chaine ... +c ( voire chaine toute blanche ) +c + write(ulsort,texte(langue,6)) lfichi + endif + endif + else + write (ulsort,*) + endif + if ( codret.eq.3 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) nuroul + endif + endif +c + end diff --git a/src/tool/Gestion_MTU/guferm.F b/src/tool/Gestion_MTU/guferm.F new file mode 100644 index 00000000..7f6ad137 --- /dev/null +++ b/src/tool/Gestion_MTU/guferm.F @@ -0,0 +1,215 @@ + subroutine guferm ( fichie, lfichi, nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestionnaire des Unites logiques - FERMeture d'une unite logique +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . e . ch<200 . nom du fichier a fermer . +c . lfichi . e . 1 . longueur du nom du fichier a fermer . +c . nuroul . e . 1 . numero de l'unite logique a fermer . +c . codret . s . 1 . 0 : tout va bien . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUFERM' ) +c +#include "genbla.h" +c +#include "gunbul.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, nuroul, codret +c + character*(*) fichie +c +c 0.4. ==> variables locales +c +#include "gulggt.h" +c + integer guimp, raison + integer iaux, code, statfi, l200 + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) + integer ulsort, langue + integer typarr +c + character*200 ficloc, nomfic(mbmxul) +c + integer iindef + double precision rindef + character*8 sindef +c + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c=== +c 1. recuperation de l'information +c=== +c +#include "impr01.h" +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. fermeture +c==== +c + codret = 0 +c + if (nuroul.gt.0 .and. nuroul.le.mbmxul) then + statfi = statut(nuroul) + else + statfi = 0 + endif +c + l200 = -1 +c +c 2.1. ==> fermeture proprement dite +c + if ( statfi.ge.3 .and. statfi.le.4 ) then +c + close ( unit=nuroul, err=2100, iostat=codret ) + goto 2101 + 2100 continue + if ( codret.eq.0 ) then + codret = -1 + endif + 2101 continue +c + else +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + l200 = max(0, min( 200, lfichi, len(fichie) ) ) + if (l200.gt.0) then + ficloc(1:l200) = fichie(1:l200) + endif + do 210 iaux = l200 + 1, 200 + ficloc(iaux:iaux) = ' ' + 210 continue + write (ulsort,21000) nuroul, ficloc + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif +c + endif +c + if (codret.ne.0.and.l200.lt.0) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + l200 = max(0, min( 200, lfichi, len(fichie) ) ) + if (l200.gt.0) then + ficloc(1:l200) = fichie(1:l200) + endif + do 211 iaux = l200 + 1, 200 + ficloc(iaux:iaux) = ' ' + 211 continue + write(ulsort,22000) nuroul, ficloc + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + endif + endif +c +c 2.2. ==> inscription dans les listes +c + if ( codret.eq.0 ) then +c + statut(nuroul) = 0 +c + call dmindf ( iindef, rindef, sindef ) +c + do 22 , iaux = 1 , 25 + nomfic(nuroul)(8*(iaux-1)+1:8*iaux) = sindef + 22 continue +c + lnomfi(nuroul) = iindef +c + endif +c +c=== +c 3. archivage de l'information +c=== +c +c (9): nb actuel d'unites ouvertes form/sequ +c (10): nb actuel d'unites ouvertes bina/sequ +c (11): nb actuel d'unites ouvertes form/dire +c (12): nb actuel d'unites ouvertes form/dire +c + if ( codret.eq.0 ) then +c + gunmbr(statfi+6) = gunmbr(statfi+6) - 1 +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c +c==== +c 4. formats +c==== +c +21000 format( + >/,'Erreur lors de la fermeture de l''unite ',i2, + >/,'Fichier :', + >/,a200, + >/,'Ce fichier n''a jamais ete ouvert ...',//) +c +22000 format( + >/,'Erreur lors de la fermeture de l''unite ',i2, + >/,'Fichier :', + >/,a200,//) +c + end diff --git a/src/tool/Gestion_MTU/gufeul.F b/src/tool/Gestion_MTU/gufeul.F new file mode 100644 index 00000000..e3ed8f57 --- /dev/null +++ b/src/tool/Gestion_MTU/gufeul.F @@ -0,0 +1,146 @@ + subroutine gufeul ( nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestionnaire des Unites logiques - FErmeture d'une Unite Logique +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . e . 1 . numero de l'unite logique a fermer . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : pas de fichier pour cette UL . +c . . . . 9 : probleme a la fermeture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUFEUL' ) +c +#include "genbla.h" +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer lfichi +c + character*200 fichie +c + integer code + integer ulsort, langue + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c + texte(1,10) = '(''Fermeture de l''''unite logique : '',i4)' + texte(1,4) = '(''Impossible de trouver un fichier associe.'')' + texte(1,5) = '(''Fermeture impossible'')' +c + texte(2,10) = '(''Closing of logical unit : '',i4)' + texte(2,4) = '(''File cannot be found.'')' + texte(2,5) = '(''Impossible to close'')' +c +c=== +c 2. recuperation de l'information +c=== +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. recherche du fichier associe a cette UL +c==== +c + call gufiul ( fichie, lfichi , nuroul, codret ) +c + if ( codret.eq.0 ) then + if ( lfichi.le.0 ) then + codret = 3 + endif + endif +c +c==== +c 4. fermeture +c==== +c + if ( codret.eq.0 ) then + call guferm ( fichie, lfichi, nuroul, codret ) + if ( codret.ne.0 ) then + codret = 9 + endif + endif +c +c==== +c 5. bilan +c==== +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) nuroul + if ( codret.eq.3 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) + endif + endif +c + end diff --git a/src/tool/Gestion_MTU/gufiul.F b/src/tool/Gestion_MTU/gufiul.F new file mode 100644 index 00000000..06dd7638 --- /dev/null +++ b/src/tool/Gestion_MTU/gufiul.F @@ -0,0 +1,166 @@ + subroutine gufiul ( fichie, lfichi, nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : recuperer le fichier associe a une unite logique +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . s . ch<200 . nom du fichier associe . +c . lfichi . s . 1 . -1 : on recupere l'unite d'entree standard . +c . . . . 0 : on recupere l'unite de sortie standard. +c . . . . >0 : longueur du nom du fichier a examiner . +c . nuroul . e . 1 . numero de l'unite logique a examiner . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : mauvais numero ou . +c . . . . 3 : aucun fichier n'est lie a ce numero . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUFIUL' ) +c +#include "genbla.h" +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, nuroul, codret + character*(*) fichie +c +c 0.4. ==> variables locales +c + integer guimp, raison, iaux + integer code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + integer ulsort + integer langue + integer typarr +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c + texte(1,10) = '(''Numero d''''unite logique : '',i4)' + texte(1,4) = '(''Doit etre compris entre 0 et '',i4)' + texte(1,5) = '(''N''''a pas ete attribue.'')' +c + texte(2,10) = '(''Logical unit # : '',i4)' + texte(2,4) = '(''Must be between 0 and '',i4)' + texte(2,5) = '(''Never reserved.'')' +c +c=== +c 2. recuperation de l'information +c=== +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. recherche du bon numero +c==== +c + codret = 0 +c + if ( nuroul.le.0 .or. nuroul.gt.mbmxul ) then +c + lfichi = 0 + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) nuroul + write (ulsort,texte(langue,4)) mbmxul + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif +c + else if ( nuroul.eq.gunmbr(14) ) then +c + lfichi = -1 +c + elseif ( nuroul.eq.gunmbr(15) ) then +c + lfichi = 0 +c + elseif ( statut(nuroul).ge.1 .and. statut(nuroul).le.6 ) then +c + lfichi = min(max(0,len(fichie)), max(0,lnomfi(nuroul))) + if (lfichi.gt.0) then + fichie(1:lfichi) = nomfic(nuroul)(1:lfichi) + endif +c + else +c + lfichi = 0 + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) nuroul + write (ulsort,texte(langue,5)) + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif +c + endif +c + do 3 iaux = max(0,lfichi)+1, len(fichie) + fichie(iaux:iaux) = ' ' + 3 continue +c + end diff --git a/src/tool/Gestion_MTU/guinfg.F b/src/tool/Gestion_MTU/guinfg.F new file mode 100644 index 00000000..5aa0eb3b --- /dev/null +++ b/src/tool/Gestion_MTU/guinfg.F @@ -0,0 +1,270 @@ + subroutine guinfg ( liste, codret, imprim ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : donne l'etat d'une ou de toutes les unites logiques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . liste . e . 1 . 0 : toutes les unites sont a renseigner . +c . . . . 1 impression, faux -> pas d'impres. . +c . codret . s . 1 . statut de l'unite a renseigner si 1 seule . +c . . . . 0 si probleme, -1 si tous les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUINFG' ) +c +#include "genbla.h" +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer liste, codret +c + logical imprim +c +c 0.4. ==> variables locales +c + integer unideb, unifin + integer ulsort, langue + integer iaux, code, unite + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + character*49 chau49 + character*200 bla200 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*59 chstat(nblang,0:8), chau59 +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c=== +c 1. initialisation +c=== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +c 1 234 567890 123456789012345678901234567890123456789 + chau49 = '(''*'',12x,''Recapitulatif des unites logiques activ' + texte(1,10) = chau49//'es'',13x,''*'')' + texte(1,4) = + > '(''* No *'',18x,''Statut de l''''unite logique'',18x,''*'')' + texte(1,5) = '(''* * Fichier : '',a49,'' *'')' +c + texte(2,10) = + > '(''*'',17x,''Summary of active logical units'',18x,''*'')' + texte(2,4) = + > '(''* # *'',17x,''Status of the logical unit'',18x,''*'')' + texte(2,5) = '(''* * File : '',a49,'' *'')' +c +c 1.2. ==> recuperation de l'information +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.3. ==> variables auxiliaires +c +c 1234567890123456789012345678901234567890123456789 + chstat(1,0) = 'Disponible ' + chstat(1,1) = 'Entree standard (sequentiel formate) ' + chstat(1,2) = 'Sortie standard (sequentiel formate) ' + chstat(1,3) = 'Ouvert en acces sequentiel formate ' + chstat(1,4) = 'Ouvert en acces sequentiel binaire ' + chstat(1,5) = 'Ouvert en acces direct binaire standard ' + chstat(1,6) = 'Ouvert en acces direct binaire special ' + chstat(1,7) = 'Interdit ' + chstat(1,8) = 'standard de la machine ' +c + chstat(2,0) = 'Available ' + chstat(2,1) = 'Standard input (formatted, sequential access) ' + chstat(2,2) = 'Standard output (formatted, sequential access) ' + chstat(2,3) = 'Opened in formatted sequential access mode ' + chstat(2,4) = 'Opened in binary sequential access mode ' + chstat(2,5) = 'Opened in binary direct access mode ' + chstat(2,6) = 'Opened in special binary direct access mode ' + chstat(2,7) = 'Forbidden ' + chstat(2,8) = 'standard of the computer ' +c + do 11 , iaux = 1 , 200 + bla200(iaux:iaux) = ' ' + 11 continue +c +c=== +c 2. verification +c=== +c + if ( liste.eq.0 ) then + unideb = 1 + unifin = mbmxul + iaux = 0 + elseif ( liste.ge.1 .and. liste.le.mbmxul ) then + unideb = liste + unifin = liste + iaux = -1 + else + if ( ulsort.ge.1 .and. ulsort.le.mbmxul ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,20000) liste, mbmxul + endif + unideb = 0 + unifin = -1 + endif +c +c=== +c 3. impressions +c=== +c + if ( imprim ) then +c +c 3.1. ==> en tete +c + write (ulsort,30030) + if ( liste.eq.0 ) then + write (ulsort,30000) + write (ulsort,texte(langue,10)) + endif + write (ulsort,30000) + write (ulsort,texte(langue,4)) + write (ulsort,30000) +c +c 3.2. ==> pour chaque unite retenue +c + do 32 , unite = unideb , unifin +c + if ( statut(unite).ne.iaux ) then +c + write (ulsort,30010) unite, chstat(langue,statut(unite)) +c + if ( statut(unite).ge.1 .and. statut(unite).le.2 ) then +c + write (ulsort,texte(langue,5)) chstat(langue,8) +c + elseif ( statut(unite).ge.3 .and. statut(unite).le.6 ) then +c + if ( lnomfi(unite).le.49 ) then + chau49(1:49) = bla200(1:49) + if ( lnomfi(unite).gt.0 ) then + chau49(1:lnomfi(unite)) =nomfic(unite)(1:lnomfi(unite)) + endif + write (ulsort,texte(langue,5)) chau49 +c + elseif ( lnomfi(unite).le.108 ) then + chau49 = nomfic(unite)(1:49) + write (ulsort,texte(langue,5)) chau49 + chau59(1:59) = bla200(1:59) + chau59(1:lnomfi(unite)-49) = + > nomfic(unite)(50:lnomfi(unite)) + write (ulsort,30020) chau59 +c + elseif ( lnomfi(unite).le.167 ) then + chau49 = nomfic(unite)(1:49) + write (ulsort,texte(langue,5)) chau49 + chau59 = nomfic(unite)(50:108) + write (ulsort,30020) chau59 + chau59(1:59) = bla200(1:59) + chau59(1:lnomfi(unite)-108) = + > nomfic(unite)(109:lnomfi(unite)) + write (ulsort,30020) chau59 +c + else + chau49 = nomfic(unite)(1:49) + write (ulsort,texte(langue,5)) chau49 + chau59 = nomfic(unite)(50:108) + write (ulsort,30020) chau59 + chau59 = nomfic(unite)(109:167) + write (ulsort,30020) chau59 + chau59(1:59) = bla200(1:59) + chau59(1:lnomfi(unite)-167) = + > nomfic(unite)(168:lnomfi(unite)) + write (ulsort,30020) chau59 +c + endif +c + endif +c + endif +c + 32 continue +c +c 3.3. ==> fin du recapitulatif +c + write (ulsort,30000) + write (ulsort,30030) +c + endif +c +c=== +c 4. si une seule unite a ete interrogee, on renvoie le statut +c=== +c + if ( liste.ge.1 .and. liste.le.mbmxul ) then + codret = statut(liste) + else + codret = -1 + endif +c +c=== +c 5. formats +c=== +c +20000 format( + >/,'Le numero ',i4,' ne correspond a aucun code possible.', + >/,'Il faut soit un numero d''unite logique, donc compris ', + > 'entre 1 et ',i4, + >/,'soit 0 pour les avoir toutes.',/) +c +30000 format(68('*')) +30010 format('* ',i2,' * ',a59,' *') +30020 format('* * ',a59,' *') +30030 format(//) +c + end diff --git a/src/tool/Gestion_MTU/guinfo.F b/src/tool/Gestion_MTU/guinfo.F new file mode 100644 index 00000000..4a8c6be5 --- /dev/null +++ b/src/tool/Gestion_MTU/guinfo.F @@ -0,0 +1,53 @@ + subroutine guinfo +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c but : donne l'etat de toutes les unites logiques +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c + integer iaux, codret +c + logical imprim +c ______________________________________________________________________ +c +c=== +c 1. appel au programme generique +c=== +c + iaux = 0 + imprim = .true. +c + call guinfg ( iaux, codret, imprim ) +c + end diff --git a/src/tool/Gestion_MTU/guinfu.F b/src/tool/Gestion_MTU/guinfu.F new file mode 100644 index 00000000..28f7a460 --- /dev/null +++ b/src/tool/Gestion_MTU/guinfu.F @@ -0,0 +1,56 @@ + subroutine guinfu ( unite, codret, imprim ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : donne l'etat d'une unite logique particuliere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . unite . e . 1 . numero de l'unite a renseigner . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer unite, codret +c + logical imprim +c +c 0.4. ==> variables locales +c ______________________________________________________________________ +c +c=== +c 1. appel au programme generique +c=== +c + call guinfg ( unite, codret, imprim ) +c + end diff --git a/src/tool/Gestion_MTU/guinit.F b/src/tool/Gestion_MTU/guinit.F new file mode 100644 index 00000000..f4ce38e3 --- /dev/null +++ b/src/tool/Gestion_MTU/guinit.F @@ -0,0 +1,326 @@ + subroutine guinit ( enstul, sostul, langdf, + > nfconf, lfconf, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : initialiser la gestion des unites logiques +c - a priori tout est disponible +c - on reserve l'entree standard +c - on reserve la sortie standard +c - on archive ce point de depart +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . enstul . e . 1 . entree standard : numero de l'unite logique. +c . sostul . e . 1 . sortie standard : numero de l'unite logique. +c . langdf . e . 1 . langue des messages par defaut . +c . . . . 1 : francais . +c . . . . 2 : anglais . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : problemes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUINIT' ) +c +#include "genbla.h" +c +#include "gelggt.h" +#include "gedita.h" +c +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character *(*) nfconf +c + integer enstul, sostul, langdf, lfconf + integer codret +c +c 0.4. ==> variables locales +c + integer entrst, sortst + integer ulsort, langue + integer typarr +c + integer guimp, raison + integer iaux, code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + character*200 nomaux +c + integer iindef + double precision rindef + character*8 sindef +c + logical dejavu +c + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data dejavu / .false. / + data typarr / 0 / +c +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +c 1.1. ==> au debut, tout va bien ... +c + codret = 0 +c +c 1.2. ==> les valeurs indefinies +c + call dmindf ( iindef, rindef, sindef ) +c +c 1.3. ==> on verifie que l'initialisation n'a pas deja ete faite +c + if ( dejavu ) then +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) + typarr = gunmbr(18) + write (ulsort,11000) + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif +c + endif +c +c 1.4. ==> tout est libre +c + if ( codret.eq.0 ) then +c + do 141 , iaux = 1 , 25 + nomaux(8*(iaux-1)+1:8*iaux) = sindef + 141 continue +c + do 142 , iaux = 1 , mbmxul + statut(iaux) = 0 + lnomfi(iaux) = iindef + nomfic(iaux) = nomaux + 142 continue +c + do 143 , iaux = 1 , lgunmb + gunmbr(iaux) = iindef + 143 continue +c + endif +c +c==== +c 2. reservation des unites standard +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> on verifie que les numeros donnes pour les unites +c d'entree/sorties standard sont corrects. +c . s'ils le sont, on declare la sortie standard comme etant +c l'unite des messages par defaut. +c . s'ils ne le sont pas, on arrete. +c remarque : si l'unite logique souhaitee pour la sortie +c standard, sostul, il faut imprimer un message. +c or on ne sait pas ou : on le fait sur l'unite +c "ecran", faute de mieux. +c + iaux = 0 +c + if ( sostul.lt.1 .or. sostul.gt.mbmxul ) then + call dmunit ( entrst , sortst ) + langue = langdf + write (ulsort,texte(langue,1)) 'Sortie', nompro + write(sortst,21010) 'Sortie', sostul + iaux = 1 + if ( .not.dejavu ) then + ulsort = sortst + endif + else + ulsort = sostul + endif +c + if ( enstul.lt.1 .or. enstul.gt.mbmxul ) then + langue = langdf + write (ulsort,texte(langue,1)) 'Sortie', nompro + write(ulsort,21010) 'Entree', enstul + iaux = 1 + endif +c + if ( enstul.eq.sostul ) then + langue = langdf + write (ulsort,texte(langue,1)) 'Sortie', nompro + write(ulsort,21020) enstul + iaux = 1 + endif +c + if ( iaux.ne.0 ) then + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + endif +c +c 2.2. ==> reservation +c + if ( codret.eq.0 ) then +c + statut(enstul) = 1 + statut(sostul) = 2 +c + endif +c + endif +c +c==== +c 3. on archive l'information +c==== +c + if ( codret.eq.0 ) then +c +c (1): nbre maxi d'unites ouvertes form/sequ + gunmbr(1) = 2 +c +c (2): nbre maxi d'unites ouvertes bina/sequ + gunmbr(2) = 0 +c +c (3): nbre maxi d'unites ouvertes bina/dire standard + gunmbr(3) = 0 +c +c (4): nbre maxi d'unites ouvertes bina/dire special + gunmbr(4) = 0 +c +c (5): nbre total d'unites ouvertes form/sequ + gunmbr(5) = 2 +c +c (6): nbre total d'unites ouvertes bina/sequ + gunmbr(6) = 0 +c +c (7): nbre total d'unites ouvertes bina/dire standard + gunmbr(7) = 0 +c +c (8): nbre total d'unites ouvertes bina/dire special + gunmbr(8) = 0 +c +c (9): nbre actuel d'unites ouvertes form/sequ + gunmbr(9) = 2 +c +c (10): nbre actuel d'unites ouvertes bina/sequ + gunmbr(10) = 0 +c +c (11): nbre actuel d'unites ouvertes bina/dire standard + gunmbr(11) = 0 +c +c (12): nbre actuel d'unites ouvertes bina/dire special + gunmbr(12) = 0 +c +c (13): nb maxi d'unites ouvertes tous types + gunmbr(13) = 2 +c +c (14): numero de l'entree standard + gunmbr(14) = enstul +c +c (15): numero de la sortie standard + gunmbr(15) = sostul +c +c (16): numero de l'unite des messages du gu + gunmbr(16) = ulsort +c +c (17): langue des messages du gu + gunmbr(17) = langdf +c +c (18): type d'arret du gestionnaire + gunmbr(18) = typarr +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c +c==== +c 4. on note que l'on est deja passe par l'initialisation +c==== +c + if ( codret.eq.0 ) then +c + dejavu = .true. +c + code = 1 + call ugtabl ( code, tabges, sostul) +c + tabges(1) = 1 +c + code = 0 + call ugtabl ( code, tabges, sostul) +c + endif +c +c==== +c 5. recherche du mode d'arret +c==== +c + call gumoge ( nfconf, lfconf, codret ) +c +c==== +c 6. formats +c==== +c +11000 format( + >/,'L''initialisation de GU a deja ete faite.',//) +21010 format( + >/,a6,' standard : l''unite ',i8,' est incorrecte.', + >/,'Il faut un numero compris entre 1 et mbmxul.',//) +21020 format( + >/,'L''entree et la sortie standard sont sur la meme unite ',i8, + >/,'Ce n''est pas bon, mes amis ...',//) +c + end diff --git a/src/tool/Gestion_MTU/gulanm.F b/src/tool/Gestion_MTU/gulanm.F new file mode 100644 index 00000000..0fdc1ac8 --- /dev/null +++ b/src/tool/Gestion_MTU/gulanm.F @@ -0,0 +1,155 @@ + subroutine gulanm ( lang , codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestion des Unites logiques : LANgue des Messages +c - - --- - +c ______________________________________________________________________ +c +c modifie la langue des messages du gestionnaire des unites logiques +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lang . e . 1 . code de la langue souhaitee . +c . . . . 1 : francais . +c . . . . 2 : anglais . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : numero de langue impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GULANM' ) +c +#include "genbla.h" +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lang + integer codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer gmimp, guimp, raison + integer code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + integer ulsort + integer langue + integer typarr +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c + texte(1,10) = '(''Le numero de langue '',i2,'' voulu'')' + texte(1,4) = '(''pour les sorties GU est incorrect.'')' + texte(1,5) = '(''Il doit etre compris entre 1 et '',i8)' +c + texte(2,10) = '(''The language code # '',i2,'' wanted for'')' + texte(2,4) = '(''GU messages is not correct.'')' + texte(2,5) = '(''It must be included between 1 and '',i8)' +c +c=== +c 2. recuperation de l'information +c=== +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. verification de la validite du numero. +c Il faut que le numero soit compris entre 1 et le nombre maximal +c de langue. +c==== +c + if ( lang.lt.1 .or. lang.gt.nblang ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) lang + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) nblang +c + if ( typarr.eq.0 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop (nompro,ulsort,guimp, gmimp, raison) + else + codret = 3 + endif +c + endif +c +c==== +c 4. archivage du numero +c==== +c + if ( codret.eq.0 ) then +c + gunmbr(17) = lang +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gulggt.h b/src/tool/Gestion_MTU/gulggt.h new file mode 100644 index 00000000..1b317530 --- /dev/null +++ b/src/tool/Gestion_MTU/gulggt.h @@ -0,0 +1,5 @@ +c +c lgunmb : taille du tableau de gestion de gu +c + integer lgunmb + parameter ( lgunmb = 18 ) diff --git a/src/tool/Gestion_MTU/gumess.F b/src/tool/Gestion_MTU/gumess.F new file mode 100644 index 00000000..c5c72510 --- /dev/null +++ b/src/tool/Gestion_MTU/gumess.F @@ -0,0 +1,157 @@ + subroutine gumess (ulmess, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : modifie le numero de l'unite logique des messages du +c gestionnaire d'unite logique +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulmess . e . 1 . unite logique de la sortie generale . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : problemes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUMESS' ) +c +#include "genbla.h" +#include "gunbul.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulmess + integer codret +c +c 0.4. ==> variables locales +c +#include "gulggt.h" +c + logical imprim +c + integer guimp, gmimp, raison + integer iaux, ulsort +c + integer langue + integer typarr +c + integer code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c + codret = 0 +c +c 1.1. ==> initialisation des messages +c +#include "impr01.h" +c + texte(1,10) = '(''Le numero d''''unite logique '',i2,'' voulu'')' + texte(1,4) = + >'(''pour les sorties GU n''''a pas le bon statut GU.'')' +c + texte(2,10) = '(''The logical unit # '',i2,'' wanted for'')' + texte(2,4) = '(''GU messages has not the right status in GU.'')' +c +c 1.2. ==> recuperation de l'information +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c +c (16): numero de l'unite des messages du gu + ulsort = gunmbr(16) +c +c (17): langue des messages du gu + langue = gunmbr(17) +c +c (18): type d'arret du gestionnaire + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. verification de la validite du numero. il faut que le statut soit : +c 2 : Sortie standard (sequentiel formate) +c 3 : Ouvert en acces sequentiel formate +c==== +c + imprim = .false. + call guinfu ( ulmess, iaux, imprim ) +c + if ( iaux.ne.2 .and. iaux.ne.3 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) ulmess + write (ulsort,texte(langue,4)) +c + if ( typarr.eq.0 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop(nompro,ulsort,guimp, gmimp, raison) + else + codret = 3 + write (ulsort,texte(langue,2)) codret + endif +c + endif +c +c=== +c 3. archivage de l'information +c=== +c + if ( codret.eq.0 ) then +c +c (16): numero de l'unite des messages du gu + gunmbr(16) = ulmess +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c + end diff --git a/src/tool/Gestion_MTU/gumoge.F b/src/tool/Gestion_MTU/gumoge.F new file mode 100644 index 00000000..329b8143 --- /dev/null +++ b/src/tool/Gestion_MTU/gumoge.F @@ -0,0 +1,199 @@ + subroutine gumoge ( nfconf, lfconf, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Gestionnaire des Unites logiques : MOde de GEstion +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUMOGE' ) +c +#include "gunbul.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf + integer codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +#include "gulggt.h" +c + integer codre0 + integer lfmode +c + integer code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + character*8 motcle + character*200 nfmode +c + character*5 fmtent +c + integer ulsort + integer langue + integer typarr +c +#include "motcle.h" +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c + texte(1,4) = + >'(''L''''option de la memoire '',a8,'' est illisible.'')' + texte(1,5) = '(''Le type d''''arret '',i8,'' ne convient pas.'')' + texte(1,6) = '(''Il faut 0 ou 1.'')' +c + texte(2,4) = '(''The option '',a8,'' cannot be read.'')' + texte(2,5) = '(''Type '',i8,'' is not correct.'')' + texte(2,6) = '(''0 or 1 is needed.'')' +c +c=== +c 2. recuperation de l'information +c=== +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. type d'arret +c==== +c + codret = 0 +c +c 3.1. ==> recherche de l'option de pilotage qui contient le +c le type d'arret de la gestion des unites logiques +c + motcle = mcguta + call ugfino ( motcle, nfmode, lfmode, + > nfconf, lfconf, + > ulsort, langue, codre0 ) +c +c 3.2. ==> si aucune option n'a ete precisee, on arretera brutalement +c + if (codre0.eq.1 ) then +c + typarr = 0 +c +c 3.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 1 +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) motcle +c +c 3.4. ==> decodage +c + else +c + fmtent = '(I )' + if ( lfmode.lt.10 ) then + write(fmtent(3:3),'(i1)') lfmode + else + write(fmtent(3:4),'(i2)') lfmode + endif + read ( nfmode,fmtent) typarr +c + endif +c +c 3.5. ==> verification +c + if ( typarr.lt.0 .or. typarr.gt.1 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) motcle + write (ulsort,texte(langue,5)) typarr + write (ulsort,texte(langue,6)) + codret = 1 + endif +c +c==== +c 4. archivage du numero +c==== +c + if ( codret.eq.0 ) then +c + gunmbr(18) = typarr +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c + end diff --git a/src/tool/Gestion_MTU/gunbul.h b/src/tool/Gestion_MTU/gunbul.h new file mode 100644 index 00000000..29624e8f --- /dev/null +++ b/src/tool/Gestion_MTU/gunbul.h @@ -0,0 +1,5 @@ +c +c mbmxul = nombre maxi d'unite logiques gerees par le gestionnaire +c + integer mbmxul + parameter ( mbmxul = 99 ) diff --git a/src/tool/Gestion_MTU/guoufs.F b/src/tool/Gestion_MTU/guoufs.F new file mode 100644 index 00000000..38edbc52 --- /dev/null +++ b/src/tool/Gestion_MTU/guoufs.F @@ -0,0 +1,70 @@ + subroutine guoufs ( fichie, lfichi, nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : ouvrir un fichier en sequentiel formate +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . e . char * . nom du fichier a ouvrir . +c . lfichi . e . 1 . longueur du nom du fichier a ouvrir . +c . nuroul . s . 1 . numero de l'unite logique attribuee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ +#include "gunbul.h" +#endif +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, nuroul +c + character*(*) fichie +c + integer codret +c +c 0.4. ==> variables locales +c + integer lgenre + integer statfi +c ______________________________________________________________________ +c +c=== +c 1. appel au programme generique +c=== +c + statfi = 3 + lgenre = -1 + call guouge ( fichie, lfichi, statfi, lgenre, + > nuroul, codret ) +c + end diff --git a/src/tool/Gestion_MTU/guouge.F b/src/tool/Gestion_MTU/guouge.F new file mode 100644 index 00000000..97ff95e9 --- /dev/null +++ b/src/tool/Gestion_MTU/guouge.F @@ -0,0 +1,393 @@ + subroutine guouge ( fichie, lfichi, statfi, lgenre, + > nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : programme generique d'ouverture d'un fichier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fichie . e . ch<200 . nom du fichier a ouvrir . +c . lfichi . e . 1 . longueur du nom du fichier a ouvrir . +c . statfi . e . 1 . statut voulu pour l'ouverture . +c . . . . 3 : ouvert en form/sequ . +c . . . . 4 : ouvert en bina/sequ . +c . lgenre . e . 1 . longueur d'enregistrement si acces direct . +c . nuroul . s . 1 . numero de l'unite logique attribuee . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme d'ouverture du fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUOUGE' ) +c +#ifdef _DEBUG_HOMARD_ +#include "genbla.h" +#endif +c +#include "gunbul.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfichi, statfi, lgenre + integer nuroul +c + character*(*) fichie +c + integer codret +c +c 0.4. ==> variables locales +c +#include "gulggt.h" +c + integer ulsort + integer typarr + integer iaux, deb, fin, lficlo +c + integer guimp, raison + integer i, code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) + character*200 ficloc + character*6 nompra +c +#ifdef _DEBUG_HOMARD_ + integer langue +c + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +#endif +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c=== +c 1. recuperation de l'information +c=== +c +#ifdef _DEBUG_HOMARD_ +#include "impr01.h" +#endif +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) +#ifdef _DEBUG_HOMARD_ + langue = gunmbr(17) +#endif + typarr = gunmbr(18) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. verifications +c==== +c + codret = 0 + nuroul = 0 + ficloc = ' ' +c +c 2.1. ==> type d'ouverture +c + if ( statfi.eq.3 ) then + nompra = 'GUOUFS' + elseif ( statfi.eq.4 ) then + nompra = 'GUOUBS' + elseif ( statfi.eq.5 ) then + nompra = 'GUOUBD' + else + write(ulsort,11000) '? ' + if (len(fichie).gt.0) then + write(ulsort,21000) nuroul,fichie(1:min(200,len(fichie))),statfi + else + write(ulsort,*) ' statfi = ',statfi, + > ' (devrait etre entre 3 et 5)' + endif + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + endif +c +c 2.2. ==> longueur du nom du fichier +c + if ( codret.eq.0 ) then +c + iaux = len ( fichie ) +c + if ( lfichi.gt.iaux ) then + write(ulsort,11000) nompra + if ( iaux.gt.0 ) then + write(ulsort,22000) fichie(1:min(200,iaux)), lfichi, iaux + endif + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + else + deb = max(0,lfichi)+1 + do 221 i = 1, lfichi + if (fichie(i:i).ne.' ') then + deb = i + goto 222 + endif + 221 continue + 222 continue + fin = deb-1 + do 223 i = lfichi, deb, -1 + if (fichie(i:i).ne.' ') then + fin = i + goto 224 + endif + 223 continue + 224 continue + lficlo = fin-deb+1 + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( lficlo.le.0 .or. lficlo.gt.200 ) then + write(ulsort,11000) nompra + if ( iaux.gt.0 ) then + write(ulsort,23000) fichie(1:min(200,len(fichie))), lfichi + endif + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + endif +c + endif +c +c 2.3. ==> nom du fichier +c + if ( codret.eq.0 ) then +c + ficloc(1:lficlo) = fichie(deb:fin) + do 23, i = lficlo+1, 200 + ficloc(i:i) = ' ' + 23 continue +c + endif +c +c 2.4. ==> est-ce que ce fichier n'est pas deja ouvert ? +c + if ( codret.eq.0 ) then +c + nuroul = 0 +c + do 241, i = 1, mbmxul +c + if ( statut(i).ge.1 .and. statut(i).le.5 ) then + if ( lnomfi(i).eq.lficlo ) then + if ( nomfic(i)(1:lficlo).eq.ficloc(1:lficlo) ) then + nuroul = i + goto 242 + endif + endif + endif +c + 241 continue +c + 242 continue +c + if ( nuroul.ne.0 ) then + write(ulsort,11000) nompra + write(ulsort,24000) ficloc, nuroul + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + endif +c + endif +c +c 2.5. ==> recherche de la premiere unite libre +c + if ( codret.eq.0 ) then +c + do 251, i = 1, mbmxul + if ( statut(i).eq.0 ) then + nuroul = i + goto 252 + endif + 251 continue +c + write(ulsort,11000) nompra + write(ulsort,25000) ficloc + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif +c + 252 continue +c + endif +c +c==== +c 3. tout est bon, on peut ouvrir +c==== +c + if ( codret.eq.0 ) then +c + if ( statfi.eq.3 ) then +c + call dmoufs ( nuroul, ficloc, lficlo, ulsort, codret ) +c + elseif ( statfi.eq.4 ) then +c + call dmoubs ( nuroul, ficloc, lficlo, ulsort, codret ) +c + endif +c + if (codret.ne.0) then + write(ulsort,11000) nompra + write(ulsort,32000) nuroul, codret, ficloc + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + else + codret = 3 + endif + endif +c + endif +c +c=== +c 4. archivage de l'information +c=== +c + if ( codret.eq.0 ) then +c + statut(nuroul) = statfi + lnomfi(nuroul) = lficlo + nomfic(nuroul) = ficloc +c +c (9): nb actuel d'unites ouvertes form/sequ +c (10): nb actuel d'unites ouvertes bina/sequ +c (11): nb actuel d'unites ouvertes bina/dire standard +c (12): nb actuel d'unites ouvertes bina/dire special +c + gunmbr(statfi+6) = gunmbr(statfi+6) + 1 +c +c (1): nbre maxi d'unites ouvertes form/sequ +c (2): nbre maxi d'unites ouvertes bina/sequ +c (3): nbre maxi d'unites ouvertes bina/dire standard +c (4): nbre maxi d'unites ouvertes bina/dire special +c + gunmbr(statfi-2) = max(gunmbr(statfi-2),gunmbr(statfi+6)) +c +c (5): nbre total d'unites ouvertes form/sequ +c (6): nbre total d'unites ouvertes bina/sequ +c (7): nbre total d'unites ouvertes bina/dire standard +c (8): nbre total d'unites ouvertes bina/dire special +c + gunmbr(statfi+2) = gunmbr(statfi+2) + 1 +c +c (13): nbre maxi d'unites ouvertes tous types confondus + gunmbr(13) = max ( gunmbr(13), + > gunmbr(9)+gunmbr(10)+gunmbr(11)+gunmbr(12) ) +c + code = 0 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + endif +c +c==== +c 5. formats +c==== +c +11000 format( + >/,'Sous-programme GUOUGE, appele par ',a6,' :') +c +21000 format( + >/,'Erreur lors de l''ouverture de l''unite ',i2, + >/,'Fichier :', + >/,a200, + >/,'Le statut ',i8,' est inconnu. Il faut 3 ou 4.') +22000 format( + >/,'Fichier :', + >/,a200, + >/,'La longueur de son nom vaut ',i6, + >/,'... ce qui est assez curieux ...', + >/,'car la variable est dimensionnee a ',i6,' en amont.') +23000 format( + >/,'Fichier :', + >/,a200, + >/,'La longueur de son nom vaut ',i6, + >/,'... ce qui est assez curieux ... Il faut entre 1 et 200.') +c +24000 format( + >/,'Fichier :', + >/,a200, + >/,'L''ouverture est impossible car ce fichier l''est deja', + >/,'sur l''unite ',i8,'.') +c +25000 format( + >/,'Fichier :', + >/,a200, + >/,'L''ouverture est impossible car les mbmxul unites sont deja', + >/,'utilisees.') +c +32000 format( + >/,'Erreur lors de l''ouverture de l''unite ',i2, + >/,'Code de retour ',i8, + >/,'Fichier :', + >/,a200) +c + end diff --git a/src/tool/Gestion_MTU/gurbbu.F b/src/tool/Gestion_MTU/gurbbu.F new file mode 100644 index 00000000..5c670958 --- /dev/null +++ b/src/tool/Gestion_MTU/gurbbu.F @@ -0,0 +1,144 @@ + subroutine gurbbu ( nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : rembobinage d'une unite logique particuliere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . e . 1 . numero de l'unite a rembobiner . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 3 : rembobinage impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GURBBU' ) +c +#include "genbla.h" +c +#include "gunbul.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul + integer codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c +#include "gulggt.h" +c + integer ulsort, langue + integer typarr +c + integer guimp, raison + integer ios, code + integer gunmbr(lgunmb) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*200 nomfic(mbmxul) +c + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c=== +c 1. recuperation de l'information +c=== +c +#include "impr01.h" +c + code = 1 + call gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c + ulsort = gunmbr(16) + langue = gunmbr(17) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. rembobinage proprement dit +c=== +c + if ( nuroul.gt.0 .and. nuroul.le.mbmxul ) then +c + if ( statut(nuroul).eq.3 .or. statut(nuroul).eq.4 ) then +c + codret = 0 +c + rewind ( unit=nuroul, iostat=ios, err=20 ) +c + else + ios = 1 + endif +c + else + ios = 1 + endif +c + 20 continue +c + if ( ios.ne.0 ) then +c + typarr = gunmbr(18) +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,20000) nuroul, ios +c + codret = 3 + if ( typarr.eq.0 ) then + guimp = 1 + raison = 1 + call gustop ( nompro, ulsort, guimp, raison ) + endif + endif +c +20000 format( + > 'Impossible de rembobiner l''unite logique ',i7, + >/'Code d''erreur retourne par rewind : ',i7,//) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c + end diff --git a/src/tool/Gestion_MTU/gusost.F b/src/tool/Gestion_MTU/gusost.F new file mode 100644 index 00000000..948c6c8f --- /dev/null +++ b/src/tool/Gestion_MTU/gusost.F @@ -0,0 +1,64 @@ + subroutine gusost ( nuroul ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : recuperer l'unite associee a la sortie standard +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . s . 1 . numero de l'unite logique attribuee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ +#include "gunbul.h" +#endif +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nuroul +c +c 0.4. ==> variables locales +c + integer lfichi, codret + character*200 fichie +c ______________________________________________________________________ +c +c=== +c 1. appel du programme generique avec un nom de fichier bidon +c=== +c + fichie = ' ' + lfichi = 0 +c + call gucara ( fichie, lfichi, nuroul, codret ) +c + end diff --git a/src/tool/Gestion_MTU/gustat.F b/src/tool/Gestion_MTU/gustat.F new file mode 100644 index 00000000..a0509eca --- /dev/null +++ b/src/tool/Gestion_MTU/gustat.F @@ -0,0 +1,170 @@ + subroutine gustat ( gunmbr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c but : etablit les statistiques relatives a la gestion des unites +c logiques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . gunmbr . e . * . les nombres caracteristiques de la gestion . +c . . . .(1): nb maxi d'unites ouvertes form/sequ . +c . . . .(2): nb maxi d'unites ouvertes bina/sequ . +c . . . .(3): nb maxi d'unites ouvertes bina/dire sta. +c . . . .(4): nb maxi d'unites ouvertes bina/dire spe. +c . . . .(5): nb total d'unites ouvertes form/sequ . +c . . . .(6): nb total d'unites ouvertes bina/sequ . +c . . . .(7): nb total d'unites ouvertes bina/dire st. +c . . . .(8): nb total d'unites ouvertes bina/dire sp. +c . . . .(9): nb actuel d'unites ouvertes form/sequ . +c . . . .(10): nb actuel d'unites ouvertes bina/sequ . +c . . . .(11): nb actuel d'unites ouvertes bina/dire . +c . . . .(12): nb actuel d'unites ouvertes bina/dire . +c . . . .(13): nb maxi d'unites ouvertes tous types . +c . . . .(14): numero de l'entree standard . +c . . . .(15): numero de la sortie standard . +c . . . .(16): numero de l'unite des messages du gu . +c . . . .(17): langue des messages du gu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'GUSTAT' ) +#endif +c +#include "gulggt.h" +#ifdef _DEBUG_HOMARD_ +#include "genbla.h" +#include "gunbul.h" +#endif +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer gunmbr(lgunmb) +c +c 0.4. ==> variables locales +c + integer iaux +c +#ifdef _DEBUG_HOMARD_ +c + integer ulsort + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*31 chstat(nblang,5) +c + integer langue +#endif +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#ifdef _DEBUG_HOMARD_ + ulsort = gunmbr(16) + langue = gunmbr(17) +#endif +c +#ifdef _DEBUG_HOMARD_ +#include "impr01.h" +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ +c + chstat(1,1) = 'Formate, acces sequentiel ' + chstat(1,2) = 'Binaire, acces sequentiel ' + chstat(1,3) = 'Binaire, acces direct standard ' + chstat(1,4) = 'Binaire, acces direct special ' + chstat(1,5) = 'Tous types confondus ' +c + chstat(2,1) = 'Formatted, sequential access ' + chstat(2,2) = 'Binary, sequential access ' + chstat(2,3) = 'Binary, standard direct access ' + chstat(2,4) = 'Binary, special direct access ' + chstat(2,5) = 'All kinds of files ' +c + texte(1,4) = + > '('':'',22x,''Unites logiques employees'',22x,'':'')' + texte(1,5) = + > '('':'',20x,''Type'',19x,'': Nombre : Nombre :'')' + texte(1,6) = + > '('':'',43x ,'': maximum : cumule :'')' +c + texte(2,4) = + > '('':'',26x,''Used logical units'',25x,'':'')' + texte(2,5) = + > '('':'',20x,''Type'',19x,'': Maximum : Accumulated:'')' + texte(2,6) = + > '('':'',43x ,'': number : number :'')' +c +c=== +c 2. impressions +c=== +c + write (ulsort,21001) +c + write (ulsort,21002) + write (ulsort,texte(langue,4)) + write (ulsort,21003) + write (ulsort,texte(langue,5)) + write (ulsort,texte(langue,6)) + write (ulsort,21003) +c + do 2 , iaux = 1 , 4 + write (ulsort,21004) chstat(langue,iaux), + > gunmbr(iaux), gunmbr(iaux+4) + 2 continue +c + iaux = gunmbr(5) + gunmbr(6) + gunmbr(7) + gunmbr(8) + write (ulsort,21003) + write (ulsort,21004) chstat(langue,5), gunmbr(13), iaux + write (ulsort,21003) +c +21001 format(////) +21002 format(71('.')) +21003 format(':',69('.'),':') +21004 format(': ',a31,11x,':',i7,5x,':',i7,5x,':') +c +#endif +c + call dmflsh (iaux) +c + end diff --git a/src/tool/Gestion_MTU/gustop.F b/src/tool/Gestion_MTU/gustop.F new file mode 100644 index 00000000..b0e49ce9 --- /dev/null +++ b/src/tool/Gestion_MTU/gustop.F @@ -0,0 +1,82 @@ + subroutine gustop ( appela, ulsort, guimp, raison ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c but : Gestion des Unites logiques : STOP du programme +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . appela . e . 1 . nom du programme appelant . +c . ulsort . e . 1 . unite logique pour les messages . +c . guimp . e . 1 . code pilotant le type d'info a imprimer . +c . raison . e . 1 . raison de l'appel : . +c . . . . 0 : arret normal, sans core . +c . . . . >0 : call abort -> core . +c . . . . <0 : arret des gestionnaires, puis sortie . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUSTOP' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulsort, guimp, raison +c + character *(*) appela +c +c 0.4. ==> variables locales +c + integer gmimp +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#include "langue.h" +#include "impr01.h" +c +c=== +c 1. appel du programme d'arret general +c==== +c + gmimp = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGSTOP', nompro +#endif + call ugstop ( appela, ulsort, guimp, gmimp, raison ) +c + end diff --git a/src/tool/Gestion_MTU/gutabl.F b/src/tool/Gestion_MTU/gutabl.F new file mode 100644 index 00000000..5aaa228b --- /dev/null +++ b/src/tool/Gestion_MTU/gutabl.F @@ -0,0 +1,191 @@ + subroutine gutabl ( code, gunmbr, statut, nomfic, lnomfi ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : archiver ou redonner les listes caracteristiques de la +c gestion des unites logiques. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . code . e . 1 . 0 : on archive les tableaux de l'appelant . +c . . . . 1 : on renvoie les tableaux vers l'appelant. +c . gunmbr . e/s . lgunmb . les nombres caracteristiques de la gestion . +c . . . .(1): nb maxi d'unites ouvertes form/sequ . +c . . . .(2): nb maxi d'unites ouvertes bina/sequ . +c . . . .(3): nb maxi d'unites ouvertes bina/dire sta. +c . . . .(4): nb maxi d'unites ouvertes bina/dire spe. +c . . . .(5): nb total d'unites ouvertes form/sequ . +c . . . .(6): nb total d'unites ouvertes bina/sequ . +c . . . .(7): nb total d'unites ouvertes bina/dire st. +c . . . .(8): nb total d'unites ouvertes bina/dire sp. +c . . . .(9): nb actuel d'unites ouvertes form/sequ . +c . . . .(10): nb actuel d'unites ouvertes bina/sequ . +c . . . .(11): nb actuel d'unites ouvertes bina/dire . +c . . . .(12): nb actuel d'unites ouvertes bina/dire . +c . . . .(13): nb maxi d'unites ouvertes tous types . +c . . . .(14): numero de l'entree standard . +c . . . .(15): numero de la sortie standard . +c . . . .(16): numero de l'unite des messages du gu . +c . . . .(17): langue des messages du gu . +c . . . .(18): type d'arret du gu . +c . statut . e/s . mbmxul . statut de chaque unite logique : . +c . . . . 0 : disponible . +c . . . . 1 : entree standard (form/sequ) . +c . . . . 2 : sortie standard (form/sequ) . +c . . . . 3 : ouvert en form/sequ . +c . . . . 4 : ouvert en bina/sequ . +c . . . . 5 : ouvert en form/dire . +c . . . . 6 : ouvert en bina/dire . +c . . . . 7 : interdit . +c . nomfic . e/s . mbmxul . nom du fichier attache a chaque unite . +c . . . . logique ouverte . +c . lnomfi . e/s . mbmxul . longueur du nom du fichier attache a chaque. +c . . . . unite logique ouverte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'GUTABL' ) +c +#include "genbla.h" +c +#include "gunbul.h" +#include "gulggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer code + integer gunmbr(*) + integer statut(mbmxul), lnomfi(mbmxul) +c + character*(*) nomfic(mbmxul) +c +c 0.4. ==> variables locales +c + integer sortst + parameter ( sortst = 6 ) +c + integer ulsort, langue +c + integer gunmb0(lgunmb) + integer statu0(mbmxul), lnomf0(mbmxul) +c + logical initia +c + character*200 nomfi0(mbmxul) +c + integer nbmess + parameter ( nbmess = 3 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> intialisations +c + data initia / .false. / +c +c ... juste pour ne plus avoir de messages ftnchek : +c + data gunmb0(16) / sortst / +c +c ______________________________________________________________________ +c +c==== +c 1. verifications +c==== +c +#include "impr01.h" +c +c 1.1. ==> unite pour la sortie standard et langue +c + if ( .not.initia ) then + ulsort = sortst + langue = 1 + else if ( gunmb0(16).gt.0 .and. gunmb0(16).le.mbmxul ) then + ulsort = gunmb0(16) + langue = gunmb0(17) + else + ulsort = sortst + langue = 1 + endif +c +c 1.2. ==> L'initialisation n'est pas faite +c + if ( code.ne.0 .and. .not.initia ) then + write (ulsort,texte(langue,1)) 'Entree', nompro + write (ulsort,12000) + call dmabor + endif +c +12000 format( + > 'L''initialisation du gestionnaire n''a pas ete faite.', + >/'Il faut faire appel a GUINIT.',//) +c +c==== +c 2. on archive les informations transmises par l'appelant +c==== +c + if ( code.eq.0 ) then +c + call ugtaci (gunmb0, gunmbr, 1, lgunmb) + call ugtaci (statu0, statut, 1, mbmxul) + call ugtaci (lnomf0, lnomfi, 1, mbmxul) + call ugtac2 (nomfi0, nomfic, 1, mbmxul) +c + initia = .true. +c +c=== +c 3. on renvoie a l'appelant +c==== +c + elseif ( code.eq.1 ) then +c + call ugtaci (gunmbr, gunmb0, 1, lgunmb) + call ugtaci (statut, statu0, 1, mbmxul) + call ugtaci (lnomfi, lnomf0, 1, mbmxul) + call ugtac2 (nomfic, nomfi0, 1, mbmxul) +c +c=== +c 4. probleme +c==== +c + else +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write(ulsort,40000) code + call dmabor +c + endif +c +40000 format( + > 'Le choix ',i4,' pour le premier argument ne correspond ', + > 'a aucune option possible.', + >/'Il faut 0 pour archiver ou 1 pour recuperer.',/) +c + end diff --git a/src/tool/Gestion_MTU/ugdhco.F b/src/tool/Gestion_MTU/ugdhco.F new file mode 100644 index 00000000..92ce58bf --- /dev/null +++ b/src/tool/Gestion_MTU/ugdhco.F @@ -0,0 +1,108 @@ + subroutine ugdhco ( numann, datheu ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c donne la date et l'heure sous forme courte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numann . s . 1 . numero de l'annee . +c . datheu . s . 1 . nombre de secondes depuis le debut de l'an . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numann, datheu +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numjos + integer numheu, nummin, numsec + integer nbjour + integer iaux, naux +c + integer lonmoi (12) +c +c==== +c 1. initialisation +c==== +c + lonmoi (1) = 31 + lonmoi (2) = 28 + lonmoi (3) = 31 + lonmoi (4) = 30 + lonmoi (5) = 31 + lonmoi (6) = 30 + lonmoi (7) = 31 + lonmoi (8) = 31 + lonmoi (9) = 30 + lonmoi (10) = 31 + lonmoi (11) = 30 + lonmoi (12) = 31 +c +c==== +c 2. acquisition de la date +c==== +c + call dmjohe ( numann, nummoi, numjou, numjos, + > numheu, nummin, numsec ) +c +c==== +c 3. mise en forme +c==== +c +c 3.2. ==> cumul du nombre de jours pleins passes depuis le debut +c de l'annee +c + nbjour = 0 +c + naux = nummoi - 1 + do 32 , iaux = 1 , naux + nbjour = nbjour + lonmoi(mod(iaux-1,12)+1) + 32 continue +c + if ( mod(numann,4).eq.0 .and. nummoi.gt.2 ) then + nbjour = nbjour + 1 + endif +c +c 3.3. ==> cumul du nombre de jours pleins passes depuis le debut +c du mois +c + nbjour = nbjour + numjou - 1 +c +c 3.4. ==> calcul du nombre de secondes depuis le debut de l'annee +c + datheu = numsec + + > nummin*60 + + > numheu*3600 + + > nbjour*86400 +c + end diff --git a/src/tool/Gestion_MTU/ugdhfc.F b/src/tool/Gestion_MTU/ugdhfc.F new file mode 100644 index 00000000..8af5e31c --- /dev/null +++ b/src/tool/Gestion_MTU/ugdhfc.F @@ -0,0 +1,93 @@ + subroutine ugdhfc ( datheu, numann, + > datefr, heurfr, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure +c de la forme Francaise en une forme compacte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . datheu . s . 1 . nombre de seconde depuis le debut de l'an . +c . numann . s . 1 . numero de l'annee (complet) . +c . datefr . e . ch8 . date au format francais 'jj/mm/aa' . +c . heurfr . e . ch8 . heure au format francais 'hh:mm:ss' . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu, numann + integer codret +c + character*8 datefr + character*8 heurfr +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numheu, nummin, numsec +c +c==== +c 1. determination des differents numeros +c remarque : on suppose que l'on ne prendra pas des objets +c anterieurs a 1970 et qu'apres 2070, on aura recode ... +c==== +c +cgn write(*,*) 'Dans UGDHFC, datefr = ', datefr +cgn write(*,*) 'Dans UGDHFC, heurfr = ', heurfr + read ( datefr (1:2),'(i2)' ) numjou + read ( datefr (4:5),'(i2)' ) nummoi + read ( datefr (7:8),'(i2)' ) numann + if ( numann.lt.70 ) then + numann = 2000 + numann + else + numann = 1900 + numann + endif +c + read ( heurfr (1:2),'(i2)' ) numheu + read ( heurfr (4:5),'(i2)' ) nummin + read ( heurfr (7:8),'(i2)' ) numsec +c +c==== +c 2. appel du programme generique +c==== +c + if ( codret.eq.0 ) then +c + call ugdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c + endif +c + end diff --git a/src/tool/Gestion_MTU/ugdhlc.F b/src/tool/Gestion_MTU/ugdhlc.F new file mode 100644 index 00000000..1765c219 --- /dev/null +++ b/src/tool/Gestion_MTU/ugdhlc.F @@ -0,0 +1,117 @@ + subroutine ugdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure d'une forme longue en une forme compacte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . datheu . s . 1 . nombre de seconde depuis le debut de l'an . +c . numann . e . 1 . numero de l'annee . +c . numjou . e . 1 . numero du jour . +c . numheu . e . 1 . numero de l'heure . +c . nummin . e . 1 . numero de la minute . +c . numsec . e . 1 . numero de la seconde . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu + integer numann + integer nummoi, numjou, numheu, nummin, numsec + integer codret +c +c 0.4. ==> variables locales +c + integer nbjour + integer iaux, naux +c + integer lonmoi (12) +c +c==== +c 1. initialisation +c==== +c + codret = 0 +c + lonmoi (1) = 31 + lonmoi (2) = 28 + lonmoi (3) = 31 + lonmoi (4) = 30 + lonmoi (5) = 31 + lonmoi (6) = 30 + lonmoi (7) = 31 + lonmoi (8) = 31 + lonmoi (9) = 30 + lonmoi (10) = 31 + lonmoi (11) = 30 + lonmoi (12) = 31 +c +c==== +c 2. mise en forme +c==== +c +c 2.2. ==> cumul du nombre de jours pleins passes depuis le debut +c de l'annee +c + nbjour = 0 +c + naux = nummoi - 1 + do 22 , iaux = 1 , naux + nbjour = nbjour + lonmoi(iaux) + 22 continue +c + if ( mod(numann,4).eq.0 .and. nummoi.gt.2 ) then + nbjour = nbjour + 1 + endif +c +c 2.3. ==> cumul du nombre de jours pleins passes depuis le debut +c du mois +c + nbjour = nbjour + numjou - 1 +c +cc if ( numheu.lt.24 ) then +cc nbjour = nbjour - 1 +cc endif +c +c 2.4. ==> calcul du nombre de secondes depuis le debut de l'annee +c + datheu = numsec + + > nummin*60 + + > numheu*3600 + + > nbjour*86400 +c + end diff --git a/src/tool/Gestion_MTU/ugfia3.F b/src/tool/Gestion_MTU/ugfia3.F new file mode 100644 index 00000000..70e1b69f --- /dev/null +++ b/src/tool/Gestion_MTU/ugfia3.F @@ -0,0 +1,317 @@ + subroutine ugfia3 ( ligne, + > ideb1, ifin1, ideb2, ifin2, + > ideb3, ifin3, ideb4, ifin4, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c retourne les indices de debut et de fin de chacun des 4 mots possibles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ligne . e . 1 . ligne a decoder . +c . ulsort . e . 1 . unite logique d'impression . +c . idebi . s . 1 . debut du mot numero i . +c . ifini . s . 1 . fin du mot numero i . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme de decodage des noms . +c . . . . 7 : impossible de decoder le $HOME . +c . . . . : (ou une autre variable d'environnement). +c . . . . 9 : probleme avec le fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGFIA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) ligne +c + integer ideb1, ideb2, ideb3, ideb4 + integer ifin1, ifin2, ifin3, ifin4 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lemot2, lemot3 +c + integer lgmax +c + logical ouverd, quotd2, quotd3 + logical ouvers, quots2, quots3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + parameter ( lgmax = 400 ) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr03.h" +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de quotes dans la ligne :'',i4)' + texte(1,5) = '(''Il en faut 0, 2 ou 4.'')' +c + texte(2,4) = '(''Number of quotes in line :'',i4)' + texte(2,5) = '(''0, 2 or 4 is required.'')' +c + codret = 0 +c +c==== +c 2. recherche de la position du premier mot +c==== +c +c 2.1. ==> recherche de la position du debut du premier mot : ideb1 +c + ideb1 = lgmax+1 + do 21 , jaux = 1 , lgmax + if ( ligne(jaux:jaux).ne.' ' ) then + ideb1 = jaux + goto 22 + endif + 21 continue +c + 22 continue +cgn write (ulsort,90002) 'ideb1',ideb1 +c +c 2.2. ==> recherche de la position de la fin du premier mot : ifin1 +c + ifin1 = lgmax + iaux = ideb1 + 1 + do 23 , jaux = iaux , lgmax + if ( ligne(jaux:jaux).eq.' ' ) then + ifin1 = jaux - 1 + goto 24 + endif + 23 continue +c + 24 continue +cgn write (ulsort,90002) 'ifin1',ifin1 +c +c==== +c 3. reperage des debuts et fin des mots 2 et 3 +c on en profite pour reperer s'ils sont encadres par des quotes, +c en distinguant les simples et les doubles +c==== +c + lemot2 = 0 + ideb2 = -1 + ideb3 = -1 + lemot3 = 0 + ouvers = .false. + quots2 = .false. + quots3 = .false. + ouverd = .false. + quotd2 = .false. + quotd3 = .false. + kaux = 0 + iaux = ifin1 + 1 + do 31 , jaux = iaux , lgmax +c +c 3.1. ==> c'est une quote double +c + if ( ligne(jaux:jaux).eq.'"' ) then + if ( ouverd ) then + ouverd = .false. + if ( lemot2.eq.1 ) then + quotd2 = .true. + lemot2 = 2 + ifin2 = jaux-1 + elseif ( lemot3.eq.1 ) then + quotd3 = .true. + lemot3 = 2 + ifin3 = jaux-1 + endif + else + ouverd = .true. + endif + kaux = kaux + 1 +c +c 3.2. ==> c'est une quote simple +c . si une quote double est ouverte, c'est un caractere comme +c un autre, donc on ne fait rien de special +c . sinon, c'est une ouverture +c + elseif ( ligne(jaux:jaux).eq.'''' ) then +c + if ( ouverd ) then + goto 31 + elseif ( ouvers ) then + ouvers = .false. + if ( lemot2.eq.1 ) then + quots2 = .true. + lemot2 = 2 + ifin2 = jaux-1 + elseif ( lemot3.eq.1 ) then + quots3 = .true. + lemot3 = 2 + ifin3 = jaux-1 + endif + else + ouvers = .true. + endif + kaux = kaux + 1 +c +c 3.3. ==> c'est un caractere non blanc : debut de mot +c + elseif ( ligne(jaux:jaux).ne.' ' ) then + if ( lemot2.le.1 ) then + lemot2 = 1 + if ( ideb2.eq.-1 ) then + ideb2 = jaux + endif + else + lemot3 = 1 + if ( ideb3.eq.-1 ) then + ideb3 = jaux + endif + endif +c +c 3.4. ==> c'est un caractere blanc : fin de mot si pas entre quotes +c + elseif ( ligne(jaux:jaux).eq.' ' .and. .not.ouverd ) then + if ( lemot2.eq.1 ) then + lemot2 = 2 + ifin2 = jaux-1 + elseif ( lemot3.eq.1 ) then + lemot3 = 2 + ifin3 = jaux-1 + endif +c + endif +c +cgn if ( ideb1.eq.1 .and. jaux.le.80) then +cgn 3499 format( i8, a2, l2, l2, i2, i2) +cgn write (ulsort,3499)jaux,ligne(jaux:jaux),ouverd,ouvers,lemot2,lemot3 +cgn endif + 31 continue +c +c 3.n. ==> controle des quotes +c +cgn write (ulsort,*) kaux, quotd2, quotd3 +cgn write (ulsort,*) kaux, quots2, quots3 +cgn write (ulsort,*) ideb2, ifin2, ideb3,ifin3 + if ( kaux.eq.0 .or. + > ( kaux.eq.2 .and. quotd2 .and. .not.quotd3 ) .or. + > ( kaux.eq.2 .and. quotd3 .and. .not.quotd2 ) .or. + > ( kaux.eq.4 .and. quotd2 .and. quotd3 ) .or. + > ( kaux.eq.2 .and. quots2 .and. .not.quots3 ) .or. + > ( kaux.eq.2 .and. quots3 .and. .not.quots2 ) .or. + > ( kaux.eq.4 .and. quots2 .and. quots3 ) ) then + goto 40 + else +c + write (ulsort,*) ligne + write (ulsort,texte(langue,4)) kaux + write (ulsort,texte(langue,5)) + codret = 3 +c + endif +c +c==== +c 4. recherche de la position du quatrieme nom +c s'il n'y en n'a pas, on passe directement au decodage. +c==== +c + 40 continue +c + ideb4 = -1 +c + if ( codret.eq.0 ) then +c + if ( ideb3.gt.0 ) then +c +c 3.4.1. ==> recherche du debut du quatrieme nom : ideb4 +c + if ( quotd3 ) then + iaux = ifin3 + 2 + else + iaux = ifin3 + 1 + endif + do 41 , jaux = iaux , lgmax + if ( ligne(jaux:jaux).ne.' ' ) then + ideb4 = jaux + goto 42 + endif + 41 continue +c + goto 50 +c + 42 continue +c +c 3.4.2. ==> recherche de la fin du quatrieme nom : ifin4 +c + ifin4 = lgmax + iaux = ideb4 + 1 + do 43 , jaux = iaux , lgmax + if ( ligne(jaux:jaux).eq.' ' ) then + ifin4 = jaux - 1 + goto 44 + endif + 43 continue +c + 44 continue +c + endif +c + endif +c +c==== +c 5. fin +c==== +c + 50 continue +cgn write (ulsort,90002) 'ideb4, ifin4',ideb4, ifin4 +c + end diff --git a/src/tool/Gestion_MTU/ugfino.F b/src/tool/Gestion_MTU/ugfino.F new file mode 100644 index 00000000..63000ea5 --- /dev/null +++ b/src/tool/Gestion_MTU/ugfino.F @@ -0,0 +1,426 @@ + subroutine ugfino ( motcle, nfichi, lfichi, + > nfconf, lfconf, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c Copyright 2020 EDF +c ______________________________________________________________________ +c +c but : retourne le nom du fichier correspondant a un mot-cle +c en faisant la lecture directe dans le fichier de configuration +c +c note: on s'attend, dans le fichier de configuration, a trouver un +c nom de fichier nfichi "a la UNIX". Ce nom de fichier est +c converti par dmnfcv, a la fin de ce sous-programme, +c pour etre acceptable par le systeme +c d'exploitation courant (par exemple WINDOWS). +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char8 . mot-cle de reperage dans la configuration . +c . nfichi . s . char * . nom du fichier associe . +c . lfichi . s . 1 . longueur de ce nom . +c . nfconf . e . char * . nom du fichier de configuration . +c . lfconf . e . 1 . longueur de ce nom . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . 0 : le nom du fichier est trouve . +c . . . . 1 : le mot-cle est absent du fichier . +c . . . . 2 : plusieurs noms existent . +c . . . . 3 : le mot-cle n'est associe a aucun fichie. +c . . . . 5 : le mot-cle est blanc . +c . . . . 7 : impossible de decoder une variable . +c . . . . d'environnement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGFINO' ) +c +#include "consts.h" +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lfconf, lfichi + integer langue, ulsort, codret +c + character*(*) motcle + character*(*) nfconf, nfichi +c +c 0.4. ==> variables locales +c + integer ideb1, ideb2, ideb3, ideb4 + integer ifin1, ifin2, ifin3, ifin4 + integer ulconf, codre0, codre1, codre2 + integer iaux, jaux, kaux + integer lgnova, lgnout +c + integer lgmax +c + integer lgmoc + integer lgliga, lgligb +c + character*400 lignea, ligneb + character*400 nomvar, nomuti + character*400 ligbla + character*8 motloc + character*1 commen +c + logical varenv +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + parameter ( lgmax = 400 ) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Dans le fichier de configuration'')' + texte(1,5) = + > '(''Aucun fichier n''''est associe au mot-cle :'')' + texte(1,6) = + >'(''le mot-cle '',a8,'' est associe a plusieurs fichiers.'')' + texte(1,7) = '(''le mot-cle '',a8,'' est absent.'')' +c + texte(2,4) = '(''In the configuration file'')' + texte(2,5) = '(''No file is connected with the keyword :'')' + texte(2,6) = + >'(''the keyword '',a8,'' is connected with several files.'')' + texte(2,7) = '(''the keyword '',a8,'' is missing.'')' +c +c 1.2. ==> les constantes +c + codre2 = 0 + lfichi = 0 +c + do 10 iaux = 1 , len(nfichi) + nfichi (iaux:iaux) = ' ' + 10 continue +c + commen = '#' +c + do 11 , iaux = 1 , lgmax + ligbla (iaux:iaux) = ' ' + 11 continue +c +c 1.3. ==> initialisation pour ne plus avoir de messages ftnchek +c + nomvar = ligbla +c +c 1.4. ==> suppression des blancs aux extremites du mot-cle +c + jaux = min(8,len(motcle))+1 + do 141 , iaux = 1 , min(8,len(motcle)) + if ( motcle (iaux:iaux) .ne. ' ' ) then + jaux = iaux + goto 142 + endif + 141 continue +c + 142 continue +c + kaux = 0 + do 143 , iaux = min(8,len(motcle)), jaux , -1 + if ( motcle (iaux:iaux) .ne. ' ' ) then + kaux = iaux + goto 144 + endif + 143 continue +c + 144 continue +c + lgmoc = kaux - jaux + 1 + motloc = blan08 +c + if ( lgmoc.gt.0 ) then + motloc(1:lgmoc) = motcle(jaux:kaux) + codret = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Mot_cle : ', motloc +#endif + else + codret = 5 + endif +c +c=== +c 2. decodage du fichier de configuration +c=== +c + if ( codret.eq.0 ) then +c + codret = 1 +c +c 2.1. ==> ouverture du fichier de configuration +c + call guoufs ( nfconf, lfconf, ulconf, codre1 ) +c + if ( codre1.ne.0 .and. ulconf.le.0 ) then + goto 31 + else + codre1 = 0 + endif +c + call gurbbu ( ulconf, codre0 ) +c +c 2.2. ==> boucle sur les lignes +c + lgliga = len(lignea) +c + 2 continue +c + lignea = ligbla +c + read ( ulconf, 20400, end=31, err=31 ) lignea +c +c 2.2.1. ==> on ne tient pas compte d'une ligne en commentaire +c + if ( lignea(1:1).eq.commen ) then + goto 2 + endif +c +c 2.2.2. ==> nettoyage eventuel de la ligne lue (caract. non impr.): +c + call dmcpch( lignea, lgliga, ligneb, lgligb ) +c +c 2.2.3. ==> on ne tient pas compte d'une ligne blanche +c + if ( lgligb.eq.0 ) then + goto 2 + endif +c +c 2.2.4. ==> recherche du debut du mot-cle +c + iaux = index(ligneb,motloc(1:lgmoc)) +c +c 2.2.5. ==> Le mot-cle est present +c + if ( iaux.gt.0 ) then +c +c 2.2.5.1. ==> recherche des positions des mots +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGFIA3', nompro +#endif + call ugfia3 ( ligneb, + > ideb1, ifin1, ideb2, ifin2, + > ideb3, ifin3, ideb4, ifin4, + > ulsort, langue, codret ) +c +c 2.2.5.7. ==> decodage. +c On controle que le mot-cle est le bon +c et place en premier +c Si oui, on determine le nom du fichier. +c + if ( lgmoc.ne.ifin1-ideb1+1 .or. + > motloc(1:lgmoc).ne.ligneb(ideb1:ifin1) ) then + goto 2 + endif +c + if ( lfichi.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) + write (ulsort,*) nfconf(1:lfconf) + write (ulsort,texte(langue,6)) motloc(1:lgmoc) + codret = 2 + goto 31 + else + if ( ideb3.gt.0 ) then + ideb4 = ideb3 + ifin4 = ifin3 + else + ideb4 = ideb2 + ifin4 = ifin2 + endif +c + 270 continue + if ( ifin4.gt.ideb4+1 .and. + > ligneb(ideb4:ideb4+1).eq.'./' ) then + ideb4 = ideb4+2 + goto 270 + endif +c + kaux = 0 + varenv = .false. + lgnova = 0 +c + do 271 , iaux = ideb4, ifin4 +c + if ( ligneb(iaux:iaux).eq.'$' ) then +c + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre2 = 7 + endif + if ( kaux.lt.len(nfichi) .and. lgnout.gt.0 ) then + lgnout = min( len(nfichi)-kaux, lgnout ) + nfichi(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + endif + varenv = .true. + lgnova = 0 +c + elseif ( ligneb(iaux:iaux).eq.'.' .or. + > ligneb(iaux:iaux).eq.'-' .or. + > ligneb(iaux:iaux).eq.'/' ) then + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre2 = 7 + endif + if ( kaux.lt.len(nfichi) .and. lgnout.gt.0 ) then + lgnout = min( len(nfichi)-kaux, lgnout ) + nfichi(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + varenv = .false. + endif + if ( kaux.lt.len(nfichi) ) then + kaux = kaux + 1 + nfichi(kaux:kaux) = ligneb(iaux:iaux) + endif +c + else + if ( varenv ) then + lgnova = lgnova + 1 + nomvar(lgnova:lgnova) = ligneb(iaux:iaux) + if ( iaux.eq.ifin4 ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre2 = 7 + endif + if ( kaux.lt.len(nfichi) .and. lgnout.gt.0 ) then + lgnout = min( len(nfichi)-kaux, lgnout ) + nfichi(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + endif + else + if ( kaux.lt.len(nfichi) ) then + kaux = kaux + 1 + nfichi(kaux:kaux) = ligneb(iaux:iaux) + endif + endif + endif +c + 271 continue +c + lfichi = kaux + if ( codret.eq.1 ) then + codret = 0 + endif + endif +c + endif +c +c 2.2.6. ==> ligne suivante +c + goto 2 +c +c 2.3. ==> fin +c + 31 continue +c + if ( codre1.eq.0 ) then + call gufefi ( nfconf, lfconf, codre0 ) + endif +c + endif +c +c conversion eventuelle du nom du fichier trouve dans le +c fichier de configuration: sous UNIX, dmnfcv ne fait RIEN ... +c sous WINDOWS, on change les / en \ ... +c + if ( lfichi.gt.0 ) then + call dmnfcv( nfichi, lfichi ) + endif +c + if ( codret.eq.0 ) then + if ( codre1.ne.0 ) then + codret = 1 + endif + endif +c + if ( codret.eq.0 ) then + if ( codre2.ne.0 ) then + codret = 7 + endif + endif +c + if ( codret.eq.0 ) then + if ( lfichi.le.0 ) then + codret = 1 + endif + endif +c +20400 format (a400) +c +c==== +c 3. bilan +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + if ( lfconf.gt.0 .and. len(nfconf).gt.0 ) then + write (ulsort,*) nfconf(1:min(lfconf,len(nfconf))) + else + write (ulsort,*) + endif + write (ulsort,texte(langue,7)) motloc +c + endif +#endif +c + end diff --git a/src/tool/Gestion_MTU/uginit.F b/src/tool/Gestion_MTU/uginit.F new file mode 100644 index 00000000..3b771882 --- /dev/null +++ b/src/tool/Gestion_MTU/uginit.F @@ -0,0 +1,179 @@ + subroutine uginit ( ulsort, langdf, nfconf, lfconf, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : initialiser une execution +c au premier passage : +c - gestionnaire d'unites logiques +c au second passage : +c - gestionnaire des mesures de temps de calcul +c - gestionnaire de memoire +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . unite logique d'impression . +c . langdf . e . 1 . langue des messages par defaut . +c . . . . 1 : francais . +c . . . . 2 : anglais . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur de ce nom . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 2 : problemes pour la memoire . +c . . . . 3 : problemes pour les unites logiques . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGINIT' ) +c +#include "gelggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer ulsort, langdf, lfconf + integer codret +c +c 0.4. ==> variables locales +c + integer tabges(lgtage) +c + integer guimp, gmimp, raison + integer enstul, sostul + integer code, nropas + integer langlo, messlo + integer imprgt +c +c 0.5. ==> initialisations +c + data nropas / 1 / +c +c ______________________________________________________________________ +c + langlo = max(1, langdf ) +c +c==== +c 1. premier passage +c==== +c + if ( nropas.eq.1 ) then +c + codret = 0 +c +c 1.1. ==> recuperation des numeros des unites standard +c + call dmunit ( enstul, sostul ) +c +c 1.2. ==> archivage du point de depart : aucun gestionnaire n'est +c encore initialise +c +c (1): unites logiques (1 : initialise, 0 : non) +c (2): mesures de temps de calcul (1 : initialise, 0 : non) +c (3): memoire (1 : initialise, 0 : non) +c (4): langue (1: francais, 2:anglais) +c + tabges(1) = 0 + tabges(2) = 0 + tabges(3) = 0 + tabges(4) = langlo +c + code = 0 + call ugtabl ( code, tabges, sostul ) +c +c 1.3. ==> gestion des unites logiques +c + call guinit ( enstul, sostul, langlo, + > nfconf, lfconf, codret ) +c +c==== +c 2. second passage +c==== +c + elseif ( nropas.eq.2 ) then +c + codret = 0 +c + if ( ulsort.le.0 ) then + messlo = sostul + else + messlo = ulsort + endif +c +c 2.1. ==> la langue +c + code = 1 + call ugtabl ( code, tabges, messlo) +c + tabges(4) = langlo +c + code = 0 + call ugtabl ( code, tabges, messlo) +c +c 2.2. ==> redirection des messages de gu +c + call gumess ( ulsort, codret ) +c +c 2.3. ==> mesures de temps de calcul +c + imprgt = 1 + call gtinit ( messlo, langlo, imprgt ) +c +c 2.4. ==> initialisation de la gestion de la memoire +c + call gminge ( messlo, langlo, nfconf, lfconf ) +c +c==== +c 3. autre passage : erreur +c==== +c + else +c + if ( ulsort.le.0 ) then + messlo = sostul + else + messlo = ulsort + endif +c + guimp = 1 + gmimp = 1 + raison = 1 + call ugstop ( nompro,messlo,guimp, gmimp, raison) +c + endif +c +c==== +c 4. fin +c==== +c + nropas = nropas + 1 +c + end diff --git a/src/tool/Gestion_MTU/uglanm.F b/src/tool/Gestion_MTU/uglanm.F new file mode 100644 index 00000000..e3132e9a --- /dev/null +++ b/src/tool/Gestion_MTU/uglanm.F @@ -0,0 +1,152 @@ + subroutine uglanm ( lang , ulsort, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Utilitaires des Gestionnaires : LANgue des Messages +c - - --- - +c ______________________________________________________________________ +c +c modifie la langue des messages des gestionnaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lang . e . 1 . code de la langue souhaitee . +c . . . . 1 : francais . +c . . . . 2 : anglais . +c . ulsort . e . 1 . unite logique d'impression des messages . +c . codret . s . 1 . 0 : tout va bien . +c . . . . 2 : problemes pour la memoire . +c . . . . 3 : problemes pour les unites logiques . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGLANM' ) +c +#include "genbla.h" +#include "gelggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lang , ulsort + integer codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer tabges(lgtage) +c + integer guimp, gmimp, raison + integer code + integer langue +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c + texte(1,10) = '(''Le numero de langue '',i2,'' pour les'')' + texte(1,4) = '(''messages des gestionnaires est incorrect.'')' + texte(1,5) = '(''Il doit etre compris entre 1 et '',i8)' +c + texte(2,10) = '(''The language code # '',i2,'' wanted for'')' + texte(2,4) = '(''managers messages is not correct.'')' + texte(2,5) = '(''It must be included between 1 and '',i8)' +c +c==== +c 2. recuperation de l'information +c=== +c + code = 1 + call ugtabl ( code, tabges, ulsort) +c + langue = tabges(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 3. verification de la validite du numero. +c Il faut que le numero soit compris entre 1 et le nombre maximal +c de langues. +c==== +c + if ( lang.lt.1 .or. lang.gt.nblang ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) lang + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) nblang +c + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop (nompro,ulsort,guimp, gmimp, raison) +c + endif +c +c==== +c 4. changement dans les differents gestionnaires +c==== +c + call gmlanm ( lang ) + call gtlanm ( lang ) + call gulanm ( lang, codret ) +c +c==== +c 5. archivage du numero +c==== +c + if ( codret.eq.0 ) then +c + tabges(4) = lang +c + code = 0 + call ugtabl ( code, tabges, ulsort) +c + endif +c + end diff --git a/src/tool/Gestion_MTU/ugstop.F b/src/tool/Gestion_MTU/ugstop.F new file mode 100644 index 00000000..749d8733 --- /dev/null +++ b/src/tool/Gestion_MTU/ugstop.F @@ -0,0 +1,282 @@ + subroutine ugstop ( appela, messul, guimp, gmimp, raison ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : arreter une execution apres avoir arrete les gestionnaires +c - gestionnaire de memoire +c - gestionnaire des mesures de temps de calcul +c - gestionnaire d'unites logiques +c - execution elle-meme +c +c ATTENTION : dans certains cas tordus d'arret de GM ou GU, il y a +c bouclage sur l'appel a ugstop. On empeche cela +c en ne faisant les impressions qu'au premier appel +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . appela . e . 1 . nom du programme appelant . +c . messul . e . 1 . unite logique pour les messages . +c . guimp . e . 1 . pilotage des impressions gu . +c . gmimp . e . 1 . pilotage des impressions gm . +c . raison . e . 1 . raison de l'appel : . +c . . . . 0 : arret normal, sans core . +c . . . . >0 : call abort -> core . +c . . . . <0 : arret des gestionnaires, puis sortie . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGSTOP' ) +c +#include "genbla.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer messul, raison, guimp, gmimp +c + character *(*) appela +c +c 0.4. ==> variables locales +c + integer lgtage + parameter ( lgtage = 4 ) +c + integer code + integer langue + integer tabges(lgtage) +c + integer nropas, enstul, sostul, ulsort + integer iaux, jaux +c + character*06 saux06 + character*38 appelo + character*38 saux38 +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data nropas / 0 / +c +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + if ( messul.le.0 ) then + call dmunit ( enstul, sostul ) + ulsort = sostul + else + ulsort = messul + endif +c +#include "impr01.h" +c + texte(1,4) = ': A la demande du programme ' +c 12345678901234567890123456789012345678 + texte(1,5) = ': ARRET NORMAL :' + texte(1,6) = ': ARRET pour cause de probleme :' + texte(1,7) = ': ARRET sur bouclage dans ' +c + texte(2,4) = ': Requested by subroutine ' + texte(2,5) = ': NORMAL STOP :' + texte(2,6) = ': STOP because of problem :' + texte(2,7) = ': STOP because of loop in ' +c +10000 format ( + > 15x,'......................................') +10001 format ( + > 15x,': :', + > /,15x,a38, + > /,15x,':....................................:') +10002 format ( + > 15x,': :', + > /,15x,a38, + > /,15x,a38, + > /,15x,':....................................:') +c +c==== +c 2. recuperation de l'etat des differents gestionnaires +c +c (1): unites logiques (1 : initialise, 0 : non) +c (2): mesures de temps de calcul (1 : initialise, 0 : non) +c (3): memoire (1 : initialise, 0 : non) +c (4): langue (1: francais, 2:anglais) +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(1,3)) 'UGTABL', nompro +#endif + code = 1 + call ugtabl ( code, tabges, ulsort ) +c + langue = tabges(4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( langue.le.0 .or. langue.gt.nblang ) then + langue = 1 + endif +c +c==== +c 3. entete +c==== +c + nropas = nropas + 1 +c +c recopie prudente du nom de l'appelant, appela dans appelo : +c + iaux = len(appela) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DMCPCH', nompro +#endif + call dmcpch( appela, iaux, appelo, jaux ) +c + if ( jaux.eq.0 ) then + appelo = '? ? ? ' + jaux = 6 + endif +c +#ifdef _DEBUG_HOMARD_ + afaire = .true. +#else + if ( raison.le.0 ) then + afaire = .false. + else + afaire = .true. + endif +#endif +c + if ( raison.ne.0 ) then + write (ulsort,10000) + endif + if ( raison.le.0 ) then + write (ulsort,10001) texte(langue,5) + endif +c + if ( afaire ) then +c + if ( jaux.le.6 ) then + saux06(1:iaux) = appelo(1:jaux) + do 311 , iaux = jaux+1 , 6 + saux06(iaux:iaux) = ' ' + 311 continue + write (ulsort,10001) texte(langue,4)(1:29)//saux06//' :' + else + saux38(1:2) = ': ' + saux38(3:iaux+2) = appelo(1:jaux) + do 312 , iaux = jaux+3 , 38 + saux38(iaux:iaux) = ' ' + 312 continue + saux38(38:38) = ':' + write (ulsort,10002) texte(langue,4)(1:29)//' :', + > saux38//' :' + endif +c + if ( raison.gt.0 ) then + if ( nropas.eq.1 ) then + write (ulsort,10001) texte(langue,6) + else + write (ulsort,10001) texte(langue,7)(1:29)//nompro//' :' + endif + endif +c + endif +c + call dmflsh(iaux) +c +c==== +c 4. arret de la gestion de la memoire, le cas echeant +c==== +c + if ( tabges(3).ne.0 .and. nropas.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GMSTOP', nompro +#endif + call gmstop ( gmimp ) + call dmflsh(iaux) + endif +c +c==== +c 5. arret de la gestion des mesures de temps de calcul, le cas echeant +c==== +c + if ( tabges(2).ne.0 .and. nropas.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GTBILA', nompro +#endif + call gtbila + call dmflsh(iaux) + endif +c +c==== +c 6. arret de la gestion unites logiques, le cas echeant +c . en mode debug, on respecte la decision d'impression. +c . en mode optim, on n'imprime jamais. +c==== +c + if ( tabges(1).ne.0 .and. nropas.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GUBILA', nompro +#endif +#ifdef _DEBUG_HOMARD_ + iaux = guimp +#else + iaux = 0 +#endif + call gubila ( iaux ) + call dmflsh(iaux) + endif +c +c==== +c 7. arret general de l'execution : +c 0 : normal +c >0 : plantage +c <0 : arret des gestionnaires, mais le programme continue +c==== +c + if ( raison.eq.0 ) then + stop + elseif ( raison.gt.0 ) then + call dmabor + else + nropas = 0 + endif +c + end diff --git a/src/tool/Gestion_MTU/ugtabl.F b/src/tool/Gestion_MTU/ugtabl.F new file mode 100644 index 00000000..8902e8d2 --- /dev/null +++ b/src/tool/Gestion_MTU/ugtabl.F @@ -0,0 +1,128 @@ + subroutine ugtabl ( code, tabges, ulsort ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : archiver ou redonner les caracteristiques des differents +c gestionnaires. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . code . e . 1 . 0 : on archive les tableaux de l'appelant . +c . . . . 1 : on renvoie les tableaux vers l'appelant. +c . tabges . e/s . lgtage . les nombres caracteristiques de la gestion . +c . . . .(1): memoire . +c . . . .(2): mesures de temps de calcul . +c . . . .(3): unites logiques . +c . . . .(4): langue des messages . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UGTABL' ) +c +#include "genbla.h" +c +#include "gelggt.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer code, tabges(lgtage), ulsort +c +c 0.4. ==> variables locales +c + integer trges0(lgtage) + integer langue +c + logical initia +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data langue / 1 / + data initia / .false. / +c ______________________________________________________________________ +c +c==== +c 1. verifications de l'initialisation +c==== +c +#include "impr01.h" +c + if ( code.ne.0 .and. .not.initia ) then + write (ulsort,texte(langue,1)) 'Entree', nompro + write (ulsort,11000) nompro + call dmabor + endif +c +11000 format( + > 'L''initialisation du gestionnaire des gestionnaires', + > 'n''a pas ete faite.', + >/,'Il faut d''abord faire appel a ',a6,' en archivage.',//) +c +c==== +c 2. on archive les informations transmises par l'appelant +c==== +c + if ( code.eq.0 ) then +c + call ugtaci ( trges0, tabges, 1, lgtage ) +c + initia = .true. +c +c=== +c 3. on renvoie a l'appelant +c==== +c + elseif ( code.eq.1 ) then +c + call ugtaci ( tabges, trges0, 1, lgtage ) +c +c=== +c 4. probleme +c==== +c + else +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write(ulsort,40000) code + call dmabor +c + endif +c +40000 format( + > 'Le choix ',i4,' pour le premier argument ne correspond ', + > 'a aucune option possible.', + >/,'Il faut 0 pour archiver ou 1 pour recuperer.',/) +c + end diff --git a/src/tool/Gestion_MTU/ugtac2.F b/src/tool/Gestion_MTU/ugtac2.F new file mode 100644 index 00000000..b48c7275 --- /dev/null +++ b/src/tool/Gestion_MTU/ugtac2.F @@ -0,0 +1,66 @@ + subroutine ugtac2 ( tab1, tab2, indinf, indsup ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : basculer le contenu du tableau tab2 dans le tableau tab1 +c les tableaux sont character*200 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab1 . s . lgtab . tableau a remplir . +c . tab2 . e . lgtab . tableau a copier . +c . indinf . e . 1 . indice inferieur des tableaux tab1 et tab2 . +c . indsup . e . 1 . indice superieur des tableaux tab1 et tab2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer indinf, indsup +c + character*200 tab1(indinf:indsup), tab2(indinf:indsup) +c +c 0.4. ==> variables locales +c + integer i +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. copie +c==== +c + do 1 , i = indinf, indsup + tab1(i) = tab2(i) + 1 continue +c + end diff --git a/src/tool/Gestion_MTU/ugtaci.F b/src/tool/Gestion_MTU/ugtaci.F new file mode 100644 index 00000000..6cef6cf7 --- /dev/null +++ b/src/tool/Gestion_MTU/ugtaci.F @@ -0,0 +1,66 @@ + subroutine ugtaci ( tab1, tab2, indinf, indsup ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : basculer le contenu du tableau tab2 dans le tableau tab1 +c les tableaux sont entiers +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab1 . s . lgtab . tableau a remplir . +c . tab2 . e . lgtab . tableau a copier . +c . indinf . e . 1 . indice inferieur des tableaux tab1 et tab2 . +c . indsup . e . 1 . indice superieur des tableaux tab1 et tab2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer indinf, indsup +c + integer tab1(indinf:indsup), tab2(indinf:indsup) +c +c 0.4. ==> variables locales +c + integer i +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. copie +c==== +c + do 1 , i = indinf, indsup + tab1(i) = tab2(i) + 1 continue +c + end diff --git a/src/tool/Gestion_MTU/ugtacl.F b/src/tool/Gestion_MTU/ugtacl.F new file mode 100644 index 00000000..b24de179 --- /dev/null +++ b/src/tool/Gestion_MTU/ugtacl.F @@ -0,0 +1,66 @@ + subroutine ugtacl ( tab1, tab2, indinf, indsup ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : basculer le contenu du tableau tab2 dans le tableau tab1 +c les tableaux sont logiques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab1 . s . lgtab . tableau a remplir . +c . tab2 . e . lgtab . tableau a copier . +c . indinf . e . 1 . indice inferieur des tableaux tab1 et tab2 . +c . indsup . e . 1 . indice superieur des tableaux tab1 et tab2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer indinf, indsup +c + logical tab1(indinf:indsup), tab2(indinf:indsup) +c +c 0.4. ==> variables locales +c + integer i +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. copie +c==== +c + do 1 , i = indinf, indsup + tab1(i) = tab2(i) + 1 continue +c + end diff --git a/src/tool/Gestion_MTU/ugtacr.F b/src/tool/Gestion_MTU/ugtacr.F new file mode 100644 index 00000000..32504b83 --- /dev/null +++ b/src/tool/Gestion_MTU/ugtacr.F @@ -0,0 +1,66 @@ + subroutine ugtacr ( tab1, tab2, indinf, indsup ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : basculer le contenu du tableau tab2 dans le tableau tab1 +c les tableaux sont reels +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab1 . s . lgtab . tableau a remplir . +c . tab2 . e . lgtab . tableau a copier . +c . indinf . e . 1 . indice inferieur des tableaux tab1 et tab2 . +c . indsup . e . 1 . indice superieur des tableaux tab1 et tab2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer indinf, indsup +c + double precision tab1(indinf:indsup), tab2(indinf:indsup) +c +c 0.4. ==> variables locales +c + integer i +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. copie +c==== +c + do 1 , i = indinf, indsup + tab1(i) = tab2(i) + 1 continue +c + end diff --git a/src/tool/Gestion_MTU/ugtacs.F b/src/tool/Gestion_MTU/ugtacs.F new file mode 100644 index 00000000..c084e8ab --- /dev/null +++ b/src/tool/Gestion_MTU/ugtacs.F @@ -0,0 +1,68 @@ + subroutine ugtacs ( tab1, tab2, ind1, ind2 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : basculer le contenu du tableau tab2 dans le tableau tab1 +c les tableaux sont character*24 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tab1 . s . lgtab . tableau a remplir . +c . tab2 . e . lgtab . tableau a copier . +c . ind1 . e . 1 . indice inferieur des tableaux tab1 et tab2 . +c . ind2 . e . 1 . indice superieur des tableaux tab1 et tab2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ind1, ind2 +c + character*24 tab1(ind1,ind2), tab2(ind1,ind2) +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. copie +c==== +c + do 11 , iaux = 1 , ind1 + do 111 , jaux = 1 , ind2 + tab1(iaux,jaux) = tab2(iaux,jaux) + 111 continue + 11 continue +c + end diff --git a/src/tool/HOMARD_00/CMakeLists.txt b/src/tool/HOMARD_00/CMakeLists.txt new file mode 100644 index 00000000..5ae35a70 --- /dev/null +++ b/src/tool/HOMARD_00/CMakeLists.txt @@ -0,0 +1,51 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de HOMARD_00 + +SET(HOMARD_00_SOURCES + ./hoapcv.F + ./hoapec.F + ./hoapem.F + ./hoapes.F + ./hoapls.F + ./hoavcv.F + ./hoavec.F + ./hoavli.F + ./hoavlm.F + ./hocmsa.F + ./hocrma.F + ./hodeci.F + ./hoinco.F + ./hoinit.F + ./holect.F + ./holopt.F + ./holver.F + ./homajc.F + ./hoprin.F + ./hostop.F + ./hosufr.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/HOMARD_00 ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (HOMARD_00 ${HOMARD_00_SOURCES}) + +INSTALL(TARGETS HOMARD_00 EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/HOMARD_00/hoapcv.F b/src/tool/HOMARD_00/hoapcv.F new file mode 100644 index 00000000..5cfaa862 --- /dev/null +++ b/src/tool/HOMARD_00/hoapcv.F @@ -0,0 +1,497 @@ + subroutine hoapcv ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface APres adaptation : ConVersions +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAPCV' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adoptr, lgoptr + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 action + character*8 typobs, nohmap +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*50 commen(nblang) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c + endif +c +c 1.4. ==> l'etat courant +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'// + >''' C O N V E R S I O N S A P R E S A D A P T A T I O N'')' + texte(1,5) = '(62(''=''),/)' +c + texte(2,4) = + > '(//,a6,'// + >''' C O N V E R S I O N S A F T E R A D A P T A T I O N'')' + texte(2,5) = '(62(''=''),/)' +c +c 1.6. ==> le titre +c + if ( codret.eq.0 ) then +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c + endif +c +c 1.7. ==> les options reelles +c + call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif +c +c 1.8. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +#include "impr03.h" +c +c==== +c 2. compactage des tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. compactage tableaux ; codret', codret +#endif +c + if ( imem(adopti+21).eq.1 .or. imem(adopti+27).eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOMP', nompro +#endif +c + call utcomp (ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 3. conversion eventuelle du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. conversion maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+21).eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'imem(adopti+38)', imem(adopti+38) + write (ulsort,90002) 'imem(adopti+10)', imem(adopti+10) +#endif +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 3.1. ==> le cas extrude, non saturne, non neptune +c + if ( imem(adopti+38).ne.0 .and. + > imem(adopti+10).ne.26 .and. + > imem(adopti+10).ne.46 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMEXT', nompro +#endif + call pcmext ( lgopti, imem(adopti), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2. ==> conversion vers le format externe +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAIL', nompro +#endif +c + call pcmail ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> modification pour le cas non conforme +c ou saturne/neptune 2D +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'imem(adopti+29)', imem(adopti+29) + write (ulsort,90002) 'imem(adopti+10)', imem(adopti+10) +#endif +c + if ( imem(adopti+29).eq.-2 .or. + > imem(adopti+29).eq.1 .or. + > imem(adopti+29).eq.2 .or. + > imem(adopti+29).eq.3 .or. + > imem(adopti+10).eq.26 .or. + > imem(adopti+10).eq.46 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMANC', nompro +#endif + call pcmanc ( lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + call gtfims (nrssse) +c + endif +c + endif +c +c==== +c 4. conversion eventuelle d'une solution +c==== +c +c 4.1. ==> lecture +c si aucune solution n'est presente, hoapls modifiera +c l'indicateur de conversion, imem(adopti+27). +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. lecture solution ; codret', codret + write (ulsort,90002) 'imem(adopti+27)', imem(adopti+27) + write (ulsort,90002) 'imem(adopti+38)', imem(adopti+38) +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+27).eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPLS', nompro +#endif +c + call hoapls ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.2. ==> conversion +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. conversion solution ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+27).eq.1 ) then +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 4.2.1 ==> pour le cas extrude, passage du 3D au 2D +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+38).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 1 + call utsext ( smem(adopts+8), iaux, imem(adopti+10), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.2.2. ==> conversion vraie +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCSOLU', nompro +#endif +c + call pcsolu ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 4.2.3 ==> pour le cas extrude, passage du 2D au 3D +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+38).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 2 + call utsext ( smem(adopts+9), iaux, imem(adopti+10), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + call gtfims (nrssse) +c + endif +c + endif +c +c +c==== +c 5. analyse du maillage converti +c Il faut le faire seulement ici car certaines conversions +c modifient les familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. analyse ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c + if ( codret.eq.0 ) then + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codret ) + endif +c + if ( imem(adopti+3).eq.3 ) then + commen(1) = 'Maillage apres modification ' + commen(2) = 'Mesh after modification ' + elseif ( imem(adopti+21).eq.1 ) then + commen(1) = 'Maillage apres adaptation ' + commen(2) = 'Mesh after adaptation ' + else + commen(1) = 'Maillage ' + commen(2) = 'Maillage ' + endif +c + if ( codret.eq.0 ) then +c + action = smem(adopts+29) + if ( action.eq.'homa ' ) then + action = 'apad' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBILM', nompro +#endif + call utbilm ( nohmap, commen(langue), imem(adopti+2), action, + > lgetco, imem(adetco), + > ulsort, langue, codret ) + endif +c + call gtfims (nrssse) +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoapec.F b/src/tool/HOMARD_00/hoapec.F new file mode 100644 index 00000000..c9dec59a --- /dev/null +++ b/src/tool/HOMARD_00/hoapec.F @@ -0,0 +1,288 @@ + subroutine hoapec ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface APres adaptation : ECritures +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAPEC' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adetco, lgetco + integer adopts, lgopts + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 typobs +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'' E C R I T U R E D E S F I C H I E R S'')' + texte(1,5) = '(48(''=''),/)' +c + texte(2,4) = '(//,a6,'' W R I T I N G O F F I L E S'')' + texte(2,5) = '(38(''=''),/)' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. Ecriture eventuelle du maillage HOMARD +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Maillage HOMARD ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( mod(imem(adopti+4),3).eq.0 ) then +c + typobs = mchmap + nrssse = imem(adetco+3) + nrsset = imem(adetco+1) + 1 + imem(adetco+1) = nrsset +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMHO', nompro +#endif + call esemho ( typobs, nrssse, nretap, nrsset, + > imem(adopti+4), + > imem(adopti+28), smem(adopts+15), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Ecriture eventuelle du maillage de calcul +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Maillage de calcul ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+21).eq.1 ) then +c + imem(adopti+49) = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPEM', nompro +#endif + call hoapem ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. ecriture eventuelle de solutions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Solutions ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+27).eq.1 .or. imem(adopti+11).gt.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPES', nompro +#endif + call hoapes ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +c 5.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 5.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoapem.F b/src/tool/HOMARD_00/hoapem.F new file mode 100644 index 00000000..f801bb17 --- /dev/null +++ b/src/tool/HOMARD_00/hoapem.F @@ -0,0 +1,241 @@ + subroutine hoapem ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface APres adaptation : Ecritures du Maillage +c -- -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAPEM' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 nocmai, mcfima, mcnoma +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' ECRITURE DU MAILLAGE DE CALCUL'')' + texte(1,5) = '(37(''=''),/)' + texte(1,6) = '(/,a6,'' ECRITURE DU MAILLAGE ANNEXE'')' + texte(1,7) = '(34(''=''),/)' + texte(1,8) = '(''Mauvais choix de type de maillage :'',i8)' + texte(1,9) = '(''Il faut 1 ou 2.'')' +c + texte(2,4) = '(/,a6,'' WRITINGS OF CALCULATION MESH'')' + texte(2,5) = '(35(''=''),/)' + texte(2,6) = '(/,a6,'' WRITINGS OF ADDITIONAL MESH'')' + texte(2,7) = '(34(''=''),/)' + texte(2,8) = '(''Bad choice for mesh type :'',i8)' + texte(2,9) = '(''1 ou 2 is correct.'')' +c +c 1.3. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.4. ==> le titre +c + iaux = 0 + if ( taopti(50).eq.1 ) then + iaux = 4 + elseif ( taopti(50).eq.2 ) then + iaux = 6 + endif + if ( iaux.ne.0 ) then + write (ulsort,texte(langue,iaux)) saux + write (ulsort,texte(langue,iaux+1)) + endif +c +c==== +c 2. choix du maillage a ecrire +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> maillage apres adaptation +c + if ( taopti(50).eq.1 ) then +c + nocmai = taopts(2) + mcfima = mccmap + mcnoma = mccnmp +c +c 2.2. ==> maillage annexe apres adaptation +c + elseif ( taopti(50).eq.2 ) then +c + nocmai = taopts(5) + mcfima = mccmaa + mcnoma = mccnma +c +c 2.3. ==> erreur +c + else +c + write (ulsort,texte(langue,8)) taopti(50) + write (ulsort,texte(langue,9)) + codret = 2 +c + endif +c + endif +c +c==== +c 3. ecriture du maillage +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> format med +c + if ( mod(taopti(11)-6,10).eq.0 ) then +c + if ( taopti(50).eq.1 ) then + iaux = 0 + elseif ( taopti(50).eq.2 ) then + iaux = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMMD', nompro +#endif + call esemmd ( nocmai, mcfima, mcnoma, iaux, + > ulsort, langue, codret) +c +c 3.2. ==> erreur +c + else +c + codret = 5 +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoapes.F b/src/tool/HOMARD_00/hoapes.F new file mode 100644 index 00000000..3af87a5b --- /dev/null +++ b/src/tool/HOMARD_00/hoapes.F @@ -0,0 +1,260 @@ + subroutine hoapes ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface APres adaptation : Ecriture de la Solution +c -- -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAPES' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux, jaux + integer lnomfi +c + character*6 saux + character*8 typobs + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 120 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' ECRITURE DES SOLUTIONS'')' + texte(1,5) = '(29(''=''),/)' + texte(1,6) = '(''Solution : '',a)' +c + texte(2,4) = '(/,a6,'' WRITINGS OF SOLUTIONS'')' + texte(2,5) = '(28(''=''),/)' + texte(2,6) = '(''Solution: '',a)' +c +c 1.3. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.4. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#include "esimpr.h" +c +#include "impr03.h" +c +c==== +c 2. ecriture de la solution interpolee +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. solution interpolee ; codret', codret + write (ulsort,90002) 'taopti(28)', taopti(28) +#endif +c + if ( taopti(28).eq.1 ) then +c +c 2.1. ==> nom du fichier qui contiendra la solution +c + if ( codret.eq.0 ) then +c + typobs = mccsop + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) 'solution interpolee en sortie' + codret = 21 + endif +c + endif +c +c 2.2. ==> ecriture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) taopts(10) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESESMD_sol_interpolee', nompro +#endif +c + call esesmd ( taopts(10), nomfic, lnomfi, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 3. ecriture d'une solution construite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. solution construite ; codret', codret + write (ulsort,90002) 'taopti(12)', taopti(12) +#endif +c + if ( taopti(12).gt.1 ) then +c +c 3.1. ==> nom du fichier qui contiendra la solution : celui du maillage +c + if ( codret.eq.0 ) then +c + typobs = mccmap + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) + if ( codret.ne.0 ) then + write (ulsort,texte(langue,8)) 'solution construite en sortie' + codret = 31 + endif +c + endif +c +c 3.2. ==> ecriture +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) taopts(31) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESESMD_sol_construite', nompro +#endif +c + call esesmd ( taopts(31), nomfic, lnomfi, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoapls.F b/src/tool/HOMARD_00/hoapls.F new file mode 100644 index 00000000..fb1c11d8 --- /dev/null +++ b/src/tool/HOMARD_00/hoapls.F @@ -0,0 +1,244 @@ + subroutine hoapls ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c interface APres adaptation : Lectures de la SOLution +c -- - --- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 3 : probleme a la lecture . +c . . . . 5 : mauvais type de code de calcul associe . +c . . . . 6 : impossible de connaitre le code associe. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAPLS' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux + integer nbcham, nbfonc, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' LECTURE DE LA SOLUTION'')' + texte(1,5) = '(29(''=''),/)' + texte(1,6) = '(''Mauvais code de calcul :'',i5)' + texte(1,7) = '(''Solution : '',a)' + texte(1,8) = '(''Aucune fonction n''''est a interpoler.'')' +c + texte(2,4) = '(/,a6,'' READINGS OF SOLUTION'')' + texte(2,5) = '(27(''=''),/)' + texte(2,6) = '(''Bad related code:'',i5)' + texte(2,7) = '(''Solution: '',a)' + texte(2,8) = '(''No fonction is to be interpolated.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. lecture de la solution +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> format med +c + if ( mod(taopti(11)-6,10).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSMD', nompro + call dmflsh(iaux) +#endif +c + iaux = 1 + call eslsmd ( taopts(9), taopts(18), + > taopti(9), iaux, + > ulsort, langue, codret ) +c +c 2.2. ==> autres formats : probleme +c + else +c + write (ulsort,texte(langue,6)) taopti(11) + codret = 5 +c + endif +c + endif +c +c==== +c 3. la solution est-elle bien non vide ? +c Si aucune fonction n'est presente, on annule la conversion. +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro + call dmflsh (iaux) +#endif + call utcaso ( taopts(9), + > nbcham, nbfonc, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) taopts(9) + write (ulsort,90002) 'nbcham', nbcham + write (ulsort,90002) 'nbfonc', nbfonc + write (ulsort,90002) 'nbprof', nbprof + write (ulsort,90002) 'nblopg', nblopg + call gmprsx (nompro,taopts(9)) + call gmprsx (nompro,taopts(9)//'.InfoCham') + call gmprsx (nompro,taopts(9)//'.InfoPaFo') + call gmprsx (nompro,taopts(9)//'.InfoLoPG') +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbfonc.eq.0 ) then +c + write (ulsort,texte(langue,8)) + taopti(28) = 0 +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoavcv.F b/src/tool/HOMARD_00/hoavcv.F new file mode 100644 index 00000000..3b57f8de --- /dev/null +++ b/src/tool/HOMARD_00/hoavcv.F @@ -0,0 +1,633 @@ + subroutine hoavcv ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface AVant adaptation : ConVersions +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 7 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAVCV' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca2.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adoptr, lgoptr + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 action + character*8 typobs, nohman, nocman, nosvmn +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c + character*50 commen(nblang) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c + endif +c +c 1.4. ==> l'etat courant +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'// + >''' C O N V E R S I O N S A V A N T A D A P T A T I O N'')' + texte(1,5) = '(62(''=''),/)' +c + texte(2,4) = + > '(//,a6,'// + >''' C O N V E R S I O N S B E F O R E A D A P T A T I O N'')' + texte(2,5) = '(64(''=''),/)' +c +#include "impr03.h" +c +c 1.6. ==> le titre +c + if ( codret.eq.0 ) then +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c + endif +c +c 1.7. ==> les options reelles +c + call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif +c +c 1.8. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.9. ==> la date courante +c + call utdhlg ( ladate, langue ) +c +c==== +c 2. conversion du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. conversion ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 2.1. ==> prealable pour le suivi de frontiere +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. prealable frontiere ; codret', codret +#endif +c + if ( ( ( mod(imem(adopti+28),2).eq.0 ) .and. + > ( imem(adopti+28).lt.0 ) ) .or. + > ( ( mod(imem(adopti+28),5).eq.0 ) .and. + > ( imem(adopti+9).eq.0 ) ) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFDEFG', nompro +#endif +c + call sfdefg ( imem(adopti+28), + > smem(adopts), smem(adopts+15), smem(adopts+16), + > ulsort, langue, codret) +c + endif +c + endif +c + if ( imem(adopti+20).eq.1 ) then +c +c 2.2. ==> prealable pour le cas saturne/neptune 2D +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. prealable sat/nep ; codret', codret +#endif +c + if ( imem(adopti+10).eq.26 .or. + > imem(adopti+10).eq.46 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS2D', nompro +#endif +c + call vcms2d ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> conversion vraie +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. conversion ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMAIL', nompro +#endif + call vcmail ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 3. Le cas extrude, non saturne, non neptune +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. cas extrude ; codret', codret +#endif +c + if ( imem(adopti+38).ne.0 .and. + > imem(adopti+10).ne.26 .and. + > imem(adopti+10).ne.46 ) then +c +c 3.1. ==> Conversion complete +c + if ( imem(adopti+20).eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXT', nompro +#endif +c + call vcmext ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Conversion partielle +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXA', nompro +#endif +c + call vcmexa ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. s'il y a conversion de solution, on cree une structure de +c memorisation du maillage n +c==== +c + if ( imem(adopti+20).eq.1.and. imem(adopti+27).eq.1 ) then +c + if ( codret.eq.0 ) then +c + nohman = smem(adopts+2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVMN', nompro +#endif + call utsvmn ( nohman, nosvmn, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adopts+13) = nosvmn +c + endif +c + endif +c +c==== +c 5. Informations sur le maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Informations ; codret', codret +#endif +c 5.1. ==> analyse du maillage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1. analyse ; codret', codret +#endif +c + if ( imem(adopti+20).eq.1 ) then +c + if ( codret.eq.0 ) then +c + commen(1) = 'Maillage converti au format HOMARD ' + commen(2) = 'Mesh converted to the HOMARD format ' +c +#ifdef _DEBUG_HOMARD_ + call utbica ( commen(langue), + > ulsort, langue, codret ) +#endif +c + endif +c + call gtfims (nrssse) +c + else +c + commen(1) = 'Maillage lu au format HOMARD ' + commen(2) = 'Mesh read with HOMARD format ' +c + endif +c +c 5.2. ==> Nom du maillage au format HOMARD +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. nom du maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + typobs = mchman + iaux = 1 + call utosno ( typobs, nohman, iaux, ulsort, langue, codret ) +c + endif +c +c==== +c 6. Prise en compte eventuelle du suivi de frontiere +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. frontiere ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + if ( mod(imem(adopti+28),2).eq.0 .or. + > mod(imem(adopti+28),3).eq.0 .or. + > mod(imem(adopti+28),5).eq.0 ) then +c + call gtdems (nrssse) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOIN', nompro +#endif + call sfcoin ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + call gtfims (nrssse) +c + endif +c + endif +c +c==== +c 7. analyse du maillage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. analyse du maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c + if ( codret.eq.0 ) then +c + action = smem(adopts+29) + if ( action.eq.'homa ' ) then + action = 'avad' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBILM', nompro +#endif + call utbilm ( nohman, commen(langue), imem(adopti+2), action, + > lgetco, imem(adetco), + > ulsort, langue, codret ) + endif +c + call gtfims (nrssse) +c + endif +c +c==== +c 8. Filtrages de l'adaptation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. filtrage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+18).gt.0 .or. + > rmem(adoptr+2).gt.0.d0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCFIAD', nompro +#endif + call vcfiad ( lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. conversion eventuelle de l'indicateur d'erreur +c=== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. indicateur erreur ; codret', codret +#endif +c + if ( imem(adopti+26).eq.1 ) then +c +c 9.1. ==> lecture +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVLI', nompro +#endif + call hoavli ( lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 9.2. ==> prealable pour le cas extrude +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+38).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 1 + call utsext ( smem(adopts+6), iaux, imem(adopti+10), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 9.3. ==> conversion vraie +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCINDI', nompro +#endif + call vcindi ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + call gtfims (nrssse) +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,smem(adopts+7)) +cgn call gmprsx (nompro,smem(adopts+7)//'.Quadr') +cgn call gmprsx (nompro,smem(adopts+7)//'.Quadr.Support') +cgn call gmprsx (nompro,smem(adopts+7)//'.Quadr.ValeursR') +#endif +c + endif +c + endif +c +c==== +c 10. menage des structures liees au calcul +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. menage ; codret', codret +#endif +c + if ( imem(adopti+20).eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GMSGOJ', nompro +#endif + nocman = smem(adopts) + call gmsgoj ( nocman, codret ) +c + endif +c + endif +c +c==== +c 11. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. la fin ; codret', codret +#endif +c +c 11.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 11.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoavec.F b/src/tool/HOMARD_00/hoavec.F new file mode 100644 index 00000000..5b82cba4 --- /dev/null +++ b/src/tool/HOMARD_00/hoavec.F @@ -0,0 +1,276 @@ + subroutine hoavec ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface AVant adaptation : ECritures +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAVEC' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmstri.h" +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*8 typobs +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.4. ==> Va-t-on ecrire ? +c + iaux = 0 + if ( codret.eq.0 ) then +cgn print *,imem(adopti+20),imem(adopti+4) + if ( imem(adopti+20).eq.1 ) then + if ( mod(imem(adopti+4),2).eq.0 ) then + iaux = 1 + endif + endif +cgn print *,imem(adopti+3),imem(adopti+4) + if ( imem(adopti+3) .eq.-3 .and. + > mod(imem(adopti+4),2).eq.0 .and. + > imem(adopti+26).eq.1 ) then + iaux = 1 + endif + if ( imem(adopti+3) .eq.5 ) then + iaux = 1 + endif + endif +c +c----------------------------------------------------------------------- + if ( iaux.eq.1 ) then +c----------------------------------------------------------------------- +c +c 1.5. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.6. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.7. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'' E C R I T U R E D E S F I C H I E R S'')' + texte(1,5) = '(48(''=''),/)' +c + texte(2,4) = '(//,a6,'' W R I T I N G O F F I L E S'')' + texte(2,5) = '(38(''=''),/)' +c +c 1.8. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.9. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. ecriture eventuelle du maillage +c==== +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+20).eq.1 .or. imem(adopti+3).eq.5 ) then +c + if ( mod(imem(adopti+4),2).eq.0 ) then +c + typobs = mchman + nrssse = imem(adetco+3) + nrsset = imem(adetco+1) + 1 + imem(adetco+1) = nrsset +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESEMHO', nompro +#endif + call esemho ( typobs, nrssse, nretap, nrsset, + > imem(adopti+4), + > imem(adopti+28), smem(adopts+15), + > ulsort, langue, codret) +c + endif +c + endif +c + endif + +c +c==== +c 3. la fin +c==== +c +c 3.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 3.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c----------------------------------------------------------------------- + else +c----------------------------------------------------------------------- +c +c==== +c 4. Mise a jour du compteur des sections temporelles +c si rien n'a ete fait +c==== +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + endif +c----------------------------------------------------------------------- + endif +c----------------------------------------------------------------------- +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoavli.F b/src/tool/HOMARD_00/hoavli.F new file mode 100644 index 00000000..be3255cb --- /dev/null +++ b/src/tool/HOMARD_00/hoavli.F @@ -0,0 +1,208 @@ + subroutine hoavli ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface AVant adaptation : Lectures de l'Indicateur +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . es . lgoptr . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 3 : probleme a la lecture . +c . . . . 4 : impossible de connaitre le code associe. +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAVLI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,a6,'' LECTURE DE L''''INDICATEUR D''''ERREUR'')' + texte(1,5) = '(39(''=''),/)' + texte(1,6) = '(''Mauvais code de calcul :'',i5)' +c + texte(2,4) = '(/,a6,'' READINGS OF ERROR INDICATOR'')' + texte(2,5) = '(34(''=''),/)' + texte(2,6) = '(''Bad related code:'',i5)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. lecture de l'indicateur +c==== +c +c 2.1. ==> format med +c + if ( mod(taopti(11)-6,10).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLIMD', nompro +#endif + call eslimd ( taopts(7), + > taopti(13), taopti(14), taoptr(10), + > taopti(15), taopti(16), taopti(17), + > taopti(9), + > ulsort, langue, codret) +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, taopts(7)) + call gmprsx ( nompro, taopts(7)//'.InfoPaFo') + call gmprsx ( nompro, '%%%%%%14') + call gmprsx ( nompro, '%%%%%%15') + call gmprsx ( nompro, '%%%%%%15.TypeSuAs') +#endif +c +c 2.2. ==> mauvais type +c + else +c + codret = 5 +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c +c 3.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.5 ) then + write (ulsort,texte(langue,6)) taopti(11) + endif +c + endif +c +c 3.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoavlm.F b/src/tool/HOMARD_00/hoavlm.F new file mode 100644 index 00000000..26a33376 --- /dev/null +++ b/src/tool/HOMARD_00/hoavlm.F @@ -0,0 +1,289 @@ + subroutine hoavlm ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : interface AVant adaptation : Lectures du Maillage +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOAVLM' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c VERRUE CONFORME PENTAEDRE - DEBUT +#include "gmenti.h" +c VERRUE CONFORME PENTAEDRE - FIN +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec, nrssse + integer nretap, nrsset + integer iaux + integer typcca +c +c VERRUE CONFORME PENTAEDRE - DEBUT + integer adnomb + integer jaux +c VERRUE CONFORME PENTAEDRE - FIN +c + character*6 saux + character*8 nomail, nosvmn + character*8 mcfich, mcmail + character*8 typobs +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' LECTURE DU MAILLAGE DE CALCUL'')' + texte(1,5) = '(36(''=''),/)' + texte(1,6) = '(''Mauvais code de calcul :'',i5)' +c + texte(2,4) = '(/,a6,'' READINGS OF CALCULATION MESH'')' + texte(2,5) = '(35(''=''),/)' + texte(2,6) = '(''Bad related code:'',i5)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti( 4) - modhom', taopti( 4) + write (ulsort,90002) 'taopti(21) - cvmail', taopti(21) +#endif +c +c==== +c 2. lecture du maillage au format med +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. lecture au format med ; codret', codret +#endif +c + if ( taopti(21).ne.0 .or. taopti(4).eq.5 ) then +c + if ( mod(taopti(11)-6,10).eq.0 ) then +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + mcfich = mccman + mcmail = mccnmn + if ( taopti(4).eq.5 ) then + iaux = 2 + else + iaux = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMD', nompro +#endif + call eslmmd ( mcfich, mcmail, + > taopti(11), taopts(1), + > iaux, taopti(9), + > ulsort, langue, codret ) +c +c 2.3. ==> mauvais type +c + else +c + codret = 5 +c + endif +c + endif +c +c==== +c 3. lecture du maillage au format HOMARD +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. lecture au format HOMARD ; codret', codret +#endif +c +c + if ( taopti(21).eq.0 ) then +c +c 3.1. ==> lecture +c iteration n+1 pour le mode homard interpolation (4) +c iteration n pour les autres modes +c + if ( taopti(4).eq.4 ) then + typobs = mchmap + else + typobs = mchman + endif + nrssse = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMHO', nompro +#endif + call eslmho ( typobs, nrssse, nretap, nrsset, + > taopts(3), typcca, + > taopti(29), taopts(16), taopts(17), + > ulsort, langue, codret ) +c +c 3.2. ==> pour les modes homard pur (0, 1), et +c s'il y a conversion de solution, on cree les tables de +c memorisation du maillage n +c + if ( ( taopti(4).eq.0 .or. taopti(4).eq.1 ) .and. + > taopti(28).eq.1 ) then +c + if ( codret.eq.0 ) then + iaux = 1 + call utosno ( typobs, nomail, iaux, ulsort, langue, codret ) + endif +c + if ( codret.eq.0 ) then + call utsvmn ( nomail, nosvmn, + > ulsort, langue, codret ) + endif +c + if ( codret.eq.0 ) then + taopts(14) = nosvmn + endif +C + endif +c +c 3.3. ==> par defaut, le maillage est extrude en Z si c'est du +c SATURNE ou du NEPTUNE 2D +c + if ( codret.eq.0 ) then +c + if ( typcca.eq.26 .or. typcca.eq.46 ) then + taopti(39) = 3 + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.5 ) then + write (ulsort,texte(langue,6)) taopti(11) + endif +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hocmsa.F b/src/tool/HOMARD_00/hocmsa.F new file mode 100644 index 00000000..b8ff8535 --- /dev/null +++ b/src/tool/HOMARD_00/hocmsa.F @@ -0,0 +1,371 @@ + subroutine hocmsa ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : Creation d'un Maillage et d'une Solution Annexe +c -- - - - - +c Option(s) possible(s) : changement de degre +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOCMSA' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux, jaux + integer codre0 + integer codre1, codre2 + integer lnomaa +c + character*6 saux + character*8 typobs, nocmaa, nohmap + character*64 nommaa +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( imem(adopti+40).eq.1 ) then +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) +c + if ( codret.eq.0 ) then + if ( imem(adopti+40).eq.1 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + endif + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.5. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.6. ==> les messages +c + texte(1,4) = + > '(//,a6,'' M A I L L A G E E T S O L U T I O N A N N '', + >''E X E S'')' + texte(1,5) = '(65(''=''),/)' + texte(1,7) = '(''Impossible pour Code_Saturne'')' + texte(1,8) = '(''Le format'',i7,''est impossible.'')' +c + texte(2,4) = '(//,a6,'' A D D I T I O N A L M E S H A N D'', + >'' S O L U T I O N'')' + texte(2,5) = '(65(''=''),/)' + texte(2,7) = '(''Impossible for Code_Saturne'')' + texte(2,8) = '(''Format #'',i7,''cannot be written.'')' +c +c 1.7. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.8. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage homard a l'iteration n+1 +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codre1 ) +c +c 2.2. ==> le maillage med annexe +c + if ( imem(adopti+10).eq.6 .or. + > imem(adopti+10).eq.16 .or. + > imem(adopti+10).eq.26 .or. + > imem(adopti+10).eq.36 .or. + > imem(adopti+10).eq.46 .or. + > imem(adopti+10).eq.56 ) then +c + typobs = mccnma + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nommaa, lnomaa, + > jaux, + > ulsort, langue, codre2 ) +c + else +c + lnomaa = 0 + codre2 = 0 +c + endif +c +c 2.3. ==> bilan +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c==== +c 3. modification du degre du maillage +c==== +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+40).eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMDEGR', nompro +#endif +c + call mmdegr ( lgopti, imem(adopti), lgetco, imem(adetco), + > nohmap, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. conversion du maillage +c==== +c +c 4.1. ==> conversion vraie des connectivites +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMACO', nompro + call dmflsh(iaux) +#endif + call pcmaco ( imem(adopti+3), + > nocmaa, nohmap, nommaa, lnomaa, + > smem(adopts+19), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + smem(adopts+4) = nocmaa + endif +c +c 4.2. ==> les familles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PCMAFA', nompro + call dmflsh(iaux) +#endif + call pcmafa ( nocmaa, nohmap, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> verification pour le cas extrude +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+38).ne.0 .or. + > imem(adopti+10).eq.26 .or. + > imem(adopti+10).eq.36 .or. + > imem(adopti+10).eq.46 .or. + > imem(adopti+10).eq.56 ) then +c + write (ulsort,texte(langue,7)) + codret = 3 +c + endif +c + call gtfims (nrssse) +c + endif +c +c==== +c 4. ecriture du maillage +c==== +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+21).eq.1 ) then +c + imem(adopti+49) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPEM', nompro +#endif + call hoapem ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +c 5.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 5.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoconf.h b/src/tool/HOMARD_00/hoconf.h new file mode 100644 index 00000000..9f9c1bdb --- /dev/null +++ b/src/tool/HOMARD_00/hoconf.h @@ -0,0 +1,9 @@ +c +c nfconf est le nom du fichier de configuration pour HOMARD +c lfconf est la longueur de ce nom +c + character*200 nfconf + integer lfconf +c + parameter ( nfconf = 'HOMARD.Configuration' ) + parameter ( lfconf = 20 ) diff --git a/src/tool/HOMARD_00/hocrma.F b/src/tool/HOMARD_00/hocrma.F new file mode 100644 index 00000000..0a3d8ae2 --- /dev/null +++ b/src/tool/HOMARD_00/hocrma.F @@ -0,0 +1,798 @@ + subroutine hocrma ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : CReation du MAillage +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c Rappel des codes de pilotage du raffinement et deraffinement : +c 30 : mode de conformite +c 0 : conforme (defaut) +c 1 : non-conforme avec 1 seule arete decoupee (en 2) +c par face (triangle ou quadrangle) +c 2 : non-conforme avec 1 seul noeud pendant par arete +c 3 : non-conforme fidele a l'indicateur +c -1 : conforme, avec des boites pour les quad, hexa et pent +c 31 : raffinement +c -1 : raffinement uniforme +c 0 : pas de raffinement +c 1 : raffinement libre (defaut) +c 2 : raffinement libre homogene en type d'element +c 32 : deraffinement +c -1 : deraffinement uniforme +c 0 : pas de deraffinement +c 1 : deraffinement libre (defaut) +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOCRMA' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "nouvnb.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "cndoad.h" +#include "envada.h" +#include "envca1.h" +#include "envca2.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer indnoe, indare, indtri, indqua + integer indtet, indhex, indpyr, indpen +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer indnp2, indnim + integer nbprov + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux + integer codre0 + integer codre1, codre2 +c + character*6 saux +#ifdef _DEBUG_HOMARD_ + character*8 action + parameter ( action = 'adap ' ) + character*6 nompra +#endif + character*8 typobs, nohman, nohmap +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c + endif +c +c 1.4. ==> l'etat courant +c + if ( codret.eq.0 ) then +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'' C R E A T I O N D U M A I L L A G E'')' + texte(1,5) = '(46(''=''),/)' + texte(1,7) = + > '(''==> Nombre total d''''entites provisoires :'',i10)' +c + texte(2,4) = '(//,a6,'' M E S H C R E A T I O N'')' + texte(2,5) = '(32(''=''),/)' + texte(2,7) = '(''==> Total number of temporary entities :'',i10)' +c +#include "impr03.h" +c +c 1.6. ==> le titre +c + if ( codret.eq.0 ) then +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c + endif +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. les structures de base +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. les structures de base ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 2.1. ==> le maillage homard a l'iteration n +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nohman, iaux, ulsort, langue, codre1 ) +c +c 2.2. ==> le maillage homard a l'iteration n+1 +c + typobs = mchmap + iaux = 1 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codre2 ) +c +c 2.3. ==> bilan +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then + smem(adopts+3) = nohmap +#ifdef _DEBUG_HOMARD_ + iaux = 0 + call utveri ( action, nohman, nompro, iaux, + > ulsort, langue, codret ) +#endif + endif +c +c==== +c 3. Initialisations pour le maillage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Init pour le maillage ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMINMA', nompro +#endif + call cminma ( indnoe, indare, indtri, indqua, + > indtet, indhex, indpyr, indpen, + > lgopti, imem(adopti), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cminma' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c +c==== +c 4. deraffinement, sauf pour un macro-maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. deraffinement ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+31).ne.0 .and. nbiter.ne.0 ) then +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 4.1. ==> on deraffine, puis on ajuste les tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMDERA', nompro +#endif + call cmdera ( nohman, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +cgn nompra = 'cmdera' +cgn iaux = 2 +cgn call utveri ( action, nohman, nompra, iaux, +cgn > ulsort, langue, codret ) + endif +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMALDE', nompro +#endif + call cmalde ( nohman, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, indtet, indhex, indpen, + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmalde' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + call gtfims (nrssse) +c + else +c +c 4.2. ==> sans deraffinement, les indices sont initialises a la valeur +c courante +c + indnoe = nbnoto + indnp2 = nbnop2 + indnim = nbnoim + indare = nbarto + indtri = nbtrto + indqua = nbquto + indtet = nbteto + indhex = nbheto + indpyr = nbpyto + indpen = nbpeto +c + endif +c + endif +c +c==== +c 5. compactage des tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. compactage tableaux ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOMP', nompro +#endif +c + call utcomp (ulsort, langue, codret) +c + call gtfims (nrssse) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'utcomp' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c +c==== +c 6. raffinement standard du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. raffinement ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+30).ne.0 ) then +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 6.1. ==> allocation memoire pour le decoupage standard +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMALRA', nompro +#endif + call cmalra ( nohman, + > indnoe, indnp2, indnim, indare, indtri, indqua, + > indtet, indhex, indpen, + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmalra' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c +c 6.2. ==> raffinement proprement dit +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMRAFF', nompro +#endif + call cmraff ( nohman, + > indnoe, indare, indtri, indqua, + > indtet, indhex, indpen, + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + call gtfims (nrssse) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmraff' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c + endif +c +c==== +c 7. mise en conformite +c On evite evidemment le cas du raffinement non conforme ... +c Dans les autres cas : +c . A l'iteration 0 : seulement en cas de raffinement libre, quel +c que soit le type de deraffinement car il a ete +c inhibe +c . Aux iterations suivantes : toujours +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. mise en conformite ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( ( imem(adopti+29).eq.0 ) .or. + > ( imem(adopti+29).eq.-1 ) ) then +c + if ( ( nbiter.eq.0 .and. imem(adopti+30).ne.0 ) .or. + > nbiter.gt.0 ) then +c + nrssse = imem(adetco+3) + call gtdems (nrssse) +c +c 7.1. ==> nombre de mises en conformite +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNBCO', nompro +#endif + call cmnbco ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 7.2. ==> bilan +c + if ( codret.eq.0 ) then +c + nbprov = provp2 + provim + + > provar + + > provtr + provqu + + > provte + provpy + provpe + provhe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbprov +#endif + endif +c +c 7.3. ==> initialisation memoire pour la mise en conformite +c + if ( nbprov.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMALCO', nompro +#endif + call cmalco ( nohman, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmalco' + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c +c 7.4. ==> mise en conformite proprement dite +c + if ( nbprov.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMCONF', nompro +#endif + call cmconf ( nohman, + > indnoe, indare, indtri, indqua, + > indtet, indpyr, indhex, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmconf' + write (ulsort,texte(langue,3)) 'UTVERI'//nompra, nompro + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c + call gtfims (nrssse) +c + endif +c + endif +c + endif +c +c==== +c 8. creation des noeuds suplementaires : +c . noeuds p2 sur les nouvelles aretes +c . noeuds internes aux mailles +c Remarque : +c . A l'iteration 0 : seulement en cas de raffinement, quel que soit +c le type de deraffinement car il a ete inhibe +c . Aux iterations suivantes : toujours +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. creation des noeuds supp ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( codret.eq.0 ) then +c + if ( degre.eq.2 ) then +c + if ( ( nbiter.eq.0 .and. imem(adopti+30).ne.0 ) .or. + > nbiter.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNOSU', nompro +#endif + call cmnosu ( nohman, + > indnoe, lgetco, imem(adetco), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmnosu' + write (ulsort,texte(langue,3)) 'UTVERI'//nompra, nompro + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 9. mise a jour +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. mise a jour ; codret', codret +#endif +c +c 9.1. ==> communs, voisinages ... +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMMISA', nompro +#endif + call cmmisa ( nohman, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + nompra = 'cmmisa' + write (ulsort,texte(langue,3)) 'UTVERI'//nompra, nompro + iaux = 2 + call utveri ( action, nohman, nompra, iaux, + > ulsort, langue, codret ) + endif +#endif +c + endif +c + endif +c +c 9.2. ==> le numero d'iteration du maillage +c + if ( codret.eq.0 ) then +c + nbiter = nbiter + 1 +c + endif +c +c 9.3. ==> la date +c + if ( codret.eq.0 ) then +c + call utdhlg ( ladate, langue ) +c + endif +c +c==== +c 10. transfert dans la structure de l'iteration n+1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. transfert ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMTRNP', nompro +#endif + iaux = 1 + call cmtrnp ( nohman, nohmap, iaux, + > lgopti, imem(adopti), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c==== +c 11. Verifications du maillage final +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. verif maillage final ; codret', codret +#endif +c +c 11.1. ==> controle de la conformite +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOMA', nompro +#endif + call utcoma ( nohmap, + > iaux, + > ulsort, langue, codret ) +c + endif +c +c 11.2. ==> Verifications +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,3)) 'UTVERI'//nompro, nompro + iaux = 2 + call utveri ( action, nohman, nompro, iaux, + > ulsort, langue, codret ) + endif +#endif +c +c==== +c 12. la fin +c==== +c +c 12.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 12.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hodeci.F b/src/tool/HOMARD_00/hodeci.F new file mode 100644 index 00000000..97764bd5 --- /dev/null +++ b/src/tool/HOMARD_00/hodeci.F @@ -0,0 +1,919 @@ + subroutine hodeci ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOmard : traitement des DECIsions +c -- ---- +c ______________________________________________________________________ +c dans le cas ou on ne fait rien, il faut neanmoins basculer les etats +c sinon les interpolations se passent mal +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c . . . . 7 : non convergence de l'algorithme . +c ______________________________________________________________________ +c +c Rappel des codes de pilotage du raffinement et deraffinement : +c 30 : type de conformite +c 0 : conforme +c 1 : non-conforme avec 1 arete decoupee unique par maille +c 2 : non-conforme avec 1 noeud pendant unique par arete +c 3 : non-conforme fidele a l'indicateur +c -1 : conforme, avec des boites pour les quad, hexa et pent +c 31 : raffinement +c -1 : raffinement uniforme +c 0 : pas de raffinement +c 1 : raffinement libre +c 2 : raffinement libre homogene en type de maille +c 32 : deraffinement +c -1 : deraffinement uniforme +c 0 : pas de deraffinement +c 1 : deraffinement libre +c 49 : types de mailles acceptes +c 0 : tous +c 1 : uniquement ceux compatibles avec le mode d'utilisation +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HODECI' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "cndoad.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envada.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adoptr, lgoptr + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux + integer nbpass, nbpama + integer codre0 +c + integer indnoe, indare, indtri, indqua + integer indtet, indhex, indpyr, indpen + integer indnp2, indnim + integer nupaci, nbpacm, nbsoci, nbmaci + integer nbsoav(6) +c + double precision seuinf, seusup +c + character*6 saux + character*8 typobs, nohman, nohind +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +#include "impr01.h" +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c + texte(1,4) = + > '(//,a6,'' T R A I T E M E N T D E S D E C I S I O N S'')' + texte(1,5) = '(56(''=''),/)' + texte(1,6) = '(''Non convergence de l''''algorithme.'')' + texte(1,7) = '(''Contacter l''''assistance'')' + texte(1,8) = '(/,''RECHERCHE D''''UNE CIBLE - PASSAGE '', i2)' + texte(1,9) = '(34(''*''))' + texte(1,10) = + > '(/,''FIN DE LA RECHERCHE D''''UNE CIBLE'',/,31(''*''))' + texte(1,11) = '(''Le maximum d''''iterations est atteint.'')' +c + texte(2,4) = + > '(//,a6,'' T R E A T M E N T O F D E C I S I O N S'')' + texte(2,5) = '(52(''=''),/)' + texte(2,6) = '(''Algorithm failed.'')' + texte(2,7) = '(''Contact hot-line'')' + texte(2,8) = '(/,''RESEARCH OF A TARGET - ROUND # '', i2)' + texte(2,9) = '(33(''*''))' + texte(2,10) = '(/,''END OF THE RESEARCH OF A TARGET'')' + texte(2,11) = '(''The maximum of iterations is reached.'')' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.8. ==> les options reelles +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. les structures de base +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. les structures de base ; codret', codret +#endif +c +c 2.1. ==> le maillage homard +c + if ( codret.eq.0 ) then +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nohman, iaux, ulsort, langue, codret ) +c + endif +c +c 2.2. ==> les options pour la cible +c + if ( codret.eq.0 ) then +c + nbpacm = imem(adopti+42) + nbsoci = imem(adopti+43) + nbmaci = imem(adopti+44) + nupaci = 1 +c + do 22 , iaux = 1 , 6 + nbsoav(iaux) = -1 + 22 continue + seuinf = vinfne + seusup = vinfpo +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpacm', nbpacm + write (ulsort,90002) 'nbsoci', nbsoci + write (ulsort,90002) 'nbmaci', nbmaci +#endif +c + endif +c + 2999 continue +c +c==== +c 3. preparatifs a chaque passe +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. preparatifs ; codret', codret +#endif +c + imem(adetco+3) = nrssse +c +c 3.1. ==> Affichage pour la recherche eventuelle de la cible +c + if ( nbsoci.gt.0 .or. nbmaci.gt.0 ) then +c + if ( nupaci.le.nbpacm ) then + write (ulsort,texte(langue,8)) nupaci + write (ulsort,texte(langue,9)) + endif +c + endif +c +c 3.2. ==> menage de la memoire +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMENH', nompro +#endif +c + iaux = -1 + call utmemh ( nohman, iaux, + > ulsort, langue, codret) +c + endif +c +c 3.3. ==> l'indicateur d'erreur +c uniquement quand le raffinement ou le deraffinement n'est ni +c uniforme, ni inactif +c il est donne par l'utilisateur ou il est construit +c en tant qu'objet temporaire +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. indicateur ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+30).gt.0 .or. imem(adopti+31).gt.0 ) then +c + typobs = mchind + iaux = 0 + call utosno ( typobs, nohind, iaux, ulsort, langue, codret ) +c + if ( codret.eq.2 ) then + nohind = smem(adopts+7) + codret = 0 + endif +c + endif +c + endif +c +c==== +c 4. calcul des sauts entre mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. sauts entre mailles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( ( imem(adopti+30).gt.0 .or. imem(adopti+31).gt.0 ) .and. + > imem(adopti+26).eq.1 .and. imem(adopti+17).eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEISAU', nompro +#endif + call deisau ( nohman, nohind, + > lgopti, imem(adopti), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. usage des composantes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. usage des composantes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( nupaci.le.1 ) then +c + if ( ( imem(adopti+30).gt.0 .or. imem(adopti+31).gt.0 ) .and. + > imem(adopti+26).eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEIUCM', nompro +#endif + call deiucm ( nohind, + > lgopti, imem(adopti), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. suppression des entites de mise en conformite, s'il y en a +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. suppression conformite ; codret', codret +#endif +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( nbtrto.ne.nbtrpe .or. nbquto.ne.nbqupe ) then +c + if ( codret.eq.0 ) then +c + if ( nupaci.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECFSU', nompro +#endif + call decfsu ( nohman, nohind, + > lgopti, imem(adopti), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c +c==== +c 7. mise a jour des historiques des entites +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. maj des historiques ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( nupaci.le.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHIST', nompro +#endif + call dehist ( nohman, + > lgopti, imem(adopti), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. initialisation des decisions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. init. des decisions ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEINIT', nompro +#endif + call deinit ( nohman, nohind, + > lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. prise en compte des homologues +c le filtrage sur la presence des homologues se fait a l'interieur +c du programme dehomo +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. homologues ; codret', codret +#endif +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOMO', nompro +#endif + call dehomo ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. traitement de la conformite +c Si le raffinement est conforme a l'indicateur, on ne fera rien +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. traitement conformite ; codret', codret +#endif +c + if ( imem(adopti+29).ne.3 ) then +c + if ( imem(adopti+30).ne.0 .or. imem(adopti+31).ne.0 ) then +c +c 10.0. ==> On va effectuer eventuellement plusieurs fois +c le traitement pour capter tous les phenomenes mais on se met +c quand meme une securite pour ne pas tourner indefiniment ... +c On part avec un maximum de 10 passages mais dans le cas des +c pentaedres, ce nombre peut etre trop petit. +c + if ( imem(adopti+29).eq.0 .and. nbpeto.ne.0 ) then + nbpama = 50 + else + nbpama = 10 + endif +c + nbpass = 0 +c + 100 continue +c + nbpass = nbpass + 1 +c +c 10.1. ==> decisions de raffinement, quand il est libre ou uniforme +c partiel ; +c + if ( codret.eq.0 ) then +c + if ( nbpass.eq.1 ) then + imem(adetco+3) = imem(adetco+3) + 1 + endif +c + if ( imem(adopti+30).gt.0 .or. + > ( ( imem(adopti+18).gt.0 .or. rmem(adoptr+2).ge.0.d0 ) .and. + > imem(adopti+30).eq.-1 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '10.1. ==> decisions de raffinement' + write (ulsort,90002) ' avec nbpass', nbpass +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DERAFF', nompro +#endif + call deraff ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 10.2. ==> decisions de deraffinement ; +c remarque : c'est inutile sur un macro-maillage. +c + if ( codret.eq.0 ) then +c + if ( nbpass.eq.1 ) then + imem(adetco+3) = imem(adetco+3) + 1 + endif +c + if ( nbiter.ne.0 ) then +c + if ( imem(adopti+31).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '10.2. ==> decisions de deraffinement' +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEDERA', nompro +#endif + call dedera ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 10.3. ==> dans certains cas, il faut verifier que les changements de +c decision effectues en deraffinement ou en propagation de +c niveau n'ont pas modifie l'etat obtenu apres l'etape de +c conformite du raffinement. si c'est le cas, on refait +c une passe. +c cas 1 : en mode conforme, deraffinement et raffinement libre, +c a partir de l'iteration 1 +c cas 2 : en mode non conforme, raffinement non-conforme avec +c 1 arete decoupee unique par maille +c cas 3 : en mode conforme libre en presence de pentaedres +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '10.3. ==> bilan' + write (ulsort,90002) 'tyconf', imem(adopti+29) + write (ulsort,90002) 'pilraf', imem(adopti+30) + write (ulsort,90002) 'pilder', imem(adopti+31) + write (ulsort,90002) 'nbiter', nbiter + write (ulsort,90002) 'nbpeto', nbpeto +#endif +c + if ( codret.eq.0 ) then +c + if ( ( imem(adopti+29).le.0 .and. + > nbiter.ne.0 .and. + > ( imem(adopti+30).eq.1 .or. imem(adopti+30).eq.2 ) .and. + > imem(adopti+31).gt.0 ) .or. + > ( imem(adopti+29).eq.1 ) .or. + > ( imem(adopti+29).eq.0 .and. nbpeto.gt.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEBILA', nompro +#endif + call debila ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + if ( codret.eq.1 ) then + if ( nbpass.ge.nbpama ) then + codret = 10 + else + codret = 0 + goto 100 + endif + endif +c + endif +c + endif +c +c 10.4. ==> si on a introduit des contraintes sur le raffinement, il +c faut verifier que les decisions ne conduisent pas a une +c telle situation. si c'est le cas, on refait une passe. +c on se met quand meme une securite pour ne pas tourner +c indefiniment ... +c attention a bien repercuter les modifications sur les +c homologues s'il y en a +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'cont raff', imem(adopti+35) +#endif +c + if ( imem(adopti+35).gt.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '10.4. ==> contraintes sur le raffinement' +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECORA', nompro +#endif + call decora ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > iaux, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + if ( nbpass.ge.nbpama ) then + codret = 104 + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEHOMO', nompro +#endif + call dehomo ( nohman, + > lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) + goto 100 + endif + elseif ( iaux.eq.0 ) then + codret = 0 + else + codret = 104 + endif +c + endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 11. on controle que les aretes des mailles a ignorer +c n'ont pas ete touchees... +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. mailles ignorees ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+48).eq.1 .and. imem(adopti+30).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DEELIG', nompro +#endif + call deelig ( nohman, + > lgopts, smem(adopts), + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,3)) 'DELIST fin de', nompro + iaux = 2 + call delist ( nohman, nompro, iaux, + > lgopts, smem(adopts), + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 12. Cible eventuelle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. Cible ; codret', codret + write (ulsort,90002) 'nupaci', nupaci + write (ulsort,90002) 'nbsoci', nbsoci + write (ulsort,90002) 'nbmaci', nbmaci +#endif +c + if ( nbsoci.gt.0 .or. nbmaci.gt.0 ) then +c +c 12.1. ==> les indices sont initialises a la valeur courante +c + if ( codret.eq.0 ) then +c + indnoe = nbnoto + indnp2 = nbnop2 + indnim = nbnoim + indare = nbarto + indtri = nbtrto + indqua = nbquto + indtet = nbteto + indhex = nbheto + indpyr = nbpyto + indpen = nbpeto +c + endif +c +c 12.2. ==> Evaluation de la cible +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nupaci', nupaci +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpacm.lt.0 .or. ( nupaci.le.nbpacm ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DECINE', nompro +#endif + call decine ( nupaci, nbsoci, nbsoav, + > rmem(adoptr), seuinf, seusup, + > nohman, + > indnoe, indnp2, indnim, indare, indtri, indqua, + > indtet, indhex, indpen, + > lgopts, smem(adopts), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + else +c + nupaci = -1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( nupaci.gt.nbpacm ) then + write (ulsort,texte(langue,11)) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nupaci', nupaci +#endif +c + endif +c +c 12.3. ==> On recommence eventuellement +c + if ( codret.eq.0 ) then +c + if ( nupaci.ge.0 ) then + goto 2999 + endif +c + write (ulsort,texte(langue,10)) +c + endif +c + endif +c +c==== +c 13. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '13. Menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+36).eq.0 ) then +c + if ( ( ( imem(adopti+30).gt.0 .or. imem(adopti+31).gt.0 ) .and. + > imem(adopti+9).gt.0 ) .or. + > ( imem(adopti+30).gt.0 .and. imem(adopti+9).eq.0 ) ) then +c + call gmobal ( nohind , codre0 ) + if ( codre0.eq.1 ) then + call gmsgoj ( nohind , codret ) + endif +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( imem(adopti+18).ne.0 ) then + call gmsgoj ( smem(adopts+28), codret ) + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( rmem(adoptr+2).gt.0 ) then + call gmsgoj ( smem(adopts+27), codret ) + endif +c + endif +c + endif +c +c==== +c 14. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '14. fin de '//nompro//' ; codret', codret +#endif +c +c 14.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.8 ) then + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,7)) + endif +c + endif +c +c 14.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoinco.F b/src/tool/HOMARD_00/hoinco.F new file mode 100644 index 00000000..f393e132 --- /dev/null +++ b/src/tool/HOMARD_00/hoinco.F @@ -0,0 +1,234 @@ + subroutine hoinco ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c HOMARD : INformations COmplementaires +c -- -- -- +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 3 : probleme a la lecture . +c . . . . 5 : mauvais type de code de calcul associe . +c . . . . 6 : impossible de connaitre le code associe. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOINCO' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) +c + if ( codret.eq.0 ) then + if ( imem(adopti+11).ne.1 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + endif + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c======================================================================= + if ( imem(adopti+11).ne.1 ) then +c======================================================================= +c +c 1.5. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.6. ==> les messages +c + texte(1,4) = '(/,a6,'' INFORMATIONS COMPLEMENTAIRES'')' + texte(1,5) = '(35(''=''),/)' +c + texte(2,4) = '(/,a6,'' ADDITIONAL INFORMATION'')' + texte(2,5) = '(29(''=''),/)' +c +c 1.7. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +#include "impr03.h" +c +c==== +c 2. programme veritable +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. programme veritable ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFCOM', nompro +#endif + call infcom ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c +c 3.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 3.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +c======================================================================= + endif +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoinit.F b/src/tool/HOMARD_00/hoinit.F new file mode 100644 index 00000000..82b89fbc --- /dev/null +++ b/src/tool/HOMARD_00/hoinit.F @@ -0,0 +1,187 @@ + subroutine hoinit ( nfconf, lfconf, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : INITialisation +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOINIT' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf, langue, codret +c +c 0.4. ==> variables locales +c + integer ulsort + integer iaux + integer nblims +c + integer nbrmes + parameter ( nbrmes = 10 ) + character*40 messag(nblang,nbrmes) +c +#include "mesutp.h" +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c + ulsort = 6 + if ( langue.le.0 .or. langue.gt.nblang ) then + langue = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de UTMESS par ', nompro +#endif + call utmess ( messag, nbmess, nblims, + > ulsort, langue, codret ) +c +c 1.2. ==> les utilitaires +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de UTINIT par ', nompro +#endif + call utinit ( nfconf, lfconf, messag, nblims, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + endif +c +c==== +c 2. mesures de temps de calcul +c==== +c + if ( codret.eq.0 ) then +c + do 20 , iaux = 1 , nbsect + numsec (iaux) = 0 + 20 continue +c +#include "hotits.h" +c + endif +c +c==== +c 3. pretraitements +c==== +c +c 3.1. ==> les options du traitement +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINDH', nompro +#endif + call utindh ( iaux, ulsort, langue, codret ) +c + endif +c +c 3.2. ==> les communs constants +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINCG', nompro +#endif + call utincg +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINCI', nompro +#endif + call utinci ( ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTINCA', nompro +#endif + call utinca +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/HOMARD_00/holect.F b/src/tool/HOMARD_00/holect.F new file mode 100644 index 00000000..64048420 --- /dev/null +++ b/src/tool/HOMARD_00/holect.F @@ -0,0 +1,339 @@ + subroutine holect ( modhom, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : LECTures +c -- ---- +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . s . 1 . mode de fonctionnement de homard . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptatio. +c . . . . 4 : interpolation de la solution . +c . . . . 5 : mise a jour des coordonnees . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOLECT' ) +c +#include "motcle.h" +#include "nblang.h" +c +#include "mesutp.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer modhom + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adoptr, lgoptr + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'' L E C T U R E D E S D O N N E E S'')' + texte(1,5) = '(44(''=''),/)' +c + texte(2,4) = '(//,a6,'' D A T A R E A D I N G S'')' + texte(2,5) = '(32(''=''),/)' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.8. ==> les options reelles +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +#include "impr03.h" +c +c==== +c 2. lectures des options et verification +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. options, verification ; codret', codret +#endif +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c +c 2.1. ==> lecture des options +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOLOPT', nompro +#endif + call holopt ( lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> verification +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOLVER', nompro +#endif + call holver ( lgopti, imem(adopti), lgoptr, rmem(adoptr), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + modhom = imem(adopti+3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'modhom', modhom +#endif + endif +c + if ( modhom.eq.2 ) then +#include "hotit2.h" + endif + if ( modhom.eq.3 ) then +#include "hotit3.h" + endif +c + call gtfims (nrssse) +c +c==== +c 3. lecture du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. lecture maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVLM', nompro +#endif +c + call hoavlm ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. lecture de la frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. lecture frontiere ; codret', codret +#endif +c + if ( modhom.ne.5 ) then +c + if ( imem(adopti+9).eq.0 ) then + imem(adopti+28) = -abs(imem(adopti+28)) + endif +c + if ( mod(imem(adopti+28),2).eq.0 .and. imem(adopti+28).lt.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFLGEO', nompro +#endif +c + call sflgeo ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +c 5.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 5.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end +c . . . . 4 : interpolation de la solution . diff --git a/src/tool/HOMARD_00/holopt.F b/src/tool/HOMARD_00/holopt.F new file mode 100644 index 00000000..bf2ab482 --- /dev/null +++ b/src/tool/HOMARD_00/holopt.F @@ -0,0 +1,931 @@ + subroutine holopt ( lgopti, taopti, lgoptr, taoptr, + > lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : Lecture des OPTions +c -- - --- +c Remarque : les options ont deja ete lues ; elles sont decodees ici +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . es . lgopti . tableau des options . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . es . lgoptr . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . es . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOLOPT' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbmomx + parameter ( nbmomx = 11 ) +c + integer codava + integer nretap, nrsset +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer codre0, nbmot + integer adopti(nbmomx), imopti(nbmomx) + integer iaux, jaux, kaux, laux +c + double precision daux +c + character*6 saux + character*8 saux08 + character*8 motcle(nbmomx) +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "melopt.h" +#include "impr03.h" +c +c 1.3. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.4. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. valeurs par defaut +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Defaut', codret +#endif +c + if ( codret.eq.0 ) then +c +c 2.1. ==> les options generales +c +c 3 : type de bilan sur le maillage +c 5 : ecriture des fichiers au format HOMARD +c on met un faux defaut, qui sera modifie dans holver s'il n'y a +c pas eu surcharge. +c 6 : type de donnees sur les seuils hauts +c 7 : type de donnees sur les seuils bas +c 9 : messages d'information +c + taopti(3) = 7 + taopti(5) = -1 + taopti(6) = 0 + taopti(7) = 0 + taopti(9) = 1 +c +c 2.2. ==> le mode d'utilisation de HOMARD +c + taopti(4) = 1 + taopts(30) = 'homa ' +c 12345678 +c +c 2.3. ==> le pilotage de l'adaptation +c + taopti(31) = 1 + taopti(32) = 1 + taopti(33) = -1 + taopti(34) = -1 + taopti(35) = 0 + taopti(36) = 1 + taopti(38) = 0 + taopti(43) = 50 + taopti(44) = -1 + taopti(45) = -1 + taopti(49) = 0 +c +c 2.4. ==> les seuils +c + taoptr(1) = vinfpo + taoptr(2) = -vinfpo + taoptr(3) = -vinfpo +c +c 2.5. ==> la modification du maillage +c + taopti(41) = 0 +c +c 2.6. ==> les maillages extrudes +c coordonnees initiales +c + taopti(39) = 0 + taopti(40) = 1 + taoptr(4) = -1789.d0 +c +c 2.7. ==> numero de pas de temps, numero d'ordre ou valeur de l'instant +c de l'indicateur d'erreur du code de calcul associe : +c aucun par defaut +c + taopti(15) = -2 + taopti(16) = -2 + taopti(17) = -2 +c +c 2.8. ==> mise a jour de tous les champs : non par defaut +c + taopti(20) = 0 +c +c 2.9. ==> la creation des joints +c + taopti(42) = 0 +c +c 2.10. ==> le numero d'iteration +c le type du code de calcul associe +c + taopti(10) = -1 + taopti(11) = -1 +c +c 2.11. ==> le suivi de frontiere +c + taopti(29) = 1 +c + endif +c +c==== +c 3. decodage des options en oui/non +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Decodage oui/non', codret +#endif +c + if ( codret.eq.0 ) then +c + nbmot = 3 +c + motcle(1) = mcchto + motcle(2) = mcmdeg + motcle(3) = mcjoin +c + adopti(1) = 20 + adopti(2) = 41 + adopti(3) = 42 +c + do 31 , iaux = 1 , nbmot +c + jaux = taopti(adopti(iaux)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO00', nompro +#endif + call utlo00 ( motcle(iaux), jaux, ulsort, langue, codre0 ) +c + if ( codre0.eq.0 ) then + taopti(adopti(iaux)) = jaux + else + codret = 6 + endif +cgn write (ulsort,90002) motcle(iaux), jaux +c + 31 continue +c + endif +c +c==== +c 4. decodage des options numeriques entieres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Decodage entiers', codret +#endif +c + if ( codret.eq.0 ) then +c + nbmot = 11 +c + motcle( 1) = mctybi + motcle( 2) = mcinfo + motcle( 3) = mcnvma + motcle( 4) = mcnvmi + motcle( 5) = mcnbme + motcle( 6) = mcmoho + motcle( 7) = mcnuit + motcle( 8) = mcsufr + motcle( 9) = mcinad + motcle(10) = mcpacm + motcle(11) = mcnbsc +c + adopti( 1) = 3 + adopti( 2) = 9 + adopti( 3) = 33 + adopti( 4) = 34 + adopti( 5) = 35 + adopti( 6) = 4 + adopti( 7) = 10 + adopti( 8) = 29 + adopti( 9) = 38 + adopti(10) = 43 + adopti(11) = 44 +c + imopti( 1) = 1 + imopti( 2) = 1 + imopti( 3) = 1 + imopti( 4) = 1 + imopti( 5) = 1 + imopti( 6) = 1 + imopti( 7) = 1 + imopti( 8) = 1 + imopti( 9) = 1 + imopti(10) = 1 + imopti(11) = 1 +c + do 41 , iaux = 1 , nbmot +c + jaux = taopti(adopti(iaux)) + kaux = imopti(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCEN', nompro +#endif + call utmcen ( motcle(iaux), jaux, kaux, + > ulsort, langue, codre0 ) +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) jaux +#endif + taopti(adopti(iaux)) = jaux +cgn if ( iaux.eq.4 .or. iaux.eq.5 ) then +cgn taopti(adopti(iaux)+2) = 1 +cgn endif +c + elseif ( codre0.eq.4 ) then + codre0 = 0 +c + else + write (ulsort,texte(langue,6)) motcle(iaux) + jaux = 7+(codre0-2)/3 + write (ulsort,texte(langue,jaux)) + codret = 6 +c + endif +c + 41 continue +c + endif +c +c==== +c 5. decodage des options numeriques reelles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Decodage reels', codret +#endif +c + if ( codret.eq.0 ) then +c + nbmot = 10 +c + motcle(1) = mcseuh + motcle(2) = mcseub + motcle(3) = mcserh + motcle(4) = mcserb + motcle(5) = mcseph + motcle(6) = mcsepb + motcle(7) = mcsesh + motcle(8) = mcsesb + motcle(9) = mcdimi + motcle(10) = mccex2 +c + adopti(1) = 1 + adopti(2) = 2 + adopti(3) = 1 + adopti(4) = 2 + adopti(5) = 1 + adopti(6) = 2 + adopti(7) = 1 + adopti(8) = 2 + adopti(9) = 3 + adopti(10) = 4 +c + do 51 , iaux = 1 , nbmot +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCRE', nompro +#endif + call utmcre ( motcle(iaux), daux, + > ulsort, langue, codre0 ) +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) daux +#endif + taoptr(adopti(iaux)) = daux +c + if ( iaux.eq.1 ) then + if ( taopti(6).eq.0 ) then + taopti(6) = 1 + else + taopti(6) = -1 + endif + elseif ( iaux.eq.2 ) then + if ( taopti(7).eq.0 ) then + taopti(7) = 1 + else + taopti(7) = -1 + endif + elseif ( iaux.eq.3 ) then + if ( taopti(6).eq.0 ) then + taopti(6) = 2 + else + taopti(6) = -1 + endif + elseif ( iaux.eq.4 ) then + if ( taopti(7).eq.0 ) then + taopti(7) = 2 + else + taopti(7) = -1 + endif + elseif ( iaux.eq.5 ) then + if ( taopti(6).eq.0 ) then + taopti(6) = 3 + else + taopti(6) = -1 + endif + elseif ( iaux.eq.6 ) then + if ( taopti(7).eq.0 ) then + taopti(7) = 3 + else + taopti(7) = -1 + endif + elseif ( iaux.eq.7 ) then + if ( taopti(6).eq.0 ) then + taopti(6) = 4 + else + taopti(6) = -1 + endif + elseif ( iaux.eq.8 ) then + if ( taopti(7).eq.0 ) then + taopti(7) = 4 + else + taopti(7) = -1 + endif + endif +c + elseif ( codre0.eq.4 ) then + codre0 = 0 +c + else + write (ulsort,texte(langue,6)) motcle(iaux) + jaux = 7+(codre0-2)/3 + write (ulsort,texte(langue,jaux)) + codret = 6 +c + endif +c + 51 continue +c + endif +c +c==== +c 6. decodage des options caracteres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Decodage caracteres', codret +#endif +c + if ( codret.eq.0 ) then +c + nbmot = 1 +c + motcle(1) = mcacti +c + adopti(1) = 30 +c + do 61 , iaux = 1 , nbmot +c + saux08 = taopts(adopti(iaux)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCCH', nompro +#endif + call utmcch ( motcle(iaux), jaux, saux08, + > ulsort, langue, codre0 ) +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) saux08 +#endif + taopts(adopti(iaux)) = saux08 +c + elseif ( codre0.eq.4 ) then + codre0 = 0 +c + else + write (ulsort,texte(langue,6)) motcle(iaux) + jaux = 7+(codre0-2)/3 + write (ulsort,texte(langue,jaux)) + codret = 6 +c + endif +c + 61 continue +c + endif +c +c==== +c 7. options textuelles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Decodage texte - codret', codret +#endif +c +c 7.1. ==> Caracteristiques du maillage +c + if ( codret.eq.0 ) then +c +c 7.1.1. ==> type de conformite +c + motcle(1) = mctyco +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO02', nompro +#endif + call utlo02 ( motcle(1), taopti(30), ulsort, langue, codre1 ) +c +c 7.1.2. ==> type de code de calcul associe +c + motcle(1) = mcccas +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO01', nompro +#endif + call utlo01 ( motcle(1), taopti(11), ulsort, langue, codre2 ) +c +c 7.1.3. ==> Le maillage extrude +c + motcle(1) = mcmext +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO11', nompro +#endif + call utlo11 ( motcle(1), taopti(39), taopti(11), + > ulsort, langue, codre3 ) +c +c 7.1.4. ==> choix des coordonnees pour les maillages extrudes +c + motcle(1) = mccex1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO05', nompro +#endif + call utlo05 ( motcle(1), taopti(40), taopti(4), taopti(39), + > ulsort, langue, codre4 ) +c +c 7.1.5. ==> bilan +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 7.2. ==> Pilotage du raffinement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7.2. Pilotage raffinement - codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 7.2.1. ==> type de raffinement +c + motcle(1) = mctyra +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO03', nompro +#endif + call utlo03 ( motcle(1), taopti(31), ulsort, langue, codre1 ) +c +c 7.2.2. ==> type de deraffinement +c + motcle(1) = mctyde +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO03', nompro +#endif + call utlo03 ( motcle(1), taopti(32), ulsort, langue, codre2 ) +c +c 7.2.3. ==> contraintes de raffinement +c + motcle(1) = mccora +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO04', nompro +#endif + call utlo04 ( motcle(1), taopti(36), taopti(30), + > ulsort, langue, codre3 ) +c +c 7.2.4. ==> usage des composantes de l'indicateur +c + motcle(1) = mcmfi1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO06', nompro +#endif + call utlo06 ( motcle(1), taopti(8), ulsort, langue, codre4 ) +c +c 7.2.5. ==> mode de fonctionnement de l'indicateur d'erreur +c + motcle(1) = mcmfi2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO07', nompro +#endif + call utlo07 ( motcle(1), taopti(18), ulsort, langue, codre5 ) +c +c 7.2.6. ==> parametres temporels pour l'indicateur d'erreur +c + codre6 = 0 +c + nbmot = 3 +c + motcle(1) = mcntin + motcle(2) = mcnoin + motcle(3) = mcinin +c + do 726 , iaux = 1 , nbmot +c + if ( codre6.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO08', nompro +#endif + jaux = iaux + call utlo08 ( motcle(jaux), jaux, kaux, daux, laux, + > ulsort, langue, codre6 ) +c + endif +c + if ( codre6.eq.0 .and. laux.ne.0 ) then +c + if ( iaux.eq.1 ) then + taopti(13) = kaux + taopti(15) = laux + elseif ( iaux.eq.2 ) then + taopti(14) = kaux + taopti(16) = laux + else + taoptr(10) = daux + taopti(17) = laux + endif +c + endif +c + 726 continue +c +c 7.2.5. ==> bilan +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c +c 7.3. ==> ecriture des fichiers HOMARD +c + if ( codret.eq.0 ) then +c + motcle(1) = mcecfh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO09', nompro +#endif + call utlo09 ( motcle(1), taopti(5), ulsort, langue, codret ) +c + endif +c +c 7.4. ==> champs complementaires +c + if ( codret.eq.0 ) then +c + taopti(12) = 1 + nbmot = 5 +c + motcle(1) = mcicni + motcle(2) = mcicqu + motcle(3) = mcicdi + motcle(4) = mcicpa + motcle(5) = mcicvr +c + do 74 , iaux = 1 , nbmot +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) motcle(iaux) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLO10', nompro +#endif + call utlo10 ( motcle(iaux), laux, ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'codre2, laux', codre2, laux +#endif +c + if ( codre2.eq.0 .and. laux.ne.0 ) then +c + if ( iaux.eq.1 ) then + taopti(12) = taopti(12)*2 + elseif ( iaux.eq.2 ) then + taopti(12) = taopti(12)*3 + elseif ( iaux.eq.3 ) then + taopti(12) = taopti(12)*5 + elseif ( iaux.eq.4 ) then + taopti(12) = taopti(12)*7 + elseif ( iaux.eq.5 ) then + taopti(12) = taopti(12)*11 + endif +c + endif +c + 74 continue +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(12)', taopti(12) +#endif +c +c==== +c 8. options sous forme de liste +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Decodage liste', codret +#endif +c +c 8.1. ==> les groupes filtrant l'adaptation +c + if ( codret.eq.0 ) then +c + motcle(1) = mcgrad + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCLS', nompro +#endif + call utmcls ( motcle(1), iaux, taopts(15), taopti(19), + > ulsort, langue, codre0 ) +c + endif +c +c 8.2. ==> les zones geometriques a raffiner +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCZR', nompro +#endif + call utmczr ( taopts(19), taopti(37), + > ulsort, langue, codret ) +c + endif +c +c 8.3. ==> les champs a mettre a jour +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCLC', nompro +#endif + call utmclc ( taopti(20), taopti(28), taopts(18), + > ulsort, langue, codret ) +c + endif +c +c 8.4. ==> la frontiere +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(29) - suifro', taopti(29) +#endif +c +c 8.4.1. ==> les groupes formant la frontiere discrete +c + if ( mod(taopti(29),2).eq.0 ) then +c + if ( codret.eq.0 ) then +c + motcle(1) = mcgrfd + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCLS', nompro +#endif + call utmcls ( motcle(1), iaux, taopts(17), jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 8.4.2. ==> les frontieres analytiques +c + if ( mod(taopti(29),3).eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCFA', nompro +#endif + call utmcfa ( taopts(25), taopts(26), taopts(23), taopts(24), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 8.4.3. ==> les groupes formant la frontiere CAO +c + if ( mod(taopti(29),5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + motcle(1) = mcgrfr + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCLS', nompro +#endif + call utmcls ( motcle(1), iaux, taopts(17), jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. transmission des consignes d'impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. impression', codret +#endif +c +c 9.1. ==> mesures de temps +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GTINFO', nompro +#endif + call gtinfo ( taopti(9) ) +c + endif +c +c 9.2. ==> bilan memoire +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'GMINFO', nompro +#endif + call gminfo ( taopti(9) ) +c + endif +c +c==== +c 10. type d'elements autorises +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. type elements autorises', codret +#endif +c + if ( codret.eq.0 ) then +c + motcle(1) = mctyel +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLOEA', nompro +#endif + call utloea ( motcle(1), taopti(49), ulsort, langue, codret ) +c + endif +c +c==== +c 11. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'taopti' + write (ulsort,91020) taopti + write (ulsort,*) 'taoptr' + write (ulsort,92010) taoptr + write (ulsort,*) 'taopts' + write (ulsort,93010) taopts +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/holver.F b/src/tool/HOMARD_00/holver.F new file mode 100644 index 00000000..6ccd5d5e --- /dev/null +++ b/src/tool/HOMARD_00/holver.F @@ -0,0 +1,470 @@ + subroutine holver ( lgopti, taopti, lgoptr, taoptr, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : Lectures VERifications +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgoptr . e . 1 . longueur du tableau des options reelles . +c . taoptr . e . lgoptr . tableau des options reelles . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : incoherence dans les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOLVER' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgoptr + double precision taoptr(lgoptr) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nbrepb + integer nretap, nrsset + integer iaux, jaux + integer modhom +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 200 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> tout va bien +c + codret = 0 +c + nbrepb = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' VERIFICATION DES OPTIONS'')' + texte(1,5) = '(31(''=''),/)' + texte(1,8) = '(/,''Mode de fonctionnement de HOMARD :'')' +c + texte(1,95) = '(7x,''Maillage avant adaptation :'')' + texte(1,96) = '(7x,''Maillage apres adaptation :'')' + texte(1,97) = '(7x,''Maillage apres modification :'')' + texte(1,98) = '(7x,''Indicateurs d''''erreurs :'')' + texte(1,99) = '(7x,''Solution :'')' +c + texte(2,4) = '(/,a6,'' CONTROL OF OPTIONS'')' + texte(2,5) = '(25(''=''),/)' + texte(2,8) = '(/,''HOMARD running mode:'')' +c + texte(2,95) = '(7x,''Mesh before adaptation:'')' + texte(2,96) = '(7x,''Mesh after adaptation:'')' + texte(2,97) = '(7x,''Mesh after modification:'')' + texte(2,98) = '(7x,''Error indicator:'')' + texte(2,99) = '(7x,''Solution:'')' +c +#include "impr03.h" +c +#include "mslver.h" +c +c 1.3. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.4. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. verification du mode d'utilisation de homard +c==== +c + if ( taopti(4).ge.1 .and. taopti(4).le.5 ) then + modhom = taopti(4) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'modhom', modhom +#endif + else + write(ulsort,texte(langue,8)) + write(ulsort,texte(langue,11)) taopti(4) + nbrepb = nbrepb + 1 + endif +c +c==== +c 3. verification de la validite des mots_cles de pilotage +c==== +c +c 3.1. ==> type de code de calcul associe +c +#include "mslve0.h" +#include "mslve1.h" +c +c 3.2. ==> pour le mode homard pur +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. homard pur ; nbrepb', nbrepb +#endif +c + if ( modhom.eq.1 ) then +c +c 3.2.1. ==> numero d'iteration initiale +c + write(ulsort,texte(langue,23)) + if ( taopti(10).eq.0 ) then + write(ulsort,texte(langue,20)) + elseif ( taopti(10).eq.1 ) then + write(ulsort,texte(langue,21)) + elseif ( taopti(10).gt.1 ) then + write(ulsort,texte(langue,22)) taopti(10) + else + write(ulsort,texte(langue,11)) taopti(10) + nbrepb = nbrepb + 1 + endif +c +c 3.2.2. ==> type de conformite +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.2. conformite ; nbrepb', nbrepb +#endif +c +#include "mslve2.h" +c +c 3.2.3. ==> maillage extrude +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.3. maillage extrude ; nbrepb', nbrepb +#endif +c +#include "mslve3.h" +c +c 3.2.4. ==> raffinement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.4. raffinement ; nbrepb', nbrepb +#endif +c +#include "mslve5.h" +#include "mslv13.h" +#include "mslve6.h" +c +c 3.2.5. ==> deraffinement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.5. deraffinement ; nbrepb', nbrepb +#endif +c +#include "mslve7.h" +#include "mslve8.h" +c +c 3.2.6. ==> coherence entre raffinement et deraffinement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.6. raff/dera ; nbrepb', nbrepb +#endif +c +#include "mslve9.h" +c +c 3.2.7. ==> coherence des seuils +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.7. seuils ; nbrepb', nbrepb +#endif +c +#include "mslv10.h" +c +c 3.2.8. ==> indicateur de suivi de frontiere +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2.8. suivi de frontiere ; nbrepb', nbrepb +#endif +c +#include "mslv11.h" +c +c 3.3. ==> pour les autres modes +c + else +c + taopti(31) = 0 + taopti(32) = 0 +c + endif +c +c 3.4. ==> pour le mode homard pur ou interpolation de solution +c + if ( modhom.eq.1 .or. modhom.eq.4 ) then +c +c 3.4.1. ==> indicateur de conversion de la solution +c + write(ulsort,texte(langue,61)) +c + write(ulsort,texte(langue,99)) + if ( taopti(28).eq.0 ) then + write(ulsort,texte(langue,12)) + elseif ( taopti(28).eq.1 ) then + write(ulsort,texte(langue,13)) + else + write(ulsort,texte(langue,11)) taopti(28) + nbrepb = nbrepb + 1 + endif +c + endif +c +c 3.5. ==> reperage temporel de l'indicateur d'erreur +c + if ( modhom.eq.1 ) then +c +#include "mslv12.h" +c + endif +c +c==== +c 4. message si erreur +c==== +c + if ( nbrepb.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + if ( nbrepb.eq.1 ) then + write (ulsort,texte(langue,6)) + else + write (ulsort,texte(langue,7)) + endif + codret = 2 +c + endif +c +c==== +c 5. si tout va bien, on en deduit les conversions a faire +c==== +c + if ( codret.eq.0 ) then +c +c 5.1. ==> indicateur de conversion du maillage +c +c 5.1.1. ==> pour le mode homard pur +c + if ( modhom.eq.1 ) then +c + write(ulsort,texte(langue,95)) + if ( taopti(10).eq.0 ) then + taopti(21) = 1 + write(ulsort,texte(langue,13)) + else + taopti(21) = 0 + write(ulsort,texte(langue,12)) + endif +c + write(ulsort,texte(langue,96)) + taopti(22) = 1 + write(ulsort,texte(langue,13)) +c +c 5.1.2. ==> pour le mode information +c + elseif ( modhom.eq.2 ) then +c + write(ulsort,texte(langue,24)) + if ( taopti(11).ne.1 ) then + taopti(21) = 1 + write(ulsort,texte(langue,13)) + else + taopti(21) = 0 + write(ulsort,texte(langue,12)) + endif +c +c 5.1.3. ==> pour le mode modification +c + elseif ( modhom.eq.3 ) then +c + write(ulsort,texte(langue,25)) + if ( taopti(11).ne.1 ) then + taopti(21) = 1 + write(ulsort,texte(langue,13)) + else + taopti(21) = 0 + write(ulsort,texte(langue,12)) + endif +c + write(ulsort,texte(langue,97)) + taopti(22) = 1 + write(ulsort,texte(langue,13)) +c +c 5.1.4. ==> pour le mode interpolation +c + else +c + taopti(21) = 0 + taopti(22) = 0 +c + endif +c +c 5.2. ==> indicateur de conversion de l'indicateur d'erreur +c +c 5.2.1. ==> pour le mode homard pur +c + if ( modhom.eq.1 ) then +c + if ( taopti(37).eq.0 ) then + write(ulsort,texte(langue,98)) + taopti(27) = 0 + if ( taopti(10).eq.0 ) then + if ( taopti(31).gt.0 ) then + taopti(27) = 1 + endif + else + if ( taopti(31).gt.0 .or. taopti(32).gt.0 ) then + taopti(27) = 1 + endif + endif + if ( taopti(27).eq.0 ) then + write(ulsort,texte(langue,12)) + else + write(ulsort,texte(langue,13)) + endif + else + taopti(27) = 0 + endif +c +c 5.2.2. ==> pour les autres modes +c + else +c + taopti(27) = 0 +c + endif +c + endif + +c==== +c 6. ecriture des fichiers HOMARD : rien pour le mode d'information +c==== +c + if ( codret.eq.0 ) then +c + if ( modhom.eq.2 ) then + taopti(5) = 1 + endif +c + endif +c +c==== +c 7. Option du delta de coordonnees pour les maillages extrudes +c==== +c + if ( taopti(39).ne.0 ) then +c +c 7.1 ==> Si le delta est impose, on doit avoir une valeur > 0 +c + if ( codret.eq.0 ) then +c + if ( taopti(40).eq.2 ) then +c + if ( abs(taoptr(3)+1789.d0).lt.1.0d-6 ) then + write(ulsort,texte(langue,70)) + write(ulsort,texte(langue,72)) + codret = 2 +c + elseif ( taoptr(3).le.0.0d0 ) then + write(ulsort,texte(langue,70)) + write(ulsort,texte(langue,73)) + codret = 2 +c + endif +c + endif +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/homajc.F b/src/tool/HOMARD_00/homajc.F new file mode 100644 index 00000000..63b7b56f --- /dev/null +++ b/src/tool/HOMARD_00/homajc.F @@ -0,0 +1,316 @@ + subroutine homajc ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOmard : Mise A Jour des Coordonnees +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c . . . . 7 : non convergence de l'algorithme . +c ______________________________________________________________________ +c +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOMAJC' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envada.h" +c +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux + integer codre0 + integer codre1, codre2 + integer nbnhom, nbncal +c + character*6 saux + character*8 nohman, nocman +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +#include "impr01.h" +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c + texte(1,4) = + > '(//,a6,'' M I S E A J O U R C O O R D O N N E E S'')' + texte(1,5) = '(55(''=''),/)' + texte(1,6) = '(''Incoherence des nombres de noeuds'')' +c + texte(2,4) = + > '(//,a6,'' U P D A T I N G O F C O O R D I N A T E S'')' + texte(2,5) = '(54(''=''),/)' + texte(2,6) = '(''Non coherence for the number of nodes'')' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c==== +c 2. les structures de base +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. les structures de base ; codret', codret +#endif +c +c 2.1. ==> le maillage homard +c + if ( codret.eq.0 ) then +c + nohman = smem(adopts+2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'nohman : ', nohman +#endif +c + endif +c +c 2.2. ==> le maillage de calcul +c + if ( codret.eq.0 ) then +c + nocman = smem(adopts) +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'nocman : ', nocman +#endif +c + endif +c +c==== +c 3. mise a jour des coordonnees +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. maj des coordonnees ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - HOMARD', nohman//'.Noeud') + call gmprsx (nompro//' - Calcul', nocman//'.Noeud') +#endif +c +c 3.1. ==> verification de la coherence du nombre de noeuds +c + if ( codret.eq.0 ) then +c + call gmliat ( nohman//'.Noeud', 1, nbnhom, codre1 ) + call gmliat ( nocman//'.Noeud', 1, nbncal, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbnhom', nbnhom + write (ulsort,90002) 'nbncal', nbncal +#endif +c + if ( nbnhom.ne.nbncal ) then + write (ulsort,texte(langue,6)) + write (ulsort,90002) 'HOMARD', nbnhom + write (ulsort,90002) 'Calcul', nbncal + codret = 31 + endif +c + endif +c +c 3.2. ==> Copie des coordonnees +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro//' - Calcul', nocman//'.Noeud.Coor', + > 3*nbnhom-9, 3*nbnhom) + call gmprot (nompro//' - HOMARD avant', nohman//'.Noeud.Coor', + > 3*nbnhom-9, 3*nbnhom) +#endif +c + call gmcpoj ( nocman//'.Noeud.Coor', + > nohman//'.Noeud.Coor', codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro//' - HOMARD apres', nohman//'.Noeud.Coor', + > 3*nbnhom-9, 3*nbnhom) +#endif +c + endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. fin de '//nompro//' ; codret', codret +#endif +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hoprin.F b/src/tool/HOMARD_00/hoprin.F new file mode 100644 index 00000000..30835669 --- /dev/null +++ b/src/tool/HOMARD_00/hoprin.F @@ -0,0 +1,379 @@ + subroutine hoprin +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : programme PRINcipal +c -- ---- +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOPRIN' ) +c +#include "nblang.h" +#include "referx.h" +c +c 0.2. ==> communs +c On les met tous pour assurer la coherence en descendance. +c En principe, le save devrait remedier a cela mais on fait +c ceinture et bretelles +c +#include "chisig.h" +#include "cndoad.h" +#include "cofhex.h" +#include "cofpen.h" +#include "comp07.h" +#include "defiqu.h" +#include "demitr.h" +#include "dicfen.h" +#include "enti01.h" +#include "envada.h" +#include "envca1.h" +#include "envca2.h" +#include "envex1.h" +#include "fahmed.h" +#include "front0.h" +#include "front1.h" +#include "front2.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "hexcf0.h" +#include "hexcf1.h" +#include "i1i2i3.h" +#include "impr02.h" +#include "indefi.h" +#include "indefr.h" +#include "indefs.h" +#include "infini.h" +#include "j1234j.h" +#include "nancnb.h" +#include "nbfami.h" +#include "nbfamm.h" +#include "nbutil.h" +#include "nombar.h" +#include "nomber.h" +#include "nombhe.h" +#include "nombmp.h" +#include "nombno.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nombqu.h" +#include "nombsr.h" +#include "nombte.h" +#include "nombtr.h" +#include "nomest.h" +#include "nouvnb.h" +#include "op0123.h" +#include "op1234.h" +#include "op1aa6.h" +#include "ope1a3.h" +#include "ope1a4.h" +#include "ope4a6.h" +#include "oriefp.h" +#include "oriefy.h" +#include "orieqh.h" +#include "oriett.h" +#include "permut.h" +#include "precis.h" +#include "refere.h" +#include "refert.h" +#include "rfamed.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c + integer modhom + integer lnomfi, lang, ulsort, codret, codre0 + integer guimp, gmimp, raison +c + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "hoconf.h" +#include "langue.h" +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "impr03.h" +c + lang = langue + nomfic = nfconf + lnomfi = lfconf +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de HOINIT par ', nompro +#endif + call hoinit ( nomfic, lnomfi, lang, codret ) +c + call utulls ( ulsort, codre0 ) +c +c==== +c 2. lectures +c modhom est, en sortie, le mode d'utilisation de HOMARD : +c 1 : adaptation standard +c 2 : information sur un maillage +c 3 : modification d'un maillage, sans adaptation +c 4 : conversion de solution +c 5 : mise a jour des coordonnees apres un suivi de frontiere externe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOLECT', nompro +#endif + call holect ( modhom, codret ) +c +c==== +c 3. Mode : HOMARD pur +c==== +c + if ( modhom.eq.1 ) then +c +c 3.1. ==> conversions avant adaptation et ecritures +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVCV', nompro +#endif + call hoavcv ( codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVEC', nompro +#endif + call hoavec ( codret ) +c +c 3.2. ==> attribution des decisions aux faces et aux aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HODECI', nompro +#endif + call hodeci ( codret ) +c +c 3.3. ==> creation du nouveau maillage +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOCRMA', nompro +#endif + call hocrma ( codret ) +c +c 3.4. ==> suivi de frontiere (eventuellement) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOSUFR', nompro +#endif + call hosufr ( codret ) +c +c 3.5. ==> conversions apres adaptation +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPCV', nompro +#endif + call hoapcv ( codret ) +c +c 3.6. ==> informations complementaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOINCO', nompro +#endif + call hoinco ( codret ) +c +c 3.7. ==> ecritures +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPEC', nompro +#endif + call hoapec ( codret ) +c +c 3.8. ==> creation de maillage et solution annexes (eventuellement) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOCMSA', nompro +#endif + call hocmsa ( codret ) +c +c==== +c 4. Mode : information +c==== +c + elseif ( modhom.eq.2 ) then +c +c 4.1. ==> conversions +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INCONV', nompro +#endif + call inconv ( codret ) +c +c 4.2. ==> informations +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ININFM', nompro +#endif + call ininfm ( codret ) +c +c 4.3. ==> questions/reponses +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INQURE', nompro +#endif + call inqure ( codret ) +c +c==== +c 5. Mode : modification de maillage +c==== +c + elseif ( modhom.eq.3 ) then +c +c 5.1. ==> conversions initiales et ecritures +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVCV', nompro +#endif + call hoavcv ( codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVEC', nompro +#endif + call hoavec ( codret ) +c +c 5.2. ==> modification +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMODI', nompro +#endif + call mmmodi ( codret ) +c +c 5.3. ==> conversions apres modification +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPCV', nompro +#endif + call hoapcv ( codret ) +c +c 5.4. ==> informations complementaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOINCO', nompro +#endif + call hoinco ( codret ) +c +c 5.5. ==> ecritures +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPEC', nompro +#endif + call hoapec ( codret ) +c +c==== +c 6. Mode : conversion de la solution +c==== +c + elseif ( modhom.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPCV', nompro +#endif + call hoapcv ( codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAPEC', nompro +#endif + call hoapec ( codret ) +c +c==== +c 7. Mode : mise a jour des coordonnees +c==== +c + elseif ( modhom.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOMAJC', nompro +#endif + call homajc ( codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOAVEC', nompro +#endif + call hoavec ( codret ) +c +c==== +c 8. Mode : erreur +c==== +c + else + + codret = 7 +c + endif +c +c==== +c 9. la fin +c Si le code de retour est : +c . 0 : tout va bien +c . un multiple de 2 : probleme dans les objets GM +c . un multiple de 3 : probleme dans les fichiers +c . 5 : deux appels a des programmes d'initialisations +c . 7 : mode inconnu +c=== +c + call utulls ( ulsort, codre0 ) +c + guimp = 0 + gmimp = 0 +c + if ( codret.eq.0 ) then +c + raison = 0 +c + else +c + raison = 1 + if ( mod(codret,2).eq.0 ) then + gmimp = 1 + endif + if ( mod(codret,3).eq.0 ) then + guimp = 1 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'HOSTOP', nompro +#endif + call hostop ( ulsort, guimp, gmimp, raison) +c + end diff --git a/src/tool/HOMARD_00/hostop.F b/src/tool/HOMARD_00/hostop.F new file mode 100644 index 00000000..e08ab234 --- /dev/null +++ b/src/tool/HOMARD_00/hostop.F @@ -0,0 +1,107 @@ + subroutine hostop ( ulsort, guimp, gmimp, raison ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : STOP +c -- ---- +c +c but : arreter une execution apres avoir arrete les gestionnaires +c - gestionnaire de memoire +c - gestionnaire des mesures de temps de calcul +c - gestionnaire d'unites logiques +c - execution elle-meme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . unite logique pour les messages . +c . guimp . e . 1 . 1 => impressions gu . +c . gmimp . e . 1 . 1 => impressions gm . +c . raison . e . 1 . raison d appel . +c . . . . 0 : arret normal, sans core . +c . . . . .NE.0 : call abort -> core . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOSTOP' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer ulsort, raison, guimp, gmimp +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#include "langue.h" +c ______________________________________________________________________ +c +c==== +c 1. entete +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + write (ulsort,10001) +c +10001 format (/, + > /,15x,'......................................', + > /,15x,': :', + > /,15x,': H O M A R D :', + > /,15x,':....................................:') +c +c==== +c 2. arret des gestionnaires et de l'execution +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGSTOP', nompro +#endif + call ugstop ( spropb, ulsort, guimp, gmimp, raison ) +c + end diff --git a/src/tool/HOMARD_00/hosufr.F b/src/tool/HOMARD_00/hosufr.F new file mode 100644 index 00000000..9be3e05e --- /dev/null +++ b/src/tool/HOMARD_00/hosufr.F @@ -0,0 +1,289 @@ + subroutine hosufr ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c HOMARD : SUivi de FRontiere +c -- -- -- +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'HOSUFR' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux + integer nbarfr, nbqufr +c + character*6 saux + character*8 typobs, nohmap +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) +c + if ( codret.eq.0 ) then + if ( mod(imem(adopti+28),2).eq.0 .or. + > mod(imem(adopti+28),3).eq.0 .or. + > mod(imem(adopti+28),5).eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + endif + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c----------------------------------------------------------------------- + if ( mod(imem(adopti+28),2).eq.0 .or. + > mod(imem(adopti+28),3).eq.0 .or. + > mod(imem(adopti+28),5).eq.0 ) then +c----------------------------------------------------------------------- +c +c 1.5. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.6. ==> les messages +c + texte(1,4) = '(//,a6,'' S U I V I D E F R O N T I E R E'')' + texte(1,5) = '(42(''=''),/)' +c + texte(2,4) = '(//,a6,'' B O U N D A R Y F O L L O W I N G'')' + texte(2,5) = '(42(''=''),/)' +c +c 1.7. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.8. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.9. ==> le maillage homard +c + if ( codret.eq.0 ) then +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codret ) +c + endif +c +#include "impr03.h" +c +c==== +c 2. A-t-on des aretes et des quadrangles concernees +c par le suivi de frontiere ? +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Tests des aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nbarfr = 0 + nbqufr = 0 + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOAQ', nompro +#endif + call sfcoaq ( nohmap, iaux, nbarfr, nbqufr, + > ulsort, langue, codret ) +c + endif +c +c +c==== +c 3. Traitement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Traitement ; codret', codret + write (ulsort,90002) 'nbarfr', nbarfr + write (ulsort,90002) 'nbqufr', nbqufr +#endif +c + if ( nbarfr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCAFR', nompro +#endif + call sfcafr ( lgopti, imem(adopti), + > lgopts, smem(adopts), + > lgetco, imem(adetco), + > nohmap, nbarfr, nbqufr, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.3. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +c----------------------------------------------------------------------- + endif +c----------------------------------------------------------------------- +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/HOMARD_00/hotit2.h b/src/tool/HOMARD_00/hotit2.h new file mode 100644 index 00000000..a49603d1 --- /dev/null +++ b/src/tool/HOMARD_00/hotit2.h @@ -0,0 +1,54 @@ +c + numsec (40) = 40 + numsec (41) = 41 + numsec (42) = 42 + numsec (43) = 43 + numsec (44) = 44 + numsec (45) = 45 + numsec (46) = 46 + numsec (47) = 47 + numsec (48) = 48 +c + numsec (50) = 50 +c +c 2.1. ==> en francais +c +c 123456789012345678901234 + titsec (40) = 'Informations ' + titsec (41) = '. dont analyse ' + titsec (42) = '...... interpenetration ' + titsec (43) = '...... qualite ' + titsec (44) = '...... connexite ' + titsec (45) = '...... tailles ' + titsec (46) = '...... caracteristiques ' + titsec (47) = '...... diametres ' + titsec (48) = '. dont fichiers ' +c + titsec (50) = 'Questions/reponses ' +c + do 221 , iaux = 1 , nbsect + if ( numsec (iaux) .gt. 0 ) then + call gtnoms ( numsec(iaux), 1 , titsec(iaux) ) + endif + 221 continue +c +c 2.2. ==> en anglais +c +c 123456789012345678901234 + titsec (40) = 'Information ' + titsec (41) = '. analysis ' + titsec (42) = '...... interpenetration ' + titsec (43) = '...... quality ' + titsec (44) = '...... connexity ' + titsec (45) = '...... sizes ' + titsec (46) = '...... characteristics ' + titsec (47) = '...... diametres ' + titsec (48) = '. files ' +c + titsec (50) = 'Questions/answers ' +c + do 222 , iaux = 1 , nbsect + if ( numsec (iaux) .gt. 0 ) then + call gtnoms ( numsec(iaux), 2 , titsec(iaux) ) + endif + 222 continue diff --git a/src/tool/HOMARD_00/hotit3.h b/src/tool/HOMARD_00/hotit3.h new file mode 100644 index 00000000..c8451442 --- /dev/null +++ b/src/tool/HOMARD_00/hotit3.h @@ -0,0 +1,47 @@ +c + numsec (50) = 50 + numsec (51) = 51 + numsec (52) = 52 +c + do 320 , iaux = 60, 79 + numsec (iaux) = iaux + 320 continue +c +c 2.1. ==> en francais +c +c 123456789012345678901234 + titsec (50) = 'Modification ' + titsec (51) = '. dont degre ' + titsec (52) = '. creation des joints ' + titsec (60) = '.. conversion degre 1 ' + titsec (61) = '.. 4. Decompte (mmagr0) ' + titsec (62) = '.. 4. Decompte (mmag11) ' + titsec (63) = '.. 4. Decompte (mmag12) ' + titsec (64) = '.. Reallocation ' + titsec (65) = '.. 6. Creation (mmag31) ' + titsec (66) = '.. 6. Creation (mmag32) ' + titsec (67) = '.. 6. Creation (mmag33) ' + titsec (68) = '.. 6. Creation (mmag34) ' + titsec (76) = '.. 7.2. Grains (mmagr4) ' + titsec (77) = '.. 7.3. connecti (mmagr5' + titsec (78) = '.. 8. Suppression ' + titsec (79) = '.. conversion degre 2 ' +c + do 321 , iaux = 1 , nbsect + if ( numsec (iaux) .gt. 0 ) then + call gtnoms ( numsec(iaux), 1 , titsec(iaux) ) + endif + 321 continue +c +c 2.2. ==> en anglais +c +c 123456789012345678901234 + titsec (50) = 'Modification ' + titsec (51) = '. degree ' + titsec (52) = '. creation of the joints' +c + do 322 , iaux = 1 , nbsect + if ( numsec (iaux) .gt. 0 ) then + call gtnoms ( numsec(iaux), 2 , titsec(iaux) ) + endif + 322 continue diff --git a/src/tool/HOMARD_00/hotits.h b/src/tool/HOMARD_00/hotits.h new file mode 100644 index 00000000..01ef507e --- /dev/null +++ b/src/tool/HOMARD_00/hotits.h @@ -0,0 +1,219 @@ +c +c 2.0. ==> les numeros de sections +c + numsec (10) = 10 +c + numsec (20) = 20 + numsec (21) = 21 + numsec (22) = 22 + numsec (23) = 23 +c + numsec (30) = 30 + numsec (31) = 31 + numsec (32) = 32 + numsec (33) = 33 + numsec (34) = 34 + numsec (35) = 35 + numsec (36) = 36 +c + numsec (40) = 40 + numsec (41) = 41 + numsec (42) = 42 +c + numsec (50) = 50 + numsec (51) = 51 + numsec (52) = 52 + numsec (53) = 53 + numsec (54) = 54 + numsec (55) = 55 + numsec (56) = 56 + numsec (57) = 57 + numsec (58) = 58 +c + numsec (60) = 60 + numsec (61) = 61 + numsec (62) = 62 + numsec (63) = 63 + numsec (64) = 64 + numsec (65) = 65 + numsec (66) = 66 + numsec (67) = 67 +c + numsec (70) = 70 + numsec (71) = 71 + numsec (72) = 72 +c + numsec (80) = 80 + numsec (81) = 81 + numsec (82) = 82 + numsec (83) = 83 + numsec (84) = 84 + numsec (85) = 85 + numsec (86) = 86 + numsec (87) = 87 + numsec (88) = 88 +c + numsec (90) = 90 + numsec (91) = 91 + numsec (92) = 92 + numsec (93) = 93 + numsec (94) = 94 + numsec (95) = 95 +c + numsec(100) = 100 + numsec(101) = 101 + numsec(102) = 102 + numsec(103) = 103 +c + numsec(110) = 110 + numsec(111) = 111 + numsec(112) = 112 + numsec(113) = 113 +c +c 2.1. ==> en francais +c +c 123456789012345678901234 + titsec (10) = 'Initialisation ' +c + titsec (20) = 'Lectures ' + titsec (21) = '. dont options ' + titsec (22) = '. dont maillage ' + titsec (23) = '. dont frontiere ' +c + titsec (30) = 'Conversions avant adapt.' + titsec (31) = '. dont maillage ' + titsec (32) = '. dont frontieres ' + titsec (33) = '. dont analyse ' + titsec (34) = '. dont filtrage groupes ' + titsec (35) = '. dont lecture indic. ' + titsec (36) = '. dont indicateur ' +c + titsec (40) = 'Ecritures iteration n ' + titsec (41) = '. dont maillage HOMARD ' + titsec (42) = '. dont indicateur ' +c + titsec (50) = 'Prise de decisions ' + titsec (51) = '. dont calcul des sauts ' + titsec (52) = '. dont composantes ' + titsec (53) = '. dont conformite ' + titsec (54) = '. dont historiques ' + titsec (55) = '. dont initialisation ' + titsec (56) = '. dont periodicite ' + titsec (57) = '. dont raffinement ' + titsec (58) = '. dont deraffinement ' +c + titsec (60) = 'Creation du maillage ' + titsec (61) = '. dont deraffinement ' + titsec (62) = '. dont compactage ' + titsec (63) = '. dont raffinement ' + titsec (64) = '. dont conformite ' + titsec (65) = '. dont noeuds supplemen.' + titsec (66) = '. dont mise a jour ' + titsec (67) = '. dont analyse ' +c + titsec (70) = 'Suivi de la frontiere ' + titsec (71) = '. dont conversion ' + titsec (72) = '. dont traitement ' +c + titsec (80) = 'Conversions apres adapt.' + titsec (81) = '. dont maillage ' + titsec (82) = '. dont lecture solution ' + titsec (83) = '. dont solution ' + titsec (84) = '. dont analyse ' +c + titsec (90) = 'Complements ' + titsec (91) = '. dont niveau ' + titsec (92) = '. dont qualite ' + titsec (93) = '. dont diametre ' + titsec (94) = '. dont parents ' + titsec (95) = '. dont voisins recollem.' +c + titsec(100) = 'Ecritures iteration n+1 ' + titsec(101) = '. dont maillage HOMARD ' + titsec(102) = '. dont maillage calcul ' + titsec(103) = '. dont solution ' +c + titsec(110) = 'Creation du mail. annexe' + titsec(111) = '. dont changement degre ' + titsec(112) = '. dont conversion ' + titsec(113) = '. dont ecriture ' +c + do 21 , iaux = 1 , nbsect + if ( numsec(iaux).gt.0 ) then + call gtnoms ( numsec(iaux), 1 , titsec(iaux) ) + endif + 21 continue +c +c 2.2. ==> en anglais +c +c 123456789012345678901234 + titsec (10) = 'Initialisation ' +c + titsec (20) = 'Readings ' + titsec (21) = '. options ' + titsec (22) = '. mesh ' + titsec (23) = '. boundary ' +c + titsec (30) = 'Conversions before adap.' + titsec (31) = '. mesh ' + titsec (32) = '. boundary ' + titsec (33) = '. analysis ' + titsec (34) = '. groupe filtering ' + titsec (35) = '. indicator readings ' + titsec (36) = '. indicator ' +c + titsec (40) = 'Writings iteration # n ' + titsec (41) = '. HOMARD mesh ' + titsec (42) = '. indicator ' +c + titsec (50) = 'Decisions ' + titsec (51) = '. jumps ' + titsec (52) = '. components ' + titsec (53) = '. conformity ' + titsec (54) = '. history ' + titsec (55) = '. initialisation ' + titsec (56) = '. periodicity ' + titsec (57) = '. refinement ' + titsec (58) = '. unrefinement ' +c + titsec (60) = 'Mesh creation ' + titsec (61) = '. unrefinement ' + titsec (62) = '. compactification ' + titsec (63) = '. refinement ' + titsec (64) = '. conformity ' + titsec (65) = '. additional nodes creat' + titsec (66) = '. up-dating ' + titsec (67) = '. analysis ' +c + titsec (70) = 'Boundary following ' + titsec (71) = '. conversion ' + titsec (72) = '. treatment ' +c + titsec (80) = 'Conversions after adapt.' + titsec (81) = '. mesh ' + titsec (82) = '. solution readings ' + titsec (83) = '. solution ' + titsec (84) = '. analysis ' +c + titsec (90) = 'Additional information ' + titsec (91) = '. level ' + titsec (92) = '. quality ' + titsec (93) = '. diametre ' + titsec (94) = '. parents ' + titsec (95) = '. neighbours ' +c + titsec(100) = 'Writings iteration # n+1' + titsec(101) = '. HOMARD mesh ' + titsec(102) = '. calculation mesh ' + titsec(103) = '. solution ' +c + titsec(110) = 'Creation of new mesh ' + titsec(111) = '. degree modification ' + titsec(112) = '. conversion ' + titsec(113) = '. writings ' +c + do 22 , iaux = 1 , nbsect + if ( numsec(iaux).gt.0 ) then + call gtnoms ( numsec(iaux), 2 , titsec(iaux) ) + endif + 22 continue diff --git a/src/tool/Includes_Generaux/CMakeLists.txt b/src/tool/Includes_Generaux/CMakeLists.txt new file mode 100644 index 00000000..cf334f72 --- /dev/null +++ b/src/tool/Includes_Generaux/CMakeLists.txt @@ -0,0 +1,172 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +SET(HOMARD_INCLUDE + alphnu.h + chisig.h + cndoad.h + cofaar.h + cofamp.h + cofatq.h + cofexa.h + cofexh.h + cofexn.h + cofexq.h + cofext.h + cofhex.h + cofina.h + cofpen.h + cofpfh.h + cofpfp.h + coftex.h + coftfh.h + coftfp.h + coftfq.h + comp07.h + consta.h + consts.h + defiqu.h + demitr.h + derco1.h + dicfen.h + elmess.h + elnmxm.h + enti01.h + envada.h + envca1.h + envca2.h + envex1.h + envex2.h + equiva.h + esimpr.h + esutil.h + fahmed.h + fract0.h + fracta.h + fractb.h + fractc.h + fractd.h + fracte.h + fractf.h + fractg.h + fracth.h + fracti.h + fractj.h + fractk.h + fractl.h + fractm.h + fractn.h + fracto.h + front0.h + front1.h + front2.h + gedita.h + gelggt.h + genbla.h + gmenti.h + gmreel.h + gmstri.h + hexcf0.h + hexcf1.h + hexcf2.h + hexcf3.h + hexcf4.h + i1i2i3.h + impr01.h + impr02.h + impr03.h + impr04.h + impr05.h + impr06.h + indefi.h + indefr.h + indefs.h + infini.h + j1234j.h + langue.h + litme0.h + litmed.h + meddc0.h + melopt.h + mesutp.h + motcle.h + mslv10.h + mslv11.h + mslv12.h + mslv13.h + mslve0.h + mslve1.h + mslve2.h + mslve3.h + mslve4.h + mslve5.h + mslve6.h + mslve7.h + mslve8.h + mslve9.h + mslver.h + nancnb.h + nbfami.h + nbfamm.h + nbgrou.h + nblang.h + nbrmax.h + nbutil.h + nombar.h + nomber.h + nombhe.h + nombmp.h + nombno.h + nombpe.h + nombpy.h + nombqu.h + nombsr.h + nombte.h + nombtr.h + nomest.h + nouvnb.h + nuvers.h + op0012.h + op0123.h + op1234.h + op1aa6.h + ope001.h + ope002.h + ope1a3.h + ope1a4.h + ope4a6.h + oriefp.h + oriefy.h + orieqh.h + oriett.h + permut.h + precis.h + refere.h + refert.h + referx.h + rfamed.h + rftmax.h + rftmed.h + tbdim0.h + tbdim1.h + tbdim2.h + tbdim3.h + tbdim4.h + tbdim5.h + webweb.h +) diff --git a/src/tool/Includes_Generaux/alphnu.h b/src/tool/Includes_Generaux/alphnu.h new file mode 100644 index 00000000..64012a5b --- /dev/null +++ b/src/tool/Includes_Generaux/alphnu.h @@ -0,0 +1,30 @@ +c +c alphnu contient les principaux caracteres alphanumeriques +c +c de 0 a 9 : les chiffres de 0 a 9 +c de 10 a 35 : les minuscules de 'a' a 'z' +c de 36 a 61 : les majuscules de 'A' a 'Z' +c 62 : + +c + integer lgalnu + parameter ( lgalnu = 62 ) +c + integer lgaln2 + parameter ( lgaln2 = lgalnu*lgalnu ) +c + integer lgaln3 + parameter ( lgaln3 = lgalnu*lgalnu*lgalnu ) +c + integer lgaln4 + parameter ( lgaln4 = lgalnu*lgalnu*lgalnu*lgalnu ) +c + character*1 alphnu(0:lgalnu) +c + data alphnu / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', + > 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', + > 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', + > 'u', 'v', 'w', 'x', 'y', 'z', + > 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', + > 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', + > 'U', 'V', 'W', 'X', 'Y', 'Z', + > '+' / diff --git a/src/tool/Includes_Generaux/chisig.h b/src/tool/Includes_Generaux/chisig.h new file mode 100644 index 00000000..39ecac07 --- /dev/null +++ b/src/tool/Includes_Generaux/chisig.h @@ -0,0 +1,8 @@ +c +c======================================================================= +c nombre de chiffres significatifs +c----------------------------------------------------------------------- +c nbchii : nombre de chiffres significatifs des entiers +c----------------------------------------------------------------------- + integer nbchii + common /chisig/ nbchii diff --git a/src/tool/Includes_Generaux/cndoad.h b/src/tool/Includes_Generaux/cndoad.h new file mode 100644 index 00000000..2164d4e4 --- /dev/null +++ b/src/tool/Includes_Generaux/cndoad.h @@ -0,0 +1,243 @@ +c +c nndoad : nom de la structure qui contient les donnees de l'adaptation +c elle est de type DonnAdap +c elle est allouee dans utindh +c======================================================================= +c +c Attributs : +c 1 : longueur du tableau d'entiers associe au champ OptEnt +c 2 : longueur du tableau de reels associe au champ OptRee +c 3 : longueur du tableau de caracteres associe au champ OptCar +c 4 : longueur du tableau d'entiers associe au champ EtatCour +c 5 : type de programme : 1 : homard complet +c 2 : interface avant adaptation +c 3 : adaptation +c 4 : suivi de frontiere +c 5 : interface apres adaptation +c 6 : information +c +c======================================================================= +c +c 1. Champ OptEnt : liste des options entieres +c c'est un tableau d'entiers ou l'on trouve dans l'ordre : +c +c 1 : langue des messages +c 2 : libre +c 3 : type de bilan sur le maillage +c c'est le produit des options suivantes : +c 2 : nombre d'entites HOMARD 3 : interpenetration des mailles +c 5 : qualite des mailles 7 : nombre d'entites du calcul +c 11 : connexite 13 : tailles des sous-domaines +c 17 : proprietes des elements du calcul +c 19 : diametre des mailles +c Par defaut : 7, sauf pour le module d'adaptation pure : 2 +c Si 0, on ne fait rien. +c Pour l'adaptation, on ne fait le bilan avant adaptation que si +c le type de bilan est negatif +c 4 : mode de fonctionnement de HOMARD +c 1 : adaptation complete (defaut) 2 : information +c 3 : modification de maillage 4 : interpolation de solution +c 5 : mise a jour des coordonnees +c 5 : ecriture des fichiers au format HOMARD +c c'est le produit des options suivantes : +c 2 : pour le maillage n 3 : pour le maillage n+1 (defaut) +c >0 : avec la frontiere discrete, <0 : sans la frontiere discrete +c 6 : type de donnees des seuils d'erreur haut : +c -1 : probleme 0 : pas de donnees (defaut) +c 1 : en absolu 2 : en relatif +c 3 : en pourcentage d'entites 4 : en mu+n.sigma +c 5 : cible en nombre de noeuds +c 7 : type de donnees des seuils d'erreur bas : +c -1 : probleme 0 : pas de donnees (defaut) +c 1 : en absolu 2 : en relatif +c 3 : en pourcentage d'entites 4 : en mu-n.sigma +c 8 : usage des composantes multiples de l'indicateur +c 0 : norme L2 (defaut) +c 1 : norme infinie (max des valeurs absolues) +c 2 : valeur relative (si 1 seule composante) +c 9 : ecriture de messages complementaires : c'est le produit de : +c 1 : rien +c 2 : les temps de chaque section +c 3 : les caracteristiques MED des fichiers et de HOMARD +c 5 : les bilans sur la memoire +c +c 10 : numero d'iteration du maillage avant adaptation (-1 par defaut) +c 11 : type de code de calcul associe (-1 par defaut) +c 1 : HOMARD +c 6 : MED +c 16 : ATHENA (format MED) +c 26 : SATURNE_2D (format MED) +c 36 : SATURNE (format MED) +c 46 : NEPTUNE_2D (format MED) +c 56 : NEPTUNE (format MED) +c 66 : CARMEL_2D (format MED) +c 76 : CARMEL (format MED) +c 106 : NON-CONFORME (format MED) +c 12 : type d'informations ecrites sur le fichier med de sortie +c c'est le produit des options suivantes : +c 2 : niveau des mailles 3 : qualite des mailles +c 5 : diametre des mailles 7 : parente +c 11 : voisin des recollements +c Par defaut : 1 +c Si 0 ou 1, on ne fait rien. +c 13 : numero de pas de temps (eventuel) lie a l'indicateur d'erreur +c 14 : numero d'ordre (eventuel) lie a l'indicateur d'erreur +c 15 : -2, aucun numero de pas de temps n'a ete fourni pour +c l'indicateur +c 1, un numero de pas de temps est fourni +c 2, on prend le dernier pas de temps +c 16 : -2, aucun numero d'ordre n'a ete fourni pour l'indicateur +c 1, un numero est fourni +c 17 : -2, aucune valeur d'instant n'a ete fournie pour +c l'indicateur +c 1, une valeur d'instant est fournie +c 2, on prend le dernier instant +c 18 : 0, l'indicateur est utilise pour sa valeur dans chaque +c maille (defaut) +c 1, l'indicateur est utilise pour le saut entre 2 mailles +c 19 : nombre de groupes de filtrage de l'adaption +c 20 : nombre de tableaux a lire pour mise a jour +c -1 : tous +c 0 : aucun (defaut) +c >0 : certains +c +c Pour les options de 21 a 28 : 1=oui, 0=non +c 21 : conversion du maillage a l'iteration n +c 22 : conversion du maillage a l'iteration n+1 +c 27 : conversion de l'indicateur l'iteration n +c 28 : conversion de la solution a l'iteration n+1 +c 29 : suivi de frontiere : c'est le produit de : +c 1 : rien +c 2 : presence de frontieres discretes par groupe +c 3 : presence de frontieres analytiques +c 5 : frontieres par la CAO +c remarque : (2/3) et 5 sont incompatibles +c +c 30 : mode de conformite +c 0 : conforme (defaut) +c 1 : non-conforme avec au minimum 2 aretes non decoupees en 2 +c par face (triangle ou quadrangle) +c 2 : non-conforme avec 1 seul noeud pendant par arete +c 3 : non-conforme fidele a l'indicateur +c -1 : conforme, avec des boites pour les quadrangles, hexaedres +c et pentaedres +c -2 : non-conforme avec au maximum 1 arete decoupee en 2 et des +c boites pour les quadrangles, hexaedres et pentaedres +c 31 : raffinement +c -1 : raffinement uniforme +c 0 : pas de raffinement +c 1 : raffinement libre (defaut) +c 2 : raffinement libre homogene en type de maille +c 32 : deraffinement +c -1 : deraffinement uniforme +c 0 : pas de deraffinement +c 1 : deraffinement libre (defaut) +c 33 : niveau maximum +c 34 : niveau minimum +c 35 : nombre maximum de mailles (0 par defaut, c'est-a-dire libre) +c 36 : contraintes de raffinement : c'est le produit de : +c 1 : pas de contraintes (defaut) +c 2 : decalage de deux mailles avant un changement de niveau +c 3 : bande de raffinement interdite +c 5 : pas de mailles decoupees sans leurs voisines de +c dimension superieure +c 37 : nombre de zones a raffiner +c si negatif, les zones sont 2D (en x et y) +c 38 : initialisation de l'adaptation +c 0 : on garde tout (defaut) +c 1 : reactivation des mailles ou aucun indicateur n'est defini +c 39 : maillage extrude +c 0 : non (defaut) +c 1 : selon X +c 2 : selon Y +c 3 : selon Z (cas de Saturne ou Neptune) +c 40 : calcul des coordonnees pour les maillages extrudes : +c 1 : coordonnees initiales (defaut) +c 2 : valeur imposee +c 3 : moyenne arithmetique des mini/maxi en (x,y) des mailles +c 4 : moyenne geometrique des mini/maxi en (x,y) des mailles +c 5 : ecart initial, divise par 2**nivsup +c +c Pour les modifications de maillage : +c 41 : changement de degre : 1=oui, 0=non (defaut) +c 42 : creation de joints : 1=oui, 0=non (defaut) +c +c Pour la cible en nombre de noeuds : +c 43 : nombre de passages maximum : 50 par defaut +c 44 : cible en nombre de noeuds : -1 si non concerne (defaut) +c 45 : cible en nombre de mailles : -1 si non concerne (defaut) +c +c 49 : types de mailles acceptes +c s'il existe des mailles incompatibles avec l'usage de HOMARD +c 0 : on bloque (defaut) +c 1 : on les reproduit telles quelles +c 50 : type de maillage a ecrire +c 1 : maillage apres adaptation +c 2 : maillage annexe apres adaptation +c +c======================================================================= +c +c 2. Champ OptRee : liste des options reelles +c c'est un tableau de reels ou l'on trouve dans l'ordre : +c +c 1 : seuil haut (absolu, relatif ou pourcentage selon le cas) +c 2 : seuil bas (absolu, relatif ou pourcentage selon le cas) +c 3 : diametre minimal de maille pour le raffinement +c 4 : valeur imposee pour le deltaZ de Saturne ou Neptune 2D +c 10 : instant (eventuel) lie a l'indicateur d'erreur +c +c Pour les options de 11 a 16 : les limites de la zone a raffiner +c 11 : xmin +c 12 : xmax +c 13 : ymin +c 14 : ymax +c 15 : zmin +c 16 : zmax +c +c======================================================================= +c +c 3. Champ OptCar : liste des noms d'objets intermediaires +c c'est un tableau de caracteres*8 ou l'on trouve dans l'ordre : +c +c 1 : nom du maillage externe a l'iteration n +c 2 : nom du maillage externe a l'iteration n+1 +c 3 : nom du maillage HOMARD a l'iteration n +c 4 : nom du maillage HOMARD a l'iteration n+1 +c 5 : nom du maillage annexe a l'iteration n+1 +c 7 : nom de l'indicateur externe a l'iteration n +c 8 : nom de l'indicateur au format homard +c 9 : nom de la solution externe a l'iteration n +c 10 : nom de la solution externe a l'iteration n+1 +c 11 : nom du tableau des decisions sur les aretes +c 12 : nom du tableau des decisions sur les triangles +c 14 : nom des sauvegardes du maillage homard a l'iteration n +c 15 : nom des groupes de filtrage sur l'adaptation +c 16 : nom du maillage de la frontiere au format MED +c 17 : definition des frontieres discretes/CAO : nom des groupes +c 18 : nom des champs a mettre a jour +c 19 : definition des zones a raffiner par un critere geometrique +c 20 : specificites aux maillages externes +c 23 : definition des liens groupes/frontieres : nom des frontieres +c 24 : definition des liens groupes/frontieres : nom des groupes +c 25 : definition des frontieres analytiques : nom des frontieres +c 26 : definition des frontieres analytiques : valeurs reelles +c 27 : unites logiques frontieres/groupes +c 28 : structure permettant le filtrage par le diametre minimal +c 29 : structure permettant le filtrage par les groupes +c 30 : action en cours : 'adap', 'info_av', 'info_ap', 'sufr', 'modi' +c 31 : nom de la solution complementaire +c +c======================================================================= +c +c 4. Champ EtatCour : decrit l'etat courant +c c'est un tableau d'entiers ou l'on trouve dans l'ordre : +c +c 1 : numero de l'etape en cours (pour impression) +c 2 : numero de la sous-etape en cours (pour impression) +c 3 : numero de la grande section de mesure de temps en cours +c 4 : numero de la petite section de mesure de temps en cours +c +c======================================================================= +c + character*8 nndoad + common /cndoad/ nndoad diff --git a/src/tool/Includes_Generaux/cofaar.h b/src/tool/Includes_Generaux/cofaar.h new file mode 100644 index 00000000..9844f6a8 --- /dev/null +++ b/src/tool/Includes_Generaux/cofaar.h @@ -0,0 +1,10 @@ + integer coorfa, cofifa, cosfli, cosfsa +c +c code d'orientation pour une famille d'aretes + parameter ( coorfa = 3 ) +c code de famille d'orientation inverse d'une famille d'aretes + parameter ( cofifa = 4 ) +c code numero de ligne de frontiere liee a l'arete + parameter ( cosfli = 5 ) +c code numero de surface de frontiere liee a l'arete + parameter ( cosfsa = 7 ) diff --git a/src/tool/Includes_Generaux/cofamp.h b/src/tool/Includes_Generaux/cofamp.h new file mode 100644 index 00000000..c18e78b5 --- /dev/null +++ b/src/tool/Includes_Generaux/cofamp.h @@ -0,0 +1,4 @@ + integer cofaso +c +c code de la famille du sommet porteur de la maille-point + parameter ( cofaso = 3 ) diff --git a/src/tool/Includes_Generaux/cofatq.h b/src/tool/Includes_Generaux/cofatq.h new file mode 100644 index 00000000..9769dd16 --- /dev/null +++ b/src/tool/Includes_Generaux/cofatq.h @@ -0,0 +1,7 @@ + integer cosfsu, cofafa +c +c code numero de surface de frontiere liee a la face + parameter ( cosfsu = 3 ) +c +c famille des aretes internes au decoupage d'une face + parameter ( cofafa = 4 ) diff --git a/src/tool/Includes_Generaux/cofexa.h b/src/tool/Includes_Generaux/cofexa.h new file mode 100644 index 00000000..3df1a61f --- /dev/null +++ b/src/tool/Includes_Generaux/cofexa.h @@ -0,0 +1,8 @@ + integer cofxat, cofxax, cofxap +c +c famille HOMARD de l'arete translatee dans l'extrusion + parameter ( cofxat = 8 ) +c famille HOMARD du quadrangle cree dans l'extrusion + parameter ( cofxax = 9 ) +c position de l'arete + parameter ( cofxap = 10 ) diff --git a/src/tool/Includes_Generaux/cofexh.h b/src/tool/Includes_Generaux/cofexh.h new file mode 100644 index 00000000..461bfcac --- /dev/null +++ b/src/tool/Includes_Generaux/cofexh.h @@ -0,0 +1,4 @@ + integer cofexh +c +c famille des pentaedres du decoupage d'un hexaedre si extrusion + parameter ( cofexh = 3 ) diff --git a/src/tool/Includes_Generaux/cofexn.h b/src/tool/Includes_Generaux/cofexn.h new file mode 100644 index 00000000..94e839da --- /dev/null +++ b/src/tool/Includes_Generaux/cofexn.h @@ -0,0 +1,8 @@ + integer cofxnt, cofxnx, cofxnp +c +c famille HOMARD du noeud translate dans l'extrusion + parameter ( cofxnt = 2 ) +c famille HOMARD de l'arete creee dans l'extrusion + parameter ( cofxnx = 3 ) +c position du noeud + parameter ( cofxnp = 4 ) diff --git a/src/tool/Includes_Generaux/cofexq.h b/src/tool/Includes_Generaux/cofexq.h new file mode 100644 index 00000000..53816dcb --- /dev/null +++ b/src/tool/Includes_Generaux/cofexq.h @@ -0,0 +1,10 @@ + integer cofxqt, cofxqx, cofxqo, cofxqp +c +c famille HOMARD du quadrangle translate dans l'extrusion + parameter ( cofxqt = 7 ) +c famille HOMARD de l'hexaedre cree dans l'extrusion + parameter ( cofxqx = 8 ) +c orientation du quadrangle en tant que face du volume + parameter ( cofxqo = 9 ) +c position du quadrangle + parameter ( cofxqp = 10 ) diff --git a/src/tool/Includes_Generaux/cofext.h b/src/tool/Includes_Generaux/cofext.h new file mode 100644 index 00000000..cb0cd644 --- /dev/null +++ b/src/tool/Includes_Generaux/cofext.h @@ -0,0 +1,10 @@ + integer cofxtt, cofxtx, cofxto, cofxtp +c +c famille HOMARD du triangle translate dans l'extrusion + parameter ( cofxtt = 5 ) +c famille HOMARD du pentaedre cree dans l'extrusion + parameter ( cofxtx = 6 ) +c orientation du triangle en tant que face du pentaedre + parameter ( cofxto = 7 ) +c position du triangle + parameter ( cofxtp = 8 ) diff --git a/src/tool/Includes_Generaux/cofhex.h b/src/tool/Includes_Generaux/cofhex.h new file mode 100644 index 00000000..8c954405 --- /dev/null +++ b/src/tool/Includes_Generaux/cofhex.h @@ -0,0 +1,7 @@ +c=== +c codes des faces creees dans le raffinement standard d'un hexa +c suivant le code de la mere +c=== +c + integer cofh18(8), cofh25(8), cofh36(8), cofh47(8) + common /cofhex/ cofh18, cofh25, cofh36, cofh47 diff --git a/src/tool/Includes_Generaux/cofina.h b/src/tool/Includes_Generaux/cofina.h new file mode 100644 index 00000000..128ddb88 --- /dev/null +++ b/src/tool/Includes_Generaux/cofina.h @@ -0,0 +1,4 @@ + integer cosfin +c +c code de famille frontiere active/inactive + parameter ( cosfin = 6 ) diff --git a/src/tool/Includes_Generaux/cofpen.h b/src/tool/Includes_Generaux/cofpen.h new file mode 100644 index 00000000..8245538a --- /dev/null +++ b/src/tool/Includes_Generaux/cofpen.h @@ -0,0 +1,7 @@ +c=== +c codes des faces creees dans le raffinement standard d'un penta +c suivant le code de la mere +c=== +c + integer cofp08(8,0:3) + common /cofpen/ cofp08 diff --git a/src/tool/Includes_Generaux/cofpfh.h b/src/tool/Includes_Generaux/cofpfh.h new file mode 100644 index 00000000..7e2e2869 --- /dev/null +++ b/src/tool/Includes_Generaux/cofpfh.h @@ -0,0 +1,4 @@ + integer cofpfh +c +c famille des pyramides du decoupage de conformite d'un hexaedre + parameter ( cofpfh = 4 ) diff --git a/src/tool/Includes_Generaux/cofpfp.h b/src/tool/Includes_Generaux/cofpfp.h new file mode 100644 index 00000000..a03a2e8f --- /dev/null +++ b/src/tool/Includes_Generaux/cofpfp.h @@ -0,0 +1,4 @@ + integer cofpfp +c +c famille des pyramides du decoupage de conformite d'un pentaedre + parameter ( cofpfp = 4 ) diff --git a/src/tool/Includes_Generaux/coftex.h b/src/tool/Includes_Generaux/coftex.h new file mode 100644 index 00000000..62b6aaed --- /dev/null +++ b/src/tool/Includes_Generaux/coftex.h @@ -0,0 +1,6 @@ + integer cofamd, cotyel +c +c famille MED + parameter ( cofamd = 1 ) +c type d'element externe + parameter ( cotyel = 2 ) diff --git a/src/tool/Includes_Generaux/coftfh.h b/src/tool/Includes_Generaux/coftfh.h new file mode 100644 index 00000000..45407484 --- /dev/null +++ b/src/tool/Includes_Generaux/coftfh.h @@ -0,0 +1,4 @@ + integer coftfh +c +c famille des tetraedres du decoupage de conformite d'un hexaedre + parameter ( coftfh = 3 ) diff --git a/src/tool/Includes_Generaux/coftfp.h b/src/tool/Includes_Generaux/coftfp.h new file mode 100644 index 00000000..e11b6a84 --- /dev/null +++ b/src/tool/Includes_Generaux/coftfp.h @@ -0,0 +1,4 @@ + integer coftfp +c +c famille des tetraedres du decoupage de conformite d'un pentaedre + parameter ( coftfp = 3 ) diff --git a/src/tool/Includes_Generaux/coftfq.h b/src/tool/Includes_Generaux/coftfq.h new file mode 100644 index 00000000..2c026efd --- /dev/null +++ b/src/tool/Includes_Generaux/coftfq.h @@ -0,0 +1,4 @@ + integer coftfq +c +c famille des triangles du decoupage de conformite d'un quadrangle + parameter ( coftfq = 5 ) diff --git a/src/tool/Includes_Generaux/comp07.h b/src/tool/Includes_Generaux/comp07.h new file mode 100644 index 00000000..c8201bc4 --- /dev/null +++ b/src/tool/Includes_Generaux/comp07.h @@ -0,0 +1,6 @@ +c +c======================================================================= +c fonction entiere de complement a 7 : c + coen07(c) = 7 +c----------------------------------------------------------------------- + integer coen07(6) + common /comp07/ coen07 diff --git a/src/tool/Includes_Generaux/consta.h b/src/tool/Includes_Generaux/consta.h new file mode 100644 index 00000000..f5b60ad8 --- /dev/null +++ b/src/tool/Includes_Generaux/consta.h @@ -0,0 +1,17 @@ +c +c la liste qui suit concerne les constantes numeriques classiques. +c + double precision pi + parameter ( pi = 3.14159265358979d0 ) +c + double precision uns4pi, deuxpi + parameter ( uns4pi = 1.d0/(4.d0*pi) , deuxpi = 2.d0*pi ) +c +c double precision mu0 +c parameter ( mu0 = 4.d-7*pi ) +c +c double precision c0 +c parameter ( c0 = 2.9979d8 ) +c +c double precision epsil0 +c parameter ( epsil0 = 1.d0/(mu0*c0*c0) ) diff --git a/src/tool/Includes_Generaux/consts.h b/src/tool/Includes_Generaux/consts.h new file mode 100644 index 00000000..ebebd2df --- /dev/null +++ b/src/tool/Includes_Generaux/consts.h @@ -0,0 +1,25 @@ +c + character*08 blan08 + parameter ( blan08 = ' ' ) +c 12345678 +c + character*16 blan16 + parameter ( blan16 = ' ' ) +c 1234567890123456 +c + character*32 blan32 + parameter ( blan32 = ' ' ) +c 12345678901234567890123456789012 +c + character*64 blan64 + parameter ( blan64 = + >' ' + > ) +c 1234567890123456789012345678901234567890123456789012345678901234 +c + character*80 blan80 + parameter (blan80 = + >' '// + >' ' + > ) +c 1234567890123456789012345678901234567890 diff --git a/src/tool/Includes_Generaux/defiqu.h b/src/tool/Includes_Generaux/defiqu.h new file mode 100644 index 00000000..d8e5098b --- /dev/null +++ b/src/tool/Includes_Generaux/defiqu.h @@ -0,0 +1,5 @@ +c DEcalage des FIls d'un QUadrangle +c en fonction du code du pere dans l'hexaedre +c + integer defiq1(8), defiq2(8), defiq3(8), defiq4(8) + common /defiqu/ defiq1, defiq2, defiq3, defiq4 diff --git a/src/tool/Includes_Generaux/demitr.h b/src/tool/Includes_Generaux/demitr.h new file mode 100644 index 00000000..d04491c1 --- /dev/null +++ b/src/tool/Includes_Generaux/demitr.h @@ -0,0 +1,8 @@ +c +c======================================================================= +c fonction de numerotation des demi-triangles fils +c----------------------------------------------------------------------- +c nutrde(i,j) : i est le cote coupe, j est le cote ou on regarde +c----------------------------------------------------------------------- + integer nutrde(3,3) + common /demitr/ nutrde diff --git a/src/tool/Includes_Generaux/derco1.h b/src/tool/Includes_Generaux/derco1.h new file mode 100644 index 00000000..ee9c6b90 --- /dev/null +++ b/src/tool/Includes_Generaux/derco1.h @@ -0,0 +1,28 @@ +c + texte(1,11) = + >'(/,''. Prealable sur le deraffinement'',/,32(''=''),/)' + texte(1,12) = '(/,''. Niveau courant :'',i3,/,21(''=''),/)' + texte(1,13) = + >'(/,''. Ecart entre les niveaux'',i3,'' et'',i3,/,34(''=''),/)' + texte(1,15) = '(''. . rien a faire'')' + texte(1,21) = '(''. Pile de longueur'',i6,'' :'')' + texte(1,22) = '(''. . nbaret, nbare2 = '',3i2)' + texte(1,23) = + >'(''. . arete'',i10,'', de decision'',i3,'', de mere'',i10)' + texte(1,29) = + > '(''. '',a,i10,'', niveau'',i3,'', etat'',i5,'', decision'',i3)' + texte(1,30) = '(''. . ==> nouveau '',a,''('',i10,'') = '',i2,a)' +c + texte(2,11) = + >'(/,''. First operation for unrefinement'',/,34(''=''),/)' + texte(2,12) = '(/,''. Current level :'',i3,/,21(''=''),/)' + texte(2,13) = + >'(/,''. Shift between levels'',i3,'' and'',i3,/,32(''=''),/)' + texte(2,15) = '(''. . nothing to do'')' + texte(2,21) = '(''. Pile of length'',i6,'' :'')' + texte(2,22) = '(''. . nbaret, nbare2 = '',3i2)' + texte(2,23) = + > '(''. . edge #'',i10,'', decision'',i3,'', with mother #'',i10)' + texte(2,29) = + > '(''. '',a,i10,'', level'',i3,'', status'',i5,'', decision'',i3)' + texte(2,30) = '(''. . ==> new '',a,''('',i10,'') = '',i2,a)' diff --git a/src/tool/Includes_Generaux/dicfen.h b/src/tool/Includes_Generaux/dicfen.h new file mode 100644 index 00000000..87b76b7d --- /dev/null +++ b/src/tool/Includes_Generaux/dicfen.h @@ -0,0 +1,53 @@ +c +c======================================================================= +c dimensionnement des caracteristiques de familles d'entites +c----------------------------------------------------------------------- +c ncffno : nombre fige de caracteristiques de familles de noeuds +c ncffmp : nombre fige de caracteristiques de familles de mailles-points +c ncffar : nombre fige de caracteristiques de familles d'aretes +c ncfftr : nombre fige de caracteristiques de familles de triangles +c ncffqu : nombre fige de caracteristiques de familles de quadrangles +c ncffte : nombre fige de caracteristiques de familles de tetraedres +c ncffhe : nombre fige de caracteristiques de familles d'hexaedres +c ncffpy : nombre fige de caracteristiques de familles de pyramides +c ncffpe : nombre fige de caracteristiques de familles de pentaedres +c +c ncxfno : nombre de caract. d'extrusion dans les familles de noeuds +c ncxfar : nombre de caract. d'extrusion dans les familles d'aretes +c ncxftr : nombre de caract. d'extrusion dans les familles de tria. +c ncxfqu : nombre de caract. d'extrusion dans les familles de quad. +c +c ncefno : nombre de caract. d'equivalence dans les familles de noeuds +c ncefmp : nombre de caract. d'equivalence dans les familles de m.points +c ncefar : nombre de caract. d'equivalence dans les familles d'aretes +c nceftr : nombre de caract. d'equivalence dans les familles de tria. +c ncefqu : nombre de caract. d'equivalence dans les familles de quad. +c +c nctfno : nombre total de caracteristiques de familles de noeuds +c nctfmp : nombre total de caracteristiques de familles de noeuds +c nctfar : nombre total de caracteristiques de familles d'aretes +c nctftr : nombre total de caracteristiques de familles de triangles +c nctfqu : nombre total de caracteristiques de familles de quadrangles +c nctfte : nombre total de caracteristiques de familles de tetraedres +c nctfhe : nombre total de caracteristiques de familles d'hexaedres +c nctfpy : nombre total de caracteristiques de familles de pyramides +c nctfpe : nombre total de caracteristiques de familles de pentaedres +c----------------------------------------------------------------------- + integer ncffno, ncxfno, ncefno, nctfno, + > ncffmp, ncefmp, nctfmp, + > ncffar, ncxfar, ncefar, nctfar, + > ncfftr, ncxftr, nceftr, nctftr, + > ncffqu, ncxfqu, ncefqu, nctfqu, + > ncffte, nctfte, + > ncffhe, nctfhe, + > ncffpy, nctfpy, + > ncffpe, nctfpe + common /dicfen/ ncffno, ncxfno, ncefno, nctfno, + > ncffmp, ncefmp, nctfmp, + > ncffar, ncxfar, ncefar, nctfar, + > ncfftr, ncxftr, nceftr, nctftr, + > ncffqu, ncxfqu, ncefqu, nctfqu, + > ncffte, nctfte, + > ncffhe, nctfhe, + > ncffpy, nctfpy, + > ncffpe, nctfpe diff --git a/src/tool/Includes_Generaux/elmess.h b/src/tool/Includes_Generaux/elmess.h new file mode 100644 index 00000000..6f3f7ccd --- /dev/null +++ b/src/tool/Includes_Generaux/elmess.h @@ -0,0 +1,49 @@ +c 123456789012345678901234 + messag(1, 1) = 'noeuds ' + messag(1, 2) = 'mailles-points ' + messag(1, 3) = 'segments ' + messag(1, 4) = 'segments de degre 1 ' + messag(1, 5) = 'segments de degre 2 ' + messag(1, 6) = 'triangles ' + messag(1, 7) = 'triangles de degre 1 ' + messag(1, 8) = 'triangles de degre 2 ' + messag(1, 9) = 'quadrangles ' + messag(1,10) = 'quadrangles de degre 1 ' + messag(1,11) = 'quadrangles de degre 2 ' + messag(1,12) = 'tetraedres ' + messag(1,13) = 'tetraedres de degre 1 ' + messag(1,14) = 'tetraedres de degre 2 ' + messag(1,15) = 'hexaedres ' + messag(1,16) = 'hexaedres de degre 1 ' + messag(1,17) = 'hexaedres de degre 2 ' + messag(1,18) = 'pentaedres ' + messag(1,19) = 'pentaedres de degre 1 ' + messag(1,20) = 'pentaedres de degre 2 ' + messag(1,21) = 'pyramides ' + messag(1,22) = 'pyramides de degre 1 ' + messag(1,23) = 'pyramides de degre 2 ' +c + messag(2, 1) = 'nodes ' + messag(2, 2) = 'point-meshes ' + messag(2, 3) = 'bars ' + messag(2, 4) = 'linear bars ' + messag(2, 5) = 'quadratic bars ' + messag(2, 6) = 'triangles ' + messag(2, 7) = 'linear triangles ' + messag(2, 8) = 'quadratic triangles ' + messag(2, 9) = 'quadrilaterals ' + messag(2,10) = 'linear quadrilaterals ' + messag(2,11) = 'quadratic quadrilaterals' + messag(2,12) = 'tetraedra ' + messag(2,13) = 'linear tetraedra ' + messag(2,14) = 'quadratic tetraedra ' + messag(2,15) = 'hexaedra ' + messag(2,16) = 'linear hexaedra ' + messag(2,17) = 'quadratic hexaedra ' + messag(2,18) = 'pentaedra ' + messag(2,19) = 'linear pentaedra ' + messag(2,20) = 'linear pentaedra ' + messag(2,21) = 'pyramids ' + messag(2,22) = 'linear pyramids ' + messag(2,23) = 'quadratic pyramids ' +c diff --git a/src/tool/Includes_Generaux/elnmxm.h b/src/tool/Includes_Generaux/elnmxm.h new file mode 100644 index 00000000..fea551e0 --- /dev/null +++ b/src/tool/Includes_Generaux/elnmxm.h @@ -0,0 +1,4 @@ +c +c NomBre Maximum de Message de ReFerence + integer nbmmrf + parameter ( nbmmrf = 23 ) diff --git a/src/tool/Includes_Generaux/enti01.h b/src/tool/Includes_Generaux/enti01.h new file mode 100644 index 00000000..4c99cf54 --- /dev/null +++ b/src/tool/Includes_Generaux/enti01.h @@ -0,0 +1,2 @@ + character*8 suffix(4,-1:10) + common /enti01/ suffix diff --git a/src/tool/Includes_Generaux/envada.h b/src/tool/Includes_Generaux/envada.h new file mode 100644 index 00000000..2aba80ae --- /dev/null +++ b/src/tool/Includes_Generaux/envada.h @@ -0,0 +1,18 @@ +c +c======================================================================= +c environnement d'adaptation +c----------------------------------------------------------------------- +c nbiter : numero de l'adaptation, +c 0 : on en est au macro-maillage +c k : k adaptations ont ete faites +c nivinf : niveau inferieur present dans le maillage courant actif, en +c tenant compte seulement des decoupages standard +c nivsup : niveau superieur present dans le maillage courant, en +c tenant compte seulement des decoupages standard +c niincf : 10 fois le niveau inferieur present dans le maillage courant, +c en tenant compte des raccords de conformite. +c nisucf : 10 fois le niveau superieur present dans le maillage courant, +c en tenant compte des raccords de conformite. +c----------------------------------------------------------------------- + integer nbiter, nivinf, nivsup, niincf, nisucf + common /envada/ nbiter, nivinf, nivsup, niincf, nisucf diff --git a/src/tool/Includes_Generaux/envca1.h b/src/tool/Includes_Generaux/envca1.h new file mode 100644 index 00000000..2a7eb515 --- /dev/null +++ b/src/tool/Includes_Generaux/envca1.h @@ -0,0 +1,67 @@ +c +c======================================================================= +c environnement de calcul (premiere partie) +c cela correspond aux attributs de l'objet maillage HOMARD +c----------------------------------------------------------------------- +c sdim : dimension de l'espace (2 ou 3) +c mdim : dimension du maillage (1, 2 ou 3) +c degre : degre maximum d'interpolation des variables. +c maconf : conformite du maillage +c 0 : oui +c 1 : non-conforme avec 1 seule arete decoupee (en 2) +c 2 : non-conforme avec 1 seul noeud pendant par arete +c 3 : non-conforme sans contrainte +c 10 : non-conforme sans autre connaissance +c homolo : type de relations par homologues +c 0 : pas d'homologues +c 1 : relations sur les noeuds +c 2 : relations sur les noeuds et les aretes +c 3 : relations sur les noeuds, les aretes et les faces +c hierar : maillage hierarchique +c 0 : non +c 1 : oui +c rafdef : mode de raffinement/deraffinement avant le maillage +c 0 : macro-maillage +c 1 : le maillage est inchange +c 2 : le maillage est issu du raffinement pur +c d'un autre maillage +c 3 : le maillage est issu du deraffinement +c pur d'un autre maillage +c 4 : le maillage est issu de raffinement et +c de deraffinement d'un autre maillage +c 12 : le maillage est un maillage passe de degre 1 a 2 +c 21 : le maillage est un maillage passe de degre 2 a 1 +c nbmane : nombre maximum de noeuds par element +c typcca : type du code de calcul associe +c 6 : MED +c 16 : ATHENA (format MED) +c 26 : SATURNE_2D (format MED) +c 36 : SATURNE (format MED) +c 46 : NEPTUNE_2D (format MED) +c 56 : NEPTUNE (format MED) +c 66 : CARMEL_2D (format MED) +c 76 : CARMEL (format MED) +c 106 : NON-CONFORME (format MED) +c typsfr : type du suivi de frontiere +c 0 : aucun +c 1 : maillage de degre 1, avec projection des nouveaux sommets +c 2 : maillage de degre 2, seuls les noeuds P1 sont sur la +c frontiere ; les noeuds P2 restent au milieu des P1 +c 3 : maillage de degre 2, les noeuds P2 sont sur la frontiere +c maextr : maillage extrude +c 0 : non +c 1 : selon X +c 2 : selon Y +c 3 : selon Z +c mailet : presence de mailles etendues : +c 1 : aucune +c 2x : TRIA7 +c 3x : QUAD9 +c 5x : HEXA27 +c----------------------------------------------------------------------- + integer sdim, mdim, degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet + common /envca1/ sdim, mdim, degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet diff --git a/src/tool/Includes_Generaux/envca2.h b/src/tool/Includes_Generaux/envca2.h new file mode 100644 index 00000000..68e0823d --- /dev/null +++ b/src/tool/Includes_Generaux/envca2.h @@ -0,0 +1,10 @@ +c +c======================================================================= +c environnement de calcul (seconde partie) +c----------------------------------------------------------------------- +c ladate : date et heure de creation du maillage +c titre : titre du calcul +c----------------------------------------------------------------------- + character*48 ladate + character*80 titre + common /envca2/ ladate, titre diff --git a/src/tool/Includes_Generaux/envex1.h b/src/tool/Includes_Generaux/envex1.h new file mode 100644 index 00000000..5c5acb76 --- /dev/null +++ b/src/tool/Includes_Generaux/envex1.h @@ -0,0 +1,8 @@ +c +c======================================================================= +c environnement d'execution (seconde partie) +c----------------------------------------------------------------------- +c spropb : nom du sous-programme ou le plantage a eu lieu +c----------------------------------------------------------------------- + character*6 spropb + common /envex1/ spropb diff --git a/src/tool/Includes_Generaux/envex2.h b/src/tool/Includes_Generaux/envex2.h new file mode 100644 index 00000000..f4e64863 --- /dev/null +++ b/src/tool/Includes_Generaux/envex2.h @@ -0,0 +1,11 @@ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'DMFLSH', nompro +#endif + call dmflsh (iaux) +c +c 123456 + if ( spropb.eq.' ' ) then + spropb = nompro + write (ulsort,*) '===== HOMARD ===== STOP =====' + endif diff --git a/src/tool/Includes_Generaux/equiva.h b/src/tool/Includes_Generaux/equiva.h new file mode 100644 index 00000000..781f1cba --- /dev/null +++ b/src/tool/Includes_Generaux/equiva.h @@ -0,0 +1,8 @@ +c +c On trouve ici la liste des equivalences interdites de lecture +c + character*64 eqinte + parameter ( eqinte = + >'FACES_A_RECOLLER_APRES_HOMARD___________________________________' + > ) +c 1234567890123456789012345678901234567890123456789012345678901234 diff --git a/src/tool/Includes_Generaux/esimpr.h b/src/tool/Includes_Generaux/esimpr.h new file mode 100644 index 00000000..9386c9dd --- /dev/null +++ b/src/tool/Includes_Generaux/esimpr.h @@ -0,0 +1,241 @@ + texte(1,8) = + > '(''Problemes avec le fichier : '',a)' + texte(1,9) = + > '(''MFIOPE : ouverture du fichier impossible.'')' + texte(1,10) = + > '(''MFICLO : fermeture du fichier impossible.'')' + texte(1,11) = + > '(''EFSWIT : mise a jour imposible.'')' + texte(1,12) = + > '(''MMHMII : maillage inconnu : '',a)' + texte(1,13) = + > '(''MFDCRE : creation du champ '',a,'' impossible.'')' + texte(1,14) = + > '(''MFDRPR : ecriture du champ '',a,'' impossible.'')' + texte(1,15) = + > '(''MFDNFD : nombre de champs introuvable.'')' + texte(1,16) = + > '(''MFDFDI : nom du champ numero '',i4,'' introuvable.'')' + texte(1,17) = + > '(''Le nombre de valeurs du champ '',a,'' est introuvable.'')' + texte(1,18) = + > '(''MFDRPR : valeurs du champ '',a,'' illisibles.'')' + texte(1,19) = + > '(''MFDRPW : valeurs du champ '',a,'' impossibles a ecrire.'')' + texte(1,20) = + > '(''MMHNMH : nombre de maillages introuvable.'')' + texte(1,21) = + > '(5x,''Caracteristiques du maillage dans le fichier :'',/)' + texte(1,22) = + > '(8x,''Nom du maillage : '',a)' + texte(1,23) = + > '(8x,''Dimension '',a11, '' :'',i10)' + texte(1,24) = + > '(8x,''Nombre de noeuds :'',i10)' + texte(1,25) = + > '(8x,''Nombre de mailles :'',i10)' + texte(1,26) = + > '(8x,''. Nombre de '',a24,10x,'':'',i10)' + texte(1,27) = + > '(''Melange de degres :'',i9,'' en d1, '',i8,'' en d2.'')' + texte(1,28) = + > '(8x,''Le maillage est mode '',i5,'' au lieu de non structure'')' + texte(1,29) = + > '(/,8x,''Nombre de familles :'',i10)' + texte(1,31) = + > '(8x,'' . Nombre cumule de groupes :'',i10)' + texte(1,32) = '(''Champ MED : '',a)' + texte(1,33) = '(''Mauvais nombre de valeurs :'',i9)' + texte(1,34) = '(''Il en faut :'',i9)' + texte(1,35) = '(''Trop de type de fonctions.'')' + texte(1,36) = '(a,'' pour la fonction :'',i9)' + texte(1,37) = '(a,'' pour le champ :'',i9)' + texte(1,38) = '(a,'' pour le tableau :'',i9)' + texte(1,40) = '(''Il en faut 1 (ou -1) pour un indicateur.'')' + texte(1,41) = + > '(/,8x,''Nombre total d''''equivalences :'', + > i10)' + texte(1,42) = + > '(8x,''. Paires de '',a14,20x,'':'',i10)' + texte(1,46) = + > '(''Bibliotheque MED pour '',a,'' : '',a)' + texte(1,47) = + > '(''Descriptif :'',/,a)' + texte(1,51) = + > '(''Nom d''''objet MED : '',a)' + texte(1,52) = + > '(''Sa longeur vaut '',i3)' + texte(1,53) = + > '(''Cela depasse les'',i3,'' caracteres requis par MED.'')' + texte(1,54) = '(''Composante : '',a)' + texte(1,57) = '(''Nombre de points de Gauss :'',i9)' + texte(1,58) = '(''Nombre de valeurs :'',i9)' + texte(1,60) = '(''Type associe :'',i9)' + texte(1,61) = '(''Nom du profil : '',a)' + texte(1,62) = '(''Longueur du profil :'',i9)' + texte(1,63) = '(''Ce nombre doit etre positif.'')' + texte(1,64) = '(''Type geometrique MED :'',i9)' + texte(1,65) = '(''Champ standard'')' + texte(1,66) = '(''Champ aux noeuds par element'')' + texte(1,67) = + > '(''Champ aux points de Gauss avec champ aux noeuds par elt.'')' + texte(1,68) = '(''Champ aux points de Gauss'')' + texte(1,69) = '(''Type de champ reel/entier :'',i9)' + texte(1,70) = '(''Les valeurs sont introuvables :'')' + texte(1,71) = + > '(''. soit le champ n''''existe pas,'')' + texte(1,72) = + > '(''. soit le maillage support ne correspond pas,'')' + texte(1,73) = + > '(''. soit les valeurs de pas de temps sont incorrectes.'')' + texte(1,78) = '(''Code retour du programme '',a,'' :'',i10)' + texte(1,79) = '(''Probleme a la lecture.'')' + texte(1,80) = '(''Probleme a l''''ecriture.'')' + texte(1,81) = '(''Nom de la localisation : '',a)' + texte(1,82) = '(''Nombre de localisations : '',i3)' + texte(1,83) = '(''Objet de la localisation : '',a)' + texte(1,84) = '(''Objet du profil : '',a)' + texte(1,85) = '(''Nombre de composantes :'',i9)' + texte(1,86) = '(''Nombre de profils : '',i3)' + texte(1,90) = + > '(''Le pas de temps d''''interpolation n''''a pas ete choisi.'')' + texte(1,92) = '(''Aucun champ ne correspond dans le fichier.'')' + texte(1,93) = '(''Dernier numero de pas de temps.'')' + texte(1,94) = '(''Dernier numero d''''ordre.'')' + texte(1,95) = '(''Dernier instant.'')' + texte(1,96) = '(''Sur le maillage : '',a)' + texte(1,99) = '(/,''Toutes les mailles sont aplaties.'')' + texte(1,100) = '(''Type interpolation automatique.'')' + texte(1,101) = '(''Type interpolation P1.'')' + texte(1,102) = '(''Type interpolation P2.'')' + texte(1,103) = '(''Type interpolation iso-P2.'')' + texte(1,104) = '(''Type interpolation degre 1 vers 2.'')' + texte(1,105) = '(''Type interpolation degre 2 vers 1.'')' + texte(1,109) = '(''Type interpolation inconnu.'')' + texte(1,111) = '(''Nombre de sequences :'',i9)' + texte(1,112) = '(''Numero de sequence :'',i9)' + texte(1,113) = '(''Numero de pas de temps :'',i9)' + texte(1,114) = '(''Numero d''''iteration :'',i9)' + texte(1,115) = '(''Instant : '',g15.8)' + texte(1,116) = '(''Sans pas de temps'')' + texte(1,117) = '(''Nombre de fonctions P'',i1,'' :'',i9)' + texte(1,119) = '(''Champ correct.'')' +c + texte(2,8) = + > '(''Problem with the file : '',a)' + texte(2,9) = + > '(''MFIOPE : the file cannot be opened.'')' + texte(2,10) = + > '(''MFICLO : the file cannot be closed.'')' + texte(2,11) = + > '(''EFSWIT : updating cannot be done.'')' + texte(2,12) = + > '(''MMHMII : unknown mesh : '',a)' + texte(2,13) = + > '(''MFDCRE : creation of field '',a,'' failed.'')' + texte(2,14) = + > '(''MFDRPR : writing of field '',a,'' failed.'')' + texte(2,15) = + > '(''MFDNFD : number of fields cannot be found.'')' + texte(2,16) = + > '(''MFDFDI : name of field #'',i4,'' cannot be found.'')' + texte(2,17) = + >'(''The number of values of the field '',a,'' cannot be found.'')' + texte(2,18) = + > '(''MFDRPR : values of field '',a,'' cannot be read.'')' + texte(2,19) = + > '(''MFDRPR : values of field '',a,'' cannot be written.'')' + texte(2,20) = + > '(''MMHNMH : number of meshes cannot be found.'')' + texte(2,21) = + > '(5x,''Characteristics of the mesh on file :'',/)' + texte(2,22) = + > '(8x,''Name of the mesh : '',a)' + texte(2,23) = + > '(8x,''Dimension '',a11, '' :'',i10)' + texte(2,24) = + > '(8x,''Number of nodes :'',i10)' + texte(2,25) = + > '(8x,''Number of meshes :'',i10)' + texte(2,26) = + > '(8x,''. Number of '',a24,10x,'':'',i10)' + texte(2,27) = + > '(''Mix of degrees :'',i9,'' for d1, '',i8,'' for d2.'')' + texte(2,28) = + > '(8x,''Mesh is described in mode '',i5,'' instead of free.'')' + texte(2,29) = + > '(/,8x,''Number of families :'',i10)' + texte(2,31) = + > '(8x,'' . Number of groups :'',i10)' + texte(2,32) = '(''MED field : '',a)' + texte(2,33) = '(''Bad number of values :'',i9)' + texte(2,34) = '(i9,'' values are expected.'')' + texte(2,35) = '(''Too many kinds of functions.'')' + texte(2,36) = '(a,'' for the function #'',i9)' + texte(2,37) = '(a,'' for the field #'',i9)' + texte(2,38) = '(a,'' for the array #'',i9)' + texte(2,40) = '(''1 Gauss point (or -1) for indicator.'')' + texte(2,41) = + > '(/,8x,''Total number of equivalences :'',i10)' + texte(2,42) = + > '(8x,''. Pairs of '',a14,21x,'':'',i10)' + texte(2,46) = '(''MED library for '',a,'': '',a)' + texte(2,47) = + > '(''Description :'',/,a)' + texte(2,51) = + > '(''Name of the MED object : '',a)' + texte(2,52) = + > '(''Its length is '',i3)' + texte(2,53) = + > '(''It is greater than'',i3,'' characters of MED format.'')' + texte(2,54) = '(''Component : '',a)' + texte(2,57) = '(''Number of points of Gauss :'',i9)' + texte(2,58) = '(''Number of values :'',i9)' + texte(2,60) = '(''Associated type :'',i9)' + texte(2,61) = '(''Name of profile : '',a)' + texte(2,62) = '(''Length of profile :'',i9)' + texte(2,63) = '(''This number should be positive.'')' + texte(2,64) = '(''Geometric MED type :'',i9)' + texte(2,65) = '(''Standard field'')' + texte(2,66) = '(''On nodes by element field'')' + texte(2,67) = '(''On Gauss points field'')' + texte(2,67) = + > '(''On Gauss points field with on nodes by element field'')' + texte(2,68) = '(''On Gauss points field'')' + texte(2,69) = '(''Float/integer field :'',i9)' + texte(2,70) = '(''Values cannot be found :'')' + texte(2,71) = '(''. either the field does not exist,'')' + texte(2,72) = '(''. either the mesh is not the same,'')' + texte(2,73) = '(''. either the time step is uncorrect.'')' + texte(2,78) = '(''Error code of program '',a,'':'',i10)' + texte(2,79) = '(''Problem while reading.'')' + texte(2,80) = '(''Problem while writing.'')' + texte(2,81) = '(''Name of localization : '',a)' + texte(2,82) = '(''Number of localizations : '',i3)' + texte(2,83) = '(''Object of localization : '',a)' + texte(2,84) = '(''Object of profile : '',a)' + texte(2,85) = '(''Number of components :'',i9)' + texte(2,86) = '(''Number of profiles : '',i3)' + texte(2,90) = '(''Which time step ?'')' + texte(2,92) = '(''No field in the file.'')' + texte(2,93) = '(''Last time step.'')' + texte(2,94) = '(''Last rank.'')' + texte(2,95) = '(''Last instant.'')' + texte(2,96) = '(''Over the mesh : '',a)' + texte(2,99) = '(/,''All the meshes are flat.'')' + texte(2,100) = '(''Automatic interpolation.'')' + texte(2,101) = '(''P1 interpolation.'')' + texte(2,102) = '(''P2 interpolation.'')' + texte(2,103) = '(''iso-P2 interpolation.'')' + texte(2,104) = '(''Interpolation from degree 1 to 2.'')' + texte(2,105) = '(''Interpolation from degree 2 to 1.'')' + texte(2,109) = '(''Unknown interpolation.'')' + texte(2,111) = '(''Number of sequences :'',i9)' + texte(2,112) = '(''Sequence # :'',i9)' + texte(2,113) = '(''Time step :'',i9)' + texte(2,114) = '(''Rank :'',i9)' + texte(2,115) = '(''Instant : '',g15.8)' + texte(2,116) = '(''No time step'')' + texte(2,117) = '(''Number of P'',i1,'' functions:'',i9)' + texte(2,119) = '(''Correct field.'')' +c diff --git a/src/tool/Includes_Generaux/esutil.h b/src/tool/Includes_Generaux/esutil.h new file mode 100644 index 00000000..a18d57e6 --- /dev/null +++ b/src/tool/Includes_Generaux/esutil.h @@ -0,0 +1,12 @@ +c +c nombre maximal d'informations sur les champs +c +c entier +c + integer nbinec + parameter ( nbinec = 49 ) +c +c caractere +c + integer nbincc + parameter ( nbincc = 3 ) diff --git a/src/tool/Includes_Generaux/fahmed.h b/src/tool/Includes_Generaux/fahmed.h new file mode 100644 index 00000000..74f672d6 --- /dev/null +++ b/src/tool/Includes_Generaux/fahmed.h @@ -0,0 +1,15 @@ +c +c======================================================================= +c description des mailles de reference pour une connectivite a la med +c----------------------------------------------------------------------- +c nofmed : numero des faces dans les descriptions des mailles volumiques +c 1er champ : type HOMARD de la maille de reference +c 2eme champ : numero local de la face envisagee +c 3eme champ : 1 pour MED vers HOMARD, 2 pour HOMARD vers MED +c exemple pour un tetraedre : +c nofmed(3,2,1) : numero dans la description HOMARD de la 2eme +c face dans la description descendante MED +c----------------------------------------------------------------------- +c + integer nofmed(0:7,6,3) + common /fhomed/ nofmed diff --git a/src/tool/Includes_Generaux/fract0.h b/src/tool/Includes_Generaux/fract0.h new file mode 100644 index 00000000..12bea99c --- /dev/null +++ b/src/tool/Includes_Generaux/fract0.h @@ -0,0 +1,17 @@ +c +c la liste qui suit concerne les fractions atypiques +c + double precision unsonz + parameter ( unsonz = 1.d0/11.d0 ) +c + double precision unsdz + parameter ( unsdz = 1.d0/12.d0 ) +c + double precision unsqz + parameter ( unsqz = 1.d0/14.d0 ) +c + double precision unsdh + parameter ( unsdh = 1.d0/18.d0 ) +c + double precision cqs72 + parameter ( cqs72 = 5.d0/72.d0 ) diff --git a/src/tool/Includes_Generaux/fracta.h b/src/tool/Includes_Generaux/fracta.h new file mode 100644 index 00000000..e3d0aed6 --- /dev/null +++ b/src/tool/Includes_Generaux/fracta.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/2. +c + double precision unsde + parameter ( unsde = 0.5d0 ) +c + double precision trsde + parameter ( trsde = 1.5d0 ) diff --git a/src/tool/Includes_Generaux/fractb.h b/src/tool/Includes_Generaux/fractb.h new file mode 100644 index 00000000..e3b5cc4e --- /dev/null +++ b/src/tool/Includes_Generaux/fractb.h @@ -0,0 +1,11 @@ +c +c la liste qui suit concerne les fractions en x/3 +c + double precision unstr + parameter ( unstr = 1.d0/3.d0 ) +c + double precision destr + parameter ( destr = 2.d0/3.d0 ) +c + double precision qustr + parameter ( qustr = 4.d0/3.d0 ) diff --git a/src/tool/Includes_Generaux/fractc.h b/src/tool/Includes_Generaux/fractc.h new file mode 100644 index 00000000..028183d5 --- /dev/null +++ b/src/tool/Includes_Generaux/fractc.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/4 +c + double precision unsqu + parameter ( unsqu = 0.25d0 ) +c + double precision trsqu + parameter ( trsqu = 0.75d0 ) diff --git a/src/tool/Includes_Generaux/fractd.h b/src/tool/Includes_Generaux/fractd.h new file mode 100644 index 00000000..47d5c564 --- /dev/null +++ b/src/tool/Includes_Generaux/fractd.h @@ -0,0 +1,5 @@ +c +c la liste qui suit concerne les fractions en x/5 +c + double precision unscq + parameter ( unscq = 1.d0/5.d0 ) diff --git a/src/tool/Includes_Generaux/fracte.h b/src/tool/Includes_Generaux/fracte.h new file mode 100644 index 00000000..c2fb3cf2 --- /dev/null +++ b/src/tool/Includes_Generaux/fracte.h @@ -0,0 +1,5 @@ +c +c la liste qui suit concerne les fractions en x/6 +c + double precision unssix + parameter ( unssix = 1.d0/6.d0 ) diff --git a/src/tool/Includes_Generaux/fractf.h b/src/tool/Includes_Generaux/fractf.h new file mode 100644 index 00000000..dcedbbbe --- /dev/null +++ b/src/tool/Includes_Generaux/fractf.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/8 +c + double precision unshu + parameter ( unshu = 1.d0/8.d0 ) +c + double precision trshu + parameter ( trshu = 3.0d0/8.0d0 ) diff --git a/src/tool/Includes_Generaux/fractg.h b/src/tool/Includes_Generaux/fractg.h new file mode 100644 index 00000000..a8c19f73 --- /dev/null +++ b/src/tool/Includes_Generaux/fractg.h @@ -0,0 +1,14 @@ +c +c la liste qui suit concerne les fractions en x/16 +c + double precision unssz + parameter ( unssz = 1.0d0/16.0d0 ) +c + double precision trssz + parameter ( trssz = 3.0d0/16.0d0 ) +c + double precision cqssz + parameter ( cqssz = 5.0d0/16.0d0 ) +c + double precision nessz + parameter ( nessz = 9.0d0/16.0d0 ) diff --git a/src/tool/Includes_Generaux/fracth.h b/src/tool/Includes_Generaux/fracth.h new file mode 100644 index 00000000..1726c57a --- /dev/null +++ b/src/tool/Includes_Generaux/fracth.h @@ -0,0 +1,14 @@ +c +c la liste qui suit concerne les fractions en x/32 +c + double precision unstr2 + parameter ( unstr2 = 1.0d0/32.0d0 ) +c + double precision cqstr2 + parameter ( cqstr2 = 5.0d0/32.0d0 ) +c + double precision trstr2 + parameter ( trstr2 = 3.0d0/32.0d0 ) +c + double precision nfstr2 + parameter ( nfstr2 = 9.0d0/32.0d0 ) diff --git a/src/tool/Includes_Generaux/fracti.h b/src/tool/Includes_Generaux/fracti.h new file mode 100644 index 00000000..01fc3ef0 --- /dev/null +++ b/src/tool/Includes_Generaux/fracti.h @@ -0,0 +1,11 @@ +c +c la liste qui suit concerne les fractions en x/64 +c + double precision trst64 + parameter ( trst64 = 3.0d0/64.0d0 ) +c + double precision nfst64 + parameter ( nfst64 = 9.0d0/64.0d0 ) +c + double precision v7st64 + parameter ( v7st64 = 27.0d0/64.0d0 ) diff --git a/src/tool/Includes_Generaux/fractj.h b/src/tool/Includes_Generaux/fractj.h new file mode 100644 index 00000000..c899e153 --- /dev/null +++ b/src/tool/Includes_Generaux/fractj.h @@ -0,0 +1,11 @@ +c +c la liste qui suit concerne les fractions en x/128 +c + double precision ses128 + parameter ( ses128 = 7.0d0/128.0d0 ) +c + double precision qzs128 + parameter ( qzs128 = 15.0d0/128.0d0 ) +c + double precision v7s128 + parameter ( v7s128 = 27.0d0/128.0d0 ) diff --git a/src/tool/Includes_Generaux/fractk.h b/src/tool/Includes_Generaux/fractk.h new file mode 100644 index 00000000..831d0b25 --- /dev/null +++ b/src/tool/Includes_Generaux/fractk.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/9 +c + double precision unsne + parameter ( unsne = 1.d0/9.d0 ) +c + double precision desne + parameter ( desne = 2.d0/9.0d0 ) diff --git a/src/tool/Includes_Generaux/fractl.h b/src/tool/Includes_Generaux/fractl.h new file mode 100644 index 00000000..84699bf1 --- /dev/null +++ b/src/tool/Includes_Generaux/fractl.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/24 +c + double precision uns24 + parameter ( uns24 = 1.d0/24.d0 ) +c + double precision cqs24 + parameter ( cqs24 = 5.d0/24.d0 ) diff --git a/src/tool/Includes_Generaux/fractm.h b/src/tool/Includes_Generaux/fractm.h new file mode 100644 index 00000000..99cfff80 --- /dev/null +++ b/src/tool/Includes_Generaux/fractm.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/144 +c + double precision tz144 + parameter ( tz144 = 13.d0/144.d0 ) +c + double precision vc144 + parameter ( vc144 = 25.d0/144.d0 ) diff --git a/src/tool/Includes_Generaux/fractn.h b/src/tool/Includes_Generaux/fractn.h new file mode 100644 index 00000000..8328200f --- /dev/null +++ b/src/tool/Includes_Generaux/fractn.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/48 +c + double precision sts48 + parameter ( sts48 = 7.d0/48.d0 ) +c + double precision vcs48 + parameter ( vcs48 = 25.d0/48.d0 ) diff --git a/src/tool/Includes_Generaux/fracto.h b/src/tool/Includes_Generaux/fracto.h new file mode 100644 index 00000000..f59005ea --- /dev/null +++ b/src/tool/Includes_Generaux/fracto.h @@ -0,0 +1,8 @@ +c +c la liste qui suit concerne les fractions en x/36 +c + double precision uns36 + parameter ( uns36 = 1.d0/36.d0 ) +c + double precision sts36 + parameter ( sts36 = 7.d0/36.d0 ) diff --git a/src/tool/Includes_Generaux/front0.h b/src/tool/Includes_Generaux/front0.h new file mode 100644 index 00000000..f40cbebe --- /dev/null +++ b/src/tool/Includes_Generaux/front0.h @@ -0,0 +1,10 @@ +c +c======================================================================= +c front0 : reperage des frontieres pour la sortie +c----------------------------------------------------------------------- +c nrofro : numero global de la frontiere +c nrofrd : numero global pour chaque frontiere discrete +c nrofra : numero global pour chaque frontiere analytique +c----------------------------------------------------------------------- + integer nrofro, nrofrd(100), nrofra(100) + common /front0/ nrofro, nrofrd , nrofra diff --git a/src/tool/Includes_Generaux/front1.h b/src/tool/Includes_Generaux/front1.h new file mode 100644 index 00000000..277cb93b --- /dev/null +++ b/src/tool/Includes_Generaux/front1.h @@ -0,0 +1,12 @@ +c +c======================================================================= +c front1 : taille des tableaux de la geometrie de la frontiere +c----------------------------------------------------------------------- +c sfsdim : dimension de l'espace +c sfmdim : dimension du maillage +c sfnbso : nombre de sommets decrivant la frontiere +c sfnbli : nombre de lignes decrivant la frontiere +c sfnbse : taille du tableau contenant la suite des sommets des lignes +c----------------------------------------------------------------------- + integer sfsdim, sfmdim, sfnbso, sfnbli, sfnbse + common /front1/ sfsdim, sfmdim, sfnbso, sfnbli, sfnbse diff --git a/src/tool/Includes_Generaux/front2.h b/src/tool/Includes_Generaux/front2.h new file mode 100644 index 00000000..7a775295 --- /dev/null +++ b/src/tool/Includes_Generaux/front2.h @@ -0,0 +1,9 @@ +c +c======================================================================= +c front2 : lien maillage de calcul et frontiere discrete +c----------------------------------------------------------------------- +c mcnvnf : nombre veritable de noeuds sur la frontiere discrete +c mcnxnf : nombre maximal de noeuds sur la frontiere discrete +c----------------------------------------------------------------------- + integer mcnvnf, mcnxnf + common /front2/ mcnvnf, mcnxnf diff --git a/src/tool/Includes_Generaux/gedita.h b/src/tool/Includes_Generaux/gedita.h new file mode 100644 index 00000000..20cd203e --- /dev/null +++ b/src/tool/Includes_Generaux/gedita.h @@ -0,0 +1,4 @@ +c +c Ceci est le dimensionnement du tableau de gestion des gestionnaires +c + integer tabges(lgtage) diff --git a/src/tool/Includes_Generaux/gelggt.h b/src/tool/Includes_Generaux/gelggt.h new file mode 100644 index 00000000..c7cfbe4a --- /dev/null +++ b/src/tool/Includes_Generaux/gelggt.h @@ -0,0 +1,5 @@ +c +c lgtage : longueur du tableau de gestion des gestionnaires +c + integer lgtage + parameter ( lgtage = 4 ) diff --git a/src/tool/Includes_Generaux/genbla.h b/src/tool/Includes_Generaux/genbla.h new file mode 100644 index 00000000..9fc1cd7d --- /dev/null +++ b/src/tool/Includes_Generaux/genbla.h @@ -0,0 +1,5 @@ +c +c nblang = nombre maximum de langues autorisees dans les gestionnaires +c + integer nblang + parameter ( nblang = 2 ) diff --git a/src/tool/Includes_Generaux/gmenti.h b/src/tool/Includes_Generaux/gmenti.h new file mode 100644 index 00000000..5711c1a0 --- /dev/null +++ b/src/tool/Includes_Generaux/gmenti.h @@ -0,0 +1,13 @@ +c on passe a une longueur de 1000 pour Calibre 9 ????? +c +c======================================================================= +c place memoire pour les entiers +c----------------------------------------------------------------------- +c imem : tableau general en entier +c----------------------------------------------------------------------- +c + integer lgcomi + parameter ( lgcomi = 1000 ) +c + integer imem (lgcomi) + common /gmenti/ imem diff --git a/src/tool/Includes_Generaux/gmreel.h b/src/tool/Includes_Generaux/gmreel.h new file mode 100644 index 00000000..2e71167f --- /dev/null +++ b/src/tool/Includes_Generaux/gmreel.h @@ -0,0 +1,13 @@ +c on passe a une longueur de 1000 pour Calibre 9 ????? +c +c======================================================================= +c place memoire pour les reels +c----------------------------------------------------------------------- +c rmem : tableau general en reel +c----------------------------------------------------------------------- +c + integer lgcomr + parameter ( lgcomr = 1000 ) +c + double precision rmem (lgcomr) + common /gmreel/ rmem diff --git a/src/tool/Includes_Generaux/gmstri.h b/src/tool/Includes_Generaux/gmstri.h new file mode 100644 index 00000000..f97ee2f5 --- /dev/null +++ b/src/tool/Includes_Generaux/gmstri.h @@ -0,0 +1,13 @@ +c on passe a une longueur de 1000 pour Calibre 9 ????? +c +c======================================================================= +c place memoire pour les caracteres +c----------------------------------------------------------------------- +c smem : tableau general en character*8 +c----------------------------------------------------------------------- +c + integer lgcoms + parameter ( lgcoms = 1000 ) +c + character*8 smem (lgcoms) + common /gmstri/ smem diff --git a/src/tool/Includes_Generaux/hexcf0.h b/src/tool/Includes_Generaux/hexcf0.h new file mode 100644 index 00000000..678520a0 --- /dev/null +++ b/src/tool/Includes_Generaux/hexcf0.h @@ -0,0 +1,23 @@ +c + integer chnp1(0:4096) + integer chnar(0:4096) + integer chnpy(0:4096) + integer chnte(0:4096) + integer chnhe(0:4096) + integer chperm(0:4096) + integer chbirf(0:4096) + integer chetat(0:4096) + integer chtn2i(0:4096) + integer chbiet(0:1000) +c + common /hexcf0/ + > chnp1, + > chnar, + > chnpy, + > chnte, + > chnhe, + > chperm, + > chbirf, + > chetat, + > chtn2i, + > chbiet diff --git a/src/tool/Includes_Generaux/hexcf1.h b/src/tool/Includes_Generaux/hexcf1.h new file mode 100644 index 00000000..d569ed2d --- /dev/null +++ b/src/tool/Includes_Generaux/hexcf1.h @@ -0,0 +1,5 @@ +c + character*05 chclas(0:4096) + character*36 charde(0:4096) +c + common /hexcf1/ charde, chclas diff --git a/src/tool/Includes_Generaux/hexcf2.h b/src/tool/Includes_Generaux/hexcf2.h new file mode 100644 index 00000000..816b7b30 --- /dev/null +++ b/src/tool/Includes_Generaux/hexcf2.h @@ -0,0 +1,14968 @@ +c +c L'indice est le code 'binaire' du decoupage. Pour chaque numero local +c d'arete, on affecte 1 ou 0 selon que l'arete est decoupee ou non. +c Le code binaire est contruit par la somme des puissances de 2 selon +c l'ordre croissant des numeros d'aretes. Par exemple, si les aretes +c 1, 2 et 5 sont coupees, le code vaut 2**0 + 2**1 + 2**4 = 19 +c +c chnp1 : nombre de sommets a creer +c chnar : nombre d'aretes a creer +c chnpy : nombre de pyramides a creer +c chnte : nombre de tetraedres a creer +c chnhe : nombre d'hexaedres a creer +c chperm : code de la permutation pour aller sur la reference +c chbirf : code 'binaire' du decoupage de reference de la classe +c chetat : etat de l'hexaedre apres le decoupage +c chtn2i : type des noeuds P2 a interpoler +c charde : liste des aretes decoupees +c chclas : la classe d'equivalence concernee +c +c chbiet : code binaire pour un etat de l'hexaedre +c + do 12345 , iaux = 0 , 4096 + chnp1(iaux) = -1 + chnar(iaux) = -1 + chnpy(iaux) = -1 + chnte(iaux) = -1 + chnhe(iaux) = -1 + chperm(iaux) = -1 + chbirf(iaux) = -1 + chetat(iaux) = -1 + chtn2i(iaux) = -1 + charde(iaux) = ' ' +c 123456789012345678901234567890123456 + chclas(iaux) = ' ' +12345 continue + do 12346 , iaux = 0 , 1000 + chbiet(iaux) = -1 +12346 continue +c +c =========================================== +c hexaedre decoupe dont au moins un des fils est decoupe +c + chbiet(9) = 4095 +c +c =========================================== +c Classe d'equivalence 0-00 +c +c Pas de decoupage + chnp1 (0) = 0 + chnar (0) = 0 + chnpy (0) = 0 + chnte (0) = 0 + chnhe (0) = 0 + chperm (0) = 0 + chbirf (0) = 0 + chetat (0) = 0 + chtn2i (0) = 1 + chbiet (0) = 0 +c +c =========================================== +c Classe d'equivalence 1-00 +c +c Aretes coupees : 1 + chclas (1) = ' 1-00' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (1)(1:3) = ' 1' + chnp1 (1) = 0 + chnar (1) = 2 + chnpy (1) = 4 + chnte (1) = 0 + chnhe (1) = 0 + chperm (1) = 0 + chbirf (1) = 1 + chetat (1) = 11 + chtn2i (1) = 11 + chbiet (11) = 1 +c +c Aretes coupees : 2 + chclas (2) = ' 1-00' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (2)(1:3) = ' 2' + chnp1 (2) = 0 + chnar (2) = 2 + chnpy (2) = 4 + chnte (2) = 0 + chnhe (2) = 0 + chperm (2) = 330 + chbirf (2) = 1 + chetat (2) = 12 + chtn2i (2) = 11 + chbiet (12) = 2 +c +c Aretes coupees : 3 + chclas (4) = ' 1-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (4)(1:3) = ' 3' + chnp1 (4) = 0 + chnar (4) = 2 + chnpy (4) = 4 + chnte (4) = 0 + chnhe (4) = 0 + chperm (4) = 310 + chbirf (4) = 1 + chetat (4) = 13 + chtn2i (4) = 11 + chbiet (13) = 4 +c +c Aretes coupees : 4 + chclas (8) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0 + charde (8)(1:3) = ' 4' + chnp1 (8) = 0 + chnar (8) = 2 + chnpy (8) = 4 + chnte (8) = 0 + chnhe (8) = 0 + chperm (8) = 300 + chbirf (8) = 1 + chetat (8) = 14 + chtn2i (8) = 11 + chbiet (14) = 8 +c +c Aretes coupees : 5 + chclas (16) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (16)(1:3) = ' 5' + chnp1 (16) = 0 + chnar (16) = 2 + chnpy (16) = 4 + chnte (16) = 0 + chnhe (16) = 0 + chperm (16) = 30 + chbirf (16) = 1 + chetat (16) = 15 + chtn2i (16) = 11 + chbiet (15) = 16 +c +c Aretes coupees : 6 + chclas (32) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (32)(1:3) = ' 6' + chnp1 (32) = 0 + chnar (32) = 2 + chnpy (32) = 4 + chnte (32) = 0 + chnhe (32) = 0 + chperm (32) = 10 + chbirf (32) = 1 + chetat (32) = 16 + chtn2i (32) = 11 + chbiet (16) = 32 +c +c Aretes coupees : 7 + chclas (64) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (64)(1:3) = ' 7' + chnp1 (64) = 0 + chnar (64) = 2 + chnpy (64) = 4 + chnte (64) = 0 + chnhe (64) = 0 + chperm (64) = 230 + chbirf (64) = 1 + chetat (64) = 17 + chtn2i (64) = 11 + chbiet (17) = 64 +c +c Aretes coupees : 8 + chclas (128) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (128)(1:3) = ' 8' + chnp1 (128) = 0 + chnar (128) = 2 + chnpy (128) = 4 + chnte (128) = 0 + chnhe (128) = 0 + chperm (128) = 210 + chbirf (128) = 1 + chetat (128) = 18 + chtn2i (128) = 11 + chbiet (18) = 128 +c +c Aretes coupees : 9 + chclas (256) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (256)(1:3) = ' 9' + chnp1 (256) = 0 + chnar (256) = 2 + chnpy (256) = 4 + chnte (256) = 0 + chnhe (256) = 0 + chperm (256) = 100 + chbirf (256) = 1 + chetat (256) = 19 + chtn2i (256) = 11 + chbiet (19) = 256 +c +c Aretes coupees : 10 + chclas (512) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (512)(1:3) = ' 10' + chnp1 (512) = 0 + chnar (512) = 2 + chnpy (512) = 4 + chnte (512) = 0 + chnhe (512) = 0 + chperm (512) = 130 + chbirf (512) = 1 + chetat (512) = 20 + chtn2i (512) = 11 + chbiet (20) = 512 +c +c Aretes coupees : 11 + chclas (1024) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1024)(1:3) = ' 11' + chnp1 (1024) = 0 + chnar (1024) = 2 + chnpy (1024) = 4 + chnte (1024) = 0 + chnhe (1024) = 0 + chperm (1024) = 110 + chbirf (1024) = 1 + chetat (1024) = 21 + chtn2i (1024) = 11 + chbiet (21) = 1024 +c +c Aretes coupees : 12 + chclas (2048) = ' 1-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2048)(1:3) = ' 12' + chnp1 (2048) = 0 + chnar (2048) = 2 + chnpy (2048) = 4 + chnte (2048) = 0 + chnhe (2048) = 0 + chperm (2048) = 200 + chbirf (2048) = 1 + chetat (2048) = 22 + chtn2i (2048) = 11 + chbiet (22) = 2048 +c +c =========================================== +c Classe d'equivalence 2-00 +c +c Aretes coupees : 1 7 + chclas (65) = ' 2-00' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (65)(1:6) = ' 1 7' + chnp1 (65) = 1 + chnar (65) = 10 + chnpy (65) = 2 + chnte (65) = 12 + chnhe (65) = 0 + chperm (65) = 0 + chbirf (65) = 65 + chetat (65) = 23 + chtn2i (65) = 70 + chbiet (23) = 65 +c +c Aretes coupees : 1 11 + chclas (1025) = ' 2-00' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1025)(1:6) = ' 1 11' + chnp1 (1025) = 1 + chnar (1025) = 10 + chnpy (1025) = 2 + chnte (1025) = 12 + chnhe (1025) = 0 + chperm (1025) = 110 + chbirf (1025) = 65 + chetat (1025) = 24 + chtn2i (1025) = 70 + chbiet (24) = 1025 +c +c Aretes coupees : 2 8 + chclas (130) = ' 2-00' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (130)(1:6) = ' 2 8' + chnp1 (130) = 1 + chnar (130) = 10 + chnpy (130) = 2 + chnte (130) = 12 + chnhe (130) = 0 + chperm (130) = 1 + chbirf (130) = 65 + chetat (130) = 25 + chtn2i (130) = 70 + chbiet (25) = 130 +c +c Aretes coupees : 2 9 + chclas (258) = ' 2-00' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (258)(1:6) = ' 2 9' + chnp1 (258) = 1 + chnar (258) = 10 + chnpy (258) = 2 + chnte (258) = 12 + chnhe (258) = 0 + chperm (258) = 100 + chbirf (258) = 65 + chetat (258) = 26 + chtn2i (258) = 70 + chbiet (26) = 258 +c +c Aretes coupees : 3 5 + chclas (20) = ' 2-00' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (20)(1:6) = ' 3 5' + chnp1 (20) = 1 + chnar (20) = 10 + chnpy (20) = 2 + chnte (20) = 12 + chnhe (20) = 0 + chperm (20) = 101 + chbirf (20) = 65 + chetat (20) = 27 + chtn2i (20) = 70 + chbiet (27) = 20 +c +c Aretes coupees : 3 12 + chclas (2052) = ' 2-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2052)(1:6) = ' 3 12' + chnp1 (2052) = 1 + chnar (2052) = 10 + chnpy (2052) = 2 + chnte (2052) = 12 + chnhe (2052) = 0 + chperm (2052) = 310 + chbirf (2052) = 65 + chetat (2052) = 28 + chtn2i (2052) = 70 + chbiet (28) = 2052 +c +c Aretes coupees : 4 6 + chclas (40) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0 + charde (40)(1:6) = ' 4 6' + chnp1 (40) = 1 + chnar (40) = 10 + chnpy (40) = 2 + chnte (40) = 12 + chnhe (40) = 0 + chperm (40) = 10 + chbirf (40) = 65 + chetat (40) = 29 + chtn2i (40) = 70 + chbiet (29) = 40 +c +c Aretes coupees : 4 10 + chclas (520) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0 + charde (520)(1:6) = ' 4 10' + chnp1 (520) = 1 + chnar (520) = 10 + chnpy (520) = 2 + chnte (520) = 12 + chnhe (520) = 0 + chperm (520) = 300 + chbirf (520) = 65 + chetat (520) = 30 + chtn2i (520) = 70 + chbiet (30) = 520 +c +c Aretes coupees : 5 12 + chclas (2064) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2064)(1:6) = ' 5 12' + chnp1 (2064) = 1 + chnar (2064) = 10 + chnpy (2064) = 2 + chnte (2064) = 12 + chnhe (2064) = 0 + chperm (2064) = 200 + chbirf (2064) = 65 + chetat (2064) = 31 + chtn2i (2064) = 70 + chbiet (31) = 2064 +c +c Aretes coupees : 6 10 + chclas (544) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (544)(1:6) = ' 6 10' + chnp1 (544) = 1 + chnar (544) = 10 + chnpy (544) = 2 + chnte (544) = 12 + chnhe (544) = 0 + chperm (544) = 201 + chbirf (544) = 65 + chetat (544) = 32 + chtn2i (544) = 70 + chbiet (32) = 544 +c +c Aretes coupees : 7 11 + chclas (1088) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1088)(1:6) = ' 7 11' + chnp1 (1088) = 1 + chnar (1088) = 10 + chnpy (1088) = 2 + chnte (1088) = 12 + chnhe (1088) = 0 + chperm (1088) = 301 + chbirf (1088) = 65 + chetat (1088) = 33 + chtn2i (1088) = 70 + chbiet (33) = 1088 +c +c Aretes coupees : 8 9 + chclas (384) = ' 2-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (384)(1:6) = ' 8 9' + chnp1 (384) = 1 + chnar (384) = 10 + chnpy (384) = 2 + chnte (384) = 12 + chnhe (384) = 0 + chperm (384) = 210 + chbirf (384) = 65 + chetat (384) = 34 + chtn2i (384) = 70 + chbiet (34) = 384 +c +c =========================================== +c Classe d'equivalence 2-01 +c +c Aretes coupees : 1 8 + chclas (129) = ' 2-01' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (129)(1:6) = ' 1 8' + chnp1 (129) = 1 + chnar (129) = 10 + chnpy (129) = 2 + chnte (129) = 12 + chnhe (129) = 0 + chperm (129) = 0 + chbirf (129) = 129 + chetat (129) = 35 + chtn2i (129) = 70 + chbiet (35) = 129 +c +c Aretes coupees : 1 10 + chclas (513) = ' 2-01' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (513)(1:6) = ' 1 10' + chnp1 (513) = 1 + chnar (513) = 10 + chnpy (513) = 2 + chnte (513) = 12 + chnhe (513) = 0 + chperm (513) = 320 + chbirf (513) = 129 + chetat (513) = 36 + chtn2i (513) = 70 + chbiet (36) = 513 +c +c Aretes coupees : 2 6 + chclas (34) = ' 2-01' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (34)(1:6) = ' 2 6' + chnp1 (34) = 1 + chnar (34) = 10 + chnpy (34) = 2 + chnte (34) = 12 + chnhe (34) = 0 + chperm (34) = 1 + chbirf (34) = 129 + chetat (34) = 37 + chtn2i (34) = 70 + chbiet (37) = 34 +c +c Aretes coupees : 2 12 + chclas (2050) = ' 2-01' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2050)(1:6) = ' 2 12' + chnp1 (2050) = 1 + chnar (2050) = 10 + chnpy (2050) = 2 + chnte (2050) = 12 + chnhe (2050) = 0 + chperm (2050) = 120 + chbirf (2050) = 129 + chetat (2050) = 38 + chtn2i (2050) = 70 + chbiet (38) = 2050 +c +c Aretes coupees : 3 7 + chclas (68) = ' 2-01' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (68)(1:6) = ' 3 7' + chnp1 (68) = 1 + chnar (68) = 10 + chnpy (68) = 2 + chnte (68) = 12 + chnhe (68) = 0 + chperm (68) = 301 + chbirf (68) = 129 + chetat (68) = 39 + chtn2i (68) = 70 + chbiet (39) = 68 +c +c Aretes coupees : 3 9 + chclas (260) = ' 2-01' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (260)(1:6) = ' 3 9' + chnp1 (260) = 1 + chnar (260) = 10 + chnpy (260) = 2 + chnte (260) = 12 + chnhe (260) = 0 + chperm (260) = 100 + chbirf (260) = 129 + chetat (260) = 40 + chtn2i (260) = 70 + chbiet (40) = 260 +c +c Aretes coupees : 4 5 + chclas (24) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0 + charde (24)(1:6) = ' 4 5' + chnp1 (24) = 1 + chnar (24) = 10 + chnpy (24) = 2 + chnte (24) = 12 + chnhe (24) = 0 + chperm (24) = 220 + chbirf (24) = 129 + chetat (24) = 41 + chtn2i (24) = 70 + chbiet (41) = 24 +c +c Aretes coupees : 4 11 + chclas (1032) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1032)(1:6) = ' 4 11' + chnp1 (1032) = 1 + chnar (1032) = 10 + chnpy (1032) = 2 + chnte (1032) = 12 + chnhe (1032) = 0 + chperm (1032) = 300 + chbirf (1032) = 129 + chetat (1032) = 42 + chtn2i (1032) = 70 + chbiet (42) = 1032 +c +c Aretes coupees : 5 11 + chclas (1040) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1040)(1:6) = ' 5 11' + chnp1 (1040) = 1 + chnar (1040) = 10 + chnpy (1040) = 2 + chnte (1040) = 12 + chnhe (1040) = 0 + chperm (1040) = 101 + chbirf (1040) = 129 + chetat (1040) = 43 + chtn2i (1040) = 70 + chbiet (43) = 1040 +c +c Aretes coupees : 6 12 + chclas (2080) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2080)(1:6) = ' 6 12' + chnp1 (2080) = 1 + chnar (2080) = 10 + chnpy (2080) = 2 + chnte (2080) = 12 + chnhe (2080) = 0 + chperm (2080) = 200 + chbirf (2080) = 129 + chetat (2080) = 44 + chtn2i (2080) = 70 + chbiet (44) = 2080 +c +c Aretes coupees : 7 9 + chclas (320) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (320)(1:6) = ' 7 9' + chnp1 (320) = 1 + chnar (320) = 10 + chnpy (320) = 2 + chnte (320) = 12 + chnhe (320) = 0 + chperm (320) = 20 + chbirf (320) = 129 + chetat (320) = 45 + chtn2i (320) = 70 + chbiet (45) = 320 +c +c Aretes coupees : 8 10 + chclas (640) = ' 2-01' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (640)(1:6) = ' 8 10' + chnp1 (640) = 1 + chnar (640) = 10 + chnpy (640) = 2 + chnte (640) = 12 + chnhe (640) = 0 + chperm (640) = 201 + chbirf (640) = 129 + chetat (640) = 46 + chtn2i (640) = 70 + chbiet (46) = 640 +c +c =========================================== +c Classe d'equivalence 2-02 +c +c Aretes coupees : 1 12 + chclas (2049) = ' 2-02' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2049)(1:6) = ' 1 12' + chnp1 (2049) = 1 + chnar (2049) = 10 + chnpy (2049) = 2 + chnte (2049) = 12 + chnhe (2049) = 0 + chperm (2049) = 0 + chbirf (2049) = 2049 + chetat (2049) = 47 + chtn2i (2049) = 70 + chbiet (47) = 2049 +c +c Aretes coupees : 2 11 + chclas (1026) = ' 2-02' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1026)(1:6) = ' 2 11' + chnp1 (1026) = 1 + chnar (1026) = 10 + chnpy (1026) = 2 + chnte (1026) = 12 + chnhe (1026) = 0 + chperm (1026) = 110 + chbirf (1026) = 2049 + chetat (1026) = 48 + chtn2i (1026) = 70 + chbiet (48) = 1026 +c +c Aretes coupees : 3 10 + chclas (516) = ' 2-02' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (516)(1:6) = ' 3 10' + chnp1 (516) = 1 + chnar (516) = 10 + chnpy (516) = 2 + chnte (516) = 12 + chnhe (516) = 0 + chperm (516) = 310 + chbirf (516) = 2049 + chetat (516) = 49 + chtn2i (516) = 70 + chbiet (49) = 516 +c +c Aretes coupees : 4 9 + chclas (264) = ' 2-02' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0 + charde (264)(1:6) = ' 4 9' + chnp1 (264) = 1 + chnar (264) = 10 + chnpy (264) = 2 + chnte (264) = 12 + chnhe (264) = 0 + chperm (264) = 100 + chbirf (264) = 2049 + chetat (264) = 50 + chtn2i (264) = 70 + chbiet (50) = 264 +c +c Aretes coupees : 5 8 + chclas (144) = ' 2-02' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (144)(1:6) = ' 5 8' + chnp1 (144) = 1 + chnar (144) = 10 + chnpy (144) = 2 + chnte (144) = 12 + chnhe (144) = 0 + chperm (144) = 210 + chbirf (144) = 2049 + chetat (144) = 51 + chtn2i (144) = 70 + chbiet (51) = 144 +c +c Aretes coupees : 6 7 + chclas (96) = ' 2-02' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (96)(1:6) = ' 6 7' + chnp1 (96) = 1 + chnar (96) = 10 + chnpy (96) = 2 + chnte (96) = 12 + chnhe (96) = 0 + chperm (96) = 10 + chbirf (96) = 2049 + chetat (96) = 52 + chtn2i (96) = 70 + chbiet (52) = 96 +c +c =========================================== +c Classe d'equivalence 2-03 +c +c Aretes coupees : 1 2 + chclas (3) = ' 2-03' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (3)(1:6) = ' 1 2' + chnp1 (3) = 1 + chnar (3) = 11 + chnpy (3) = 6 + chnte (3) = 6 + chnhe (3) = 0 + chperm (3) = 0 + chbirf (3) = 3 + chetat (3) = 53 + chtn2i (3) = 210 + chbiet (53) = 3 +c +c Aretes coupees : 1 3 + chclas (5) = ' 2-03' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (5)(1:6) = ' 1 3' + chnp1 (5) = 1 + chnar (5) = 11 + chnpy (5) = 6 + chnte (5) = 6 + chnhe (5) = 0 + chperm (5) = 221 + chbirf (5) = 3 + chetat (5) = 54 + chtn2i (5) = 210 + chbiet (54) = 5 +c +c Aretes coupees : 1 5 + chclas (17) = ' 2-03' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (17)(1:6) = ' 1 5' + chnp1 (17) = 1 + chnar (17) = 11 + chnpy (17) = 6 + chnte (17) = 6 + chnhe (17) = 0 + chperm (17) = 101 + chbirf (17) = 3 + chetat (17) = 55 + chtn2i (17) = 210 + chbiet (55) = 17 +c +c Aretes coupees : 1 6 + chclas (33) = ' 2-03' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (33)(1:6) = ' 1 6' + chnp1 (33) = 1 + chnar (33) = 11 + chnpy (33) = 6 + chnte (33) = 6 + chnhe (33) = 0 + chperm (33) = 320 + chbirf (33) = 3 + chetat (33) = 56 + chtn2i (33) = 210 + chbiet (56) = 33 +c +c Aretes coupees : 2 4 + chclas (10) = ' 2-03' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0 + charde (10)(1:6) = ' 2 4' + chnp1 (10) = 1 + chnar (10) = 11 + chnpy (10) = 6 + chnte (10) = 6 + chnhe (10) = 0 + chperm (10) = 1 + chbirf (10) = 3 + chetat (10) = 57 + chtn2i (10) = 210 + chbiet (57) = 10 +c +c Aretes coupees : 2 5 + chclas (18) = ' 2-03' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (18)(1:6) = ' 2 5' + chnp1 (18) = 1 + chnar (18) = 11 + chnpy (18) = 6 + chnte (18) = 6 + chnhe (18) = 0 + chperm (18) = 330 + chbirf (18) = 3 + chetat (18) = 58 + chtn2i (18) = 210 + chbiet (58) = 18 +c +c Aretes coupees : 2 7 + chclas (66) = ' 2-03' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (66)(1:6) = ' 2 7' + chnp1 (66) = 1 + chnar (66) = 11 + chnpy (66) = 6 + chnte (66) = 6 + chnhe (66) = 0 + chperm (66) = 230 + chbirf (66) = 3 + chetat (66) = 59 + chtn2i (66) = 210 + chbiet (59) = 66 +c +c Aretes coupees : 3 4 + chclas (12) = ' 2-03' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 + charde (12)(1:6) = ' 3 4' + chnp1 (12) = 1 + chnar (12) = 11 + chnpy (12) = 6 + chnte (12) = 6 + chnhe (12) = 0 + chperm (12) = 220 + chbirf (12) = 3 + chetat (12) = 60 + chtn2i (12) = 210 + chbiet (60) = 12 +c +c Aretes coupees : 3 6 + chclas (36) = ' 2-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (36)(1:6) = ' 3 6' + chnp1 (36) = 1 + chnar (36) = 11 + chnpy (36) = 6 + chnte (36) = 6 + chnhe (36) = 0 + chperm (36) = 10 + chbirf (36) = 3 + chetat (36) = 61 + chtn2i (36) = 210 + chbiet (61) = 36 +c +c Aretes coupees : 3 8 + chclas (132) = ' 2-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (132)(1:6) = ' 3 8' + chnp1 (132) = 1 + chnar (132) = 11 + chnpy (132) = 6 + chnte (132) = 6 + chnhe (132) = 0 + chperm (132) = 310 + chbirf (132) = 3 + chetat (132) = 62 + chtn2i (132) = 210 + chbiet (62) = 132 +c +c Aretes coupees : 4 7 + chclas (72) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 + charde (72)(1:6) = ' 4 7' + chnp1 (72) = 1 + chnar (72) = 11 + chnpy (72) = 6 + chnte (72) = 6 + chnhe (72) = 0 + chperm (72) = 300 + chbirf (72) = 3 + chetat (72) = 63 + chtn2i (72) = 210 + chbiet (63) = 72 +c +c Aretes coupees : 4 8 + chclas (136) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0 + charde (136)(1:6) = ' 4 8' + chnp1 (136) = 1 + chnar (136) = 11 + chnpy (136) = 6 + chnte (136) = 6 + chnhe (136) = 0 + chperm (136) = 121 + chbirf (136) = 3 + chetat (136) = 64 + chtn2i (136) = 210 + chbiet (64) = 136 +c +c Aretes coupees : 5 9 + chclas (272) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0 + charde (272)(1:6) = ' 5 9' + chnp1 (272) = 1 + chnar (272) = 11 + chnpy (272) = 6 + chnte (272) = 6 + chnhe (272) = 0 + chperm (272) = 100 + chbirf (272) = 3 + chetat (272) = 65 + chtn2i (272) = 210 + chbiet (65) = 272 +c +c Aretes coupees : 5 10 + chclas (528) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0 + charde (528)(1:6) = ' 5 10' + chnp1 (528) = 1 + chnar (528) = 11 + chnpy (528) = 6 + chnte (528) = 6 + chnhe (528) = 0 + chperm (528) = 30 + chbirf (528) = 3 + chetat (528) = 66 + chtn2i (528) = 210 + chbiet (66) = 528 +c +c Aretes coupees : 6 9 + chclas (288) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0 + charde (288)(1:6) = ' 6 9' + chnp1 (288) = 1 + chnar (288) = 11 + chnpy (288) = 6 + chnte (288) = 6 + chnhe (288) = 0 + chperm (288) = 321 + chbirf (288) = 3 + chetat (288) = 67 + chtn2i (288) = 210 + chbiet (67) = 288 +c +c Aretes coupees : 6 11 + chclas (1056) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1056)(1:6) = ' 6 11' + chnp1 (1056) = 1 + chnar (1056) = 11 + chnpy (1056) = 6 + chnte (1056) = 6 + chnhe (1056) = 0 + chperm (1056) = 110 + chbirf (1056) = 3 + chetat (1056) = 68 + chtn2i (1056) = 210 + chbiet (68) = 1056 +c +c Aretes coupees : 7 10 + chclas (576) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0 + charde (576)(1:6) = ' 7 10' + chnp1 (576) = 1 + chnar (576) = 11 + chnpy (576) = 6 + chnte (576) = 6 + chnhe (576) = 0 + chperm (576) = 130 + chbirf (576) = 3 + chetat (576) = 69 + chtn2i (576) = 210 + chbiet (69) = 576 +c +c Aretes coupees : 7 12 + chclas (2112) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2112)(1:6) = ' 7 12' + chnp1 (2112) = 1 + chnar (2112) = 11 + chnpy (2112) = 6 + chnte (2112) = 6 + chnhe (2112) = 0 + chperm (2112) = 301 + chbirf (2112) = 3 + chetat (2112) = 70 + chtn2i (2112) = 210 + chbiet (70) = 2112 +c +c Aretes coupees : 8 11 + chclas (1152) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1152)(1:6) = ' 8 11' + chnp1 (1152) = 1 + chnar (1152) = 11 + chnpy (1152) = 6 + chnte (1152) = 6 + chnhe (1152) = 0 + chperm (1152) = 210 + chbirf (1152) = 3 + chetat (1152) = 71 + chtn2i (1152) = 210 + chbiet (71) = 1152 +c +c Aretes coupees : 8 12 + chclas (2176) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2176)(1:6) = ' 8 12' + chnp1 (2176) = 1 + chnar (2176) = 11 + chnpy (2176) = 6 + chnte (2176) = 6 + chnhe (2176) = 0 + chperm (2176) = 120 + chbirf (2176) = 3 + chetat (2176) = 72 + chtn2i (2176) = 210 + chbiet (72) = 2176 +c +c Aretes coupees : 9 10 + chclas (768) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (768)(1:6) = ' 9 10' + chnp1 (768) = 1 + chnar (768) = 11 + chnpy (768) = 6 + chnte (768) = 6 + chnhe (768) = 0 + chperm (768) = 201 + chbirf (768) = 3 + chetat (768) = 73 + chtn2i (768) = 210 + chbiet (73) = 768 +c +c Aretes coupees : 9 11 + chclas (1280) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1280)(1:6) = ' 9 11' + chnp1 (1280) = 1 + chnar (1280) = 11 + chnpy (1280) = 6 + chnte (1280) = 6 + chnhe (1280) = 0 + chperm (1280) = 20 + chbirf (1280) = 3 + chetat (1280) = 74 + chtn2i (1280) = 210 + chbiet (74) = 1280 +c +c Aretes coupees : 10 12 + chclas (2560) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2560)(1:6) = ' 10 12' + chnp1 (2560) = 1 + chnar (2560) = 11 + chnpy (2560) = 6 + chnte (2560) = 6 + chnhe (2560) = 0 + chperm (2560) = 200 + chbirf (2560) = 3 + chetat (2560) = 75 + chtn2i (2560) = 210 + chbiet (75) = 2560 +c +c Aretes coupees : 11 12 + chclas (3072) = ' 2-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3072)(1:6) = ' 11 12' + chnp1 (3072) = 1 + chnar (3072) = 11 + chnpy (3072) = 6 + chnte (3072) = 6 + chnhe (3072) = 0 + chperm (3072) = 21 + chbirf (3072) = 3 + chetat (3072) = 76 + chtn2i (3072) = 210 + chbiet (76) = 3072 +c +c =========================================== +c Classe d'equivalence 2-04 +c +c Aretes coupees : 1 4 + chclas (9) = ' 2-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0 + charde (9)(1:6) = ' 1 4' + chnp1 (9) = 1 + chnar (9) = 10 + chnpy (9) = 5 + chnte (9) = 6 + chnhe (9) = 0 + chperm (9) = 0 + chbirf (9) = 9 + chetat (9) = 77 + chtn2i (9) = 10 + chbiet (77) = 9 +c +c Aretes coupees : 1 9 + chclas (257) = ' 2-04' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (257)(1:6) = ' 1 9' + chnp1 (257) = 1 + chnar (257) = 10 + chnpy (257) = 5 + chnte (257) = 6 + chnhe (257) = 0 + chperm (257) = 100 + chbirf (257) = 9 + chetat (257) = 78 + chtn2i (257) = 10 + chbiet (78) = 257 +c +c Aretes coupees : 2 3 + chclas (6) = ' 2-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 + charde (6)(1:6) = ' 2 3' + chnp1 (6) = 1 + chnar (6) = 10 + chnpy (6) = 5 + chnte (6) = 6 + chnhe (6) = 0 + chperm (6) = 1 + chbirf (6) = 9 + chetat (6) = 79 + chtn2i (6) = 10 + chbiet (79) = 6 +c +c Aretes coupees : 2 10 + chclas (514) = ' 2-04' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (514)(1:6) = ' 2 10' + chnp1 (514) = 1 + chnar (514) = 10 + chnpy (514) = 5 + chnte (514) = 6 + chnhe (514) = 0 + chperm (514) = 130 + chbirf (514) = 9 + chetat (514) = 80 + chtn2i (514) = 10 + chbiet (80) = 514 +c +c Aretes coupees : 3 11 + chclas (1028) = ' 2-04' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1028)(1:6) = ' 3 11' + chnp1 (1028) = 1 + chnar (1028) = 10 + chnpy (1028) = 5 + chnte (1028) = 6 + chnhe (1028) = 0 + chperm (1028) = 110 + chbirf (1028) = 9 + chetat (1028) = 81 + chtn2i (1028) = 10 + chbiet (81) = 1028 +c +c Aretes coupees : 4 12 + chclas (2056) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2056)(1:6) = ' 4 12' + chnp1 (2056) = 1 + chnar (2056) = 10 + chnpy (2056) = 5 + chnte (2056) = 6 + chnhe (2056) = 0 + chperm (2056) = 300 + chbirf (2056) = 9 + chetat (2056) = 82 + chtn2i (2056) = 10 + chbiet (82) = 2056 +c +c Aretes coupees : 5 6 + chclas (48) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0 + charde (48)(1:6) = ' 5 6' + chnp1 (48) = 1 + chnar (48) = 10 + chnpy (48) = 5 + chnte (48) = 6 + chnhe (48) = 0 + chperm (48) = 101 + chbirf (48) = 9 + chetat (48) = 83 + chtn2i (48) = 10 + chbiet (83) = 48 +c +c Aretes coupees : 5 7 + chclas (80) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 + charde (80)(1:6) = ' 5 7' + chnp1 (80) = 1 + chnar (80) = 10 + chnpy (80) = 5 + chnte (80) = 6 + chnhe (80) = 0 + chperm (80) = 30 + chbirf (80) = 9 + chetat (80) = 84 + chtn2i (80) = 10 + chbiet (84) = 80 +c +c Aretes coupees : 6 8 + chclas (160) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 + charde (160)(1:6) = ' 6 8' + chnp1 (160) = 1 + chnar (160) = 10 + chnpy (160) = 5 + chnte (160) = 6 + chnhe (160) = 0 + chperm (160) = 10 + chbirf (160) = 9 + chetat (160) = 85 + chtn2i (160) = 10 + chbiet (85) = 160 +c +c Aretes coupees : 7 8 + chclas (192) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (192)(1:6) = ' 7 8' + chnp1 (192) = 1 + chnar (192) = 10 + chnpy (192) = 5 + chnte (192) = 6 + chnhe (192) = 0 + chperm (192) = 301 + chbirf (192) = 9 + chetat (192) = 86 + chtn2i (192) = 10 + chbiet (86) = 192 +c +c Aretes coupees : 9 12 + chclas (2304) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2304)(1:6) = ' 9 12' + chnp1 (2304) = 1 + chnar (2304) = 10 + chnpy (2304) = 5 + chnte (2304) = 6 + chnhe (2304) = 0 + chperm (2304) = 200 + chbirf (2304) = 9 + chetat (2304) = 87 + chtn2i (2304) = 10 + chbiet (87) = 2304 +c +c Aretes coupees : 10 11 + chclas (1536) = ' 2-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1536)(1:6) = ' 10 11' + chnp1 (1536) = 1 + chnar (1536) = 10 + chnpy (1536) = 5 + chnte (1536) = 6 + chnhe (1536) = 0 + chperm (1536) = 201 + chbirf (1536) = 9 + chetat (1536) = 88 + chtn2i (1536) = 10 + chbiet (88) = 1536 +c +c =========================================== +c Classe d'equivalence 3-00 +c +c Aretes coupees : 1 7 11 + chclas (1089) = ' 3-00' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1089)(1:9) = ' 1 7 11' + chnp1 (1089) = 1 + chnar (1089) = 11 + chnpy (1089) = 0 + chnte (1089) = 18 + chnhe (1089) = 0 + chperm (1089) = 0 + chbirf (1089) = 1089 + chetat (1089) = 89 + chtn2i (1089) = 70 + chbiet (89) = 1089 +c +c Aretes coupees : 2 8 9 + chclas (386) = ' 3-00' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (386)(1:9) = ' 2 8 9' + chnp1 (386) = 1 + chnar (386) = 11 + chnpy (386) = 0 + chnte (386) = 18 + chnhe (386) = 0 + chperm (386) = 100 + chbirf (386) = 1089 + chetat (386) = 90 + chtn2i (386) = 70 + chbiet (90) = 386 +c +c Aretes coupees : 3 5 12 + chclas (2068) = ' 3-00' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2068)(1:9) = ' 3 5 12' + chnp1 (2068) = 1 + chnar (2068) = 11 + chnpy (2068) = 0 + chnte (2068) = 18 + chnhe (2068) = 0 + chperm (2068) = 200 + chbirf (2068) = 1089 + chetat (2068) = 91 + chtn2i (2068) = 70 + chbiet (91) = 2068 +c +c Aretes coupees : 4 6 10 + chclas (552) = ' 3-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0 + charde (552)(1:9) = ' 4 6 10' + chnp1 (552) = 1 + chnar (552) = 11 + chnpy (552) = 0 + chnte (552) = 18 + chnhe (552) = 0 + chperm (552) = 300 + chbirf (552) = 1089 + chetat (552) = 92 + chtn2i (552) = 70 + chbiet (92) = 552 +c +c =========================================== +c Classe d'equivalence 3-01 +c +c Aretes coupees : 1 8 10 + chclas (641) = ' 3-01' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (641)(1:9) = ' 1 8 10' + chnp1 (641) = 1 + chnar (641) = 11 + chnpy (641) = 0 + chnte (641) = 18 + chnhe (641) = 0 + chperm (641) = 0 + chbirf (641) = 641 + chetat (641) = 93 + chtn2i (641) = 70 + chbiet (93) = 641 +c +c Aretes coupees : 2 6 12 + chclas (2082) = ' 3-01' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2082)(1:9) = ' 2 6 12' + chnp1 (2082) = 1 + chnar (2082) = 11 + chnpy (2082) = 0 + chnte (2082) = 18 + chnhe (2082) = 0 + chperm (2082) = 200 + chbirf (2082) = 641 + chetat (2082) = 94 + chtn2i (2082) = 70 + chbiet (94) = 2082 +c +c Aretes coupees : 3 7 9 + chclas (324) = ' 3-01' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (324)(1:9) = ' 3 7 9' + chnp1 (324) = 1 + chnar (324) = 11 + chnpy (324) = 0 + chnte (324) = 18 + chnhe (324) = 0 + chperm (324) = 100 + chbirf (324) = 641 + chetat (324) = 95 + chtn2i (324) = 70 + chbiet (95) = 324 +c +c Aretes coupees : 4 5 11 + chclas (1048) = ' 3-01' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1048)(1:9) = ' 4 5 11' + chnp1 (1048) = 1 + chnar (1048) = 11 + chnpy (1048) = 0 + chnte (1048) = 18 + chnhe (1048) = 0 + chperm (1048) = 300 + chbirf (1048) = 641 + chetat (1048) = 96 + chtn2i (1048) = 70 + chbiet (96) = 1048 +c +c =========================================== +c Classe d'equivalence 3-02 +c +c Aretes coupees : 1 2 5 + chclas (19) = ' 3-02' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (19)(1:9) = ' 1 2 5' + chnp1 (19) = 1 + chnar (19) = 14 + chnpy (19) = 12 + chnte (19) = 0 + chnhe (19) = 0 + chperm (19) = 0 + chbirf (19) = 19 + chetat (19) = 97 + chtn2i (19) = 210 + chbiet (97) = 19 +c +c Aretes coupees : 1 3 6 + chclas (37) = ' 3-02' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (37)(1:9) = ' 1 3 6' + chnp1 (37) = 1 + chnar (37) = 14 + chnpy (37) = 12 + chnte (37) = 0 + chnhe (37) = 0 + chperm (37) = 10 + chbirf (37) = 19 + chetat (37) = 98 + chtn2i (37) = 210 + chbiet (98) = 37 +c +c Aretes coupees : 2 4 7 + chclas (74) = ' 3-02' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 + charde (74)(1:9) = ' 2 4 7' + chnp1 (74) = 1 + chnar (74) = 14 + chnpy (74) = 12 + chnte (74) = 0 + chnhe (74) = 0 + chperm (74) = 300 + chbirf (74) = 19 + chetat (74) = 99 + chtn2i (74) = 210 + chbiet (99) = 74 +c +c Aretes coupees : 3 4 8 + chclas (140) = ' 3-02' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0 + charde (140)(1:9) = ' 3 4 8' + chnp1 (140) = 1 + chnar (140) = 14 + chnpy (140) = 12 + chnte (140) = 0 + chnhe (140) = 0 + chperm (140) = 310 + chbirf (140) = 19 + chetat (140) = 100 + chtn2i (140) = 210 + chbiet (100) = 140 +c +c Aretes coupees : 5 9 10 + chclas (784) = ' 3-02' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0 + charde (784)(1:9) = ' 5 9 10' + chnp1 (784) = 1 + chnar (784) = 14 + chnpy (784) = 12 + chnte (784) = 0 + chnhe (784) = 0 + chperm (784) = 100 + chbirf (784) = 19 + chetat (784) = 101 + chtn2i (784) = 210 + chbiet (101) = 784 +c +c Aretes coupees : 6 9 11 + chclas (1312) = ' 3-02' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0 + charde (1312)(1:9) = ' 6 9 11' + chnp1 (1312) = 1 + chnar (1312) = 14 + chnpy (1312) = 12 + chnte (1312) = 0 + chnhe (1312) = 0 + chperm (1312) = 110 + chbirf (1312) = 19 + chetat (1312) = 102 + chtn2i (1312) = 210 + chbiet (102) = 1312 +c +c Aretes coupees : 7 10 12 + chclas (2624) = ' 3-02' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1 + charde (2624)(1:9) = ' 7 10 12' + chnp1 (2624) = 1 + chnar (2624) = 14 + chnpy (2624) = 12 + chnte (2624) = 0 + chnhe (2624) = 0 + chperm (2624) = 200 + chbirf (2624) = 19 + chetat (2624) = 103 + chtn2i (2624) = 210 + chbiet (103) = 2624 +c +c Aretes coupees : 8 11 12 + chclas (3200) = ' 3-02' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1 + charde (3200)(1:9) = ' 8 11 12' + chnp1 (3200) = 1 + chnar (3200) = 14 + chnpy (3200) = 12 + chnte (3200) = 0 + chnhe (3200) = 0 + chperm (3200) = 210 + chbirf (3200) = 19 + chetat (3200) = 104 + chtn2i (3200) = 210 + chbiet (104) = 3200 +c +c =========================================== +c Classe d'equivalence 3-03 +c +c Aretes coupees : 1 2 9 + chclas (259) = ' 3-03' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (259)(1:9) = ' 1 2 9' + chnp1 (259) = 1 + chnar (259) = 12 + chnpy (259) = 7 + chnte (259) = 6 + chnhe (259) = 0 + chperm (259) = 0 + chbirf (259) = 259 + chetat (259) = 105 + chtn2i (259) = 210 + chbiet (105) = 259 +c +c Aretes coupees : 1 3 11 + chclas (1029) = ' 3-03' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1029)(1:9) = ' 1 3 11' + chnp1 (1029) = 1 + chnar (1029) = 12 + chnpy (1029) = 7 + chnte (1029) = 6 + chnhe (1029) = 0 + chperm (1029) = 221 + chbirf (1029) = 259 + chetat (1029) = 106 + chtn2i (1029) = 210 + chbiet (106) = 1029 +c +c Aretes coupees : 1 4 6 + chclas (41) = ' 3-03' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0 + charde (41)(1:9) = ' 1 4 6' + chnp1 (41) = 1 + chnar (41) = 12 + chnpy (41) = 7 + chnte (41) = 6 + chnhe (41) = 0 + chperm (41) = 320 + chbirf (41) = 259 + chetat (41) = 107 + chtn2i (41) = 210 + chbiet (107) = 41 +c +c Aretes coupees : 1 4 7 + chclas (73) = ' 3-03' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 + charde (73)(1:9) = ' 1 4 7' + chnp1 (73) = 1 + chnar (73) = 12 + chnpy (73) = 7 + chnte (73) = 6 + chnhe (73) = 0 + chperm (73) = 300 + chbirf (73) = 259 + chetat (73) = 108 + chtn2i (73) = 210 + chbiet (108) = 73 +c +c Aretes coupees : 1 5 7 + chclas (81) = ' 3-03' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 + charde (81)(1:9) = ' 1 5 7' + chnp1 (81) = 1 + chnar (81) = 12 + chnpy (81) = 7 + chnte (81) = 6 + chnhe (81) = 0 + chperm (81) = 101 + chbirf (81) = 259 + chetat (81) = 109 + chtn2i (81) = 210 + chbiet (109) = 81 +c +c Aretes coupees : 1 9 11 + chclas (1281) = ' 3-03' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1281)(1:9) = ' 1 9 11' + chnp1 (1281) = 1 + chnar (1281) = 12 + chnpy (1281) = 7 + chnte (1281) = 6 + chnhe (1281) = 0 + chperm (1281) = 20 + chbirf (1281) = 259 + chetat (1281) = 110 + chtn2i (1281) = 210 + chbiet (110) = 1281 +c +c Aretes coupees : 2 3 5 + chclas (22) = ' 3-03' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (22)(1:9) = ' 2 3 5' + chnp1 (22) = 1 + chnar (22) = 12 + chnpy (22) = 7 + chnte (22) = 6 + chnhe (22) = 0 + chperm (22) = 330 + chbirf (22) = 259 + chetat (22) = 111 + chtn2i (22) = 210 + chbiet (111) = 22 +c +c Aretes coupees : 2 3 8 + chclas (134) = ' 3-03' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (134)(1:9) = ' 2 3 8' + chnp1 (134) = 1 + chnar (134) = 12 + chnpy (134) = 7 + chnte (134) = 6 + chnhe (134) = 0 + chperm (134) = 310 + chbirf (134) = 259 + chetat (134) = 112 + chtn2i (134) = 210 + chbiet (112) = 134 +c +c Aretes coupees : 2 4 10 + chclas (522) = ' 3-03' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0 + charde (522)(1:9) = ' 2 4 10' + chnp1 (522) = 1 + chnar (522) = 12 + chnpy (522) = 7 + chnte (522) = 6 + chnhe (522) = 0 + chperm (522) = 1 + chbirf (522) = 259 + chetat (522) = 113 + chtn2i (522) = 210 + chbiet (113) = 522 +c +c Aretes coupees : 2 7 8 + chclas (194) = ' 3-03' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (194)(1:9) = ' 2 7 8' + chnp1 (194) = 1 + chnar (194) = 12 + chnpy (194) = 7 + chnte (194) = 6 + chnhe (194) = 0 + chperm (194) = 230 + chbirf (194) = 259 + chetat (194) = 114 + chtn2i (194) = 210 + chbiet (114) = 194 +c +c Aretes coupees : 2 9 10 + chclas (770) = ' 3-03' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (770)(1:9) = ' 2 9 10' + chnp1 (770) = 1 + chnar (770) = 12 + chnpy (770) = 7 + chnte (770) = 6 + chnhe (770) = 0 + chperm (770) = 201 + chbirf (770) = 259 + chetat (770) = 115 + chtn2i (770) = 210 + chbiet (115) = 770 +c +c Aretes coupees : 3 4 12 + chclas (2060) = ' 3-03' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2060)(1:9) = ' 3 4 12' + chnp1 (2060) = 1 + chnar (2060) = 12 + chnpy (2060) = 7 + chnte (2060) = 6 + chnhe (2060) = 0 + chperm (2060) = 220 + chbirf (2060) = 259 + chetat (2060) = 116 + chtn2i (2060) = 210 + chbiet (116) = 2060 +c +c Aretes coupees : 3 5 6 + chclas (52) = ' 3-03' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 + charde (52)(1:9) = ' 3 5 6' + chnp1 (52) = 1 + chnar (52) = 12 + chnpy (52) = 7 + chnte (52) = 6 + chnhe (52) = 0 + chperm (52) = 10 + chbirf (52) = 259 + chetat (52) = 117 + chtn2i (52) = 210 + chbiet (117) = 52 +c +c Aretes coupees : 3 11 12 + chclas (3076) = ' 3-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3076)(1:9) = ' 3 11 12' + chnp1 (3076) = 1 + chnar (3076) = 12 + chnpy (3076) = 7 + chnte (3076) = 6 + chnhe (3076) = 0 + chperm (3076) = 21 + chbirf (3076) = 259 + chetat (3076) = 118 + chtn2i (3076) = 210 + chbiet (118) = 3076 +c +c Aretes coupees : 4 6 8 + chclas (168) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0 + charde (168)(1:9) = ' 4 6 8' + chnp1 (168) = 1 + chnar (168) = 12 + chnpy (168) = 7 + chnte (168) = 6 + chnhe (168) = 0 + chperm (168) = 121 + chbirf (168) = 259 + chetat (168) = 119 + chtn2i (168) = 210 + chbiet (119) = 168 +c +c Aretes coupees : 4 10 12 + chclas (2568) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2568)(1:9) = ' 4 10 12' + chnp1 (2568) = 1 + chnar (2568) = 12 + chnpy (2568) = 7 + chnte (2568) = 6 + chnhe (2568) = 0 + chperm (2568) = 200 + chbirf (2568) = 259 + chetat (2568) = 120 + chtn2i (2568) = 210 + chbiet (120) = 2568 +c +c Aretes coupees : 5 6 10 + chclas (560) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0 + charde (560)(1:9) = ' 5 6 10' + chnp1 (560) = 1 + chnar (560) = 12 + chnpy (560) = 7 + chnte (560) = 6 + chnhe (560) = 0 + chperm (560) = 30 + chbirf (560) = 259 + chetat (560) = 121 + chtn2i (560) = 210 + chbiet (121) = 560 +c +c Aretes coupees : 5 7 12 + chclas (2128) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1 + charde (2128)(1:9) = ' 5 7 12' + chnp1 (2128) = 1 + chnar (2128) = 12 + chnpy (2128) = 7 + chnte (2128) = 6 + chnhe (2128) = 0 + chperm (2128) = 301 + chbirf (2128) = 259 + chetat (2128) = 122 + chtn2i (2128) = 210 + chbiet (122) = 2128 +c +c Aretes coupees : 5 9 12 + chclas (2320) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2320)(1:9) = ' 5 9 12' + chnp1 (2320) = 1 + chnar (2320) = 12 + chnpy (2320) = 7 + chnte (2320) = 6 + chnhe (2320) = 0 + chperm (2320) = 100 + chbirf (2320) = 259 + chetat (2320) = 123 + chtn2i (2320) = 210 + chbiet (123) = 2320 +c +c Aretes coupees : 6 8 9 + chclas (416) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0 + charde (416)(1:9) = ' 6 8 9' + chnp1 (416) = 1 + chnar (416) = 12 + chnpy (416) = 7 + chnte (416) = 6 + chnhe (416) = 0 + chperm (416) = 321 + chbirf (416) = 259 + chetat (416) = 124 + chtn2i (416) = 210 + chbiet (124) = 416 +c +c Aretes coupees : 6 10 11 + chclas (1568) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1568)(1:9) = ' 6 10 11' + chnp1 (1568) = 1 + chnar (1568) = 12 + chnpy (1568) = 7 + chnte (1568) = 6 + chnhe (1568) = 0 + chperm (1568) = 110 + chbirf (1568) = 259 + chetat (1568) = 125 + chtn2i (1568) = 210 + chbiet (125) = 1568 +c +c Aretes coupees : 7 8 11 + chclas (1216) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0 + charde (1216)(1:9) = ' 7 8 11' + chnp1 (1216) = 1 + chnar (1216) = 12 + chnpy (1216) = 7 + chnte (1216) = 6 + chnhe (1216) = 0 + chperm (1216) = 210 + chbirf (1216) = 259 + chetat (1216) = 126 + chtn2i (1216) = 210 + chbiet (126) = 1216 +c +c Aretes coupees : 7 10 11 + chclas (1600) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1600)(1:9) = ' 7 10 11' + chnp1 (1600) = 1 + chnar (1600) = 12 + chnpy (1600) = 7 + chnte (1600) = 6 + chnhe (1600) = 0 + chperm (1600) = 130 + chbirf (1600) = 259 + chetat (1600) = 127 + chtn2i (1600) = 210 + chbiet (127) = 1600 +c +c Aretes coupees : 8 9 12 + chclas (2432) = ' 3-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2432)(1:9) = ' 8 9 12' + chnp1 (2432) = 1 + chnar (2432) = 12 + chnpy (2432) = 7 + chnte (2432) = 6 + chnhe (2432) = 0 + chperm (2432) = 120 + chbirf (2432) = 259 + chetat (2432) = 128 + chtn2i (2432) = 210 + chbiet (128) = 2432 +c +c =========================================== +c Classe d'equivalence 3-04 +c +c Aretes coupees : 1 2 10 + chclas (515) = ' 3-04' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (515)(1:9) = ' 1 2 10' + chnp1 (515) = 1 + chnar (515) = 12 + chnpy (515) = 7 + chnte (515) = 6 + chnhe (515) = 0 + chperm (515) = 0 + chbirf (515) = 515 + chetat (515) = 129 + chtn2i (515) = 210 + chbiet (129) = 515 +c +c Aretes coupees : 1 3 9 + chclas (261) = ' 3-04' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (261)(1:9) = ' 1 3 9' + chnp1 (261) = 1 + chnar (261) = 12 + chnpy (261) = 7 + chnte (261) = 6 + chnhe (261) = 0 + chperm (261) = 221 + chbirf (261) = 515 + chetat (261) = 130 + chtn2i (261) = 210 + chbiet (130) = 261 +c +c Aretes coupees : 1 4 5 + chclas (25) = ' 3-04' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0 + charde (25)(1:9) = ' 1 4 5' + chnp1 (25) = 1 + chnar (25) = 12 + chnpy (25) = 7 + chnte (25) = 6 + chnhe (25) = 0 + chperm (25) = 101 + chbirf (25) = 515 + chetat (25) = 131 + chtn2i (25) = 210 + chbiet (131) = 25 +c +c Aretes coupees : 1 4 8 + chclas (137) = ' 3-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0 + charde (137)(1:9) = ' 1 4 8' + chnp1 (137) = 1 + chnar (137) = 12 + chnpy (137) = 7 + chnte (137) = 6 + chnhe (137) = 0 + chperm (137) = 121 + chbirf (137) = 515 + chetat (137) = 132 + chtn2i (137) = 210 + chbiet (132) = 137 +c +c Aretes coupees : 1 6 8 + chclas (161) = ' 3-04' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 + charde (161)(1:9) = ' 1 6 8' + chnp1 (161) = 1 + chnar (161) = 12 + chnpy (161) = 7 + chnte (161) = 6 + chnhe (161) = 0 + chperm (161) = 320 + chbirf (161) = 515 + chetat (161) = 133 + chtn2i (161) = 210 + chbiet (133) = 161 +c +c Aretes coupees : 1 9 10 + chclas (769) = ' 3-04' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (769)(1:9) = ' 1 9 10' + chnp1 (769) = 1 + chnar (769) = 12 + chnpy (769) = 7 + chnte (769) = 6 + chnhe (769) = 0 + chperm (769) = 201 + chbirf (769) = 515 + chetat (769) = 134 + chtn2i (769) = 210 + chbiet (134) = 769 +c +c Aretes coupees : 2 3 6 + chclas (38) = ' 3-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (38)(1:9) = ' 2 3 6' + chnp1 (38) = 1 + chnar (38) = 12 + chnpy (38) = 7 + chnte (38) = 6 + chnhe (38) = 0 + chperm (38) = 10 + chbirf (38) = 515 + chetat (38) = 135 + chtn2i (38) = 210 + chbiet (135) = 38 +c +c Aretes coupees : 2 3 7 + chclas (70) = ' 3-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (70)(1:9) = ' 2 3 7' + chnp1 (70) = 1 + chnar (70) = 12 + chnpy (70) = 7 + chnte (70) = 6 + chnhe (70) = 0 + chperm (70) = 230 + chbirf (70) = 515 + chetat (70) = 136 + chtn2i (70) = 210 + chbiet (136) = 70 +c +c Aretes coupees : 2 4 12 + chclas (2058) = ' 3-04' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2058)(1:9) = ' 2 4 12' + chnp1 (2058) = 1 + chnar (2058) = 12 + chnpy (2058) = 7 + chnte (2058) = 6 + chnhe (2058) = 0 + chperm (2058) = 1 + chbirf (2058) = 515 + chetat (2058) = 137 + chtn2i (2058) = 210 + chbiet (137) = 2058 +c +c Aretes coupees : 2 5 6 + chclas (50) = ' 3-04' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0 + charde (50)(1:9) = ' 2 5 6' + chnp1 (50) = 1 + chnar (50) = 12 + chnpy (50) = 7 + chnte (50) = 6 + chnhe (50) = 0 + chperm (50) = 330 + chbirf (50) = 515 + chetat (50) = 138 + chtn2i (50) = 210 + chbiet (138) = 50 +c +c Aretes coupees : 2 10 12 + chclas (2562) = ' 3-04' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2562)(1:9) = ' 2 10 12' + chnp1 (2562) = 1 + chnar (2562) = 12 + chnpy (2562) = 7 + chnte (2562) = 6 + chnhe (2562) = 0 + chperm (2562) = 200 + chbirf (2562) = 515 + chetat (2562) = 139 + chtn2i (2562) = 210 + chbiet (139) = 2562 +c +c Aretes coupees : 3 4 11 + chclas (1036) = ' 3-04' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1036)(1:9) = ' 3 4 11' + chnp1 (1036) = 1 + chnar (1036) = 12 + chnpy (1036) = 7 + chnte (1036) = 6 + chnhe (1036) = 0 + chperm (1036) = 220 + chbirf (1036) = 515 + chetat (1036) = 140 + chtn2i (1036) = 210 + chbiet (140) = 1036 +c +c Aretes coupees : 3 7 8 + chclas (196) = ' 3-04' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (196)(1:9) = ' 3 7 8' + chnp1 (196) = 1 + chnar (196) = 12 + chnpy (196) = 7 + chnte (196) = 6 + chnhe (196) = 0 + chperm (196) = 310 + chbirf (196) = 515 + chetat (196) = 141 + chtn2i (196) = 210 + chbiet (141) = 196 +c +c Aretes coupees : 3 9 11 + chclas (1284) = ' 3-04' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1284)(1:9) = ' 3 9 11' + chnp1 (1284) = 1 + chnar (1284) = 12 + chnpy (1284) = 7 + chnte (1284) = 6 + chnhe (1284) = 0 + chperm (1284) = 20 + chbirf (1284) = 515 + chetat (1284) = 142 + chtn2i (1284) = 210 + chbiet (142) = 1284 +c +c Aretes coupees : 4 5 7 + chclas (88) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0 + charde (88)(1:9) = ' 4 5 7' + chnp1 (88) = 1 + chnar (88) = 12 + chnpy (88) = 7 + chnte (88) = 6 + chnhe (88) = 0 + chperm (88) = 300 + chbirf (88) = 515 + chetat (88) = 143 + chtn2i (88) = 210 + chbiet (143) = 88 +c +c Aretes coupees : 4 11 12 + chclas (3080) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3080)(1:9) = ' 4 11 12' + chnp1 (3080) = 1 + chnar (3080) = 12 + chnpy (3080) = 7 + chnte (3080) = 6 + chnhe (3080) = 0 + chperm (3080) = 21 + chbirf (3080) = 515 + chetat (3080) = 144 + chtn2i (3080) = 210 + chbiet (144) = 3080 +c +c Aretes coupees : 5 6 11 + chclas (1072) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0 + charde (1072)(1:9) = ' 5 6 11' + chnp1 (1072) = 1 + chnar (1072) = 12 + chnpy (1072) = 7 + chnte (1072) = 6 + chnhe (1072) = 0 + chperm (1072) = 110 + chbirf (1072) = 515 + chetat (1072) = 145 + chtn2i (1072) = 210 + chbiet (145) = 1072 +c +c Aretes coupees : 5 7 9 + chclas (336) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0 + charde (336)(1:9) = ' 5 7 9' + chnp1 (336) = 1 + chnar (336) = 12 + chnpy (336) = 7 + chnte (336) = 6 + chnhe (336) = 0 + chperm (336) = 100 + chbirf (336) = 515 + chetat (336) = 146 + chtn2i (336) = 210 + chbiet (146) = 336 +c +c Aretes coupees : 5 10 11 + chclas (1552) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1552)(1:9) = ' 5 10 11' + chnp1 (1552) = 1 + chnar (1552) = 12 + chnpy (1552) = 7 + chnte (1552) = 6 + chnhe (1552) = 0 + chperm (1552) = 30 + chbirf (1552) = 515 + chetat (1552) = 147 + chtn2i (1552) = 210 + chbiet (147) = 1552 +c +c Aretes coupees : 6 8 12 + chclas (2208) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1 + charde (2208)(1:9) = ' 6 8 12' + chnp1 (2208) = 1 + chnar (2208) = 12 + chnpy (2208) = 7 + chnte (2208) = 6 + chnhe (2208) = 0 + chperm (2208) = 120 + chbirf (2208) = 515 + chetat (2208) = 148 + chtn2i (2208) = 210 + chbiet (148) = 2208 +c +c Aretes coupees : 6 9 12 + chclas (2336) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2336)(1:9) = ' 6 9 12' + chnp1 (2336) = 1 + chnar (2336) = 12 + chnpy (2336) = 7 + chnte (2336) = 6 + chnhe (2336) = 0 + chperm (2336) = 321 + chbirf (2336) = 515 + chetat (2336) = 149 + chtn2i (2336) = 210 + chbiet (149) = 2336 +c +c Aretes coupees : 7 8 10 + chclas (704) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0 + charde (704)(1:9) = ' 7 8 10' + chnp1 (704) = 1 + chnar (704) = 12 + chnpy (704) = 7 + chnte (704) = 6 + chnhe (704) = 0 + chperm (704) = 130 + chbirf (704) = 515 + chetat (704) = 150 + chtn2i (704) = 210 + chbiet (150) = 704 +c +c Aretes coupees : 7 9 12 + chclas (2368) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2368)(1:9) = ' 7 9 12' + chnp1 (2368) = 1 + chnar (2368) = 12 + chnpy (2368) = 7 + chnte (2368) = 6 + chnhe (2368) = 0 + chperm (2368) = 301 + chbirf (2368) = 515 + chetat (2368) = 151 + chtn2i (2368) = 210 + chbiet (151) = 2368 +c +c Aretes coupees : 8 10 11 + chclas (1664) = ' 3-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1664)(1:9) = ' 8 10 11' + chnp1 (1664) = 1 + chnar (1664) = 12 + chnpy (1664) = 7 + chnte (1664) = 6 + chnhe (1664) = 0 + chperm (1664) = 210 + chbirf (1664) = 515 + chetat (1664) = 152 + chtn2i (1664) = 210 + chbiet (152) = 1664 +c +c =========================================== +c Classe d'equivalence 3-05 +c +c Aretes coupees : 1 2 11 + chclas (1027) = ' 3-05' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1027)(1:9) = ' 1 2 11' + chnp1 (1027) = 1 + chnar (1027) = 12 + chnpy (1027) = 4 + chnte (1027) = 12 + chnhe (1027) = 0 + chperm (1027) = 0 + chbirf (1027) = 1027 + chetat (1027) = 153 + chtn2i (1027) = 210 + chbiet (153) = 1027 +c +c Aretes coupees : 1 3 12 + chclas (2053) = ' 3-05' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2053)(1:9) = ' 1 3 12' + chnp1 (2053) = 1 + chnar (2053) = 12 + chnpy (2053) = 4 + chnte (2053) = 12 + chnhe (2053) = 0 + chperm (2053) = 221 + chbirf (2053) = 1027 + chetat (2053) = 154 + chtn2i (2053) = 210 + chbiet (154) = 2053 +c +c Aretes coupees : 1 5 12 + chclas (2065) = ' 3-05' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2065)(1:9) = ' 1 5 12' + chnp1 (2065) = 1 + chnar (2065) = 12 + chnpy (2065) = 4 + chnte (2065) = 12 + chnhe (2065) = 0 + chperm (2065) = 101 + chbirf (2065) = 1027 + chetat (2065) = 155 + chtn2i (2065) = 210 + chbiet (155) = 2065 +c +c Aretes coupees : 1 6 7 + chclas (97) = ' 3-05' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (97)(1:9) = ' 1 6 7' + chnp1 (97) = 1 + chnar (97) = 12 + chnpy (97) = 4 + chnte (97) = 12 + chnhe (97) = 0 + chperm (97) = 320 + chbirf (97) = 1027 + chetat (97) = 156 + chtn2i (97) = 210 + chbiet (156) = 97 +c +c Aretes coupees : 1 7 12 + chclas (2113) = ' 3-05' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2113)(1:9) = ' 1 7 12' + chnp1 (2113) = 1 + chnar (2113) = 12 + chnpy (2113) = 4 + chnte (2113) = 12 + chnhe (2113) = 0 + chperm (2113) = 301 + chbirf (2113) = 1027 + chetat (2113) = 157 + chtn2i (2113) = 210 + chbiet (157) = 2113 +c +c Aretes coupees : 1 11 12 + chclas (3073) = ' 3-05' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3073)(1:9) = ' 1 11 12' + chnp1 (3073) = 1 + chnar (3073) = 12 + chnpy (3073) = 4 + chnte (3073) = 12 + chnhe (3073) = 0 + chperm (3073) = 21 + chbirf (3073) = 1027 + chetat (3073) = 158 + chtn2i (3073) = 210 + chbiet (158) = 3073 +c +c Aretes coupees : 2 4 9 + chclas (266) = ' 3-05' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0 + charde (266)(1:9) = ' 2 4 9' + chnp1 (266) = 1 + chnar (266) = 12 + chnpy (266) = 4 + chnte (266) = 12 + chnhe (266) = 0 + chperm (266) = 1 + chbirf (266) = 1027 + chetat (266) = 159 + chtn2i (266) = 210 + chbiet (159) = 266 +c +c Aretes coupees : 2 5 8 + chclas (146) = ' 3-05' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (146)(1:9) = ' 2 5 8' + chnp1 (146) = 1 + chnar (146) = 12 + chnpy (146) = 4 + chnte (146) = 12 + chnhe (146) = 0 + chperm (146) = 330 + chbirf (146) = 1027 + chetat (146) = 160 + chtn2i (146) = 210 + chbiet (160) = 146 +c +c Aretes coupees : 2 7 11 + chclas (1090) = ' 3-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1090)(1:9) = ' 2 7 11' + chnp1 (1090) = 1 + chnar (1090) = 12 + chnpy (1090) = 4 + chnte (1090) = 12 + chnhe (1090) = 0 + chperm (1090) = 230 + chbirf (1090) = 1027 + chetat (1090) = 161 + chtn2i (1090) = 210 + chbiet (161) = 1090 +c +c Aretes coupees : 2 8 11 + chclas (1154) = ' 3-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1154)(1:9) = ' 2 8 11' + chnp1 (1154) = 1 + chnar (1154) = 12 + chnpy (1154) = 4 + chnte (1154) = 12 + chnhe (1154) = 0 + chperm (1154) = 210 + chbirf (1154) = 1027 + chetat (1154) = 162 + chtn2i (1154) = 210 + chbiet (162) = 1154 +c +c Aretes coupees : 2 9 11 + chclas (1282) = ' 3-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1282)(1:9) = ' 2 9 11' + chnp1 (1282) = 1 + chnar (1282) = 12 + chnpy (1282) = 4 + chnte (1282) = 12 + chnhe (1282) = 0 + chperm (1282) = 20 + chbirf (1282) = 1027 + chetat (1282) = 163 + chtn2i (1282) = 210 + chbiet (163) = 1282 +c +c Aretes coupees : 3 4 10 + chclas (524) = ' 3-05' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0 + charde (524)(1:9) = ' 3 4 10' + chnp1 (524) = 1 + chnar (524) = 12 + chnpy (524) = 4 + chnte (524) = 12 + chnhe (524) = 0 + chperm (524) = 220 + chbirf (524) = 1027 + chetat (524) = 164 + chtn2i (524) = 210 + chbiet (164) = 524 +c +c Aretes coupees : 3 5 8 + chclas (148) = ' 3-05' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (148)(1:9) = ' 3 5 8' + chnp1 (148) = 1 + chnar (148) = 12 + chnpy (148) = 4 + chnte (148) = 12 + chnhe (148) = 0 + chperm (148) = 310 + chbirf (148) = 1027 + chetat (148) = 165 + chtn2i (148) = 210 + chbiet (165) = 148 +c +c Aretes coupees : 3 5 10 + chclas (532) = ' 3-05' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 0 + charde (532)(1:9) = ' 3 5 10' + chnp1 (532) = 1 + chnar (532) = 12 + chnpy (532) = 4 + chnte (532) = 12 + chnhe (532) = 0 + chperm (532) = 30 + chbirf (532) = 1027 + chetat (532) = 166 + chtn2i (532) = 210 + chbiet (166) = 532 +c +c Aretes coupees : 3 6 10 + chclas (548) = ' 3-05' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (548)(1:9) = ' 3 6 10' + chnp1 (548) = 1 + chnar (548) = 12 + chnpy (548) = 4 + chnte (548) = 12 + chnhe (548) = 0 + chperm (548) = 10 + chbirf (548) = 1027 + chetat (548) = 167 + chtn2i (548) = 210 + chbiet (167) = 548 +c +c Aretes coupees : 3 10 12 + chclas (2564) = ' 3-05' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2564)(1:9) = ' 3 10 12' + chnp1 (2564) = 1 + chnar (2564) = 12 + chnpy (2564) = 4 + chnte (2564) = 12 + chnhe (2564) = 0 + chperm (2564) = 200 + chbirf (2564) = 1027 + chetat (2564) = 168 + chtn2i (2564) = 210 + chbiet (168) = 2564 +c +c Aretes coupees : 4 6 7 + chclas (104) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0 + charde (104)(1:9) = ' 4 6 7' + chnp1 (104) = 1 + chnar (104) = 12 + chnpy (104) = 4 + chnte (104) = 12 + chnhe (104) = 0 + chperm (104) = 300 + chbirf (104) = 1027 + chetat (104) = 169 + chtn2i (104) = 210 + chbiet (169) = 104 +c +c Aretes coupees : 4 6 9 + chclas (296) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0 + charde (296)(1:9) = ' 4 6 9' + chnp1 (296) = 1 + chnar (296) = 12 + chnpy (296) = 4 + chnte (296) = 12 + chnhe (296) = 0 + chperm (296) = 321 + chbirf (296) = 1027 + chetat (296) = 170 + chtn2i (296) = 210 + chbiet (170) = 296 +c +c Aretes coupees : 4 8 9 + chclas (392) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0 + charde (392)(1:9) = ' 4 8 9' + chnp1 (392) = 1 + chnar (392) = 12 + chnpy (392) = 4 + chnte (392) = 12 + chnhe (392) = 0 + chperm (392) = 121 + chbirf (392) = 1027 + chetat (392) = 171 + chtn2i (392) = 210 + chbiet (171) = 392 +c +c Aretes coupees : 4 9 10 + chclas (776) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0 + charde (776)(1:9) = ' 4 9 10' + chnp1 (776) = 1 + chnar (776) = 12 + chnpy (776) = 4 + chnte (776) = 12 + chnhe (776) = 0 + chperm (776) = 201 + chbirf (776) = 1027 + chetat (776) = 172 + chtn2i (776) = 210 + chbiet (172) = 776 +c +c Aretes coupees : 5 8 9 + chclas (400) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0 + charde (400)(1:9) = ' 5 8 9' + chnp1 (400) = 1 + chnar (400) = 12 + chnpy (400) = 4 + chnte (400) = 12 + chnhe (400) = 0 + chperm (400) = 100 + chbirf (400) = 1027 + chetat (400) = 173 + chtn2i (400) = 210 + chbiet (173) = 400 +c +c Aretes coupees : 5 8 12 + chclas (2192) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2192)(1:9) = ' 5 8 12' + chnp1 (2192) = 1 + chnar (2192) = 12 + chnpy (2192) = 4 + chnte (2192) = 12 + chnhe (2192) = 0 + chperm (2192) = 120 + chbirf (2192) = 1027 + chetat (2192) = 174 + chtn2i (2192) = 210 + chbiet (174) = 2192 +c +c Aretes coupees : 6 7 10 + chclas (608) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0 + charde (608)(1:9) = ' 6 7 10' + chnp1 (608) = 1 + chnar (608) = 12 + chnpy (608) = 4 + chnte (608) = 12 + chnhe (608) = 0 + chperm (608) = 130 + chbirf (608) = 1027 + chetat (608) = 175 + chtn2i (608) = 210 + chbiet (175) = 608 +c +c Aretes coupees : 6 7 11 + chclas (1120) = ' 3-05' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1120)(1:9) = ' 6 7 11' + chnp1 (1120) = 1 + chnar (1120) = 12 + chnpy (1120) = 4 + chnte (1120) = 12 + chnhe (1120) = 0 + chperm (1120) = 110 + chbirf (1120) = 1027 + chetat (1120) = 176 + chtn2i (1120) = 210 + chbiet (176) = 1120 +c +c =========================================== +c Classe d'equivalence 3-06 +c +c Aretes coupees : 1 2 12 + chclas (2051) = ' 3-06' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2051)(1:9) = ' 1 2 12' + chnp1 (2051) = 1 + chnar (2051) = 12 + chnpy (2051) = 4 + chnte (2051) = 12 + chnhe (2051) = 0 + chperm (2051) = 0 + chbirf (2051) = 2051 + chetat (2051) = 177 + chtn2i (2051) = 210 + chbiet (177) = 2051 +c +c Aretes coupees : 1 3 10 + chclas (517) = ' 3-06' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (517)(1:9) = ' 1 3 10' + chnp1 (517) = 1 + chnar (517) = 12 + chnpy (517) = 4 + chnte (517) = 12 + chnhe (517) = 0 + chperm (517) = 221 + chbirf (517) = 2051 + chetat (517) = 178 + chtn2i (517) = 210 + chbiet (178) = 517 +c +c Aretes coupees : 1 5 8 + chclas (145) = ' 3-06' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (145)(1:9) = ' 1 5 8' + chnp1 (145) = 1 + chnar (145) = 12 + chnpy (145) = 4 + chnte (145) = 12 + chnhe (145) = 0 + chperm (145) = 101 + chbirf (145) = 2051 + chetat (145) = 179 + chtn2i (145) = 210 + chbiet (179) = 145 +c +c Aretes coupees : 1 6 12 + chclas (2081) = ' 3-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2081)(1:9) = ' 1 6 12' + chnp1 (2081) = 1 + chnar (2081) = 12 + chnpy (2081) = 4 + chnte (2081) = 12 + chnhe (2081) = 0 + chperm (2081) = 320 + chbirf (2081) = 2051 + chetat (2081) = 180 + chtn2i (2081) = 210 + chbiet (180) = 2081 +c +c Aretes coupees : 1 8 12 + chclas (2177) = ' 3-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2177)(1:9) = ' 1 8 12' + chnp1 (2177) = 1 + chnar (2177) = 12 + chnpy (2177) = 4 + chnte (2177) = 12 + chnhe (2177) = 0 + chperm (2177) = 120 + chbirf (2177) = 2051 + chetat (2177) = 181 + chtn2i (2177) = 210 + chbiet (181) = 2177 +c +c Aretes coupees : 1 10 12 + chclas (2561) = ' 3-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2561)(1:9) = ' 1 10 12' + chnp1 (2561) = 1 + chnar (2561) = 12 + chnpy (2561) = 4 + chnte (2561) = 12 + chnhe (2561) = 0 + chperm (2561) = 200 + chbirf (2561) = 2051 + chetat (2561) = 182 + chtn2i (2561) = 210 + chbiet (182) = 2561 +c +c Aretes coupees : 2 4 11 + chclas (1034) = ' 3-06' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1034)(1:9) = ' 2 4 11' + chnp1 (1034) = 1 + chnar (1034) = 12 + chnpy (1034) = 4 + chnte (1034) = 12 + chnhe (1034) = 0 + chperm (1034) = 1 + chbirf (1034) = 2051 + chetat (1034) = 183 + chtn2i (1034) = 210 + chbiet (183) = 1034 +c +c Aretes coupees : 2 5 11 + chclas (1042) = ' 3-06' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1042)(1:9) = ' 2 5 11' + chnp1 (1042) = 1 + chnar (1042) = 12 + chnpy (1042) = 4 + chnte (1042) = 12 + chnhe (1042) = 0 + chperm (1042) = 330 + chbirf (1042) = 2051 + chetat (1042) = 184 + chtn2i (1042) = 210 + chbiet (184) = 1042 +c +c Aretes coupees : 2 6 7 + chclas (98) = ' 3-06' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (98)(1:9) = ' 2 6 7' + chnp1 (98) = 1 + chnar (98) = 12 + chnpy (98) = 4 + chnte (98) = 12 + chnhe (98) = 0 + chperm (98) = 230 + chbirf (98) = 2051 + chetat (98) = 185 + chtn2i (98) = 210 + chbiet (185) = 98 +c +c Aretes coupees : 2 6 11 + chclas (1058) = ' 3-06' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1058)(1:9) = ' 2 6 11' + chnp1 (1058) = 1 + chnar (1058) = 12 + chnpy (1058) = 4 + chnte (1058) = 12 + chnhe (1058) = 0 + chperm (1058) = 110 + chbirf (1058) = 2051 + chetat (1058) = 186 + chtn2i (1058) = 210 + chbiet (186) = 1058 +c +c Aretes coupees : 2 11 12 + chclas (3074) = ' 3-06' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3074)(1:9) = ' 2 11 12' + chnp1 (3074) = 1 + chnar (3074) = 12 + chnpy (3074) = 4 + chnte (3074) = 12 + chnhe (3074) = 0 + chperm (3074) = 21 + chbirf (3074) = 2051 + chetat (3074) = 187 + chtn2i (3074) = 210 + chbiet (187) = 3074 +c +c Aretes coupees : 3 4 9 + chclas (268) = ' 3-06' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0 + charde (268)(1:9) = ' 3 4 9' + chnp1 (268) = 1 + chnar (268) = 12 + chnpy (268) = 4 + chnte (268) = 12 + chnhe (268) = 0 + chperm (268) = 220 + chbirf (268) = 2051 + chetat (268) = 188 + chtn2i (268) = 210 + chbiet (188) = 268 +c +c Aretes coupees : 3 6 7 + chclas (100) = ' 3-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (100)(1:9) = ' 3 6 7' + chnp1 (100) = 1 + chnar (100) = 12 + chnpy (100) = 4 + chnte (100) = 12 + chnhe (100) = 0 + chperm (100) = 10 + chbirf (100) = 2051 + chetat (100) = 189 + chtn2i (100) = 210 + chbiet (189) = 100 +c +c Aretes coupees : 3 7 10 + chclas (580) = ' 3-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0 + charde (580)(1:9) = ' 3 7 10' + chnp1 (580) = 1 + chnar (580) = 12 + chnpy (580) = 4 + chnte (580) = 12 + chnhe (580) = 0 + chperm (580) = 130 + chbirf (580) = 2051 + chetat (580) = 190 + chtn2i (580) = 210 + chbiet (190) = 580 +c +c Aretes coupees : 3 8 10 + chclas (644) = ' 3-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (644)(1:9) = ' 3 8 10' + chnp1 (644) = 1 + chnar (644) = 12 + chnpy (644) = 4 + chnte (644) = 12 + chnhe (644) = 0 + chperm (644) = 310 + chbirf (644) = 2051 + chetat (644) = 191 + chtn2i (644) = 210 + chbiet (191) = 644 +c +c Aretes coupees : 3 9 10 + chclas (772) = ' 3-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (772)(1:9) = ' 3 9 10' + chnp1 (772) = 1 + chnar (772) = 12 + chnpy (772) = 4 + chnte (772) = 12 + chnhe (772) = 0 + chperm (772) = 201 + chbirf (772) = 2051 + chetat (772) = 192 + chtn2i (772) = 210 + chbiet (192) = 772 +c +c Aretes coupees : 4 5 8 + chclas (152) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0 + charde (152)(1:9) = ' 4 5 8' + chnp1 (152) = 1 + chnar (152) = 12 + chnpy (152) = 4 + chnte (152) = 12 + chnhe (152) = 0 + chperm (152) = 121 + chbirf (152) = 2051 + chetat (152) = 193 + chtn2i (152) = 210 + chbiet (193) = 152 +c +c Aretes coupees : 4 5 9 + chclas (280) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0 + charde (280)(1:9) = ' 4 5 9' + chnp1 (280) = 1 + chnar (280) = 12 + chnpy (280) = 4 + chnte (280) = 12 + chnhe (280) = 0 + chperm (280) = 100 + chbirf (280) = 2051 + chetat (280) = 194 + chtn2i (280) = 210 + chbiet (194) = 280 +c +c Aretes coupees : 4 7 9 + chclas (328) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0 + charde (328)(1:9) = ' 4 7 9' + chnp1 (328) = 1 + chnar (328) = 12 + chnpy (328) = 4 + chnte (328) = 12 + chnhe (328) = 0 + chperm (328) = 300 + chbirf (328) = 2051 + chetat (328) = 195 + chtn2i (328) = 210 + chbiet (195) = 328 +c +c Aretes coupees : 4 9 11 + chclas (1288) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1288)(1:9) = ' 4 9 11' + chnp1 (1288) = 1 + chnar (1288) = 12 + chnpy (1288) = 4 + chnte (1288) = 12 + chnhe (1288) = 0 + chperm (1288) = 20 + chbirf (1288) = 2051 + chetat (1288) = 196 + chtn2i (1288) = 210 + chbiet (196) = 1288 +c +c Aretes coupees : 5 8 10 + chclas (656) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 + charde (656)(1:9) = ' 5 8 10' + chnp1 (656) = 1 + chnar (656) = 12 + chnpy (656) = 4 + chnte (656) = 12 + chnhe (656) = 0 + chperm (656) = 30 + chbirf (656) = 2051 + chetat (656) = 197 + chtn2i (656) = 210 + chbiet (197) = 656 +c +c Aretes coupees : 5 8 11 + chclas (1168) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1168)(1:9) = ' 5 8 11' + chnp1 (1168) = 1 + chnar (1168) = 12 + chnpy (1168) = 4 + chnte (1168) = 12 + chnhe (1168) = 0 + chperm (1168) = 210 + chbirf (1168) = 2051 + chetat (1168) = 198 + chtn2i (1168) = 210 + chbiet (198) = 1168 +c +c Aretes coupees : 6 7 9 + chclas (352) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0 + charde (352)(1:9) = ' 6 7 9' + chnp1 (352) = 1 + chnar (352) = 12 + chnpy (352) = 4 + chnte (352) = 12 + chnhe (352) = 0 + chperm (352) = 321 + chbirf (352) = 2051 + chetat (352) = 199 + chtn2i (352) = 210 + chbiet (199) = 352 +c +c Aretes coupees : 6 7 12 + chclas (2144) = ' 3-06' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2144)(1:9) = ' 6 7 12' + chnp1 (2144) = 1 + chnar (2144) = 12 + chnpy (2144) = 4 + chnte (2144) = 12 + chnhe (2144) = 0 + chperm (2144) = 301 + chbirf (2144) = 2051 + chetat (2144) = 200 + chtn2i (2144) = 210 + chbiet (200) = 2144 +c +c =========================================== +c Classe d'equivalence 3-07 +c +c Aretes coupees : 1 2 6 + chclas (35) = ' 3-07' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 + charde (35)(1:9) = ' 1 2 6' + chnp1 (35) = 1 + chnar (35) = 13 + chnpy (35) = 8 + chnte (35) = 6 + chnhe (35) = 0 + chperm (35) = 0 + chbirf (35) = 35 + chetat (35) = 201 + chtn2i (35) = 210 + chbiet (201) = 35 +c +c Aretes coupees : 1 3 8 + chclas (133) = ' 3-07' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (133)(1:9) = ' 1 3 8' + chnp1 (133) = 1 + chnar (133) = 13 + chnpy (133) = 8 + chnte (133) = 6 + chnhe (133) = 0 + chperm (133) = 310 + chbirf (133) = 35 + chetat (133) = 202 + chtn2i (133) = 210 + chbiet (202) = 133 +c +c Aretes coupees : 1 5 10 + chclas (529) = ' 3-07' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0 + charde (529)(1:9) = ' 1 5 10' + chnp1 (529) = 1 + chnar (529) = 13 + chnpy (529) = 8 + chnte (529) = 6 + chnhe (529) = 0 + chperm (529) = 30 + chbirf (529) = 35 + chetat (529) = 203 + chtn2i (529) = 210 + chbiet (203) = 529 +c +c Aretes coupees : 2 4 5 + chclas (26) = ' 3-07' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0 + charde (26)(1:9) = ' 2 4 5' + chnp1 (26) = 1 + chnar (26) = 13 + chnpy (26) = 8 + chnte (26) = 6 + chnhe (26) = 0 + chperm (26) = 330 + chbirf (26) = 35 + chetat (26) = 204 + chtn2i (26) = 210 + chbiet (204) = 26 +c +c Aretes coupees : 2 7 12 + chclas (2114) = ' 3-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2114)(1:9) = ' 2 7 12' + chnp1 (2114) = 1 + chnar (2114) = 13 + chnpy (2114) = 8 + chnte (2114) = 6 + chnhe (2114) = 0 + chperm (2114) = 230 + chbirf (2114) = 35 + chetat (2114) = 205 + chtn2i (2114) = 210 + chbiet (205) = 2114 +c +c Aretes coupees : 3 4 7 + chclas (76) = ' 3-07' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0 + charde (76)(1:9) = ' 3 4 7' + chnp1 (76) = 1 + chnar (76) = 13 + chnpy (76) = 8 + chnte (76) = 6 + chnhe (76) = 0 + chperm (76) = 300 + chbirf (76) = 35 + chetat (76) = 206 + chtn2i (76) = 210 + chbiet (206) = 76 +c +c Aretes coupees : 3 6 9 + chclas (292) = ' 3-07' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0 + charde (292)(1:9) = ' 3 6 9' + chnp1 (292) = 1 + chnar (292) = 13 + chnpy (292) = 8 + chnte (292) = 6 + chnhe (292) = 0 + chperm (292) = 10 + chbirf (292) = 35 + chetat (292) = 207 + chtn2i (292) = 210 + chbiet (207) = 292 +c +c Aretes coupees : 4 8 11 + chclas (1160) = ' 3-07' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1160)(1:9) = ' 4 8 11' + chnp1 (1160) = 1 + chnar (1160) = 13 + chnpy (1160) = 8 + chnte (1160) = 6 + chnhe (1160) = 0 + chperm (1160) = 210 + chbirf (1160) = 35 + chetat (1160) = 208 + chtn2i (1160) = 210 + chbiet (208) = 1160 +c +c Aretes coupees : 5 9 11 + chclas (1296) = ' 3-07' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1296)(1:9) = ' 5 9 11' + chnp1 (1296) = 1 + chnar (1296) = 13 + chnpy (1296) = 8 + chnte (1296) = 6 + chnhe (1296) = 0 + chperm (1296) = 100 + chbirf (1296) = 35 + chetat (1296) = 209 + chtn2i (1296) = 210 + chbiet (209) = 1296 +c +c Aretes coupees : 6 11 12 + chclas (3104) = ' 3-07' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3104)(1:9) = ' 6 11 12' + chnp1 (3104) = 1 + chnar (3104) = 13 + chnpy (3104) = 8 + chnte (3104) = 6 + chnhe (3104) = 0 + chperm (3104) = 110 + chbirf (3104) = 35 + chetat (3104) = 210 + chtn2i (3104) = 210 + chbiet (210) = 3104 +c +c Aretes coupees : 7 9 10 + chclas (832) = ' 3-07' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0 + charde (832)(1:9) = ' 7 9 10' + chnp1 (832) = 1 + chnar (832) = 13 + chnpy (832) = 8 + chnte (832) = 6 + chnhe (832) = 0 + chperm (832) = 130 + chbirf (832) = 35 + chetat (832) = 211 + chtn2i (832) = 210 + chbiet (211) = 832 +c +c Aretes coupees : 8 10 12 + chclas (2688) = ' 3-07' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2688)(1:9) = ' 8 10 12' + chnp1 (2688) = 1 + chnar (2688) = 13 + chnpy (2688) = 8 + chnte (2688) = 6 + chnhe (2688) = 0 + chperm (2688) = 200 + chbirf (2688) = 35 + chetat (2688) = 212 + chtn2i (2688) = 210 + chbiet (212) = 2688 +c +c =========================================== +c Classe d'equivalence 3-08 +c +c Aretes coupees : 1 2 7 + chclas (67) = ' 3-08' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (67)(1:9) = ' 1 2 7' + chnp1 (67) = 1 + chnar (67) = 13 + chnpy (67) = 8 + chnte (67) = 6 + chnhe (67) = 0 + chperm (67) = 0 + chbirf (67) = 67 + chetat (67) = 213 + chtn2i (67) = 210 + chbiet (213) = 67 +c +c Aretes coupees : 1 3 5 + chclas (21) = ' 3-08' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0 + charde (21)(1:9) = ' 1 3 5' + chnp1 (21) = 1 + chnar (21) = 13 + chnpy (21) = 8 + chnte (21) = 6 + chnhe (21) = 0 + chperm (21) = 101 + chbirf (21) = 67 + chetat (21) = 214 + chtn2i (21) = 210 + chbiet (214) = 21 +c +c Aretes coupees : 1 6 11 + chclas (1057) = ' 3-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1057)(1:9) = ' 1 6 11' + chnp1 (1057) = 1 + chnar (1057) = 13 + chnpy (1057) = 8 + chnte (1057) = 6 + chnhe (1057) = 0 + chperm (1057) = 110 + chbirf (1057) = 67 + chetat (1057) = 215 + chtn2i (1057) = 210 + chbiet (215) = 1057 +c +c Aretes coupees : 2 4 8 + chclas (138) = ' 3-08' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0 + charde (138)(1:9) = ' 2 4 8' + chnp1 (138) = 1 + chnar (138) = 13 + chnpy (138) = 8 + chnte (138) = 6 + chnhe (138) = 0 + chperm (138) = 1 + chbirf (138) = 67 + chetat (138) = 216 + chtn2i (138) = 210 + chbiet (216) = 138 +c +c Aretes coupees : 2 5 9 + chclas (274) = ' 3-08' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0 + charde (274)(1:9) = ' 2 5 9' + chnp1 (274) = 1 + chnar (274) = 13 + chnpy (274) = 8 + chnte (274) = 6 + chnhe (274) = 0 + chperm (274) = 100 + chbirf (274) = 67 + chetat (274) = 217 + chtn2i (274) = 210 + chbiet (217) = 274 +c +c Aretes coupees : 3 4 6 + chclas (44) = ' 3-08' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0 + charde (44)(1:9) = ' 3 4 6' + chnp1 (44) = 1 + chnar (44) = 13 + chnpy (44) = 8 + chnte (44) = 6 + chnhe (44) = 0 + chperm (44) = 10 + chbirf (44) = 67 + chetat (44) = 218 + chtn2i (44) = 210 + chbiet (218) = 44 +c +c Aretes coupees : 3 8 12 + chclas (2180) = ' 3-08' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2180)(1:9) = ' 3 8 12' + chnp1 (2180) = 1 + chnar (2180) = 13 + chnpy (2180) = 8 + chnte (2180) = 6 + chnhe (2180) = 0 + chperm (2180) = 310 + chbirf (2180) = 67 + chetat (2180) = 219 + chtn2i (2180) = 210 + chbiet (219) = 2180 +c +c Aretes coupees : 4 7 10 + chclas (584) = ' 3-08' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 + charde (584)(1:9) = ' 4 7 10' + chnp1 (584) = 1 + chnar (584) = 13 + chnpy (584) = 8 + chnte (584) = 6 + chnhe (584) = 0 + chperm (584) = 300 + chbirf (584) = 67 + chetat (584) = 220 + chtn2i (584) = 210 + chbiet (220) = 584 +c +c Aretes coupees : 5 10 12 + chclas (2576) = ' 3-08' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2576)(1:9) = ' 5 10 12' + chnp1 (2576) = 1 + chnar (2576) = 13 + chnpy (2576) = 8 + chnte (2576) = 6 + chnhe (2576) = 0 + chperm (2576) = 200 + chbirf (2576) = 67 + chetat (2576) = 221 + chtn2i (2576) = 210 + chbiet (221) = 2576 +c +c Aretes coupees : 6 9 10 + chclas (800) = ' 3-08' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0 + charde (800)(1:9) = ' 6 9 10' + chnp1 (800) = 1 + chnar (800) = 13 + chnpy (800) = 8 + chnte (800) = 6 + chnhe (800) = 0 + chperm (800) = 201 + chbirf (800) = 67 + chetat (800) = 222 + chtn2i (800) = 210 + chbiet (222) = 800 +c +c Aretes coupees : 7 11 12 + chclas (3136) = ' 3-08' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3136)(1:9) = ' 7 11 12' + chnp1 (3136) = 1 + chnar (3136) = 13 + chnpy (3136) = 8 + chnte (3136) = 6 + chnhe (3136) = 0 + chperm (3136) = 301 + chbirf (3136) = 67 + chetat (3136) = 223 + chtn2i (3136) = 210 + chbiet (223) = 3136 +c +c Aretes coupees : 8 9 11 + chclas (1408) = ' 3-08' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1408)(1:9) = ' 8 9 11' + chnp1 (1408) = 1 + chnar (1408) = 13 + chnpy (1408) = 8 + chnte (1408) = 6 + chnhe (1408) = 0 + chperm (1408) = 210 + chbirf (1408) = 67 + chetat (1408) = 224 + chtn2i (1408) = 210 + chbiet (224) = 1408 +c +c =========================================== +c Classe d'equivalence 3-09 +c +c Aretes coupees : 1 2 8 + chclas (131) = ' 3-09' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 + charde (131)(1:9) = ' 1 2 8' + chnp1 (131) = 1 + chnar (131) = 12 + chnpy (131) = 4 + chnte (131) = 12 + chnhe (131) = 0 + chperm (131) = 0 + chbirf (131) = 131 + chetat (131) = 225 + chtn2i (131) = 210 + chbiet (225) = 131 +c +c Aretes coupees : 1 3 7 + chclas (69) = ' 3-09' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0 + charde (69)(1:9) = ' 1 3 7' + chnp1 (69) = 1 + chnar (69) = 12 + chnpy (69) = 4 + chnte (69) = 12 + chnhe (69) = 0 + chperm (69) = 221 + chbirf (69) = 131 + chetat (69) = 226 + chtn2i (69) = 210 + chbiet (226) = 69 +c +c Aretes coupees : 1 5 11 + chclas (1041) = ' 3-09' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1041)(1:9) = ' 1 5 11' + chnp1 (1041) = 1 + chnar (1041) = 12 + chnpy (1041) = 4 + chnte (1041) = 12 + chnhe (1041) = 0 + chperm (1041) = 101 + chbirf (1041) = 131 + chetat (1041) = 227 + chtn2i (1041) = 210 + chbiet (227) = 1041 +c +c Aretes coupees : 1 6 10 + chclas (545) = ' 3-09' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (545)(1:9) = ' 1 6 10' + chnp1 (545) = 1 + chnar (545) = 12 + chnpy (545) = 4 + chnte (545) = 12 + chnhe (545) = 0 + chperm (545) = 320 + chbirf (545) = 131 + chetat (545) = 228 + chtn2i (545) = 210 + chbiet (228) = 545 +c +c Aretes coupees : 1 7 10 + chclas (577) = ' 3-09' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0 + charde (577)(1:9) = ' 1 7 10' + chnp1 (577) = 1 + chnar (577) = 12 + chnpy (577) = 4 + chnte (577) = 12 + chnhe (577) = 0 + chperm (577) = 130 + chbirf (577) = 131 + chetat (577) = 229 + chtn2i (577) = 210 + chbiet (229) = 577 +c +c Aretes coupees : 1 8 11 + chclas (1153) = ' 3-09' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1153)(1:9) = ' 1 8 11' + chnp1 (1153) = 1 + chnar (1153) = 12 + chnpy (1153) = 4 + chnte (1153) = 12 + chnhe (1153) = 0 + chperm (1153) = 210 + chbirf (1153) = 131 + chetat (1153) = 230 + chtn2i (1153) = 210 + chbiet (230) = 1153 +c +c Aretes coupees : 2 4 6 + chclas (42) = ' 3-09' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0 + charde (42)(1:9) = ' 2 4 6' + chnp1 (42) = 1 + chnar (42) = 12 + chnpy (42) = 4 + chnte (42) = 12 + chnhe (42) = 0 + chperm (42) = 1 + chbirf (42) = 131 + chetat (42) = 231 + chtn2i (42) = 210 + chbiet (231) = 42 +c +c Aretes coupees : 2 5 12 + chclas (2066) = ' 3-09' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2066)(1:9) = ' 2 5 12' + chnp1 (2066) = 1 + chnar (2066) = 12 + chnpy (2066) = 4 + chnte (2066) = 12 + chnhe (2066) = 0 + chperm (2066) = 330 + chbirf (2066) = 131 + chetat (2066) = 232 + chtn2i (2066) = 210 + chbiet (232) = 2066 +c +c Aretes coupees : 2 6 9 + chclas (290) = ' 3-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0 + charde (290)(1:9) = ' 2 6 9' + chnp1 (290) = 1 + chnar (290) = 12 + chnpy (290) = 4 + chnte (290) = 12 + chnhe (290) = 0 + chperm (290) = 321 + chbirf (290) = 131 + chetat (290) = 233 + chtn2i (290) = 210 + chbiet (233) = 290 +c +c Aretes coupees : 2 7 9 + chclas (322) = ' 3-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (322)(1:9) = ' 2 7 9' + chnp1 (322) = 1 + chnar (322) = 12 + chnpy (322) = 4 + chnte (322) = 12 + chnhe (322) = 0 + chperm (322) = 230 + chbirf (322) = 131 + chetat (322) = 234 + chtn2i (322) = 210 + chbiet (234) = 322 +c +c Aretes coupees : 2 8 12 + chclas (2178) = ' 3-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2178)(1:9) = ' 2 8 12' + chnp1 (2178) = 1 + chnar (2178) = 12 + chnpy (2178) = 4 + chnte (2178) = 12 + chnhe (2178) = 0 + chperm (2178) = 120 + chbirf (2178) = 131 + chetat (2178) = 235 + chtn2i (2178) = 210 + chbiet (235) = 2178 +c +c Aretes coupees : 3 4 5 + chclas (28) = ' 3-09' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0 + charde (28)(1:9) = ' 3 4 5' + chnp1 (28) = 1 + chnar (28) = 12 + chnpy (28) = 4 + chnte (28) = 12 + chnhe (28) = 0 + chperm (28) = 220 + chbirf (28) = 131 + chetat (28) = 236 + chtn2i (28) = 210 + chbiet (236) = 28 +c +c Aretes coupees : 3 5 9 + chclas (276) = ' 3-09' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0 + charde (276)(1:9) = ' 3 5 9' + chnp1 (276) = 1 + chnar (276) = 12 + chnpy (276) = 4 + chnte (276) = 12 + chnhe (276) = 0 + chperm (276) = 100 + chbirf (276) = 131 + chetat (276) = 237 + chtn2i (276) = 210 + chbiet (237) = 276 +c +c Aretes coupees : 3 6 12 + chclas (2084) = ' 3-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2084)(1:9) = ' 3 6 12' + chnp1 (2084) = 1 + chnar (2084) = 12 + chnpy (2084) = 4 + chnte (2084) = 12 + chnhe (2084) = 0 + chperm (2084) = 10 + chbirf (2084) = 131 + chetat (2084) = 238 + chtn2i (2084) = 210 + chbiet (238) = 2084 +c +c Aretes coupees : 3 7 12 + chclas (2116) = ' 3-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2116)(1:9) = ' 3 7 12' + chnp1 (2116) = 1 + chnar (2116) = 12 + chnpy (2116) = 4 + chnte (2116) = 12 + chnhe (2116) = 0 + chperm (2116) = 301 + chbirf (2116) = 131 + chetat (2116) = 239 + chtn2i (2116) = 210 + chbiet (239) = 2116 +c +c Aretes coupees : 3 8 9 + chclas (388) = ' 3-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (388)(1:9) = ' 3 8 9' + chnp1 (388) = 1 + chnar (388) = 12 + chnpy (388) = 4 + chnte (388) = 12 + chnhe (388) = 0 + chperm (388) = 310 + chbirf (388) = 131 + chetat (388) = 240 + chtn2i (388) = 210 + chbiet (240) = 388 +c +c Aretes coupees : 4 5 10 + chclas (536) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0 + charde (536)(1:9) = ' 4 5 10' + chnp1 (536) = 1 + chnar (536) = 12 + chnpy (536) = 4 + chnte (536) = 12 + chnhe (536) = 0 + chperm (536) = 30 + chbirf (536) = 131 + chetat (536) = 241 + chtn2i (536) = 210 + chbiet (241) = 536 +c +c Aretes coupees : 4 6 11 + chclas (1064) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1064)(1:9) = ' 4 6 11' + chnp1 (1064) = 1 + chnar (1064) = 12 + chnpy (1064) = 4 + chnte (1064) = 12 + chnhe (1064) = 0 + chperm (1064) = 110 + chbirf (1064) = 131 + chetat (1064) = 242 + chtn2i (1064) = 210 + chbiet (242) = 1064 +c +c Aretes coupees : 4 7 11 + chclas (1096) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1096)(1:9) = ' 4 7 11' + chnp1 (1096) = 1 + chnar (1096) = 12 + chnpy (1096) = 4 + chnte (1096) = 12 + chnhe (1096) = 0 + chperm (1096) = 300 + chbirf (1096) = 131 + chetat (1096) = 243 + chtn2i (1096) = 210 + chbiet (243) = 1096 +c +c Aretes coupees : 4 8 10 + chclas (648) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 + charde (648)(1:9) = ' 4 8 10' + chnp1 (648) = 1 + chnar (648) = 12 + chnpy (648) = 4 + chnte (648) = 12 + chnhe (648) = 0 + chperm (648) = 121 + chbirf (648) = 131 + chetat (648) = 244 + chtn2i (648) = 210 + chbiet (244) = 648 +c +c Aretes coupees : 5 11 12 + chclas (3088) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3088)(1:9) = ' 5 11 12' + chnp1 (3088) = 1 + chnar (3088) = 12 + chnpy (3088) = 4 + chnte (3088) = 12 + chnhe (3088) = 0 + chperm (3088) = 21 + chbirf (3088) = 131 + chetat (3088) = 245 + chtn2i (3088) = 210 + chbiet (245) = 3088 +c +c Aretes coupees : 6 10 12 + chclas (2592) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2592)(1:9) = ' 6 10 12' + chnp1 (2592) = 1 + chnar (2592) = 12 + chnpy (2592) = 4 + chnte (2592) = 12 + chnhe (2592) = 0 + chperm (2592) = 200 + chbirf (2592) = 131 + chetat (2592) = 246 + chtn2i (2592) = 210 + chbiet (246) = 2592 +c +c Aretes coupees : 7 9 11 + chclas (1344) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1344)(1:9) = ' 7 9 11' + chnp1 (1344) = 1 + chnar (1344) = 12 + chnpy (1344) = 4 + chnte (1344) = 12 + chnhe (1344) = 0 + chperm (1344) = 20 + chbirf (1344) = 131 + chetat (1344) = 247 + chtn2i (1344) = 210 + chbiet (247) = 1344 +c +c Aretes coupees : 8 9 10 + chclas (896) = ' 3-09' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (896)(1:9) = ' 8 9 10' + chnp1 (896) = 1 + chnar (896) = 12 + chnpy (896) = 4 + chnte (896) = 12 + chnhe (896) = 0 + chperm (896) = 201 + chbirf (896) = 131 + chetat (896) = 248 + chtn2i (896) = 210 + chbiet (248) = 896 +c +c =========================================== +c Classe d'equivalence 3-10 +c +c Aretes coupees : 1 4 9 + chclas (265) = ' 3-10' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0 + charde (265)(1:9) = ' 1 4 9' + chnp1 (265) = 1 + chnar (265) = 11 + chnpy (265) = 6 + chnte (265) = 6 + chnhe (265) = 0 + chperm (265) = 0 + chbirf (265) = 265 + chetat (265) = 249 + chtn2i (265) = 70 + chbiet (249) = 265 +c +c Aretes coupees : 1 4 12 + chclas (2057) = ' 3-10' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2057)(1:9) = ' 1 4 12' + chnp1 (2057) = 1 + chnar (2057) = 11 + chnpy (2057) = 6 + chnte (2057) = 6 + chnhe (2057) = 0 + chperm (2057) = 300 + chbirf (2057) = 265 + chetat (2057) = 250 + chtn2i (2057) = 70 + chbiet (250) = 2057 +c +c Aretes coupees : 1 9 12 + chclas (2305) = ' 3-10' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2305)(1:9) = ' 1 9 12' + chnp1 (2305) = 1 + chnar (2305) = 11 + chnpy (2305) = 6 + chnte (2305) = 6 + chnhe (2305) = 0 + chperm (2305) = 100 + chbirf (2305) = 265 + chetat (2305) = 251 + chtn2i (2305) = 70 + chbiet (251) = 2305 +c +c Aretes coupees : 2 3 10 + chclas (518) = ' 3-10' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0 + charde (518)(1:9) = ' 2 3 10' + chnp1 (518) = 1 + chnar (518) = 11 + chnpy (518) = 6 + chnte (518) = 6 + chnhe (518) = 0 + chperm (518) = 330 + chbirf (518) = 265 + chetat (518) = 252 + chtn2i (518) = 70 + chbiet (252) = 518 +c +c Aretes coupees : 2 3 11 + chclas (1030) = ' 3-10' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1030)(1:9) = ' 2 3 11' + chnp1 (1030) = 1 + chnar (1030) = 11 + chnpy (1030) = 6 + chnte (1030) = 6 + chnhe (1030) = 0 + chperm (1030) = 310 + chbirf (1030) = 265 + chetat (1030) = 253 + chtn2i (1030) = 70 + chbiet (253) = 1030 +c +c Aretes coupees : 2 10 11 + chclas (1538) = ' 3-10' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1538)(1:9) = ' 2 10 11' + chnp1 (1538) = 1 + chnar (1538) = 11 + chnpy (1538) = 6 + chnte (1538) = 6 + chnhe (1538) = 0 + chperm (1538) = 130 + chbirf (1538) = 265 + chetat (1538) = 254 + chtn2i (1538) = 70 + chbiet (254) = 1538 +c +c Aretes coupees : 3 10 11 + chclas (1540) = ' 3-10' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1540)(1:9) = ' 3 10 11' + chnp1 (1540) = 1 + chnar (1540) = 11 + chnpy (1540) = 6 + chnte (1540) = 6 + chnhe (1540) = 0 + chperm (1540) = 110 + chbirf (1540) = 265 + chetat (1540) = 255 + chtn2i (1540) = 70 + chbiet (255) = 1540 +c +c Aretes coupees : 4 9 12 + chclas (2312) = ' 3-10' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2312)(1:9) = ' 4 9 12' + chnp1 (2312) = 1 + chnar (2312) = 11 + chnpy (2312) = 6 + chnte (2312) = 6 + chnhe (2312) = 0 + chperm (2312) = 200 + chbirf (2312) = 265 + chetat (2312) = 256 + chtn2i (2312) = 70 + chbiet (256) = 2312 +c +c Aretes coupees : 5 6 7 + chclas (112) = ' 3-10' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0 + charde (112)(1:9) = ' 5 6 7' + chnp1 (112) = 1 + chnar (112) = 11 + chnpy (112) = 6 + chnte (112) = 6 + chnhe (112) = 0 + chperm (112) = 30 + chbirf (112) = 265 + chetat (112) = 257 + chtn2i (112) = 70 + chbiet (257) = 112 +c +c Aretes coupees : 5 6 8 + chclas (176) = ' 3-10' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0 + charde (176)(1:9) = ' 5 6 8' + chnp1 (176) = 1 + chnar (176) = 11 + chnpy (176) = 6 + chnte (176) = 6 + chnhe (176) = 0 + chperm (176) = 10 + chbirf (176) = 265 + chetat (176) = 258 + chtn2i (176) = 70 + chbiet (258) = 176 +c +c Aretes coupees : 5 7 8 + chclas (208) = ' 3-10' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0 + charde (208)(1:9) = ' 5 7 8' + chnp1 (208) = 1 + chnar (208) = 11 + chnpy (208) = 6 + chnte (208) = 6 + chnhe (208) = 0 + chperm (208) = 230 + chbirf (208) = 265 + chetat (208) = 259 + chtn2i (208) = 70 + chbiet (259) = 208 +c +c Aretes coupees : 6 7 8 + chclas (224) = ' 3-10' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 + charde (224)(1:9) = ' 6 7 8' + chnp1 (224) = 1 + chnar (224) = 11 + chnpy (224) = 6 + chnte (224) = 6 + chnhe (224) = 0 + chperm (224) = 210 + chbirf (224) = 265 + chetat (224) = 260 + chtn2i (224) = 70 + chbiet (260) = 224 +c +c =========================================== +c Classe d'equivalence 3-11 +c +c Aretes coupees : 1 4 10 + chclas (521) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0 + charde (521)(1:9) = ' 1 4 10' + chnp1 (521) = 1 + chnar (521) = 11 + chnpy (521) = 3 + chnte (521) = 12 + chnhe (521) = 0 + chperm (521) = 0 + chbirf (521) = 521 + chetat (521) = 261 + chtn2i (521) = 70 + chbiet (261) = 521 +c +c Aretes coupees : 1 4 11 + chclas (1033) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1033)(1:9) = ' 1 4 11' + chnp1 (1033) = 1 + chnar (1033) = 11 + chnpy (1033) = 3 + chnte (1033) = 12 + chnhe (1033) = 0 + chperm (1033) = 220 + chbirf (1033) = 521 + chetat (1033) = 262 + chtn2i (1033) = 70 + chbiet (262) = 1033 +c +c Aretes coupees : 1 7 8 + chclas (193) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (193)(1:9) = ' 1 7 8' + chnp1 (193) = 1 + chnar (193) = 11 + chnpy (193) = 3 + chnte (193) = 12 + chnhe (193) = 0 + chperm (193) = 121 + chbirf (193) = 521 + chetat (193) = 263 + chtn2i (193) = 70 + chbiet (263) = 193 +c +c Aretes coupees : 1 7 9 + chclas (321) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (321)(1:9) = ' 1 7 9' + chnp1 (321) = 1 + chnar (321) = 11 + chnpy (321) = 3 + chnte (321) = 12 + chnhe (321) = 0 + chperm (321) = 100 + chbirf (321) = 521 + chetat (321) = 264 + chtn2i (321) = 70 + chbiet (264) = 321 +c +c Aretes coupees : 1 8 9 + chclas (385) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (385)(1:9) = ' 1 8 9' + chnp1 (385) = 1 + chnar (385) = 11 + chnpy (385) = 3 + chnte (385) = 12 + chnhe (385) = 0 + chperm (385) = 320 + chbirf (385) = 521 + chetat (385) = 265 + chtn2i (385) = 70 + chbiet (265) = 385 +c +c Aretes coupees : 1 10 11 + chclas (1537) = ' 3-11' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1537)(1:9) = ' 1 10 11' + chnp1 (1537) = 1 + chnar (1537) = 11 + chnpy (1537) = 3 + chnte (1537) = 12 + chnhe (1537) = 0 + chperm (1537) = 201 + chbirf (1537) = 521 + chetat (1537) = 266 + chtn2i (1537) = 70 + chbiet (266) = 1537 +c +c Aretes coupees : 2 3 9 + chclas (262) = ' 3-11' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0 + charde (262)(1:9) = ' 2 3 9' + chnp1 (262) = 1 + chnar (262) = 11 + chnpy (262) = 3 + chnte (262) = 12 + chnhe (262) = 0 + chperm (262) = 221 + chbirf (262) = 521 + chetat (262) = 267 + chtn2i (262) = 70 + chbiet (267) = 262 +c +c Aretes coupees : 2 3 12 + chclas (2054) = ' 3-11' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2054)(1:9) = ' 2 3 12' + chnp1 (2054) = 1 + chnar (2054) = 11 + chnpy (2054) = 3 + chnte (2054) = 12 + chnhe (2054) = 0 + chperm (2054) = 1 + chbirf (2054) = 521 + chetat (2054) = 268 + chtn2i (2054) = 70 + chbiet (268) = 2054 +c +c Aretes coupees : 2 6 8 + chclas (162) = ' 3-11' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 + charde (162)(1:9) = ' 2 6 8' + chnp1 (162) = 1 + chnar (162) = 11 + chnpy (162) = 3 + chnte (162) = 12 + chnhe (162) = 0 + chperm (162) = 10 + chbirf (162) = 521 + chetat (162) = 269 + chtn2i (162) = 70 + chbiet (269) = 162 +c +c Aretes coupees : 2 6 10 + chclas (546) = ' 3-11' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (546)(1:9) = ' 2 6 10' + chnp1 (546) = 1 + chnar (546) = 11 + chnpy (546) = 3 + chnte (546) = 12 + chnhe (546) = 0 + chperm (546) = 330 + chbirf (546) = 521 + chetat (546) = 270 + chtn2i (546) = 70 + chbiet (270) = 546 +c +c Aretes coupees : 2 8 10 + chclas (642) = ' 3-11' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (642)(1:9) = ' 2 8 10' + chnp1 (642) = 1 + chnar (642) = 11 + chnpy (642) = 3 + chnte (642) = 12 + chnhe (642) = 0 + chperm (642) = 130 + chbirf (642) = 521 + chetat (642) = 271 + chtn2i (642) = 70 + chbiet (271) = 642 +c +c Aretes coupees : 2 9 12 + chclas (2306) = ' 3-11' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2306)(1:9) = ' 2 9 12' + chnp1 (2306) = 1 + chnar (2306) = 11 + chnpy (2306) = 3 + chnte (2306) = 12 + chnhe (2306) = 0 + chperm (2306) = 200 + chbirf (2306) = 521 + chetat (2306) = 272 + chtn2i (2306) = 70 + chbiet (272) = 2306 +c +c Aretes coupees : 3 5 7 + chclas (84) = ' 3-11' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0 + charde (84)(1:9) = ' 3 5 7' + chnp1 (84) = 1 + chnar (84) = 11 + chnpy (84) = 3 + chnte (84) = 12 + chnhe (84) = 0 + chperm (84) = 230 + chbirf (84) = 521 + chetat (84) = 273 + chtn2i (84) = 70 + chbiet (273) = 84 +c +c Aretes coupees : 3 5 11 + chclas (1044) = ' 3-11' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1044)(1:9) = ' 3 5 11' + chnp1 (1044) = 1 + chnar (1044) = 11 + chnpy (1044) = 3 + chnte (1044) = 12 + chnhe (1044) = 0 + chperm (1044) = 110 + chbirf (1044) = 521 + chetat (1044) = 274 + chtn2i (1044) = 70 + chbiet (274) = 1044 +c +c Aretes coupees : 3 7 11 + chclas (1092) = ' 3-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1092)(1:9) = ' 3 7 11' + chnp1 (1092) = 1 + chnar (1092) = 11 + chnpy (1092) = 3 + chnte (1092) = 12 + chnhe (1092) = 0 + chperm (1092) = 310 + chbirf (1092) = 521 + chetat (1092) = 275 + chtn2i (1092) = 70 + chbiet (275) = 1092 +c +c Aretes coupees : 3 9 12 + chclas (2308) = ' 3-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2308)(1:9) = ' 3 9 12' + chnp1 (2308) = 1 + chnar (2308) = 11 + chnpy (2308) = 3 + chnte (2308) = 12 + chnhe (2308) = 0 + chperm (2308) = 20 + chbirf (2308) = 521 + chetat (2308) = 276 + chtn2i (2308) = 70 + chbiet (276) = 2308 +c +c Aretes coupees : 4 5 6 + chclas (56) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0 + charde (56)(1:9) = ' 4 5 6' + chnp1 (56) = 1 + chnar (56) = 11 + chnpy (56) = 3 + chnte (56) = 12 + chnhe (56) = 0 + chperm (56) = 101 + chbirf (56) = 521 + chetat (56) = 277 + chtn2i (56) = 70 + chbiet (277) = 56 +c +c Aretes coupees : 4 5 12 + chclas (2072) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2072)(1:9) = ' 4 5 12' + chnp1 (2072) = 1 + chnar (2072) = 11 + chnpy (2072) = 3 + chnte (2072) = 12 + chnhe (2072) = 0 + chperm (2072) = 300 + chbirf (2072) = 521 + chetat (2072) = 278 + chtn2i (2072) = 70 + chbiet (278) = 2072 +c +c Aretes coupees : 4 6 12 + chclas (2088) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2088)(1:9) = ' 4 6 12' + chnp1 (2088) = 1 + chnar (2088) = 11 + chnpy (2088) = 3 + chnte (2088) = 12 + chnhe (2088) = 0 + chperm (2088) = 120 + chbirf (2088) = 521 + chetat (2088) = 279 + chtn2i (2088) = 70 + chbiet (279) = 2088 +c +c Aretes coupees : 4 10 11 + chclas (1544) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1544)(1:9) = ' 4 10 11' + chnp1 (1544) = 1 + chnar (1544) = 11 + chnpy (1544) = 3 + chnte (1544) = 12 + chnhe (1544) = 0 + chperm (1544) = 21 + chbirf (1544) = 521 + chetat (1544) = 280 + chtn2i (1544) = 70 + chbiet (280) = 1544 +c +c Aretes coupees : 5 6 12 + chclas (2096) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2096)(1:9) = ' 5 6 12' + chnp1 (2096) = 1 + chnar (2096) = 11 + chnpy (2096) = 3 + chnte (2096) = 12 + chnhe (2096) = 0 + chperm (2096) = 321 + chbirf (2096) = 521 + chetat (2096) = 281 + chtn2i (2096) = 70 + chbiet (281) = 2096 +c +c Aretes coupees : 5 7 11 + chclas (1104) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1104)(1:9) = ' 5 7 11' + chnp1 (1104) = 1 + chnar (1104) = 11 + chnpy (1104) = 3 + chnte (1104) = 12 + chnhe (1104) = 0 + chperm (1104) = 30 + chbirf (1104) = 521 + chetat (1104) = 282 + chtn2i (1104) = 70 + chbiet (282) = 1104 +c +c Aretes coupees : 6 8 10 + chclas (672) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0 + charde (672)(1:9) = ' 6 8 10' + chnp1 (672) = 1 + chnar (672) = 11 + chnpy (672) = 3 + chnte (672) = 12 + chnhe (672) = 0 + chperm (672) = 210 + chbirf (672) = 521 + chetat (672) = 283 + chtn2i (672) = 70 + chbiet (283) = 672 +c +c Aretes coupees : 7 8 9 + chclas (448) = ' 3-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (448)(1:9) = ' 7 8 9' + chnp1 (448) = 1 + chnar (448) = 11 + chnpy (448) = 3 + chnte (448) = 12 + chnhe (448) = 0 + chperm (448) = 301 + chbirf (448) = 521 + chetat (448) = 284 + chtn2i (448) = 70 + chbiet (284) = 448 +c +c =========================================== +c Classe d'equivalence 4-00 +c +c Aretes coupees : 1 2 3 4 + chclas (15) = ' 4-00' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 + charde (15)(1:12) = ' 1 2 3 4' + chnp1 (15) = 0 + chnar (15) = 4 + chnpy (15) = 5 + chnte (15) = 4 + chnhe (15) = 0 + chperm (15) = 0 + chbirf (15) = 15 + chetat (15) = 285 + chtn2i (15) = 13 + chbiet (285) = 15 +c +c Aretes coupees : 1 5 6 9 + chclas (305) = ' 4-00' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0 + charde (305)(1:12) = ' 1 5 6 9' + chnp1 (305) = 0 + chnar (305) = 4 + chnpy (305) = 5 + chnte (305) = 4 + chnhe (305) = 0 + chperm (305) = 100 + chbirf (305) = 15 + chetat (305) = 286 + chtn2i (305) = 13 + chbiet (286) = 305 +c +c Aretes coupees : 2 5 7 10 + chclas (594) = ' 4-00' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0 + charde (594)(1:12) = ' 2 5 7 10' + chnp1 (594) = 0 + chnar (594) = 4 + chnpy (594) = 5 + chnte (594) = 4 + chnhe (594) = 0 + chperm (594) = 30 + chbirf (594) = 15 + chetat (594) = 287 + chtn2i (594) = 13 + chbiet (287) = 594 +c +c Aretes coupees : 3 6 8 11 + chclas (1188) = ' 4-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0 + charde (1188)(1:12) = ' 3 6 8 11' + chnp1 (1188) = 0 + chnar (1188) = 4 + chnpy (1188) = 5 + chnte (1188) = 4 + chnhe (1188) = 0 + chperm (1188) = 10 + chbirf (1188) = 15 + chetat (1188) = 288 + chtn2i (1188) = 13 + chbiet (288) = 1188 +c +c Aretes coupees : 4 7 8 12 + chclas (2248) = ' 4-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1 + charde (2248)(1:12) = ' 4 7 8 12' + chnp1 (2248) = 0 + chnar (2248) = 4 + chnpy (2248) = 5 + chnte (2248) = 4 + chnhe (2248) = 0 + chperm (2248) = 300 + chbirf (2248) = 15 + chetat (2248) = 289 + chtn2i (2248) = 13 + chbiet (289) = 2248 +c +c Aretes coupees : 9 10 11 12 + chclas (3840) = ' 4-00' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3840)(1:12) = ' 9 10 11 12' + chnp1 (3840) = 0 + chnar (3840) = 4 + chnpy (3840) = 5 + chnte (3840) = 4 + chnhe (3840) = 0 + chperm (3840) = 200 + chbirf (3840) = 15 + chetat (3840) = 290 + chtn2i (3840) = 13 + chbiet (290) = 3840 +c +c =========================================== +c Classe d'equivalence 4-01 +c +c Aretes coupees : 1 2 9 10 + chclas (771) = ' 4-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (771)(1:12) = ' 1 2 9 10' + chnp1 (771) = 1 + chnar (771) = 14 + chnpy (771) = 12 + chnte (771) = 0 + chnhe (771) = 0 + chperm (771) = 0 + chbirf (771) = 771 + chetat (771) = 291 + chtn2i (771) = 210 + chbiet (291) = 771 +c +c Aretes coupees : 1 3 9 11 + chclas (1285) = ' 4-01' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1285)(1:12) = ' 1 3 9 11' + chnp1 (1285) = 1 + chnar (1285) = 14 + chnpy (1285) = 12 + chnte (1285) = 0 + chnhe (1285) = 0 + chperm (1285) = 20 + chbirf (1285) = 771 + chetat (1285) = 292 + chtn2i (1285) = 210 + chbiet (292) = 1285 +c +c Aretes coupees : 1 4 5 7 + chclas (89) = ' 4-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0 + charde (89)(1:12) = ' 1 4 5 7' + chnp1 (89) = 1 + chnar (89) = 14 + chnpy (89) = 12 + chnte (89) = 0 + chnhe (89) = 0 + chperm (89) = 300 + chbirf (89) = 771 + chetat (89) = 293 + chtn2i (89) = 210 + chbiet (293) = 89 +c +c Aretes coupees : 1 4 6 8 + chclas (169) = ' 4-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0 + charde (169)(1:12) = ' 1 4 6 8' + chnp1 (169) = 1 + chnar (169) = 14 + chnpy (169) = 12 + chnte (169) = 0 + chnhe (169) = 0 + chperm (169) = 320 + chbirf (169) = 771 + chetat (169) = 294 + chtn2i (169) = 210 + chbiet (294) = 169 +c +c Aretes coupees : 2 3 5 6 + chclas (54) = ' 4-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0 + charde (54)(1:12) = ' 2 3 5 6' + chnp1 (54) = 1 + chnar (54) = 14 + chnpy (54) = 12 + chnte (54) = 0 + chnhe (54) = 0 + chperm (54) = 10 + chbirf (54) = 771 + chetat (54) = 295 + chtn2i (54) = 210 + chbiet (295) = 54 +c +c Aretes coupees : 2 3 7 8 + chclas (198) = ' 4-01' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (198)(1:12) = ' 2 3 7 8' + chnp1 (198) = 1 + chnar (198) = 14 + chnpy (198) = 12 + chnte (198) = 0 + chnhe (198) = 0 + chperm (198) = 310 + chbirf (198) = 771 + chetat (198) = 296 + chtn2i (198) = 210 + chbiet (296) = 198 +c +c Aretes coupees : 2 4 10 12 + chclas (2570) = ' 4-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2570)(1:12) = ' 2 4 10 12' + chnp1 (2570) = 1 + chnar (2570) = 14 + chnpy (2570) = 12 + chnte (2570) = 0 + chnhe (2570) = 0 + chperm (2570) = 200 + chbirf (2570) = 771 + chetat (2570) = 297 + chtn2i (2570) = 210 + chbiet (297) = 2570 +c +c Aretes coupees : 3 4 11 12 + chclas (3084) = ' 4-01' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3084)(1:12) = ' 3 4 11 12' + chnp1 (3084) = 1 + chnar (3084) = 14 + chnpy (3084) = 12 + chnte (3084) = 0 + chnhe (3084) = 0 + chperm (3084) = 220 + chbirf (3084) = 771 + chetat (3084) = 298 + chtn2i (3084) = 210 + chbiet (298) = 3084 +c +c Aretes coupees : 5 6 10 11 + chclas (1584) = ' 4-01' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0 + charde (1584)(1:12) = ' 5 6 10 11' + chnp1 (1584) = 1 + chnar (1584) = 14 + chnpy (1584) = 12 + chnte (1584) = 0 + chnhe (1584) = 0 + chperm (1584) = 110 + chbirf (1584) = 771 + chetat (1584) = 299 + chtn2i (1584) = 210 + chbiet (299) = 1584 +c +c Aretes coupees : 5 7 9 12 + chclas (2384) = ' 4-01' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 1 + charde (2384)(1:12) = ' 5 7 9 12' + chnp1 (2384) = 1 + chnar (2384) = 14 + chnpy (2384) = 12 + chnte (2384) = 0 + chnhe (2384) = 0 + chperm (2384) = 100 + chbirf (2384) = 771 + chetat (2384) = 300 + chtn2i (2384) = 210 + chbiet (300) = 2384 +c +c Aretes coupees : 6 8 9 12 + chclas (2464) = ' 4-01' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1 + charde (2464)(1:12) = ' 6 8 9 12' + chnp1 (2464) = 1 + chnar (2464) = 14 + chnpy (2464) = 12 + chnte (2464) = 0 + chnhe (2464) = 0 + chperm (2464) = 120 + chbirf (2464) = 771 + chetat (2464) = 301 + chtn2i (2464) = 210 + chbiet (301) = 2464 +c +c Aretes coupees : 7 8 10 11 + chclas (1728) = ' 4-01' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0 + charde (1728)(1:12) = ' 7 8 10 11' + chnp1 (1728) = 1 + chnar (1728) = 14 + chnpy (1728) = 12 + chnte (1728) = 0 + chnhe (1728) = 0 + chperm (1728) = 210 + chbirf (1728) = 771 + chetat (1728) = 302 + chtn2i (1728) = 210 + chbiet (302) = 1728 +c +c =========================================== +c Classe d'equivalence 4-02 +c +c Aretes coupees : 1 2 9 11 + chclas (1283) = ' 4-02' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1283)(1:12) = ' 1 2 9 11' + chnp1 (1283) = 1 + chnar (1283) = 14 + chnpy (1283) = 9 + chnte (1283) = 6 + chnhe (1283) = 0 + chperm (1283) = 0 + chbirf (1283) = 1283 + chetat (1283) = 303 + chtn2i (1283) = 210 + chbiet (303) = 1283 +c +c Aretes coupees : 1 3 11 12 + chclas (3077) = ' 4-02' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3077)(1:12) = ' 1 3 11 12' + chnp1 (3077) = 1 + chnar (3077) = 14 + chnpy (3077) = 9 + chnte (3077) = 6 + chnhe (3077) = 0 + chperm (3077) = 21 + chbirf (3077) = 1283 + chetat (3077) = 304 + chtn2i (3077) = 210 + chbiet (304) = 3077 +c +c Aretes coupees : 1 4 6 7 + chclas (105) = ' 4-02' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0 + charde (105)(1:12) = ' 1 4 6 7' + chnp1 (105) = 1 + chnar (105) = 14 + chnpy (105) = 9 + chnte (105) = 6 + chnhe (105) = 0 + chperm (105) = 300 + chbirf (105) = 1283 + chetat (105) = 305 + chtn2i (105) = 210 + chbiet (305) = 105 +c +c Aretes coupees : 1 5 7 12 + chclas (2129) = ' 4-02' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1 + charde (2129)(1:12) = ' 1 5 7 12' + chnp1 (2129) = 1 + chnar (2129) = 14 + chnpy (2129) = 9 + chnte (2129) = 6 + chnhe (2129) = 0 + chperm (2129) = 101 + chbirf (2129) = 1283 + chetat (2129) = 306 + chtn2i (2129) = 210 + chbiet (306) = 2129 +c +c Aretes coupees : 2 3 5 8 + chclas (150) = ' 4-02' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (150)(1:12) = ' 2 3 5 8' + chnp1 (150) = 1 + chnar (150) = 14 + chnpy (150) = 9 + chnte (150) = 6 + chnhe (150) = 0 + chperm (150) = 310 + chbirf (150) = 1283 + chetat (150) = 307 + chtn2i (150) = 210 + chbiet (307) = 150 +c +c Aretes coupees : 2 4 9 10 + chclas (778) = ' 4-02' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0 + charde (778)(1:12) = ' 2 4 9 10' + chnp1 (778) = 1 + chnar (778) = 14 + chnpy (778) = 9 + chnte (778) = 6 + chnhe (778) = 0 + chperm (778) = 1 + chbirf (778) = 1283 + chetat (778) = 308 + chtn2i (778) = 210 + chbiet (308) = 778 +c +c Aretes coupees : 2 7 8 11 + chclas (1218) = ' 4-02' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0 + charde (1218)(1:12) = ' 2 7 8 11' + chnp1 (1218) = 1 + chnar (1218) = 14 + chnpy (1218) = 9 + chnte (1218) = 6 + chnhe (1218) = 0 + chperm (1218) = 210 + chbirf (1218) = 1283 + chetat (1218) = 309 + chtn2i (1218) = 210 + chbiet (309) = 1218 +c +c Aretes coupees : 3 4 10 12 + chclas (2572) = ' 4-02' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2572)(1:12) = ' 3 4 10 12' + chnp1 (2572) = 1 + chnar (2572) = 14 + chnpy (2572) = 9 + chnte (2572) = 6 + chnhe (2572) = 0 + chperm (2572) = 200 + chbirf (2572) = 1283 + chetat (2572) = 310 + chtn2i (2572) = 210 + chbiet (310) = 2572 +c +c Aretes coupees : 3 5 6 10 + chclas (564) = ' 4-02' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0 + charde (564)(1:12) = ' 3 5 6 10' + chnp1 (564) = 1 + chnar (564) = 14 + chnpy (564) = 9 + chnte (564) = 6 + chnhe (564) = 0 + chperm (564) = 10 + chbirf (564) = 1283 + chetat (564) = 311 + chtn2i (564) = 210 + chbiet (311) = 564 +c +c Aretes coupees : 4 6 8 9 + chclas (424) = ' 4-02' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0 + charde (424)(1:12) = ' 4 6 8 9' + chnp1 (424) = 1 + chnar (424) = 14 + chnpy (424) = 9 + chnte (424) = 6 + chnhe (424) = 0 + chperm (424) = 121 + chbirf (424) = 1283 + chetat (424) = 312 + chtn2i (424) = 210 + chbiet (312) = 424 +c +c Aretes coupees : 5 8 9 12 + chclas (2448) = ' 4-02' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1 + charde (2448)(1:12) = ' 5 8 9 12' + chnp1 (2448) = 1 + chnar (2448) = 14 + chnpy (2448) = 9 + chnte (2448) = 6 + chnhe (2448) = 0 + chperm (2448) = 100 + chbirf (2448) = 1283 + chetat (2448) = 313 + chtn2i (2448) = 210 + chbiet (313) = 2448 +c +c Aretes coupees : 6 7 10 11 + chclas (1632) = ' 4-02' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0 + charde (1632)(1:12) = ' 6 7 10 11' + chnp1 (1632) = 1 + chnar (1632) = 14 + chnpy (1632) = 9 + chnte (1632) = 6 + chnhe (1632) = 0 + chperm (1632) = 110 + chbirf (1632) = 1283 + chetat (1632) = 314 + chtn2i (1632) = 210 + chbiet (314) = 1632 +c +c =========================================== +c Classe d'equivalence 4-03 +c +c Aretes coupees : 1 2 10 12 + chclas (2563) = ' 4-03' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2563)(1:12) = ' 1 2 10 12' + chnp1 (2563) = 1 + chnar (2563) = 14 + chnpy (2563) = 9 + chnte (2563) = 6 + chnhe (2563) = 0 + chperm (2563) = 0 + chbirf (2563) = 2563 + chetat (2563) = 315 + chtn2i (2563) = 210 + chbiet (315) = 2563 +c +c Aretes coupees : 1 3 9 10 + chclas (773) = ' 4-03' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (773)(1:12) = ' 1 3 9 10' + chnp1 (773) = 1 + chnar (773) = 14 + chnpy (773) = 9 + chnte (773) = 6 + chnhe (773) = 0 + chperm (773) = 201 + chbirf (773) = 2563 + chetat (773) = 316 + chtn2i (773) = 210 + chbiet (316) = 773 +c +c Aretes coupees : 1 4 5 8 + chclas (153) = ' 4-03' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0 + charde (153)(1:12) = ' 1 4 5 8' + chnp1 (153) = 1 + chnar (153) = 14 + chnpy (153) = 9 + chnte (153) = 6 + chnhe (153) = 0 + chperm (153) = 101 + chbirf (153) = 2563 + chetat (153) = 317 + chtn2i (153) = 210 + chbiet (317) = 153 +c +c Aretes coupees : 1 6 8 12 + chclas (2209) = ' 4-03' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1 + charde (2209)(1:12) = ' 1 6 8 12' + chnp1 (2209) = 1 + chnar (2209) = 14 + chnpy (2209) = 9 + chnte (2209) = 6 + chnhe (2209) = 0 + chperm (2209) = 120 + chbirf (2209) = 2563 + chetat (2209) = 318 + chtn2i (2209) = 210 + chbiet (318) = 2209 +c +c Aretes coupees : 2 3 6 7 + chclas (102) = ' 4-03' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (102)(1:12) = ' 2 3 6 7' + chnp1 (102) = 1 + chnar (102) = 14 + chnpy (102) = 9 + chnte (102) = 6 + chnhe (102) = 0 + chperm (102) = 10 + chbirf (102) = 2563 + chetat (102) = 319 + chtn2i (102) = 210 + chbiet (319) = 102 +c +c Aretes coupees : 2 4 11 12 + chclas (3082) = ' 4-03' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3082)(1:12) = ' 2 4 11 12' + chnp1 (3082) = 1 + chnar (3082) = 14 + chnpy (3082) = 9 + chnte (3082) = 6 + chnhe (3082) = 0 + chperm (3082) = 1 + chbirf (3082) = 2563 + chetat (3082) = 320 + chtn2i (3082) = 210 + chbiet (320) = 3082 +c +c Aretes coupees : 2 5 6 11 + chclas (1074) = ' 4-03' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0 + charde (1074)(1:12) = ' 2 5 6 11' + chnp1 (1074) = 1 + chnar (1074) = 14 + chnpy (1074) = 9 + chnte (1074) = 6 + chnhe (1074) = 0 + chperm (1074) = 110 + chbirf (1074) = 2563 + chetat (1074) = 321 + chtn2i (1074) = 210 + chbiet (321) = 1074 +c +c Aretes coupees : 3 4 9 11 + chclas (1292) = ' 4-03' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1292)(1:12) = ' 3 4 9 11' + chnp1 (1292) = 1 + chnar (1292) = 14 + chnpy (1292) = 9 + chnte (1292) = 6 + chnhe (1292) = 0 + chperm (1292) = 20 + chbirf (1292) = 2563 + chetat (1292) = 322 + chtn2i (1292) = 210 + chbiet (322) = 1292 +c +c Aretes coupees : 3 7 8 10 + chclas (708) = ' 4-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 0 + charde (708)(1:12) = ' 3 7 8 10' + chnp1 (708) = 1 + chnar (708) = 14 + chnpy (708) = 9 + chnte (708) = 6 + chnhe (708) = 0 + chperm (708) = 310 + chbirf (708) = 2563 + chetat (708) = 323 + chtn2i (708) = 210 + chbiet (323) = 708 +c +c Aretes coupees : 4 5 7 9 + chclas (344) = ' 4-03' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0 + charde (344)(1:12) = ' 4 5 7 9' + chnp1 (344) = 1 + chnar (344) = 14 + chnpy (344) = 9 + chnte (344) = 6 + chnhe (344) = 0 + chperm (344) = 100 + chbirf (344) = 2563 + chetat (344) = 324 + chtn2i (344) = 210 + chbiet (324) = 344 +c +c Aretes coupees : 5 8 10 11 + chclas (1680) = ' 4-03' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0 + charde (1680)(1:12) = ' 5 8 10 11' + chnp1 (1680) = 1 + chnar (1680) = 14 + chnpy (1680) = 9 + chnte (1680) = 6 + chnhe (1680) = 0 + chperm (1680) = 210 + chbirf (1680) = 2563 + chetat (1680) = 325 + chtn2i (1680) = 210 + chbiet (325) = 1680 +c +c Aretes coupees : 6 7 9 12 + chclas (2400) = ' 4-03' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 1 + charde (2400)(1:12) = ' 6 7 9 12' + chnp1 (2400) = 1 + chnar (2400) = 14 + chnpy (2400) = 9 + chnte (2400) = 6 + chnhe (2400) = 0 + chperm (2400) = 301 + chbirf (2400) = 2563 + chetat (2400) = 326 + chtn2i (2400) = 210 + chbiet (326) = 2400 +c +c =========================================== +c Classe d'equivalence 4-04 +c +c Aretes coupees : 1 2 11 12 + chclas (3075) = ' 4-04' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3075)(1:12) = ' 1 2 11 12' + chnp1 (3075) = 1 + chnar (3075) = 14 + chnpy (3075) = 6 + chnte (3075) = 12 + chnhe (3075) = 0 + chperm (3075) = 0 + chbirf (3075) = 3075 + chetat (3075) = 327 + chtn2i (3075) = 210 + chbiet (327) = 3075 +c +c Aretes coupees : 1 3 10 12 + chclas (2565) = ' 4-04' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2565)(1:12) = ' 1 3 10 12' + chnp1 (2565) = 1 + chnar (2565) = 14 + chnpy (2565) = 6 + chnte (2565) = 12 + chnhe (2565) = 0 + chperm (2565) = 200 + chbirf (2565) = 3075 + chetat (2565) = 328 + chtn2i (2565) = 210 + chbiet (328) = 2565 +c +c Aretes coupees : 1 5 8 12 + chclas (2193) = ' 4-04' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2193)(1:12) = ' 1 5 8 12' + chnp1 (2193) = 1 + chnar (2193) = 14 + chnpy (2193) = 6 + chnte (2193) = 12 + chnhe (2193) = 0 + chperm (2193) = 120 + chbirf (2193) = 3075 + chetat (2193) = 329 + chtn2i (2193) = 210 + chbiet (329) = 2193 +c +c Aretes coupees : 1 6 7 12 + chclas (2145) = ' 4-04' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2145)(1:12) = ' 1 6 7 12' + chnp1 (2145) = 1 + chnar (2145) = 14 + chnpy (2145) = 6 + chnte (2145) = 12 + chnhe (2145) = 0 + chperm (2145) = 320 + chbirf (2145) = 3075 + chetat (2145) = 330 + chtn2i (2145) = 210 + chbiet (330) = 2145 +c +c Aretes coupees : 2 4 9 11 + chclas (1290) = ' 4-04' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1290)(1:12) = ' 2 4 9 11' + chnp1 (1290) = 1 + chnar (1290) = 14 + chnpy (1290) = 6 + chnte (1290) = 12 + chnhe (1290) = 0 + chperm (1290) = 20 + chbirf (1290) = 3075 + chetat (1290) = 331 + chtn2i (1290) = 210 + chbiet (331) = 1290 +c +c Aretes coupees : 2 5 8 11 + chclas (1170) = ' 4-04' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1170)(1:12) = ' 2 5 8 11' + chnp1 (1170) = 1 + chnar (1170) = 14 + chnpy (1170) = 6 + chnte (1170) = 12 + chnhe (1170) = 0 + chperm (1170) = 210 + chbirf (1170) = 3075 + chetat (1170) = 332 + chtn2i (1170) = 210 + chbiet (332) = 1170 +c +c Aretes coupees : 2 6 7 11 + chclas (1122) = ' 4-04' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1122)(1:12) = ' 2 6 7 11' + chnp1 (1122) = 1 + chnar (1122) = 14 + chnpy (1122) = 6 + chnte (1122) = 12 + chnhe (1122) = 0 + chperm (1122) = 110 + chbirf (1122) = 3075 + chetat (1122) = 333 + chtn2i (1122) = 210 + chbiet (333) = 1122 +c +c Aretes coupees : 3 4 9 10 + chclas (780) = ' 4-04' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0 + charde (780)(1:12) = ' 3 4 9 10' + chnp1 (780) = 1 + chnar (780) = 14 + chnpy (780) = 6 + chnte (780) = 12 + chnhe (780) = 0 + chperm (780) = 220 + chbirf (780) = 3075 + chetat (780) = 334 + chtn2i (780) = 210 + chbiet (334) = 780 +c +c Aretes coupees : 3 5 8 10 + chclas (660) = ' 4-04' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0 + charde (660)(1:12) = ' 3 5 8 10' + chnp1 (660) = 1 + chnar (660) = 14 + chnpy (660) = 6 + chnte (660) = 12 + chnhe (660) = 0 + chperm (660) = 310 + chbirf (660) = 3075 + chetat (660) = 335 + chtn2i (660) = 210 + chbiet (335) = 660 +c +c Aretes coupees : 3 6 7 10 + chclas (612) = ' 4-04' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0 + charde (612)(1:12) = ' 3 6 7 10' + chnp1 (612) = 1 + chnar (612) = 14 + chnpy (612) = 6 + chnte (612) = 12 + chnhe (612) = 0 + chperm (612) = 10 + chbirf (612) = 3075 + chetat (612) = 336 + chtn2i (612) = 210 + chbiet (336) = 612 +c +c Aretes coupees : 4 5 8 9 + chclas (408) = ' 4-04' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0 + charde (408)(1:12) = ' 4 5 8 9' + chnp1 (408) = 1 + chnar (408) = 14 + chnpy (408) = 6 + chnte (408) = 12 + chnhe (408) = 0 + chperm (408) = 100 + chbirf (408) = 3075 + chetat (408) = 337 + chtn2i (408) = 210 + chbiet (337) = 408 +c +c Aretes coupees : 4 6 7 9 + chclas (360) = ' 4-04' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0, 0 + charde (360)(1:12) = ' 4 6 7 9' + chnp1 (360) = 1 + chnar (360) = 14 + chnpy (360) = 6 + chnte (360) = 12 + chnhe (360) = 0 + chperm (360) = 300 + chbirf (360) = 3075 + chetat (360) = 338 + chtn2i (360) = 210 + chbiet (338) = 360 +c +c =========================================== +c Classe d'equivalence 4-05 +c +c Aretes coupees : 1 2 6 8 + chclas (163) = ' 4-05' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 + charde (163)(1:12) = ' 1 2 6 8' + chnp1 (163) = 1 + chnar (163) = 14 + chnpy (163) = 9 + chnte (163) = 6 + chnhe (163) = 0 + chperm (163) = 0 + chbirf (163) = 163 + chetat (163) = 339 + chtn2i (163) = 210 + chbiet (339) = 163 +c +c Aretes coupees : 1 2 6 10 + chclas (547) = ' 4-05' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (547)(1:12) = ' 1 2 6 10' + chnp1 (547) = 1 + chnar (547) = 14 + chnpy (547) = 9 + chnte (547) = 6 + chnhe (547) = 0 + chperm (547) = 320 + chbirf (547) = 163 + chetat (547) = 340 + chtn2i (547) = 210 + chbiet (340) = 547 +c +c Aretes coupees : 1 3 7 8 + chclas (197) = ' 4-05' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (197)(1:12) = ' 1 3 7 8' + chnp1 (197) = 1 + chnar (197) = 14 + chnpy (197) = 9 + chnte (197) = 6 + chnhe (197) = 0 + chperm (197) = 221 + chbirf (197) = 163 + chetat (197) = 341 + chtn2i (197) = 210 + chbiet (341) = 197 +c +c Aretes coupees : 1 3 8 9 + chclas (389) = ' 4-05' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (389)(1:12) = ' 1 3 8 9' + chnp1 (389) = 1 + chnar (389) = 14 + chnpy (389) = 9 + chnte (389) = 6 + chnhe (389) = 0 + chperm (389) = 310 + chbirf (389) = 163 + chetat (389) = 342 + chtn2i (389) = 210 + chbiet (342) = 389 +c +c Aretes coupees : 1 4 5 10 + chclas (537) = ' 4-05' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0 + charde (537)(1:12) = ' 1 4 5 10' + chnp1 (537) = 1 + chnar (537) = 14 + chnpy (537) = 9 + chnte (537) = 6 + chnhe (537) = 0 + chperm (537) = 30 + chbirf (537) = 163 + chetat (537) = 343 + chtn2i (537) = 210 + chbiet (343) = 537 +c +c Aretes coupees : 1 4 8 11 + chclas (1161) = ' 4-05' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1161)(1:12) = ' 1 4 8 11' + chnp1 (1161) = 1 + chnar (1161) = 14 + chnpy (1161) = 9 + chnte (1161) = 6 + chnhe (1161) = 0 + chperm (1161) = 210 + chbirf (1161) = 163 + chetat (1161) = 344 + chtn2i (1161) = 210 + chbiet (344) = 1161 +c +c Aretes coupees : 1 5 10 11 + chclas (1553) = ' 4-05' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1553)(1:12) = ' 1 5 10 11' + chnp1 (1553) = 1 + chnar (1553) = 14 + chnpy (1553) = 9 + chnte (1553) = 6 + chnhe (1553) = 0 + chperm (1553) = 101 + chbirf (1553) = 163 + chetat (1553) = 345 + chtn2i (1553) = 210 + chbiet (345) = 1553 +c +c Aretes coupees : 1 7 9 10 + chclas (833) = ' 4-05' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0, 0 + charde (833)(1:12) = ' 1 7 9 10' + chnp1 (833) = 1 + chnar (833) = 14 + chnpy (833) = 9 + chnte (833) = 6 + chnhe (833) = 0 + chperm (833) = 130 + chbirf (833) = 163 + chetat (833) = 346 + chtn2i (833) = 210 + chbiet (346) = 833 +c +c Aretes coupees : 2 3 6 9 + chclas (294) = ' 4-05' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0 + charde (294)(1:12) = ' 2 3 6 9' + chnp1 (294) = 1 + chnar (294) = 14 + chnpy (294) = 9 + chnte (294) = 6 + chnhe (294) = 0 + chperm (294) = 321 + chbirf (294) = 163 + chetat (294) = 347 + chtn2i (294) = 210 + chbiet (347) = 294 +c +c Aretes coupees : 2 3 7 12 + chclas (2118) = ' 4-05' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2118)(1:12) = ' 2 3 7 12' + chnp1 (2118) = 1 + chnar (2118) = 14 + chnpy (2118) = 9 + chnte (2118) = 6 + chnhe (2118) = 0 + chperm (2118) = 301 + chbirf (2118) = 163 + chetat (2118) = 348 + chtn2i (2118) = 210 + chbiet (348) = 2118 +c +c Aretes coupees : 2 4 5 6 + chclas (58) = ' 4-05' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0 + charde (58)(1:12) = ' 2 4 5 6' + chnp1 (58) = 1 + chnar (58) = 14 + chnpy (58) = 9 + chnte (58) = 6 + chnhe (58) = 0 + chperm (58) = 1 + chbirf (58) = 163 + chetat (58) = 349 + chtn2i (58) = 210 + chbiet (349) = 58 +c +c Aretes coupees : 2 4 5 12 + chclas (2074) = ' 4-05' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2074)(1:12) = ' 2 4 5 12' + chnp1 (2074) = 1 + chnar (2074) = 14 + chnpy (2074) = 9 + chnte (2074) = 6 + chnhe (2074) = 0 + chperm (2074) = 330 + chbirf (2074) = 163 + chetat (2074) = 350 + chtn2i (2074) = 210 + chbiet (350) = 2074 +c +c Aretes coupees : 2 7 9 12 + chclas (2370) = ' 4-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2370)(1:12) = ' 2 7 9 12' + chnp1 (2370) = 1 + chnar (2370) = 14 + chnpy (2370) = 9 + chnte (2370) = 6 + chnhe (2370) = 0 + chperm (2370) = 230 + chbirf (2370) = 163 + chetat (2370) = 351 + chtn2i (2370) = 210 + chbiet (351) = 2370 +c +c Aretes coupees : 2 8 10 12 + chclas (2690) = ' 4-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2690)(1:12) = ' 2 8 10 12' + chnp1 (2690) = 1 + chnar (2690) = 14 + chnpy (2690) = 9 + chnte (2690) = 6 + chnhe (2690) = 0 + chperm (2690) = 120 + chbirf (2690) = 163 + chetat (2690) = 352 + chtn2i (2690) = 210 + chbiet (352) = 2690 +c +c Aretes coupees : 3 4 5 7 + chclas (92) = ' 4-05' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0 + charde (92)(1:12) = ' 3 4 5 7' + chnp1 (92) = 1 + chnar (92) = 14 + chnpy (92) = 9 + chnte (92) = 6 + chnhe (92) = 0 + chperm (92) = 220 + chbirf (92) = 163 + chetat (92) = 353 + chtn2i (92) = 210 + chbiet (353) = 92 +c +c Aretes coupees : 3 4 7 11 + chclas (1100) = ' 4-05' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1100)(1:12) = ' 3 4 7 11' + chnp1 (1100) = 1 + chnar (1100) = 14 + chnpy (1100) = 9 + chnte (1100) = 6 + chnhe (1100) = 0 + chperm (1100) = 300 + chbirf (1100) = 163 + chetat (1100) = 354 + chtn2i (1100) = 210 + chbiet (354) = 1100 +c +c Aretes coupees : 3 5 9 11 + chclas (1300) = ' 4-05' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1300)(1:12) = ' 3 5 9 11' + chnp1 (1300) = 1 + chnar (1300) = 14 + chnpy (1300) = 9 + chnte (1300) = 6 + chnhe (1300) = 0 + chperm (1300) = 100 + chbirf (1300) = 163 + chetat (1300) = 355 + chtn2i (1300) = 210 + chbiet (355) = 1300 +c +c Aretes coupees : 3 6 9 12 + chclas (2340) = ' 4-05' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2340)(1:12) = ' 3 6 9 12' + chnp1 (2340) = 1 + chnar (2340) = 14 + chnpy (2340) = 9 + chnte (2340) = 6 + chnhe (2340) = 0 + chperm (2340) = 10 + chbirf (2340) = 163 + chetat (2340) = 356 + chtn2i (2340) = 210 + chbiet (356) = 2340 +c +c Aretes coupees : 4 6 11 12 + chclas (3112) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3112)(1:12) = ' 4 6 11 12' + chnp1 (3112) = 1 + chnar (3112) = 14 + chnpy (3112) = 9 + chnte (3112) = 6 + chnhe (3112) = 0 + chperm (3112) = 110 + chbirf (3112) = 163 + chetat (3112) = 357 + chtn2i (3112) = 210 + chbiet (357) = 3112 +c +c Aretes coupees : 4 8 10 11 + chclas (1672) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1672)(1:12) = ' 4 8 10 11' + chnp1 (1672) = 1 + chnar (1672) = 14 + chnpy (1672) = 9 + chnte (1672) = 6 + chnhe (1672) = 0 + chperm (1672) = 121 + chbirf (1672) = 163 + chetat (1672) = 358 + chtn2i (1672) = 210 + chbiet (358) = 1672 +c +c Aretes coupees : 5 6 11 12 + chclas (3120) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1 + charde (3120)(1:12) = ' 5 6 11 12' + chnp1 (3120) = 1 + chnar (3120) = 14 + chnpy (3120) = 9 + chnte (3120) = 6 + chnhe (3120) = 0 + chperm (3120) = 21 + chbirf (3120) = 163 + chetat (3120) = 359 + chtn2i (3120) = 210 + chbiet (359) = 3120 +c +c Aretes coupees : 5 7 9 11 + chclas (1360) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0 + charde (1360)(1:12) = ' 5 7 9 11' + chnp1 (1360) = 1 + chnar (1360) = 14 + chnpy (1360) = 9 + chnte (1360) = 6 + chnhe (1360) = 0 + chperm (1360) = 20 + chbirf (1360) = 163 + chetat (1360) = 360 + chtn2i (1360) = 210 + chbiet (360) = 1360 +c +c Aretes coupees : 6 8 10 12 + chclas (2720) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1 + charde (2720)(1:12) = ' 6 8 10 12' + chnp1 (2720) = 1 + chnar (2720) = 14 + chnpy (2720) = 9 + chnte (2720) = 6 + chnhe (2720) = 0 + chperm (2720) = 200 + chbirf (2720) = 163 + chetat (2720) = 361 + chtn2i (2720) = 210 + chbiet (361) = 2720 +c +c Aretes coupees : 7 8 9 10 + chclas (960) = ' 4-05' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0 + charde (960)(1:12) = ' 7 8 9 10' + chnp1 (960) = 1 + chnar (960) = 14 + chnpy (960) = 9 + chnte (960) = 6 + chnhe (960) = 0 + chperm (960) = 201 + chbirf (960) = 163 + chetat (960) = 362 + chtn2i (960) = 210 + chbiet (362) = 960 +c +c =========================================== +c Classe d'equivalence 4-06 +c +c Aretes coupees : 1 2 7 8 + chclas (195) = ' 4-06' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0 + charde (195)(1:12) = ' 1 2 7 8' + chnp1 (195) = 1 + chnar (195) = 14 + chnpy (195) = 9 + chnte (195) = 6 + chnhe (195) = 0 + chperm (195) = 0 + chbirf (195) = 195 + chetat (195) = 363 + chtn2i (195) = 210 + chbiet (363) = 195 +c +c Aretes coupees : 1 2 7 9 + chclas (323) = ' 4-06' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (323)(1:12) = ' 1 2 7 9' + chnp1 (323) = 1 + chnar (323) = 14 + chnpy (323) = 9 + chnte (323) = 6 + chnhe (323) = 0 + chperm (323) = 230 + chbirf (323) = 195 + chetat (323) = 364 + chtn2i (323) = 210 + chbiet (364) = 323 +c +c Aretes coupees : 1 3 5 7 + chclas (85) = ' 4-06' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0 + charde (85)(1:12) = ' 1 3 5 7' + chnp1 (85) = 1 + chnar (85) = 14 + chnpy (85) = 9 + chnte (85) = 6 + chnhe (85) = 0 + chperm (85) = 221 + chbirf (85) = 195 + chetat (85) = 365 + chtn2i (85) = 210 + chbiet (365) = 85 +c +c Aretes coupees : 1 3 5 11 + chclas (1045) = ' 4-06' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1045)(1:12) = ' 1 3 5 11' + chnp1 (1045) = 1 + chnar (1045) = 14 + chnpy (1045) = 9 + chnte (1045) = 6 + chnhe (1045) = 0 + chperm (1045) = 101 + chbirf (1045) = 195 + chetat (1045) = 366 + chtn2i (1045) = 210 + chbiet (366) = 1045 +c +c Aretes coupees : 1 4 6 11 + chclas (1065) = ' 4-06' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1065)(1:12) = ' 1 4 6 11' + chnp1 (1065) = 1 + chnar (1065) = 14 + chnpy (1065) = 9 + chnte (1065) = 6 + chnhe (1065) = 0 + chperm (1065) = 110 + chbirf (1065) = 195 + chetat (1065) = 367 + chtn2i (1065) = 210 + chbiet (367) = 1065 +c +c Aretes coupees : 1 4 7 10 + chclas (585) = ' 4-06' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 + charde (585)(1:12) = ' 1 4 7 10' + chnp1 (585) = 1 + chnar (585) = 14 + chnpy (585) = 9 + chnte (585) = 6 + chnhe (585) = 0 + chperm (585) = 130 + chbirf (585) = 195 + chetat (585) = 368 + chtn2i (585) = 210 + chbiet (368) = 585 +c +c Aretes coupees : 1 6 10 11 + chclas (1569) = ' 4-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1569)(1:12) = ' 1 6 10 11' + chnp1 (1569) = 1 + chnar (1569) = 14 + chnpy (1569) = 9 + chnte (1569) = 6 + chnhe (1569) = 0 + chperm (1569) = 320 + chbirf (1569) = 195 + chetat (1569) = 369 + chtn2i (1569) = 210 + chbiet (369) = 1569 +c +c Aretes coupees : 1 8 9 11 + chclas (1409) = ' 4-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1409)(1:12) = ' 1 8 9 11' + chnp1 (1409) = 1 + chnar (1409) = 14 + chnpy (1409) = 9 + chnte (1409) = 6 + chnhe (1409) = 0 + chperm (1409) = 210 + chbirf (1409) = 195 + chetat (1409) = 370 + chtn2i (1409) = 210 + chbiet (370) = 1409 +c +c Aretes coupees : 2 3 5 9 + chclas (278) = ' 4-06' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0 + charde (278)(1:12) = ' 2 3 5 9' + chnp1 (278) = 1 + chnar (278) = 14 + chnpy (278) = 9 + chnte (278) = 6 + chnhe (278) = 0 + chperm (278) = 100 + chbirf (278) = 195 + chetat (278) = 371 + chtn2i (278) = 210 + chbiet (371) = 278 +c +c Aretes coupees : 2 3 8 12 + chclas (2182) = ' 4-06' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2182)(1:12) = ' 2 3 8 12' + chnp1 (2182) = 1 + chnar (2182) = 14 + chnpy (2182) = 9 + chnte (2182) = 6 + chnhe (2182) = 0 + chperm (2182) = 120 + chbirf (2182) = 195 + chetat (2182) = 372 + chtn2i (2182) = 210 + chbiet (372) = 2182 +c +c Aretes coupees : 2 4 6 8 + chclas (170) = ' 4-06' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0 + charde (170)(1:12) = ' 2 4 6 8' + chnp1 (170) = 1 + chnar (170) = 14 + chnpy (170) = 9 + chnte (170) = 6 + chnhe (170) = 0 + chperm (170) = 1 + chbirf (170) = 195 + chetat (170) = 373 + chtn2i (170) = 210 + chbiet (373) = 170 +c +c Aretes coupees : 2 4 8 10 + chclas (650) = ' 4-06' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 + charde (650)(1:12) = ' 2 4 8 10' + chnp1 (650) = 1 + chnar (650) = 14 + chnpy (650) = 9 + chnte (650) = 6 + chnhe (650) = 0 + chperm (650) = 121 + chbirf (650) = 195 + chetat (650) = 374 + chtn2i (650) = 210 + chbiet (374) = 650 +c +c Aretes coupees : 2 5 9 12 + chclas (2322) = ' 4-06' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2322)(1:12) = ' 2 5 9 12' + chnp1 (2322) = 1 + chnar (2322) = 14 + chnpy (2322) = 9 + chnte (2322) = 6 + chnhe (2322) = 0 + chperm (2322) = 330 + chbirf (2322) = 195 + chetat (2322) = 375 + chtn2i (2322) = 210 + chbiet (375) = 2322 +c +c Aretes coupees : 2 6 9 10 + chclas (802) = ' 4-06' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0 + charde (802)(1:12) = ' 2 6 9 10' + chnp1 (802) = 1 + chnar (802) = 14 + chnpy (802) = 9 + chnte (802) = 6 + chnhe (802) = 0 + chperm (802) = 321 + chbirf (802) = 195 + chetat (802) = 376 + chtn2i (802) = 210 + chbiet (376) = 802 +c +c Aretes coupees : 3 4 5 6 + chclas (60) = ' 4-06' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0 + charde (60)(1:12) = ' 3 4 5 6' + chnp1 (60) = 1 + chnar (60) = 14 + chnpy (60) = 9 + chnte (60) = 6 + chnhe (60) = 0 + chperm (60) = 220 + chbirf (60) = 195 + chetat (60) = 377 + chtn2i (60) = 210 + chbiet (377) = 60 +c +c Aretes coupees : 3 4 6 12 + chclas (2092) = ' 4-06' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2092)(1:12) = ' 3 4 6 12' + chnp1 (2092) = 1 + chnar (2092) = 14 + chnpy (2092) = 9 + chnte (2092) = 6 + chnhe (2092) = 0 + chperm (2092) = 10 + chbirf (2092) = 195 + chetat (2092) = 378 + chtn2i (2092) = 210 + chbiet (378) = 2092 +c +c Aretes coupees : 3 7 11 12 + chclas (3140) = ' 4-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3140)(1:12) = ' 3 7 11 12' + chnp1 (3140) = 1 + chnar (3140) = 14 + chnpy (3140) = 9 + chnte (3140) = 6 + chnhe (3140) = 0 + chperm (3140) = 301 + chbirf (3140) = 195 + chetat (3140) = 379 + chtn2i (3140) = 210 + chbiet (379) = 3140 +c +c Aretes coupees : 3 8 9 12 + chclas (2436) = ' 4-06' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2436)(1:12) = ' 3 8 9 12' + chnp1 (2436) = 1 + chnar (2436) = 14 + chnpy (2436) = 9 + chnte (2436) = 6 + chnhe (2436) = 0 + chperm (2436) = 310 + chbirf (2436) = 195 + chetat (2436) = 380 + chtn2i (2436) = 210 + chbiet (380) = 2436 +c +c Aretes coupees : 4 5 10 12 + chclas (2584) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2584)(1:12) = ' 4 5 10 12' + chnp1 (2584) = 1 + chnar (2584) = 14 + chnpy (2584) = 9 + chnte (2584) = 6 + chnhe (2584) = 0 + chperm (2584) = 30 + chbirf (2584) = 195 + chetat (2584) = 381 + chtn2i (2584) = 210 + chbiet (381) = 2584 +c +c Aretes coupees : 4 7 10 11 + chclas (1608) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1608)(1:12) = ' 4 7 10 11' + chnp1 (1608) = 1 + chnar (1608) = 14 + chnpy (1608) = 9 + chnte (1608) = 6 + chnhe (1608) = 0 + chperm (1608) = 300 + chbirf (1608) = 195 + chetat (1608) = 382 + chtn2i (1608) = 210 + chbiet (382) = 1608 +c +c Aretes coupees : 5 6 10 12 + chclas (2608) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 1 + charde (2608)(1:12) = ' 5 6 10 12' + chnp1 (2608) = 1 + chnar (2608) = 14 + chnpy (2608) = 9 + chnte (2608) = 6 + chnhe (2608) = 0 + chperm (2608) = 200 + chbirf (2608) = 195 + chetat (2608) = 383 + chtn2i (2608) = 210 + chbiet (383) = 2608 +c +c Aretes coupees : 5 7 11 12 + chclas (3152) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 1 + charde (3152)(1:12) = ' 5 7 11 12' + chnp1 (3152) = 1 + chnar (3152) = 14 + chnpy (3152) = 9 + chnte (3152) = 6 + chnhe (3152) = 0 + chperm (3152) = 21 + chbirf (3152) = 195 + chetat (3152) = 384 + chtn2i (3152) = 210 + chbiet (384) = 3152 +c +c Aretes coupees : 6 8 9 10 + chclas (928) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 0, 0 + charde (928)(1:12) = ' 6 8 9 10' + chnp1 (928) = 1 + chnar (928) = 14 + chnpy (928) = 9 + chnte (928) = 6 + chnhe (928) = 0 + chperm (928) = 201 + chbirf (928) = 195 + chetat (928) = 385 + chtn2i (928) = 210 + chbiet (385) = 928 +c +c Aretes coupees : 7 8 9 11 + chclas (1472) = ' 4-06' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0 + charde (1472)(1:12) = ' 7 8 9 11' + chnp1 (1472) = 1 + chnar (1472) = 14 + chnpy (1472) = 9 + chnte (1472) = 6 + chnhe (1472) = 0 + chperm (1472) = 20 + chbirf (1472) = 195 + chetat (1472) = 386 + chtn2i (1472) = 210 + chbiet (386) = 1472 +c +c =========================================== +c Classe d'equivalence 4-07 +c +c Aretes coupees : 1 2 8 9 + chclas (387) = ' 4-07' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (387)(1:12) = ' 1 2 8 9' + chnp1 (387) = 1 + chnar (387) = 13 + chnpy (387) = 5 + chnte (387) = 12 + chnhe (387) = 0 + chperm (387) = 0 + chbirf (387) = 387 + chetat (387) = 387 + chtn2i (387) = 210 + chbiet (387) = 387 +c +c Aretes coupees : 1 3 7 11 + chclas (1093) = ' 4-07' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1093)(1:12) = ' 1 3 7 11' + chnp1 (1093) = 1 + chnar (1093) = 13 + chnpy (1093) = 5 + chnte (1093) = 12 + chnhe (1093) = 0 + chperm (1093) = 221 + chbirf (1093) = 387 + chetat (1093) = 388 + chtn2i (1093) = 210 + chbiet (388) = 1093 +c +c Aretes coupees : 1 4 6 10 + chclas (553) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0 + charde (553)(1:12) = ' 1 4 6 10' + chnp1 (553) = 1 + chnar (553) = 13 + chnpy (553) = 5 + chnte (553) = 12 + chnhe (553) = 0 + chperm (553) = 320 + chbirf (553) = 387 + chetat (553) = 389 + chtn2i (553) = 210 + chbiet (389) = 553 +c +c Aretes coupees : 1 4 7 11 + chclas (1097) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1097)(1:12) = ' 1 4 7 11' + chnp1 (1097) = 1 + chnar (1097) = 13 + chnpy (1097) = 5 + chnte (1097) = 12 + chnhe (1097) = 0 + chperm (1097) = 300 + chbirf (1097) = 387 + chetat (1097) = 390 + chtn2i (1097) = 210 + chbiet (390) = 1097 +c +c Aretes coupees : 1 5 7 11 + chclas (1105) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1105)(1:12) = ' 1 5 7 11' + chnp1 (1105) = 1 + chnar (1105) = 13 + chnpy (1105) = 5 + chnte (1105) = 12 + chnhe (1105) = 0 + chperm (1105) = 101 + chbirf (1105) = 387 + chetat (1105) = 391 + chtn2i (1105) = 210 + chbiet (391) = 1105 +c +c Aretes coupees : 1 7 8 11 + chclas (1217) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0 + charde (1217)(1:12) = ' 1 7 8 11' + chnp1 (1217) = 1 + chnar (1217) = 13 + chnpy (1217) = 5 + chnte (1217) = 12 + chnhe (1217) = 0 + chperm (1217) = 210 + chbirf (1217) = 387 + chetat (1217) = 392 + chtn2i (1217) = 210 + chbiet (392) = 1217 +c +c Aretes coupees : 1 7 9 11 + chclas (1345) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1345)(1:12) = ' 1 7 9 11' + chnp1 (1345) = 1 + chnar (1345) = 13 + chnpy (1345) = 5 + chnte (1345) = 12 + chnhe (1345) = 0 + chperm (1345) = 20 + chbirf (1345) = 387 + chetat (1345) = 393 + chtn2i (1345) = 210 + chbiet (393) = 1345 +c +c Aretes coupees : 1 7 10 11 + chclas (1601) = ' 4-07' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1601)(1:12) = ' 1 7 10 11' + chnp1 (1601) = 1 + chnar (1601) = 13 + chnpy (1601) = 5 + chnte (1601) = 12 + chnhe (1601) = 0 + chperm (1601) = 130 + chbirf (1601) = 387 + chetat (1601) = 394 + chtn2i (1601) = 210 + chbiet (394) = 1601 +c +c Aretes coupees : 2 3 5 12 + chclas (2070) = ' 4-07' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2070)(1:12) = ' 2 3 5 12' + chnp1 (2070) = 1 + chnar (2070) = 13 + chnpy (2070) = 5 + chnte (2070) = 12 + chnhe (2070) = 0 + chperm (2070) = 330 + chbirf (2070) = 387 + chetat (2070) = 395 + chtn2i (2070) = 210 + chbiet (395) = 2070 +c +c Aretes coupees : 2 3 8 9 + chclas (390) = ' 4-07' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0 + charde (390)(1:12) = ' 2 3 8 9' + chnp1 (390) = 1 + chnar (390) = 13 + chnpy (390) = 5 + chnte (390) = 12 + chnhe (390) = 0 + chperm (390) = 310 + chbirf (390) = 387 + chetat (390) = 396 + chtn2i (390) = 210 + chbiet (396) = 390 +c +c Aretes coupees : 2 4 6 10 + chclas (554) = ' 4-07' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0 + charde (554)(1:12) = ' 2 4 6 10' + chnp1 (554) = 1 + chnar (554) = 13 + chnpy (554) = 5 + chnte (554) = 12 + chnhe (554) = 0 + chperm (554) = 1 + chbirf (554) = 387 + chetat (554) = 397 + chtn2i (554) = 210 + chbiet (397) = 554 +c +c Aretes coupees : 2 6 8 9 + chclas (418) = ' 4-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0 + charde (418)(1:12) = ' 2 6 8 9' + chnp1 (418) = 1 + chnar (418) = 13 + chnpy (418) = 5 + chnte (418) = 12 + chnhe (418) = 0 + chperm (418) = 321 + chbirf (418) = 387 + chetat (418) = 398 + chtn2i (418) = 210 + chbiet (398) = 418 +c +c Aretes coupees : 2 7 8 9 + chclas (450) = ' 4-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (450)(1:12) = ' 2 7 8 9' + chnp1 (450) = 1 + chnar (450) = 13 + chnpy (450) = 5 + chnte (450) = 12 + chnhe (450) = 0 + chperm (450) = 230 + chbirf (450) = 387 + chetat (450) = 399 + chtn2i (450) = 210 + chbiet (399) = 450 +c +c Aretes coupees : 2 8 9 10 + chclas (898) = ' 4-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (898)(1:12) = ' 2 8 9 10' + chnp1 (898) = 1 + chnar (898) = 13 + chnpy (898) = 5 + chnte (898) = 12 + chnhe (898) = 0 + chperm (898) = 201 + chbirf (898) = 387 + chetat (898) = 400 + chtn2i (898) = 210 + chbiet (400) = 898 +c +c Aretes coupees : 2 8 9 12 + chclas (2434) = ' 4-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2434)(1:12) = ' 2 8 9 12' + chnp1 (2434) = 1 + chnar (2434) = 13 + chnpy (2434) = 5 + chnte (2434) = 12 + chnhe (2434) = 0 + chperm (2434) = 120 + chbirf (2434) = 387 + chetat (2434) = 401 + chtn2i (2434) = 210 + chbiet (401) = 2434 +c +c Aretes coupees : 3 4 5 12 + chclas (2076) = ' 4-07' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2076)(1:12) = ' 3 4 5 12' + chnp1 (2076) = 1 + chnar (2076) = 13 + chnpy (2076) = 5 + chnte (2076) = 12 + chnhe (2076) = 0 + chperm (2076) = 220 + chbirf (2076) = 387 + chetat (2076) = 402 + chtn2i (2076) = 210 + chbiet (402) = 2076 +c +c Aretes coupees : 3 5 6 12 + chclas (2100) = ' 4-07' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2100)(1:12) = ' 3 5 6 12' + chnp1 (2100) = 1 + chnar (2100) = 13 + chnpy (2100) = 5 + chnte (2100) = 12 + chnhe (2100) = 0 + chperm (2100) = 10 + chbirf (2100) = 387 + chetat (2100) = 403 + chtn2i (2100) = 210 + chbiet (403) = 2100 +c +c Aretes coupees : 3 5 7 12 + chclas (2132) = ' 4-07' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1 + charde (2132)(1:12) = ' 3 5 7 12' + chnp1 (2132) = 1 + chnar (2132) = 13 + chnpy (2132) = 5 + chnte (2132) = 12 + chnhe (2132) = 0 + chperm (2132) = 301 + chbirf (2132) = 387 + chetat (2132) = 404 + chtn2i (2132) = 210 + chbiet (404) = 2132 +c +c Aretes coupees : 3 5 9 12 + chclas (2324) = ' 4-07' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2324)(1:12) = ' 3 5 9 12' + chnp1 (2324) = 1 + chnar (2324) = 13 + chnpy (2324) = 5 + chnte (2324) = 12 + chnhe (2324) = 0 + chperm (2324) = 100 + chbirf (2324) = 387 + chetat (2324) = 405 + chtn2i (2324) = 210 + chbiet (405) = 2324 +c +c Aretes coupees : 3 5 11 12 + chclas (3092) = ' 4-07' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3092)(1:12) = ' 3 5 11 12' + chnp1 (3092) = 1 + chnar (3092) = 13 + chnpy (3092) = 5 + chnte (3092) = 12 + chnhe (3092) = 0 + chperm (3092) = 21 + chbirf (3092) = 387 + chetat (3092) = 406 + chtn2i (3092) = 210 + chbiet (406) = 3092 +c +c Aretes coupees : 4 5 6 10 + chclas (568) = ' 4-07' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 0 + charde (568)(1:12) = ' 4 5 6 10' + chnp1 (568) = 1 + chnar (568) = 13 + chnpy (568) = 5 + chnte (568) = 12 + chnhe (568) = 0 + chperm (568) = 30 + chbirf (568) = 387 + chetat (568) = 407 + chtn2i (568) = 210 + chbiet (407) = 568 +c +c Aretes coupees : 4 6 8 10 + chclas (680) = ' 4-07' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0 + charde (680)(1:12) = ' 4 6 8 10' + chnp1 (680) = 1 + chnar (680) = 13 + chnpy (680) = 5 + chnte (680) = 12 + chnhe (680) = 0 + chperm (680) = 121 + chbirf (680) = 387 + chetat (680) = 408 + chtn2i (680) = 210 + chbiet (408) = 680 +c +c Aretes coupees : 4 6 10 11 + chclas (1576) = ' 4-07' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1576)(1:12) = ' 4 6 10 11' + chnp1 (1576) = 1 + chnar (1576) = 13 + chnpy (1576) = 5 + chnte (1576) = 12 + chnhe (1576) = 0 + chperm (1576) = 110 + chbirf (1576) = 387 + chetat (1576) = 409 + chtn2i (1576) = 210 + chbiet (409) = 1576 +c +c Aretes coupees : 4 6 10 12 + chclas (2600) = ' 4-07' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2600)(1:12) = ' 4 6 10 12' + chnp1 (2600) = 1 + chnar (2600) = 13 + chnpy (2600) = 5 + chnte (2600) = 12 + chnhe (2600) = 0 + chperm (2600) = 200 + chbirf (2600) = 387 + chetat (2600) = 410 + chtn2i (2600) = 210 + chbiet (410) = 2600 +c +c =========================================== +c Classe d'equivalence 4-08 +c +c Aretes coupees : 1 2 8 10 + chclas (643) = ' 4-08' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (643)(1:12) = ' 1 2 8 10' + chnp1 (643) = 1 + chnar (643) = 13 + chnpy (643) = 5 + chnte (643) = 12 + chnhe (643) = 0 + chperm (643) = 0 + chbirf (643) = 643 + chetat (643) = 411 + chtn2i (643) = 210 + chbiet (411) = 643 +c +c Aretes coupees : 1 3 7 9 + chclas (325) = ' 4-08' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (325)(1:12) = ' 1 3 7 9' + chnp1 (325) = 1 + chnar (325) = 13 + chnpy (325) = 5 + chnte (325) = 12 + chnhe (325) = 0 + chperm (325) = 221 + chbirf (325) = 643 + chetat (325) = 412 + chtn2i (325) = 210 + chbiet (412) = 325 +c +c Aretes coupees : 1 4 5 11 + chclas (1049) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1049)(1:12) = ' 1 4 5 11' + chnp1 (1049) = 1 + chnar (1049) = 13 + chnpy (1049) = 5 + chnte (1049) = 12 + chnhe (1049) = 0 + chperm (1049) = 101 + chbirf (1049) = 643 + chetat (1049) = 413 + chtn2i (1049) = 210 + chbiet (413) = 1049 +c +c Aretes coupees : 1 4 8 10 + chclas (649) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 + charde (649)(1:12) = ' 1 4 8 10' + chnp1 (649) = 1 + chnar (649) = 13 + chnpy (649) = 5 + chnte (649) = 12 + chnhe (649) = 0 + chperm (649) = 121 + chbirf (649) = 643 + chetat (649) = 414 + chtn2i (649) = 210 + chbiet (414) = 649 +c +c Aretes coupees : 1 6 8 10 + chclas (673) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0 + charde (673)(1:12) = ' 1 6 8 10' + chnp1 (673) = 1 + chnar (673) = 13 + chnpy (673) = 5 + chnte (673) = 12 + chnhe (673) = 0 + chperm (673) = 320 + chbirf (673) = 643 + chetat (673) = 415 + chtn2i (673) = 210 + chbiet (415) = 673 +c +c Aretes coupees : 1 7 8 10 + chclas (705) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 0 + charde (705)(1:12) = ' 1 7 8 10' + chnp1 (705) = 1 + chnar (705) = 13 + chnpy (705) = 5 + chnte (705) = 12 + chnhe (705) = 0 + chperm (705) = 130 + chbirf (705) = 643 + chetat (705) = 416 + chtn2i (705) = 210 + chbiet (416) = 705 +c +c Aretes coupees : 1 8 9 10 + chclas (897) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (897)(1:12) = ' 1 8 9 10' + chnp1 (897) = 1 + chnar (897) = 13 + chnpy (897) = 5 + chnte (897) = 12 + chnhe (897) = 0 + chperm (897) = 201 + chbirf (897) = 643 + chetat (897) = 417 + chtn2i (897) = 210 + chbiet (417) = 897 +c +c Aretes coupees : 1 8 10 11 + chclas (1665) = ' 4-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1665)(1:12) = ' 1 8 10 11' + chnp1 (1665) = 1 + chnar (1665) = 13 + chnpy (1665) = 5 + chnte (1665) = 12 + chnhe (1665) = 0 + chperm (1665) = 210 + chbirf (1665) = 643 + chetat (1665) = 418 + chtn2i (1665) = 210 + chbiet (418) = 1665 +c +c Aretes coupees : 2 3 6 12 + chclas (2086) = ' 4-08' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2086)(1:12) = ' 2 3 6 12' + chnp1 (2086) = 1 + chnar (2086) = 13 + chnpy (2086) = 5 + chnte (2086) = 12 + chnhe (2086) = 0 + chperm (2086) = 10 + chbirf (2086) = 643 + chetat (2086) = 419 + chtn2i (2086) = 210 + chbiet (419) = 2086 +c +c Aretes coupees : 2 3 7 9 + chclas (326) = ' 4-08' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 + charde (326)(1:12) = ' 2 3 7 9' + chnp1 (326) = 1 + chnar (326) = 13 + chnpy (326) = 5 + chnte (326) = 12 + chnhe (326) = 0 + chperm (326) = 230 + chbirf (326) = 643 + chetat (326) = 420 + chtn2i (326) = 210 + chbiet (420) = 326 +c +c Aretes coupees : 2 4 6 12 + chclas (2090) = ' 4-08' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2090)(1:12) = ' 2 4 6 12' + chnp1 (2090) = 1 + chnar (2090) = 13 + chnpy (2090) = 5 + chnte (2090) = 12 + chnhe (2090) = 0 + chperm (2090) = 1 + chbirf (2090) = 643 + chetat (2090) = 421 + chtn2i (2090) = 210 + chbiet (421) = 2090 +c +c Aretes coupees : 2 5 6 12 + chclas (2098) = ' 4-08' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2098)(1:12) = ' 2 5 6 12' + chnp1 (2098) = 1 + chnar (2098) = 13 + chnpy (2098) = 5 + chnte (2098) = 12 + chnhe (2098) = 0 + chperm (2098) = 330 + chbirf (2098) = 643 + chetat (2098) = 422 + chtn2i (2098) = 210 + chbiet (422) = 2098 +c +c Aretes coupees : 2 6 8 12 + chclas (2210) = ' 4-08' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1 + charde (2210)(1:12) = ' 2 6 8 12' + chnp1 (2210) = 1 + chnar (2210) = 13 + chnpy (2210) = 5 + chnte (2210) = 12 + chnhe (2210) = 0 + chperm (2210) = 120 + chbirf (2210) = 643 + chetat (2210) = 423 + chtn2i (2210) = 210 + chbiet (423) = 2210 +c +c Aretes coupees : 2 6 9 12 + chclas (2338) = ' 4-08' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2338)(1:12) = ' 2 6 9 12' + chnp1 (2338) = 1 + chnar (2338) = 13 + chnpy (2338) = 5 + chnte (2338) = 12 + chnhe (2338) = 0 + chperm (2338) = 321 + chbirf (2338) = 643 + chetat (2338) = 424 + chtn2i (2338) = 210 + chbiet (424) = 2338 +c +c Aretes coupees : 2 6 10 12 + chclas (2594) = ' 4-08' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2594)(1:12) = ' 2 6 10 12' + chnp1 (2594) = 1 + chnar (2594) = 13 + chnpy (2594) = 5 + chnte (2594) = 12 + chnhe (2594) = 0 + chperm (2594) = 200 + chbirf (2594) = 643 + chetat (2594) = 425 + chtn2i (2594) = 210 + chbiet (425) = 2594 +c +c Aretes coupees : 3 4 5 11 + chclas (1052) = ' 4-08' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1052)(1:12) = ' 3 4 5 11' + chnp1 (1052) = 1 + chnar (1052) = 13 + chnpy (1052) = 5 + chnte (1052) = 12 + chnhe (1052) = 0 + chperm (1052) = 220 + chbirf (1052) = 643 + chetat (1052) = 426 + chtn2i (1052) = 210 + chbiet (426) = 1052 +c +c Aretes coupees : 3 5 7 9 + chclas (340) = ' 4-08' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0 + charde (340)(1:12) = ' 3 5 7 9' + chnp1 (340) = 1 + chnar (340) = 13 + chnpy (340) = 5 + chnte (340) = 12 + chnhe (340) = 0 + chperm (340) = 100 + chbirf (340) = 643 + chetat (340) = 427 + chtn2i (340) = 210 + chbiet (427) = 340 +c +c Aretes coupees : 3 7 8 9 + chclas (452) = ' 4-08' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (452)(1:12) = ' 3 7 8 9' + chnp1 (452) = 1 + chnar (452) = 13 + chnpy (452) = 5 + chnte (452) = 12 + chnhe (452) = 0 + chperm (452) = 310 + chbirf (452) = 643 + chetat (452) = 428 + chtn2i (452) = 210 + chbiet (428) = 452 +c +c Aretes coupees : 3 7 9 11 + chclas (1348) = ' 4-08' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1348)(1:12) = ' 3 7 9 11' + chnp1 (1348) = 1 + chnar (1348) = 13 + chnpy (1348) = 5 + chnte (1348) = 12 + chnhe (1348) = 0 + chperm (1348) = 20 + chbirf (1348) = 643 + chetat (1348) = 429 + chtn2i (1348) = 210 + chbiet (429) = 1348 +c +c Aretes coupees : 3 7 9 12 + chclas (2372) = ' 4-08' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2372)(1:12) = ' 3 7 9 12' + chnp1 (2372) = 1 + chnar (2372) = 13 + chnpy (2372) = 5 + chnte (2372) = 12 + chnhe (2372) = 0 + chperm (2372) = 301 + chbirf (2372) = 643 + chetat (2372) = 430 + chtn2i (2372) = 210 + chbiet (430) = 2372 +c +c Aretes coupees : 4 5 6 11 + chclas (1080) = ' 4-08' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 0 + charde (1080)(1:12) = ' 4 5 6 11' + chnp1 (1080) = 1 + chnar (1080) = 13 + chnpy (1080) = 5 + chnte (1080) = 12 + chnhe (1080) = 0 + chperm (1080) = 110 + chbirf (1080) = 643 + chetat (1080) = 431 + chtn2i (1080) = 210 + chbiet (431) = 1080 +c +c Aretes coupees : 4 5 7 11 + chclas (1112) = ' 4-08' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1112)(1:12) = ' 4 5 7 11' + chnp1 (1112) = 1 + chnar (1112) = 13 + chnpy (1112) = 5 + chnte (1112) = 12 + chnhe (1112) = 0 + chperm (1112) = 300 + chbirf (1112) = 643 + chetat (1112) = 432 + chtn2i (1112) = 210 + chbiet (432) = 1112 +c +c Aretes coupees : 4 5 10 11 + chclas (1560) = ' 4-08' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1560)(1:12) = ' 4 5 10 11' + chnp1 (1560) = 1 + chnar (1560) = 13 + chnpy (1560) = 5 + chnte (1560) = 12 + chnhe (1560) = 0 + chperm (1560) = 30 + chbirf (1560) = 643 + chetat (1560) = 433 + chtn2i (1560) = 210 + chbiet (433) = 1560 +c +c Aretes coupees : 4 5 11 12 + chclas (3096) = ' 4-08' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3096)(1:12) = ' 4 5 11 12' + chnp1 (3096) = 1 + chnar (3096) = 13 + chnpy (3096) = 5 + chnte (3096) = 12 + chnhe (3096) = 0 + chperm (3096) = 21 + chbirf (3096) = 643 + chetat (3096) = 434 + chtn2i (3096) = 210 + chbiet (434) = 3096 +c +c =========================================== +c Classe d'equivalence 4-09 +c +c Aretes coupees : 1 2 6 12 + chclas (2083) = ' 4-09' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2083)(1:12) = ' 1 2 6 12' + chnp1 (2083) = 1 + chnar (2083) = 14 + chnpy (2083) = 6 + chnte (2083) = 12 + chnhe (2083) = 0 + chperm (2083) = 0 + chbirf (2083) = 2083 + chetat (2083) = 435 + chtn2i (2083) = 210 + chbiet (435) = 2083 +c +c Aretes coupees : 1 3 8 10 + chclas (645) = ' 4-09' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (645)(1:12) = ' 1 3 8 10' + chnp1 (645) = 1 + chnar (645) = 14 + chnpy (645) = 6 + chnte (645) = 12 + chnhe (645) = 0 + chperm (645) = 310 + chbirf (645) = 2083 + chetat (645) = 436 + chtn2i (645) = 210 + chbiet (436) = 645 +c +c Aretes coupees : 1 5 8 10 + chclas (657) = ' 4-09' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 + charde (657)(1:12) = ' 1 5 8 10' + chnp1 (657) = 1 + chnar (657) = 14 + chnpy (657) = 6 + chnte (657) = 12 + chnhe (657) = 0 + chperm (657) = 30 + chbirf (657) = 2083 + chetat (657) = 437 + chtn2i (657) = 210 + chbiet (437) = 657 +c +c Aretes coupees : 1 8 10 12 + chclas (2689) = ' 4-09' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2689)(1:12) = ' 1 8 10 12' + chnp1 (2689) = 1 + chnar (2689) = 14 + chnpy (2689) = 6 + chnte (2689) = 12 + chnhe (2689) = 0 + chperm (2689) = 200 + chbirf (2689) = 2083 + chetat (2689) = 438 + chtn2i (2689) = 210 + chbiet (438) = 2689 +c +c Aretes coupees : 2 4 5 11 + chclas (1050) = ' 4-09' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1050)(1:12) = ' 2 4 5 11' + chnp1 (1050) = 1 + chnar (1050) = 14 + chnpy (1050) = 6 + chnte (1050) = 12 + chnhe (1050) = 0 + chperm (1050) = 330 + chbirf (1050) = 2083 + chetat (1050) = 439 + chtn2i (1050) = 210 + chbiet (439) = 1050 +c +c Aretes coupees : 2 6 7 12 + chclas (2146) = ' 4-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2146)(1:12) = ' 2 6 7 12' + chnp1 (2146) = 1 + chnar (2146) = 14 + chnpy (2146) = 6 + chnte (2146) = 12 + chnhe (2146) = 0 + chperm (2146) = 230 + chbirf (2146) = 2083 + chetat (2146) = 440 + chtn2i (2146) = 210 + chbiet (440) = 2146 +c +c Aretes coupees : 2 6 11 12 + chclas (3106) = ' 4-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3106)(1:12) = ' 2 6 11 12' + chnp1 (3106) = 1 + chnar (3106) = 14 + chnpy (3106) = 6 + chnte (3106) = 12 + chnhe (3106) = 0 + chperm (3106) = 110 + chbirf (3106) = 2083 + chetat (3106) = 441 + chtn2i (3106) = 210 + chbiet (441) = 3106 +c +c Aretes coupees : 3 4 7 9 + chclas (332) = ' 4-09' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 0, 0 + charde (332)(1:12) = ' 3 4 7 9' + chnp1 (332) = 1 + chnar (332) = 14 + chnpy (332) = 6 + chnte (332) = 12 + chnhe (332) = 0 + chperm (332) = 300 + chbirf (332) = 2083 + chetat (332) = 442 + chtn2i (332) = 210 + chbiet (442) = 332 +c +c Aretes coupees : 3 6 7 9 + chclas (356) = ' 4-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0 + charde (356)(1:12) = ' 3 6 7 9' + chnp1 (356) = 1 + chnar (356) = 14 + chnpy (356) = 6 + chnte (356) = 12 + chnhe (356) = 0 + chperm (356) = 10 + chbirf (356) = 2083 + chetat (356) = 443 + chtn2i (356) = 210 + chbiet (443) = 356 +c +c Aretes coupees : 3 7 9 10 + chclas (836) = ' 4-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0 + charde (836)(1:12) = ' 3 7 9 10' + chnp1 (836) = 1 + chnar (836) = 14 + chnpy (836) = 6 + chnte (836) = 12 + chnhe (836) = 0 + chperm (836) = 130 + chbirf (836) = 2083 + chetat (836) = 444 + chtn2i (836) = 210 + chbiet (444) = 836 +c +c Aretes coupees : 4 5 8 11 + chclas (1176) = ' 4-09' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1176)(1:12) = ' 4 5 8 11' + chnp1 (1176) = 1 + chnar (1176) = 14 + chnpy (1176) = 6 + chnte (1176) = 12 + chnhe (1176) = 0 + chperm (1176) = 210 + chbirf (1176) = 2083 + chetat (1176) = 445 + chtn2i (1176) = 210 + chbiet (445) = 1176 +c +c Aretes coupees : 4 5 9 11 + chclas (1304) = ' 4-09' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1304)(1:12) = ' 4 5 9 11' + chnp1 (1304) = 1 + chnar (1304) = 14 + chnpy (1304) = 6 + chnte (1304) = 12 + chnhe (1304) = 0 + chperm (1304) = 100 + chbirf (1304) = 2083 + chetat (1304) = 446 + chtn2i (1304) = 210 + chbiet (446) = 1304 +c +c =========================================== +c Classe d'equivalence 4-10 +c +c Aretes coupees : 1 2 7 11 + chclas (1091) = ' 4-10' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1091)(1:12) = ' 1 2 7 11' + chnp1 (1091) = 1 + chnar (1091) = 14 + chnpy (1091) = 6 + chnte (1091) = 12 + chnhe (1091) = 0 + chperm (1091) = 0 + chbirf (1091) = 1091 + chetat (1091) = 447 + chtn2i (1091) = 210 + chbiet (447) = 1091 +c +c Aretes coupees : 1 3 5 12 + chclas (2069) = ' 4-10' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2069)(1:12) = ' 1 3 5 12' + chnp1 (2069) = 1 + chnar (2069) = 14 + chnpy (2069) = 6 + chnte (2069) = 12 + chnhe (2069) = 0 + chperm (2069) = 101 + chbirf (2069) = 1091 + chetat (2069) = 448 + chtn2i (2069) = 210 + chbiet (448) = 2069 +c +c Aretes coupees : 1 6 7 11 + chclas (1121) = ' 4-10' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1121)(1:12) = ' 1 6 7 11' + chnp1 (1121) = 1 + chnar (1121) = 14 + chnpy (1121) = 6 + chnte (1121) = 12 + chnhe (1121) = 0 + chperm (1121) = 110 + chbirf (1121) = 1091 + chetat (1121) = 449 + chtn2i (1121) = 210 + chbiet (449) = 1121 +c +c Aretes coupees : 1 7 11 12 + chclas (3137) = ' 4-10' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3137)(1:12) = ' 1 7 11 12' + chnp1 (3137) = 1 + chnar (3137) = 14 + chnpy (3137) = 6 + chnte (3137) = 12 + chnhe (3137) = 0 + chperm (3137) = 301 + chbirf (3137) = 1091 + chetat (3137) = 450 + chtn2i (3137) = 210 + chbiet (450) = 3137 +c +c Aretes coupees : 2 4 8 9 + chclas (394) = ' 4-10' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0 + charde (394)(1:12) = ' 2 4 8 9' + chnp1 (394) = 1 + chnar (394) = 14 + chnpy (394) = 6 + chnte (394) = 12 + chnhe (394) = 0 + chperm (394) = 1 + chbirf (394) = 1091 + chetat (394) = 451 + chtn2i (394) = 210 + chbiet (451) = 394 +c +c Aretes coupees : 2 5 8 9 + chclas (402) = ' 4-10' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0 + charde (402)(1:12) = ' 2 5 8 9' + chnp1 (402) = 1 + chnar (402) = 14 + chnpy (402) = 6 + chnte (402) = 12 + chnhe (402) = 0 + chperm (402) = 100 + chbirf (402) = 1091 + chetat (402) = 452 + chtn2i (402) = 210 + chbiet (452) = 402 +c +c Aretes coupees : 2 8 9 11 + chclas (1410) = ' 4-10' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1410)(1:12) = ' 2 8 9 11' + chnp1 (1410) = 1 + chnar (1410) = 14 + chnpy (1410) = 6 + chnte (1410) = 12 + chnhe (1410) = 0 + chperm (1410) = 210 + chbirf (1410) = 1091 + chetat (1410) = 453 + chtn2i (1410) = 210 + chbiet (453) = 1410 +c +c Aretes coupees : 3 4 6 10 + chclas (556) = ' 4-10' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0 + charde (556)(1:12) = ' 3 4 6 10' + chnp1 (556) = 1 + chnar (556) = 14 + chnpy (556) = 6 + chnte (556) = 12 + chnhe (556) = 0 + chperm (556) = 10 + chbirf (556) = 1091 + chetat (556) = 454 + chtn2i (556) = 210 + chbiet (454) = 556 +c +c Aretes coupees : 3 5 8 12 + chclas (2196) = ' 4-10' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2196)(1:12) = ' 3 5 8 12' + chnp1 (2196) = 1 + chnar (2196) = 14 + chnpy (2196) = 6 + chnte (2196) = 12 + chnhe (2196) = 0 + chperm (2196) = 310 + chbirf (2196) = 1091 + chetat (2196) = 455 + chtn2i (2196) = 210 + chbiet (455) = 2196 +c +c Aretes coupees : 3 5 10 12 + chclas (2580) = ' 4-10' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2580)(1:12) = ' 3 5 10 12' + chnp1 (2580) = 1 + chnar (2580) = 14 + chnpy (2580) = 6 + chnte (2580) = 12 + chnhe (2580) = 0 + chperm (2580) = 200 + chbirf (2580) = 1091 + chetat (2580) = 456 + chtn2i (2580) = 210 + chbiet (456) = 2580 +c +c Aretes coupees : 4 6 7 10 + chclas (616) = ' 4-10' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0 + charde (616)(1:12) = ' 4 6 7 10' + chnp1 (616) = 1 + chnar (616) = 14 + chnpy (616) = 6 + chnte (616) = 12 + chnhe (616) = 0 + chperm (616) = 300 + chbirf (616) = 1091 + chetat (616) = 457 + chtn2i (616) = 210 + chbiet (457) = 616 +c +c Aretes coupees : 4 6 9 10 + chclas (808) = ' 4-10' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0 + charde (808)(1:12) = ' 4 6 9 10' + chnp1 (808) = 1 + chnar (808) = 14 + chnpy (808) = 6 + chnte (808) = 12 + chnhe (808) = 0 + chperm (808) = 201 + chbirf (808) = 1091 + chetat (808) = 458 + chtn2i (808) = 210 + chbiet (458) = 808 +c +c =========================================== +c Classe d'equivalence 4-11 +c +c Aretes coupees : 1 2 6 7 + chclas (99) = ' 4-11' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (99)(1:12) = ' 1 2 6 7' + chnp1 (99) = 1 + chnar (99) = 15 + chnpy (99) = 10 + chnte (99) = 6 + chnhe (99) = 0 + chperm (99) = 0 + chbirf (99) = 99 + chetat (99) = 459 + chtn2i (99) = 210 + chbiet (459) = 99 +c +c Aretes coupees : 1 2 6 11 + chclas (1059) = ' 4-11' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1059)(1:12) = ' 1 2 6 11' + chnp1 (1059) = 1 + chnar (1059) = 15 + chnpy (1059) = 10 + chnte (1059) = 6 + chnhe (1059) = 0 + chperm (1059) = 320 + chbirf (1059) = 99 + chetat (1059) = 460 + chtn2i (1059) = 210 + chbiet (460) = 1059 +c +c Aretes coupees : 1 2 7 12 + chclas (2115) = ' 4-11' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2115)(1:12) = ' 1 2 7 12' + chnp1 (2115) = 1 + chnar (2115) = 15 + chnpy (2115) = 10 + chnte (2115) = 6 + chnhe (2115) = 0 + chperm (2115) = 230 + chbirf (2115) = 99 + chetat (2115) = 461 + chtn2i (2115) = 210 + chbiet (461) = 2115 +c +c Aretes coupees : 1 3 5 8 + chclas (149) = ' 4-11' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (149)(1:12) = ' 1 3 5 8' + chnp1 (149) = 1 + chnar (149) = 15 + chnpy (149) = 10 + chnte (149) = 6 + chnhe (149) = 0 + chperm (149) = 221 + chbirf (149) = 99 + chetat (149) = 462 + chtn2i (149) = 210 + chbiet (462) = 149 +c +c Aretes coupees : 1 3 5 10 + chclas (533) = ' 4-11' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 0 + charde (533)(1:12) = ' 1 3 5 10' + chnp1 (533) = 1 + chnar (533) = 15 + chnpy (533) = 10 + chnte (533) = 6 + chnhe (533) = 0 + chperm (533) = 101 + chbirf (533) = 99 + chetat (533) = 463 + chtn2i (533) = 210 + chbiet (463) = 533 +c +c Aretes coupees : 1 3 8 12 + chclas (2181) = ' 4-11' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2181)(1:12) = ' 1 3 8 12' + chnp1 (2181) = 1 + chnar (2181) = 15 + chnpy (2181) = 10 + chnte (2181) = 6 + chnhe (2181) = 0 + chperm (2181) = 310 + chbirf (2181) = 99 + chetat (2181) = 464 + chtn2i (2181) = 210 + chbiet (464) = 2181 +c +c Aretes coupees : 1 5 10 12 + chclas (2577) = ' 4-11' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2577)(1:12) = ' 1 5 10 12' + chnp1 (2577) = 1 + chnar (2577) = 15 + chnpy (2577) = 10 + chnte (2577) = 6 + chnhe (2577) = 0 + chperm (2577) = 30 + chbirf (2577) = 99 + chetat (2577) = 465 + chtn2i (2577) = 210 + chbiet (465) = 2577 +c +c Aretes coupees : 1 6 11 12 + chclas (3105) = ' 4-11' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3105)(1:12) = ' 1 6 11 12' + chnp1 (3105) = 1 + chnar (3105) = 15 + chnpy (3105) = 10 + chnte (3105) = 6 + chnhe (3105) = 0 + chperm (3105) = 110 + chbirf (3105) = 99 + chetat (3105) = 466 + chtn2i (3105) = 210 + chbiet (466) = 3105 +c +c Aretes coupees : 2 4 5 8 + chclas (154) = ' 4-11' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0 + charde (154)(1:12) = ' 2 4 5 8' + chnp1 (154) = 1 + chnar (154) = 15 + chnpy (154) = 10 + chnte (154) = 6 + chnhe (154) = 0 + chperm (154) = 1 + chbirf (154) = 99 + chetat (154) = 467 + chtn2i (154) = 210 + chbiet (467) = 154 +c +c Aretes coupees : 2 4 5 9 + chclas (282) = ' 4-11' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0 + charde (282)(1:12) = ' 2 4 5 9' + chnp1 (282) = 1 + chnar (282) = 15 + chnpy (282) = 10 + chnte (282) = 6 + chnhe (282) = 0 + chperm (282) = 330 + chbirf (282) = 99 + chetat (282) = 468 + chtn2i (282) = 210 + chbiet (468) = 282 +c +c Aretes coupees : 2 4 8 11 + chclas (1162) = ' 4-11' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1162)(1:12) = ' 2 4 8 11' + chnp1 (1162) = 1 + chnar (1162) = 15 + chnpy (1162) = 10 + chnte (1162) = 6 + chnhe (1162) = 0 + chperm (1162) = 121 + chbirf (1162) = 99 + chetat (1162) = 469 + chtn2i (1162) = 210 + chbiet (469) = 1162 +c +c Aretes coupees : 2 5 9 11 + chclas (1298) = ' 4-11' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1298)(1:12) = ' 2 5 9 11' + chnp1 (1298) = 1 + chnar (1298) = 15 + chnpy (1298) = 10 + chnte (1298) = 6 + chnhe (1298) = 0 + chperm (1298) = 100 + chbirf (1298) = 99 + chetat (1298) = 470 + chtn2i (1298) = 210 + chbiet (470) = 1298 +c +c Aretes coupees : 2 7 11 12 + chclas (3138) = ' 4-11' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3138)(1:12) = ' 2 7 11 12' + chnp1 (3138) = 1 + chnar (3138) = 15 + chnpy (3138) = 10 + chnte (3138) = 6 + chnhe (3138) = 0 + chperm (3138) = 301 + chbirf (3138) = 99 + chetat (3138) = 471 + chtn2i (3138) = 210 + chbiet (471) = 3138 +c +c Aretes coupees : 3 4 6 7 + chclas (108) = ' 4-11' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 + charde (108)(1:12) = ' 3 4 6 7' + chnp1 (108) = 1 + chnar (108) = 15 + chnpy (108) = 10 + chnte (108) = 6 + chnhe (108) = 0 + chperm (108) = 220 + chbirf (108) = 99 + chetat (108) = 472 + chtn2i (108) = 210 + chbiet (472) = 108 +c +c Aretes coupees : 3 4 6 9 + chclas (300) = ' 4-11' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 0 + charde (300)(1:12) = ' 3 4 6 9' + chnp1 (300) = 1 + chnar (300) = 15 + chnpy (300) = 10 + chnte (300) = 6 + chnhe (300) = 0 + chperm (300) = 10 + chbirf (300) = 99 + chetat (300) = 473 + chtn2i (300) = 210 + chbiet (473) = 300 +c +c Aretes coupees : 3 4 7 10 + chclas (588) = ' 4-11' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 0 + charde (588)(1:12) = ' 3 4 7 10' + chnp1 (588) = 1 + chnar (588) = 15 + chnpy (588) = 10 + chnte (588) = 6 + chnhe (588) = 0 + chperm (588) = 300 + chbirf (588) = 99 + chetat (588) = 474 + chtn2i (588) = 210 + chbiet (474) = 588 +c +c Aretes coupees : 3 6 9 10 + chclas (804) = ' 4-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 + charde (804)(1:12) = ' 3 6 9 10' + chnp1 (804) = 1 + chnar (804) = 15 + chnpy (804) = 10 + chnte (804) = 6 + chnhe (804) = 0 + chperm (804) = 321 + chbirf (804) = 99 + chetat (804) = 475 + chtn2i (804) = 210 + chbiet (475) = 804 +c +c Aretes coupees : 3 8 10 12 + chclas (2692) = ' 4-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2692)(1:12) = ' 3 8 10 12' + chnp1 (2692) = 1 + chnar (2692) = 15 + chnpy (2692) = 10 + chnte (2692) = 6 + chnhe (2692) = 0 + chperm (2692) = 120 + chbirf (2692) = 99 + chetat (2692) = 476 + chtn2i (2692) = 210 + chbiet (476) = 2692 +c +c Aretes coupees : 4 7 9 10 + chclas (840) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0 + charde (840)(1:12) = ' 4 7 9 10' + chnp1 (840) = 1 + chnar (840) = 15 + chnpy (840) = 10 + chnte (840) = 6 + chnhe (840) = 0 + chperm (840) = 130 + chbirf (840) = 99 + chetat (840) = 477 + chtn2i (840) = 210 + chbiet (477) = 840 +c +c Aretes coupees : 4 8 9 11 + chclas (1416) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1416)(1:12) = ' 4 8 9 11' + chnp1 (1416) = 1 + chnar (1416) = 15 + chnpy (1416) = 10 + chnte (1416) = 6 + chnhe (1416) = 0 + chperm (1416) = 210 + chbirf (1416) = 99 + chetat (1416) = 478 + chtn2i (1416) = 210 + chbiet (478) = 1416 +c +c Aretes coupees : 5 8 9 11 + chclas (1424) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0 + charde (1424)(1:12) = ' 5 8 9 11' + chnp1 (1424) = 1 + chnar (1424) = 15 + chnpy (1424) = 10 + chnte (1424) = 6 + chnhe (1424) = 0 + chperm (1424) = 20 + chbirf (1424) = 99 + chetat (1424) = 479 + chtn2i (1424) = 210 + chbiet (479) = 1424 +c +c Aretes coupees : 5 8 10 12 + chclas (2704) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1 + charde (2704)(1:12) = ' 5 8 10 12' + chnp1 (2704) = 1 + chnar (2704) = 15 + chnpy (2704) = 10 + chnte (2704) = 6 + chnhe (2704) = 0 + chperm (2704) = 200 + chbirf (2704) = 99 + chetat (2704) = 480 + chtn2i (2704) = 210 + chbiet (480) = 2704 +c +c Aretes coupees : 6 7 9 10 + chclas (864) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0 + charde (864)(1:12) = ' 6 7 9 10' + chnp1 (864) = 1 + chnar (864) = 15 + chnpy (864) = 10 + chnte (864) = 6 + chnhe (864) = 0 + chperm (864) = 201 + chbirf (864) = 99 + chetat (864) = 481 + chtn2i (864) = 210 + chbiet (481) = 864 +c +c Aretes coupees : 6 7 11 12 + chclas (3168) = ' 4-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1 + charde (3168)(1:12) = ' 6 7 11 12' + chnp1 (3168) = 1 + chnar (3168) = 15 + chnpy (3168) = 10 + chnte (3168) = 6 + chnhe (3168) = 0 + chperm (3168) = 21 + chbirf (3168) = 99 + chetat (3168) = 482 + chtn2i (3168) = 210 + chbiet (482) = 3168 +c +c =========================================== +c Classe d'equivalence 4-12 +c +c Aretes coupees : 1 2 9 12 + chclas (2307) = ' 4-12' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2307)(1:12) = ' 1 2 9 12' + chnp1 (2307) = 1 + chnar (2307) = 13 + chnpy (2307) = 8 + chnte (2307) = 6 + chnhe (2307) = 0 + chperm (2307) = 0 + chbirf (2307) = 2307 + chetat (2307) = 483 + chtn2i (2307) = 210 + chbiet (483) = 2307 +c +c Aretes coupees : 1 3 10 11 + chclas (1541) = ' 4-12' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1541)(1:12) = ' 1 3 10 11' + chnp1 (1541) = 1 + chnar (1541) = 13 + chnpy (1541) = 8 + chnte (1541) = 6 + chnhe (1541) = 0 + chperm (1541) = 221 + chbirf (1541) = 2307 + chetat (1541) = 484 + chtn2i (1541) = 210 + chbiet (484) = 1541 +c +c Aretes coupees : 1 4 6 12 + chclas (2089) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2089)(1:12) = ' 1 4 6 12' + chnp1 (2089) = 1 + chnar (2089) = 13 + chnpy (2089) = 8 + chnte (2089) = 6 + chnhe (2089) = 0 + chperm (2089) = 320 + chbirf (2089) = 2307 + chetat (2089) = 485 + chtn2i (2089) = 210 + chbiet (485) = 2089 +c +c Aretes coupees : 1 4 7 9 + chclas (329) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0 + charde (329)(1:12) = ' 1 4 7 9' + chnp1 (329) = 1 + chnar (329) = 13 + chnpy (329) = 8 + chnte (329) = 6 + chnhe (329) = 0 + chperm (329) = 300 + chbirf (329) = 2307 + chetat (329) = 486 + chtn2i (329) = 210 + chbiet (486) = 329 +c +c Aretes coupees : 1 4 9 11 + chclas (1289) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1289)(1:12) = ' 1 4 9 11' + chnp1 (1289) = 1 + chnar (1289) = 13 + chnpy (1289) = 8 + chnte (1289) = 6 + chnhe (1289) = 0 + chperm (1289) = 20 + chbirf (1289) = 2307 + chetat (1289) = 487 + chtn2i (1289) = 210 + chbiet (487) = 1289 +c +c Aretes coupees : 1 4 10 12 + chclas (2569) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2569)(1:12) = ' 1 4 10 12' + chnp1 (2569) = 1 + chnar (2569) = 13 + chnpy (2569) = 8 + chnte (2569) = 6 + chnhe (2569) = 0 + chperm (2569) = 200 + chbirf (2569) = 2307 + chetat (2569) = 488 + chtn2i (2569) = 210 + chbiet (488) = 2569 +c +c Aretes coupees : 1 5 7 8 + chclas (209) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0 + charde (209)(1:12) = ' 1 5 7 8' + chnp1 (209) = 1 + chnar (209) = 13 + chnpy (209) = 8 + chnte (209) = 6 + chnhe (209) = 0 + chperm (209) = 101 + chbirf (209) = 2307 + chetat (209) = 489 + chtn2i (209) = 210 + chbiet (489) = 209 +c +c Aretes coupees : 1 8 9 12 + chclas (2433) = ' 4-12' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2433)(1:12) = ' 1 8 9 12' + chnp1 (2433) = 1 + chnar (2433) = 13 + chnpy (2433) = 8 + chnte (2433) = 6 + chnhe (2433) = 0 + chperm (2433) = 120 + chbirf (2433) = 2307 + chetat (2433) = 490 + chtn2i (2433) = 210 + chbiet (490) = 2433 +c +c Aretes coupees : 2 3 5 11 + chclas (1046) = ' 4-12' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1046)(1:12) = ' 2 3 5 11' + chnp1 (1046) = 1 + chnar (1046) = 13 + chnpy (1046) = 8 + chnte (1046) = 6 + chnhe (1046) = 0 + chperm (1046) = 330 + chbirf (1046) = 2307 + chetat (1046) = 491 + chtn2i (1046) = 210 + chbiet (491) = 1046 +c +c Aretes coupees : 2 3 8 10 + chclas (646) = ' 4-12' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0 + charde (646)(1:12) = ' 2 3 8 10' + chnp1 (646) = 1 + chnar (646) = 13 + chnpy (646) = 8 + chnte (646) = 6 + chnhe (646) = 0 + chperm (646) = 310 + chbirf (646) = 2307 + chetat (646) = 492 + chtn2i (646) = 210 + chbiet (492) = 646 +c +c Aretes coupees : 2 3 9 10 + chclas (774) = ' 4-12' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0 + charde (774)(1:12) = ' 2 3 9 10' + chnp1 (774) = 1 + chnar (774) = 13 + chnpy (774) = 8 + chnte (774) = 6 + chnhe (774) = 0 + chperm (774) = 201 + chbirf (774) = 2307 + chetat (774) = 493 + chtn2i (774) = 210 + chbiet (493) = 774 +c +c Aretes coupees : 2 3 11 12 + chclas (3078) = ' 4-12' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3078)(1:12) = ' 2 3 11 12' + chnp1 (3078) = 1 + chnar (3078) = 13 + chnpy (3078) = 8 + chnte (3078) = 6 + chnhe (3078) = 0 + chperm (3078) = 21 + chbirf (3078) = 2307 + chetat (3078) = 494 + chtn2i (3078) = 210 + chbiet (494) = 3078 +c +c Aretes coupees : 2 4 10 11 + chclas (1546) = ' 4-12' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1546)(1:12) = ' 2 4 10 11' + chnp1 (1546) = 1 + chnar (1546) = 13 + chnpy (1546) = 8 + chnte (1546) = 6 + chnhe (1546) = 0 + chperm (1546) = 1 + chbirf (1546) = 2307 + chetat (1546) = 495 + chtn2i (1546) = 210 + chbiet (495) = 1546 +c +c Aretes coupees : 2 6 7 8 + chclas (226) = ' 4-12' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 + charde (226)(1:12) = ' 2 6 7 8' + chnp1 (226) = 1 + chnar (226) = 13 + chnpy (226) = 8 + chnte (226) = 6 + chnhe (226) = 0 + chperm (226) = 230 + chbirf (226) = 2307 + chetat (226) = 496 + chtn2i (226) = 210 + chbiet (496) = 226 +c +c Aretes coupees : 2 6 10 11 + chclas (1570) = ' 4-12' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1570)(1:12) = ' 2 6 10 11' + chnp1 (1570) = 1 + chnar (1570) = 13 + chnpy (1570) = 8 + chnte (1570) = 6 + chnhe (1570) = 0 + chperm (1570) = 110 + chbirf (1570) = 2307 + chetat (1570) = 497 + chtn2i (1570) = 210 + chbiet (497) = 1570 +c +c Aretes coupees : 3 4 9 12 + chclas (2316) = ' 4-12' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2316)(1:12) = ' 3 4 9 12' + chnp1 (2316) = 1 + chnar (2316) = 13 + chnpy (2316) = 8 + chnte (2316) = 6 + chnhe (2316) = 0 + chperm (2316) = 220 + chbirf (2316) = 2307 + chetat (2316) = 498 + chtn2i (2316) = 210 + chbiet (498) = 2316 +c +c Aretes coupees : 3 5 6 7 + chclas (116) = ' 4-12' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 0 + charde (116)(1:12) = ' 3 5 6 7' + chnp1 (116) = 1 + chnar (116) = 13 + chnpy (116) = 8 + chnte (116) = 6 + chnhe (116) = 0 + chperm (116) = 10 + chbirf (116) = 2307 + chetat (116) = 499 + chtn2i (116) = 210 + chbiet (499) = 116 +c +c Aretes coupees : 3 7 10 11 + chclas (1604) = ' 4-12' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1604)(1:12) = ' 3 7 10 11' + chnp1 (1604) = 1 + chnar (1604) = 13 + chnpy (1604) = 8 + chnte (1604) = 6 + chnhe (1604) = 0 + chperm (1604) = 130 + chbirf (1604) = 2307 + chetat (1604) = 500 + chtn2i (1604) = 210 + chbiet (500) = 1604 +c +c Aretes coupees : 4 5 6 8 + chclas (184) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0 + charde (184)(1:12) = ' 4 5 6 8' + chnp1 (184) = 1 + chnar (184) = 13 + chnpy (184) = 8 + chnte (184) = 6 + chnhe (184) = 0 + chperm (184) = 121 + chbirf (184) = 2307 + chetat (184) = 501 + chtn2i (184) = 210 + chbiet (501) = 184 +c +c Aretes coupees : 4 5 9 12 + chclas (2328) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2328)(1:12) = ' 4 5 9 12' + chnp1 (2328) = 1 + chnar (2328) = 13 + chnpy (2328) = 8 + chnte (2328) = 6 + chnhe (2328) = 0 + chperm (2328) = 100 + chbirf (2328) = 2307 + chetat (2328) = 502 + chtn2i (2328) = 210 + chbiet (502) = 2328 +c +c Aretes coupees : 5 6 7 12 + chclas (2160) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1 + charde (2160)(1:12) = ' 5 6 7 12' + chnp1 (2160) = 1 + chnar (2160) = 13 + chnpy (2160) = 8 + chnte (2160) = 6 + chnhe (2160) = 0 + chperm (2160) = 301 + chbirf (2160) = 2307 + chetat (2160) = 503 + chtn2i (2160) = 210 + chbiet (503) = 2160 +c +c Aretes coupees : 5 6 8 10 + chclas (688) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 0 + charde (688)(1:12) = ' 5 6 8 10' + chnp1 (688) = 1 + chnar (688) = 13 + chnpy (688) = 8 + chnte (688) = 6 + chnhe (688) = 0 + chperm (688) = 30 + chbirf (688) = 2307 + chetat (688) = 504 + chtn2i (688) = 210 + chbiet (504) = 688 +c +c Aretes coupees : 5 7 8 11 + chclas (1232) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 0 + charde (1232)(1:12) = ' 5 7 8 11' + chnp1 (1232) = 1 + chnar (1232) = 13 + chnpy (1232) = 8 + chnte (1232) = 6 + chnhe (1232) = 0 + chperm (1232) = 210 + chbirf (1232) = 2307 + chetat (1232) = 505 + chtn2i (1232) = 210 + chbiet (505) = 1232 +c +c Aretes coupees : 6 7 8 9 + chclas (480) = ' 4-12' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0 + charde (480)(1:12) = ' 6 7 8 9' + chnp1 (480) = 1 + chnar (480) = 13 + chnpy (480) = 8 + chnte (480) = 6 + chnhe (480) = 0 + chperm (480) = 321 + chbirf (480) = 2307 + chetat (480) = 506 + chtn2i (480) = 210 + chbiet (506) = 480 +c +c =========================================== +c Classe d'equivalence 4-13 +c +c Aretes coupees : 1 2 10 11 + chclas (1539) = ' 4-13' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1539)(1:12) = ' 1 2 10 11' + chnp1 (1539) = 1 + chnar (1539) = 13 + chnpy (1539) = 8 + chnte (1539) = 6 + chnhe (1539) = 0 + chperm (1539) = 0 + chbirf (1539) = 1539 + chetat (1539) = 507 + chtn2i (1539) = 210 + chbiet (507) = 1539 +c +c Aretes coupees : 1 3 9 12 + chclas (2309) = ' 4-13' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2309)(1:12) = ' 1 3 9 12' + chnp1 (2309) = 1 + chnar (2309) = 13 + chnpy (2309) = 8 + chnte (2309) = 6 + chnhe (2309) = 0 + chperm (2309) = 221 + chbirf (2309) = 1539 + chetat (2309) = 508 + chtn2i (2309) = 210 + chbiet (508) = 2309 +c +c Aretes coupees : 1 4 5 12 + chclas (2073) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2073)(1:12) = ' 1 4 5 12' + chnp1 (2073) = 1 + chnar (2073) = 13 + chnpy (2073) = 8 + chnte (2073) = 6 + chnhe (2073) = 0 + chperm (2073) = 101 + chbirf (2073) = 1539 + chetat (2073) = 509 + chtn2i (2073) = 210 + chbiet (509) = 2073 +c +c Aretes coupees : 1 4 8 9 + chclas (393) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0 + charde (393)(1:12) = ' 1 4 8 9' + chnp1 (393) = 1 + chnar (393) = 13 + chnpy (393) = 8 + chnte (393) = 6 + chnhe (393) = 0 + chperm (393) = 121 + chbirf (393) = 1539 + chetat (393) = 510 + chtn2i (393) = 210 + chbiet (510) = 393 +c +c Aretes coupees : 1 4 9 10 + chclas (777) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0 + charde (777)(1:12) = ' 1 4 9 10' + chnp1 (777) = 1 + chnar (777) = 13 + chnpy (777) = 8 + chnte (777) = 6 + chnhe (777) = 0 + chperm (777) = 201 + chbirf (777) = 1539 + chetat (777) = 511 + chtn2i (777) = 210 + chbiet (511) = 777 +c +c Aretes coupees : 1 4 11 12 + chclas (3081) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3081)(1:12) = ' 1 4 11 12' + chnp1 (3081) = 1 + chnar (3081) = 13 + chnpy (3081) = 8 + chnte (3081) = 6 + chnhe (3081) = 0 + chperm (3081) = 21 + chbirf (3081) = 1539 + chetat (3081) = 512 + chtn2i (3081) = 210 + chbiet (512) = 3081 +c +c Aretes coupees : 1 6 7 8 + chclas (225) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 + charde (225)(1:12) = ' 1 6 7 8' + chnp1 (225) = 1 + chnar (225) = 13 + chnpy (225) = 8 + chnte (225) = 6 + chnhe (225) = 0 + chperm (225) = 320 + chbirf (225) = 1539 + chetat (225) = 513 + chtn2i (225) = 210 + chbiet (513) = 225 +c +c Aretes coupees : 1 7 9 12 + chclas (2369) = ' 4-13' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2369)(1:12) = ' 1 7 9 12' + chnp1 (2369) = 1 + chnar (2369) = 13 + chnpy (2369) = 8 + chnte (2369) = 6 + chnhe (2369) = 0 + chperm (2369) = 301 + chbirf (2369) = 1539 + chetat (2369) = 514 + chtn2i (2369) = 210 + chbiet (514) = 2369 +c +c Aretes coupees : 2 3 6 10 + chclas (550) = ' 4-13' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (550)(1:12) = ' 2 3 6 10' + chnp1 (550) = 1 + chnar (550) = 13 + chnpy (550) = 8 + chnte (550) = 6 + chnhe (550) = 0 + chperm (550) = 10 + chbirf (550) = 1539 + chetat (550) = 515 + chtn2i (550) = 210 + chbiet (515) = 550 +c +c Aretes coupees : 2 3 7 11 + chclas (1094) = ' 4-13' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1094)(1:12) = ' 2 3 7 11' + chnp1 (1094) = 1 + chnar (1094) = 13 + chnpy (1094) = 8 + chnte (1094) = 6 + chnhe (1094) = 0 + chperm (1094) = 230 + chbirf (1094) = 1539 + chetat (1094) = 516 + chtn2i (1094) = 210 + chbiet (516) = 1094 +c +c Aretes coupees : 2 3 9 11 + chclas (1286) = ' 4-13' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1286)(1:12) = ' 2 3 9 11' + chnp1 (1286) = 1 + chnar (1286) = 13 + chnpy (1286) = 8 + chnte (1286) = 6 + chnhe (1286) = 0 + chperm (1286) = 20 + chbirf (1286) = 1539 + chetat (1286) = 517 + chtn2i (1286) = 210 + chbiet (517) = 1286 +c +c Aretes coupees : 2 3 10 12 + chclas (2566) = ' 4-13' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2566)(1:12) = ' 2 3 10 12' + chnp1 (2566) = 1 + chnar (2566) = 13 + chnpy (2566) = 8 + chnte (2566) = 6 + chnhe (2566) = 0 + chperm (2566) = 200 + chbirf (2566) = 1539 + chetat (2566) = 518 + chtn2i (2566) = 210 + chbiet (518) = 2566 +c +c Aretes coupees : 2 4 9 12 + chclas (2314) = ' 4-13' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2314)(1:12) = ' 2 4 9 12' + chnp1 (2314) = 1 + chnar (2314) = 13 + chnpy (2314) = 8 + chnte (2314) = 6 + chnhe (2314) = 0 + chperm (2314) = 1 + chbirf (2314) = 1539 + chetat (2314) = 519 + chtn2i (2314) = 210 + chbiet (519) = 2314 +c +c Aretes coupees : 2 5 6 8 + chclas (178) = ' 4-13' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0 + charde (178)(1:12) = ' 2 5 6 8' + chnp1 (178) = 1 + chnar (178) = 13 + chnpy (178) = 8 + chnte (178) = 6 + chnhe (178) = 0 + chperm (178) = 330 + chbirf (178) = 1539 + chetat (178) = 520 + chtn2i (178) = 210 + chbiet (520) = 178 +c +c Aretes coupees : 2 8 10 11 + chclas (1666) = ' 4-13' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1666)(1:12) = ' 2 8 10 11' + chnp1 (1666) = 1 + chnar (1666) = 13 + chnpy (1666) = 8 + chnte (1666) = 6 + chnhe (1666) = 0 + chperm (1666) = 210 + chbirf (1666) = 1539 + chetat (1666) = 521 + chtn2i (1666) = 210 + chbiet (521) = 1666 +c +c Aretes coupees : 3 4 10 11 + chclas (1548) = ' 4-13' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1548)(1:12) = ' 3 4 10 11' + chnp1 (1548) = 1 + chnar (1548) = 13 + chnpy (1548) = 8 + chnte (1548) = 6 + chnhe (1548) = 0 + chperm (1548) = 220 + chbirf (1548) = 1539 + chetat (1548) = 522 + chtn2i (1548) = 210 + chbiet (522) = 1548 +c +c Aretes coupees : 3 5 7 8 + chclas (212) = ' 4-13' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0 + charde (212)(1:12) = ' 3 5 7 8' + chnp1 (212) = 1 + chnar (212) = 13 + chnpy (212) = 8 + chnte (212) = 6 + chnhe (212) = 0 + chperm (212) = 310 + chbirf (212) = 1539 + chetat (212) = 523 + chtn2i (212) = 210 + chbiet (523) = 212 +c +c Aretes coupees : 3 5 10 11 + chclas (1556) = ' 4-13' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1556)(1:12) = ' 3 5 10 11' + chnp1 (1556) = 1 + chnar (1556) = 13 + chnpy (1556) = 8 + chnte (1556) = 6 + chnhe (1556) = 0 + chperm (1556) = 30 + chbirf (1556) = 1539 + chetat (1556) = 524 + chtn2i (1556) = 210 + chbiet (524) = 1556 +c +c Aretes coupees : 4 5 6 7 + chclas (120) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0 + charde (120)(1:12) = ' 4 5 6 7' + chnp1 (120) = 1 + chnar (120) = 13 + chnpy (120) = 8 + chnte (120) = 6 + chnhe (120) = 0 + chperm (120) = 300 + chbirf (120) = 1539 + chetat (120) = 525 + chtn2i (120) = 210 + chbiet (525) = 120 +c +c Aretes coupees : 4 6 9 12 + chclas (2344) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2344)(1:12) = ' 4 6 9 12' + chnp1 (2344) = 1 + chnar (2344) = 13 + chnpy (2344) = 8 + chnte (2344) = 6 + chnhe (2344) = 0 + chperm (2344) = 321 + chbirf (2344) = 1539 + chetat (2344) = 526 + chtn2i (2344) = 210 + chbiet (526) = 2344 +c +c Aretes coupees : 5 6 7 11 + chclas (1136) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 0 + charde (1136)(1:12) = ' 5 6 7 11' + chnp1 (1136) = 1 + chnar (1136) = 13 + chnpy (1136) = 8 + chnte (1136) = 6 + chnhe (1136) = 0 + chperm (1136) = 110 + chbirf (1136) = 1539 + chetat (1136) = 527 + chtn2i (1136) = 210 + chbiet (527) = 1136 +c +c Aretes coupees : 5 6 8 12 + chclas (2224) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1 + charde (2224)(1:12) = ' 5 6 8 12' + chnp1 (2224) = 1 + chnar (2224) = 13 + chnpy (2224) = 8 + chnte (2224) = 6 + chnhe (2224) = 0 + chperm (2224) = 120 + chbirf (2224) = 1539 + chetat (2224) = 528 + chtn2i (2224) = 210 + chbiet (528) = 2224 +c +c Aretes coupees : 5 7 8 9 + chclas (464) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 1, 1, 0, 0, 0 + charde (464)(1:12) = ' 5 7 8 9' + chnp1 (464) = 1 + chnar (464) = 13 + chnpy (464) = 8 + chnte (464) = 6 + chnhe (464) = 0 + chperm (464) = 100 + chbirf (464) = 1539 + chetat (464) = 529 + chtn2i (464) = 210 + chbiet (529) = 464 +c +c Aretes coupees : 6 7 8 10 + chclas (736) = ' 4-13' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0 + charde (736)(1:12) = ' 6 7 8 10' + chnp1 (736) = 1 + chnar (736) = 13 + chnpy (736) = 8 + chnte (736) = 6 + chnhe (736) = 0 + chperm (736) = 130 + chbirf (736) = 1539 + chetat (736) = 530 + chtn2i (736) = 210 + chbiet (530) = 736 +c +c =========================================== +c Classe d'equivalence 4-14 +c +c Aretes coupees : 1 2 8 11 + chclas (1155) = ' 4-14' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0 + charde (1155)(1:12) = ' 1 2 8 11' + chnp1 (1155) = 1 + chnar (1155) = 14 + chnpy (1155) = 6 + chnte (1155) = 12 + chnhe (1155) = 0 + chperm (1155) = 0 + chbirf (1155) = 1155 + chetat (1155) = 531 + chtn2i (1155) = 210 + chbiet (531) = 1155 +c +c Aretes coupees : 1 3 7 12 + chclas (2117) = ' 4-14' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1 + charde (2117)(1:12) = ' 1 3 7 12' + chnp1 (2117) = 1 + chnar (2117) = 14 + chnpy (2117) = 6 + chnte (2117) = 12 + chnhe (2117) = 0 + chperm (2117) = 301 + chbirf (2117) = 1155 + chetat (2117) = 532 + chtn2i (2117) = 210 + chbiet (532) = 2117 +c +c Aretes coupees : 1 5 11 12 + chclas (3089) = ' 4-14' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3089)(1:12) = ' 1 5 11 12' + chnp1 (3089) = 1 + chnar (3089) = 14 + chnpy (3089) = 6 + chnte (3089) = 12 + chnhe (3089) = 0 + chperm (3089) = 101 + chbirf (3089) = 1155 + chetat (3089) = 533 + chtn2i (3089) = 210 + chbiet (533) = 3089 +c +c Aretes coupees : 1 6 7 10 + chclas (609) = ' 4-14' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0 + charde (609)(1:12) = ' 1 6 7 10' + chnp1 (609) = 1 + chnar (609) = 14 + chnpy (609) = 6 + chnte (609) = 12 + chnhe (609) = 0 + chperm (609) = 320 + chbirf (609) = 1155 + chetat (609) = 534 + chtn2i (609) = 210 + chbiet (534) = 609 +c +c Aretes coupees : 2 4 6 9 + chclas (298) = ' 4-14' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0 + charde (298)(1:12) = ' 2 4 6 9' + chnp1 (298) = 1 + chnar (298) = 14 + chnpy (298) = 6 + chnte (298) = 12 + chnhe (298) = 0 + chperm (298) = 1 + chbirf (298) = 1155 + chetat (298) = 535 + chtn2i (298) = 210 + chbiet (535) = 298 +c +c Aretes coupees : 2 5 8 12 + chclas (2194) = ' 4-14' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2194)(1:12) = ' 2 5 8 12' + chnp1 (2194) = 1 + chnar (2194) = 14 + chnpy (2194) = 6 + chnte (2194) = 12 + chnhe (2194) = 0 + chperm (2194) = 120 + chbirf (2194) = 1155 + chetat (2194) = 536 + chtn2i (2194) = 210 + chbiet (536) = 2194 +c +c Aretes coupees : 2 7 9 11 + chclas (1346) = ' 4-14' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1346)(1:12) = ' 2 7 9 11' + chnp1 (1346) = 1 + chnar (1346) = 14 + chnpy (1346) = 6 + chnte (1346) = 12 + chnhe (1346) = 0 + chperm (1346) = 20 + chbirf (1346) = 1155 + chetat (1346) = 537 + chtn2i (1346) = 210 + chbiet (537) = 1346 +c +c Aretes coupees : 3 4 5 10 + chclas (540) = ' 4-14' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 0, 0 + charde (540)(1:12) = ' 3 4 5 10' + chnp1 (540) = 1 + chnar (540) = 14 + chnpy (540) = 6 + chnte (540) = 12 + chnhe (540) = 0 + chperm (540) = 220 + chbirf (540) = 1155 + chetat (540) = 538 + chtn2i (540) = 210 + chbiet (538) = 540 +c +c Aretes coupees : 3 5 8 9 + chclas (404) = ' 4-14' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0 + charde (404)(1:12) = ' 3 5 8 9' + chnp1 (404) = 1 + chnar (404) = 14 + chnpy (404) = 6 + chnte (404) = 12 + chnhe (404) = 0 + chperm (404) = 100 + chbirf (404) = 1155 + chetat (404) = 539 + chtn2i (404) = 210 + chbiet (539) = 404 +c +c Aretes coupees : 3 6 10 12 + chclas (2596) = ' 4-14' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2596)(1:12) = ' 3 6 10 12' + chnp1 (2596) = 1 + chnar (2596) = 14 + chnpy (2596) = 6 + chnte (2596) = 12 + chnhe (2596) = 0 + chperm (2596) = 200 + chbirf (2596) = 1155 + chetat (2596) = 540 + chtn2i (2596) = 210 + chbiet (540) = 2596 +c +c Aretes coupees : 4 6 7 11 + chclas (1128) = ' 4-14' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1128)(1:12) = ' 4 6 7 11' + chnp1 (1128) = 1 + chnar (1128) = 14 + chnpy (1128) = 6 + chnte (1128) = 12 + chnhe (1128) = 0 + chperm (1128) = 300 + chbirf (1128) = 1155 + chetat (1128) = 541 + chtn2i (1128) = 210 + chbiet (541) = 1128 +c +c Aretes coupees : 4 8 9 10 + chclas (904) = ' 4-14' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0 + charde (904)(1:12) = ' 4 8 9 10' + chnp1 (904) = 1 + chnar (904) = 14 + chnpy (904) = 6 + chnte (904) = 12 + chnhe (904) = 0 + chperm (904) = 201 + chbirf (904) = 1155 + chetat (904) = 542 + chtn2i (904) = 210 + chbiet (542) = 904 +c +c =========================================== +c Classe d'equivalence 4-15 +c +c Aretes coupees : 1 2 8 12 + chclas (2179) = ' 4-15' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 1 + charde (2179)(1:12) = ' 1 2 8 12' + chnp1 (2179) = 1 + chnar (2179) = 14 + chnpy (2179) = 6 + chnte (2179) = 12 + chnhe (2179) = 0 + chperm (2179) = 0 + chbirf (2179) = 2179 + chetat (2179) = 543 + chtn2i (2179) = 210 + chbiet (543) = 2179 +c +c Aretes coupees : 1 3 7 10 + chclas (581) = ' 4-15' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 0 + charde (581)(1:12) = ' 1 3 7 10' + chnp1 (581) = 1 + chnar (581) = 14 + chnpy (581) = 6 + chnte (581) = 12 + chnhe (581) = 0 + chperm (581) = 130 + chbirf (581) = 2179 + chetat (581) = 544 + chtn2i (581) = 210 + chbiet (544) = 581 +c +c Aretes coupees : 1 5 8 11 + chclas (1169) = ' 4-15' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1169)(1:12) = ' 1 5 8 11' + chnp1 (1169) = 1 + chnar (1169) = 14 + chnpy (1169) = 6 + chnte (1169) = 12 + chnhe (1169) = 0 + chperm (1169) = 210 + chbirf (1169) = 2179 + chetat (1169) = 545 + chtn2i (1169) = 210 + chbiet (545) = 1169 +c +c Aretes coupees : 1 6 10 12 + chclas (2593) = ' 4-15' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2593)(1:12) = ' 1 6 10 12' + chnp1 (2593) = 1 + chnar (2593) = 14 + chnpy (2593) = 6 + chnte (2593) = 12 + chnhe (2593) = 0 + chperm (2593) = 200 + chbirf (2593) = 2179 + chetat (2593) = 546 + chtn2i (2593) = 210 + chbiet (546) = 2593 +c +c Aretes coupees : 2 4 6 11 + chclas (1066) = ' 4-15' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0 + charde (1066)(1:12) = ' 2 4 6 11' + chnp1 (1066) = 1 + chnar (1066) = 14 + chnpy (1066) = 6 + chnte (1066) = 12 + chnhe (1066) = 0 + chperm (1066) = 110 + chbirf (1066) = 2179 + chetat (1066) = 547 + chtn2i (1066) = 210 + chbiet (547) = 1066 +c +c Aretes coupees : 2 5 11 12 + chclas (3090) = ' 4-15' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3090)(1:12) = ' 2 5 11 12' + chnp1 (3090) = 1 + chnar (3090) = 14 + chnpy (3090) = 6 + chnte (3090) = 12 + chnhe (3090) = 0 + chperm (3090) = 330 + chbirf (3090) = 2179 + chetat (3090) = 548 + chtn2i (3090) = 210 + chbiet (548) = 3090 +c +c Aretes coupees : 2 6 7 9 + chclas (354) = ' 4-15' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0 + charde (354)(1:12) = ' 2 6 7 9' + chnp1 (354) = 1 + chnar (354) = 14 + chnpy (354) = 6 + chnte (354) = 12 + chnhe (354) = 0 + chperm (354) = 230 + chbirf (354) = 2179 + chetat (354) = 549 + chtn2i (354) = 210 + chbiet (549) = 354 +c +c Aretes coupees : 3 4 5 9 + chclas (284) = ' 4-15' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 0, 0 + charde (284)(1:12) = ' 3 4 5 9' + chnp1 (284) = 1 + chnar (284) = 14 + chnpy (284) = 6 + chnte (284) = 12 + chnhe (284) = 0 + chperm (284) = 100 + chbirf (284) = 2179 + chetat (284) = 550 + chtn2i (284) = 210 + chbiet (550) = 284 +c +c Aretes coupees : 3 6 7 12 + chclas (2148) = ' 4-15' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2148)(1:12) = ' 3 6 7 12' + chnp1 (2148) = 1 + chnar (2148) = 14 + chnpy (2148) = 6 + chnte (2148) = 12 + chnhe (2148) = 0 + chperm (2148) = 10 + chbirf (2148) = 2179 + chetat (2148) = 551 + chtn2i (2148) = 210 + chbiet (551) = 2148 +c +c Aretes coupees : 3 8 9 10 + chclas (900) = ' 4-15' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (900)(1:12) = ' 3 8 9 10' + chnp1 (900) = 1 + chnar (900) = 14 + chnpy (900) = 6 + chnte (900) = 12 + chnhe (900) = 0 + chperm (900) = 310 + chbirf (900) = 2179 + chetat (900) = 552 + chtn2i (900) = 210 + chbiet (552) = 900 +c +c Aretes coupees : 4 5 8 10 + chclas (664) = ' 4-15' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 0 + charde (664)(1:12) = ' 4 5 8 10' + chnp1 (664) = 1 + chnar (664) = 14 + chnpy (664) = 6 + chnte (664) = 12 + chnhe (664) = 0 + chperm (664) = 30 + chbirf (664) = 2179 + chetat (664) = 553 + chtn2i (664) = 210 + chbiet (553) = 664 +c +c Aretes coupees : 4 7 9 11 + chclas (1352) = ' 4-15' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1352)(1:12) = ' 4 7 9 11' + chnp1 (1352) = 1 + chnar (1352) = 14 + chnpy (1352) = 6 + chnte (1352) = 12 + chnhe (1352) = 0 + chperm (1352) = 300 + chbirf (1352) = 2179 + chetat (1352) = 554 + chtn2i (1352) = 210 + chbiet (554) = 1352 +c +c =========================================== +c Classe d'equivalence 4-16 +c +c Aretes coupees : 1 2 5 8 + chclas (147) = ' 4-16' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 + charde (147)(1:12) = ' 1 2 5 8' + chnp1 (147) = 1 + chnar (147) = 15 + chnpy (147) = 10 + chnte (147) = 6 + chnhe (147) = 0 + chperm (147) = 0 + chbirf (147) = 147 + chetat (147) = 555 + chtn2i (147) = 210 + chbiet (555) = 147 +c +c Aretes coupees : 1 2 5 11 + chclas (1043) = ' 4-16' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1043)(1:12) = ' 1 2 5 11' + chnp1 (1043) = 1 + chnar (1043) = 15 + chnpy (1043) = 10 + chnte (1043) = 6 + chnhe (1043) = 0 + chperm (1043) = 101 + chbirf (1043) = 147 + chetat (1043) = 556 + chtn2i (1043) = 210 + chbiet (556) = 1043 +c +c Aretes coupees : 1 2 5 12 + chclas (2067) = ' 4-16' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2067)(1:12) = ' 1 2 5 12' + chnp1 (2067) = 1 + chnar (2067) = 15 + chnpy (2067) = 10 + chnte (2067) = 6 + chnhe (2067) = 0 + chperm (2067) = 330 + chbirf (2067) = 147 + chetat (2067) = 557 + chtn2i (2067) = 210 + chbiet (557) = 2067 +c +c Aretes coupees : 1 3 6 7 + chclas (101) = ' 4-16' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0 + charde (101)(1:12) = ' 1 3 6 7' + chnp1 (101) = 1 + chnar (101) = 15 + chnpy (101) = 10 + chnte (101) = 6 + chnhe (101) = 0 + chperm (101) = 221 + chbirf (101) = 147 + chetat (101) = 558 + chtn2i (101) = 210 + chbiet (558) = 101 +c +c Aretes coupees : 1 3 6 10 + chclas (549) = ' 4-16' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0 + charde (549)(1:12) = ' 1 3 6 10' + chnp1 (549) = 1 + chnar (549) = 15 + chnpy (549) = 10 + chnte (549) = 6 + chnhe (549) = 0 + chperm (549) = 320 + chbirf (549) = 147 + chetat (549) = 559 + chtn2i (549) = 210 + chbiet (559) = 549 +c +c Aretes coupees : 1 3 6 12 + chclas (2085) = ' 4-16' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2085)(1:12) = ' 1 3 6 12' + chnp1 (2085) = 1 + chnar (2085) = 15 + chnpy (2085) = 10 + chnte (2085) = 6 + chnhe (2085) = 0 + chperm (2085) = 10 + chbirf (2085) = 147 + chetat (2085) = 560 + chtn2i (2085) = 210 + chbiet (560) = 2085 +c +c Aretes coupees : 1 7 10 12 + chclas (2625) = ' 4-16' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1 + charde (2625)(1:12) = ' 1 7 10 12' + chnp1 (2625) = 1 + chnar (2625) = 15 + chnpy (2625) = 10 + chnte (2625) = 6 + chnhe (2625) = 0 + chperm (2625) = 130 + chbirf (2625) = 147 + chetat (2625) = 561 + chtn2i (2625) = 210 + chbiet (561) = 2625 +c +c Aretes coupees : 1 8 11 12 + chclas (3201) = ' 4-16' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1 + charde (3201)(1:12) = ' 1 8 11 12' + chnp1 (3201) = 1 + chnar (3201) = 15 + chnpy (3201) = 10 + chnte (3201) = 6 + chnhe (3201) = 0 + chperm (3201) = 210 + chbirf (3201) = 147 + chetat (3201) = 562 + chtn2i (3201) = 210 + chbiet (562) = 3201 +c +c Aretes coupees : 2 4 6 7 + chclas (106) = ' 4-16' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0 + charde (106)(1:12) = ' 2 4 6 7' + chnp1 (106) = 1 + chnar (106) = 15 + chnpy (106) = 10 + chnte (106) = 6 + chnhe (106) = 0 + chperm (106) = 1 + chbirf (106) = 147 + chetat (106) = 563 + chtn2i (106) = 210 + chbiet (563) = 106 +c +c Aretes coupees : 2 4 7 9 + chclas (330) = ' 4-16' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0 + charde (330)(1:12) = ' 2 4 7 9' + chnp1 (330) = 1 + chnar (330) = 15 + chnpy (330) = 10 + chnte (330) = 6 + chnhe (330) = 0 + chperm (330) = 230 + chbirf (330) = 147 + chetat (330) = 564 + chtn2i (330) = 210 + chbiet (564) = 330 +c +c Aretes coupees : 2 4 7 11 + chclas (1098) = ' 4-16' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1098)(1:12) = ' 2 4 7 11' + chnp1 (1098) = 1 + chnar (1098) = 15 + chnpy (1098) = 10 + chnte (1098) = 6 + chnhe (1098) = 0 + chperm (1098) = 300 + chbirf (1098) = 147 + chetat (1098) = 565 + chtn2i (1098) = 210 + chbiet (565) = 1098 +c +c Aretes coupees : 2 6 9 11 + chclas (1314) = ' 4-16' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0 + charde (1314)(1:12) = ' 2 6 9 11' + chnp1 (1314) = 1 + chnar (1314) = 15 + chnpy (1314) = 10 + chnte (1314) = 6 + chnhe (1314) = 0 + chperm (1314) = 321 + chbirf (1314) = 147 + chetat (1314) = 566 + chtn2i (1314) = 210 + chbiet (566) = 1314 +c +c Aretes coupees : 2 8 11 12 + chclas (3202) = ' 4-16' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1 + charde (3202)(1:12) = ' 2 8 11 12' + chnp1 (3202) = 1 + chnar (3202) = 15 + chnpy (3202) = 10 + chnte (3202) = 6 + chnhe (3202) = 0 + chperm (3202) = 120 + chbirf (3202) = 147 + chetat (3202) = 567 + chtn2i (3202) = 210 + chbiet (567) = 3202 +c +c Aretes coupees : 3 4 5 8 + chclas (156) = ' 4-16' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0 + charde (156)(1:12) = ' 3 4 5 8' + chnp1 (156) = 1 + chnar (156) = 15 + chnpy (156) = 10 + chnte (156) = 6 + chnhe (156) = 0 + chperm (156) = 220 + chbirf (156) = 147 + chetat (156) = 568 + chtn2i (156) = 210 + chbiet (568) = 156 +c +c Aretes coupees : 3 4 8 9 + chclas (396) = ' 4-16' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0 + charde (396)(1:12) = ' 3 4 8 9' + chnp1 (396) = 1 + chnar (396) = 15 + chnpy (396) = 10 + chnte (396) = 6 + chnhe (396) = 0 + chperm (396) = 310 + chbirf (396) = 147 + chetat (396) = 569 + chtn2i (396) = 210 + chbiet (569) = 396 +c +c Aretes coupees : 3 4 8 10 + chclas (652) = ' 4-16' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0 + charde (652)(1:12) = ' 3 4 8 10' + chnp1 (652) = 1 + chnar (652) = 15 + chnpy (652) = 10 + chnte (652) = 6 + chnhe (652) = 0 + chperm (652) = 121 + chbirf (652) = 147 + chetat (652) = 570 + chtn2i (652) = 210 + chbiet (570) = 652 +c +c Aretes coupees : 3 5 9 10 + chclas (788) = ' 4-16' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0, 0 + charde (788)(1:12) = ' 3 5 9 10' + chnp1 (788) = 1 + chnar (788) = 15 + chnpy (788) = 10 + chnte (788) = 6 + chnhe (788) = 0 + chperm (788) = 100 + chbirf (788) = 147 + chetat (788) = 571 + chtn2i (788) = 210 + chbiet (571) = 788 +c +c Aretes coupees : 3 7 10 12 + chclas (2628) = ' 4-16' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 1 + charde (2628)(1:12) = ' 3 7 10 12' + chnp1 (2628) = 1 + chnar (2628) = 15 + chnpy (2628) = 10 + chnte (2628) = 6 + chnhe (2628) = 0 + chperm (2628) = 301 + chbirf (2628) = 147 + chetat (2628) = 572 + chtn2i (2628) = 210 + chbiet (572) = 2628 +c +c Aretes coupees : 4 5 9 10 + chclas (792) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0 + charde (792)(1:12) = ' 4 5 9 10' + chnp1 (792) = 1 + chnar (792) = 15 + chnpy (792) = 10 + chnte (792) = 6 + chnhe (792) = 0 + chperm (792) = 30 + chbirf (792) = 147 + chetat (792) = 573 + chtn2i (792) = 210 + chbiet (573) = 792 +c +c Aretes coupees : 4 6 9 11 + chclas (1320) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0 + charde (1320)(1:12) = ' 4 6 9 11' + chnp1 (1320) = 1 + chnar (1320) = 15 + chnpy (1320) = 10 + chnte (1320) = 6 + chnhe (1320) = 0 + chperm (1320) = 110 + chbirf (1320) = 147 + chetat (1320) = 574 + chtn2i (1320) = 210 + chbiet (574) = 1320 +c +c Aretes coupees : 5 8 9 10 + chclas (912) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0 + charde (912)(1:12) = ' 5 8 9 10' + chnp1 (912) = 1 + chnar (912) = 15 + chnpy (912) = 10 + chnte (912) = 6 + chnhe (912) = 0 + chperm (912) = 201 + chbirf (912) = 147 + chetat (912) = 575 + chtn2i (912) = 210 + chbiet (575) = 912 +c +c Aretes coupees : 5 8 11 12 + chclas (3216) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 + charde (3216)(1:12) = ' 5 8 11 12' + chnp1 (3216) = 1 + chnar (3216) = 15 + chnpy (3216) = 10 + chnte (3216) = 6 + chnhe (3216) = 0 + chperm (3216) = 21 + chbirf (3216) = 147 + chetat (3216) = 576 + chtn2i (3216) = 210 + chbiet (576) = 3216 +c +c Aretes coupees : 6 7 9 11 + chclas (1376) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0 + charde (1376)(1:12) = ' 6 7 9 11' + chnp1 (1376) = 1 + chnar (1376) = 15 + chnpy (1376) = 10 + chnte (1376) = 6 + chnhe (1376) = 0 + chperm (1376) = 20 + chbirf (1376) = 147 + chetat (1376) = 577 + chtn2i (1376) = 210 + chbiet (577) = 1376 +c +c Aretes coupees : 6 7 10 12 + chclas (2656) = ' 4-16' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 1 + charde (2656)(1:12) = ' 6 7 10 12' + chnp1 (2656) = 1 + chnar (2656) = 15 + chnpy (2656) = 10 + chnte (2656) = 6 + chnhe (2656) = 0 + chperm (2656) = 200 + chbirf (2656) = 147 + chetat (2656) = 578 + chtn2i (2656) = 210 + chbiet (578) = 2656 +c +c =========================================== +c Classe d'equivalence 4-17 +c +c Aretes coupees : 1 4 10 11 + chclas (1545) = ' 4-17' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1545)(1:12) = ' 1 4 10 11' + chnp1 (1545) = 1 + chnar (1545) = 12 + chnpy (1545) = 4 + chnte (1545) = 12 + chnhe (1545) = 0 + chperm (1545) = 0 + chbirf (1545) = 1545 + chetat (1545) = 579 + chtn2i (1545) = 70 + chbiet (579) = 1545 +c +c Aretes coupees : 1 7 8 9 + chclas (449) = ' 4-17' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (449)(1:12) = ' 1 7 8 9' + chnp1 (449) = 1 + chnar (449) = 12 + chnpy (449) = 4 + chnte (449) = 12 + chnhe (449) = 0 + chperm (449) = 100 + chbirf (449) = 1545 + chetat (449) = 580 + chtn2i (449) = 70 + chbiet (580) = 449 +c +c Aretes coupees : 2 3 9 12 + chclas (2310) = ' 4-17' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2310)(1:12) = ' 2 3 9 12' + chnp1 (2310) = 1 + chnar (2310) = 12 + chnpy (2310) = 4 + chnte (2310) = 12 + chnhe (2310) = 0 + chperm (2310) = 200 + chbirf (2310) = 1545 + chetat (2310) = 581 + chtn2i (2310) = 70 + chbiet (581) = 2310 +c +c Aretes coupees : 2 6 8 10 + chclas (674) = ' 4-17' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0 + charde (674)(1:12) = ' 2 6 8 10' + chnp1 (674) = 1 + chnar (674) = 12 + chnpy (674) = 4 + chnte (674) = 12 + chnhe (674) = 0 + chperm (674) = 10 + chbirf (674) = 1545 + chetat (674) = 582 + chtn2i (674) = 70 + chbiet (582) = 674 +c +c Aretes coupees : 3 5 7 11 + chclas (1108) = ' 4-17' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1108)(1:12) = ' 3 5 7 11' + chnp1 (1108) = 1 + chnar (1108) = 12 + chnpy (1108) = 4 + chnte (1108) = 12 + chnhe (1108) = 0 + chperm (1108) = 110 + chbirf (1108) = 1545 + chetat (1108) = 583 + chtn2i (1108) = 70 + chbiet (583) = 1108 +c +c Aretes coupees : 4 5 6 12 + chclas (2104) = ' 4-17' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2104)(1:12) = ' 4 5 6 12' + chnp1 (2104) = 1 + chnar (2104) = 12 + chnpy (2104) = 4 + chnte (2104) = 12 + chnhe (2104) = 0 + chperm (2104) = 300 + chbirf (2104) = 1545 + chetat (2104) = 584 + chtn2i (2104) = 70 + chbiet (584) = 2104 +c +c =========================================== +c Classe d'equivalence 4-18 +c +c Aretes coupees : 1 4 9 12 + chclas (2313) = ' 4-18' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2313)(1:12) = ' 1 4 9 12' + chnp1 (2313) = 0 + chnar (2313) = 0 + chnpy (2313) = 0 + chnte (2313) = 0 + chnhe (2313) = 2 + chperm (2313) = 0 + chbirf (2313) = 2313 + chetat (2313) = 585 + chtn2i (2313) = 1 + chbiet (585) = 2313 +c +c Aretes coupees : 2 3 10 11 + chclas (1542) = ' 4-18' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1542)(1:12) = ' 2 3 10 11' + chnp1 (1542) = 0 + chnar (1542) = 0 + chnpy (1542) = 0 + chnte (1542) = 0 + chnhe (1542) = 2 + chperm (1542) = 110 + chbirf (1542) = 2313 + chetat (1542) = 586 + chtn2i (1542) = 1 + chbiet (586) = 1542 +c +c Aretes coupees : 5 6 7 8 + chclas (240) = ' 4-18' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0 + charde (240)(1:12) = ' 5 6 7 8' + chnp1 (240) = 0 + chnar (240) = 0 + chnpy (240) = 0 + chnte (240) = 0 + chnhe (240) = 2 + chperm (240) = 10 + chbirf (240) = 2313 + chetat (240) = 587 + chtn2i (240) = 1 + chbiet (587) = 240 +c +c =========================================== +c Classe d'equivalence 5-00 +c +c Aretes coupees : 1 2 6 8 12 + chclas (2211) = ' 5-00' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1 + charde (2211)(1:15) = ' 1 2 6 8 12' + chnp1 (2211) = 1 + chnar (2211) = 16 + chnpy (2211) = 11 + chnte (2211) = 6 + chnhe (2211) = 0 + chperm (2211) = 0 + chbirf (2211) = 2211 + chetat (2211) = 588 + chtn2i (2211) = 210 + chbiet (588) = 2211 +c +c Aretes coupees : 1 2 6 10 12 + chclas (2595) = ' 5-00' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2595)(1:15) = ' 1 2 6 10 12' + chnp1 (2595) = 1 + chnar (2595) = 16 + chnpy (2595) = 11 + chnte (2595) = 6 + chnhe (2595) = 0 + chperm (2595) = 320 + chbirf (2595) = 2211 + chetat (2595) = 589 + chtn2i (2595) = 210 + chbiet (589) = 2595 +c +c Aretes coupees : 1 2 8 10 12 + chclas (2691) = ' 5-00' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2691)(1:15) = ' 1 2 8 10 12' + chnp1 (2691) = 1 + chnar (2691) = 16 + chnpy (2691) = 11 + chnte (2691) = 6 + chnhe (2691) = 0 + chperm (2691) = 120 + chbirf (2691) = 2211 + chetat (2691) = 590 + chtn2i (2691) = 210 + chbiet (590) = 2691 +c +c Aretes coupees : 1 3 7 8 10 + chclas (709) = ' 5-00' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 0 + charde (709)(1:15) = ' 1 3 7 8 10' + chnp1 (709) = 1 + chnar (709) = 16 + chnpy (709) = 11 + chnte (709) = 6 + chnhe (709) = 0 + chperm (709) = 221 + chbirf (709) = 2211 + chetat (709) = 591 + chtn2i (709) = 210 + chbiet (591) = 709 +c +c Aretes coupees : 1 3 7 9 10 + chclas (837) = ' 5-00' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0 + charde (837)(1:15) = ' 1 3 7 9 10' + chnp1 (837) = 1 + chnar (837) = 16 + chnpy (837) = 11 + chnte (837) = 6 + chnhe (837) = 0 + chperm (837) = 130 + chbirf (837) = 2211 + chetat (837) = 592 + chtn2i (837) = 210 + chbiet (592) = 837 +c +c Aretes coupees : 1 3 8 9 10 + chclas (901) = ' 5-00' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (901)(1:15) = ' 1 3 8 9 10' + chnp1 (901) = 1 + chnar (901) = 16 + chnpy (901) = 11 + chnte (901) = 6 + chnhe (901) = 0 + chperm (901) = 310 + chbirf (901) = 2211 + chetat (901) = 593 + chtn2i (901) = 210 + chbiet (593) = 901 +c +c Aretes coupees : 1 4 5 8 10 + chclas (665) = ' 5-00' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 0 + charde (665)(1:15) = ' 1 4 5 8 10' + chnp1 (665) = 1 + chnar (665) = 16 + chnpy (665) = 11 + chnte (665) = 6 + chnhe (665) = 0 + chperm (665) = 30 + chbirf (665) = 2211 + chetat (665) = 594 + chtn2i (665) = 210 + chbiet (594) = 665 +c +c Aretes coupees : 1 4 5 8 11 + chclas (1177) = ' 5-00' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1177)(1:15) = ' 1 4 5 8 11' + chnp1 (1177) = 1 + chnar (1177) = 16 + chnpy (1177) = 11 + chnte (1177) = 6 + chnhe (1177) = 0 + chperm (1177) = 210 + chbirf (1177) = 2211 + chetat (1177) = 595 + chtn2i (1177) = 210 + chbiet (595) = 1177 +c +c Aretes coupees : 1 5 8 10 11 + chclas (1681) = ' 5-00' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0 + charde (1681)(1:15) = ' 1 5 8 10 11' + chnp1 (1681) = 1 + chnar (1681) = 16 + chnpy (1681) = 11 + chnte (1681) = 6 + chnhe (1681) = 0 + chperm (1681) = 101 + chbirf (1681) = 2211 + chetat (1681) = 596 + chtn2i (1681) = 210 + chbiet (596) = 1681 +c +c Aretes coupees : 1 6 8 10 12 + chclas (2721) = ' 5-00' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1 + charde (2721)(1:15) = ' 1 6 8 10 12' + chnp1 (2721) = 1 + chnar (2721) = 16 + chnpy (2721) = 11 + chnte (2721) = 6 + chnhe (2721) = 0 + chperm (2721) = 200 + chbirf (2721) = 2211 + chetat (2721) = 597 + chtn2i (2721) = 210 + chbiet (597) = 2721 +c +c Aretes coupees : 2 3 6 7 9 + chclas (358) = ' 5-00' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0 + charde (358)(1:15) = ' 2 3 6 7 9' + chnp1 (358) = 1 + chnar (358) = 16 + chnpy (358) = 11 + chnte (358) = 6 + chnhe (358) = 0 + chperm (358) = 321 + chbirf (358) = 2211 + chetat (358) = 598 + chtn2i (358) = 210 + chbiet (598) = 358 +c +c Aretes coupees : 2 3 6 7 12 + chclas (2150) = ' 5-00' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2150)(1:15) = ' 2 3 6 7 12' + chnp1 (2150) = 1 + chnar (2150) = 16 + chnpy (2150) = 11 + chnte (2150) = 6 + chnhe (2150) = 0 + chperm (2150) = 301 + chbirf (2150) = 2211 + chetat (2150) = 599 + chtn2i (2150) = 210 + chbiet (599) = 2150 +c +c Aretes coupees : 2 4 5 6 11 + chclas (1082) = ' 5-00' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 1, 0 + charde (1082)(1:15) = ' 2 4 5 6 11' + chnp1 (1082) = 1 + chnar (1082) = 16 + chnpy (1082) = 11 + chnte (1082) = 6 + chnhe (1082) = 0 + chperm (1082) = 1 + chbirf (1082) = 2211 + chetat (1082) = 600 + chtn2i (1082) = 210 + chbiet (600) = 1082 +c +c Aretes coupees : 2 4 5 11 12 + chclas (3098) = ' 5-00' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3098)(1:15) = ' 2 4 5 11 12' + chnp1 (3098) = 1 + chnar (3098) = 16 + chnpy (3098) = 11 + chnte (3098) = 6 + chnhe (3098) = 0 + chperm (3098) = 330 + chbirf (3098) = 2211 + chetat (3098) = 601 + chtn2i (3098) = 210 + chbiet (601) = 3098 +c +c Aretes coupees : 2 4 6 11 12 + chclas (3114) = ' 5-00' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3114)(1:15) = ' 2 4 6 11 12' + chnp1 (3114) = 1 + chnar (3114) = 16 + chnpy (3114) = 11 + chnte (3114) = 6 + chnhe (3114) = 0 + chperm (3114) = 110 + chbirf (3114) = 2211 + chetat (3114) = 602 + chtn2i (3114) = 210 + chbiet (602) = 3114 +c +c Aretes coupees : 2 5 6 11 12 + chclas (3122) = ' 5-00' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1 + charde (3122)(1:15) = ' 2 5 6 11 12' + chnp1 (3122) = 1 + chnar (3122) = 16 + chnpy (3122) = 11 + chnte (3122) = 6 + chnhe (3122) = 0 + chperm (3122) = 21 + chbirf (3122) = 2211 + chetat (3122) = 603 + chtn2i (3122) = 210 + chbiet (603) = 3122 +c +c Aretes coupees : 2 6 7 9 12 + chclas (2402) = ' 5-00' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 0, 1 + charde (2402)(1:15) = ' 2 6 7 9 12' + chnp1 (2402) = 1 + chnar (2402) = 16 + chnpy (2402) = 11 + chnte (2402) = 6 + chnhe (2402) = 0 + chperm (2402) = 230 + chbirf (2402) = 2211 + chetat (2402) = 604 + chtn2i (2402) = 210 + chbiet (604) = 2402 +c +c Aretes coupees : 3 4 5 7 9 + chclas (348) = ' 5-00' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 0 + charde (348)(1:15) = ' 3 4 5 7 9' + chnp1 (348) = 1 + chnar (348) = 16 + chnpy (348) = 11 + chnte (348) = 6 + chnhe (348) = 0 + chperm (348) = 220 + chbirf (348) = 2211 + chetat (348) = 605 + chtn2i (348) = 210 + chbiet (605) = 348 +c +c Aretes coupees : 3 4 5 9 11 + chclas (1308) = ' 5-00' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1308)(1:15) = ' 3 4 5 9 11' + chnp1 (1308) = 1 + chnar (1308) = 16 + chnpy (1308) = 11 + chnte (1308) = 6 + chnhe (1308) = 0 + chperm (1308) = 100 + chbirf (1308) = 2211 + chetat (1308) = 606 + chtn2i (1308) = 210 + chbiet (606) = 1308 +c +c Aretes coupees : 3 4 7 9 11 + chclas (1356) = ' 5-00' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1356)(1:15) = ' 3 4 7 9 11' + chnp1 (1356) = 1 + chnar (1356) = 16 + chnpy (1356) = 11 + chnte (1356) = 6 + chnhe (1356) = 0 + chperm (1356) = 300 + chbirf (1356) = 2211 + chetat (1356) = 607 + chtn2i (1356) = 210 + chbiet (607) = 1356 +c +c Aretes coupees : 3 6 7 9 12 + chclas (2404) = ' 5-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1 + charde (2404)(1:15) = ' 3 6 7 9 12' + chnp1 (2404) = 1 + chnar (2404) = 16 + chnpy (2404) = 11 + chnte (2404) = 6 + chnhe (2404) = 0 + chperm (2404) = 10 + chbirf (2404) = 2211 + chetat (2404) = 608 + chtn2i (2404) = 210 + chbiet (608) = 2404 +c +c Aretes coupees : 3 7 8 9 10 + chclas (964) = ' 5-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0 + charde (964)(1:15) = ' 3 7 8 9 10' + chnp1 (964) = 1 + chnar (964) = 16 + chnpy (964) = 11 + chnte (964) = 6 + chnhe (964) = 0 + chperm (964) = 201 + chbirf (964) = 2211 + chetat (964) = 609 + chtn2i (964) = 210 + chbiet (609) = 964 +c +c Aretes coupees : 4 5 7 9 11 + chclas (1368) = ' 5-00' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0 + charde (1368)(1:15) = ' 4 5 7 9 11' + chnp1 (1368) = 1 + chnar (1368) = 16 + chnpy (1368) = 11 + chnte (1368) = 6 + chnhe (1368) = 0 + chperm (1368) = 20 + chbirf (1368) = 2211 + chetat (1368) = 610 + chtn2i (1368) = 210 + chbiet (610) = 1368 +c +c Aretes coupees : 4 5 8 10 11 + chclas (1688) = ' 5-00' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0 + charde (1688)(1:15) = ' 4 5 8 10 11' + chnp1 (1688) = 1 + chnar (1688) = 16 + chnpy (1688) = 11 + chnte (1688) = 6 + chnhe (1688) = 0 + chperm (1688) = 121 + chbirf (1688) = 2211 + chetat (1688) = 611 + chtn2i (1688) = 210 + chbiet (611) = 1688 +c +c =========================================== +c Classe d'equivalence 5-01 +c +c Aretes coupees : 1 2 7 8 11 + chclas (1219) = ' 5-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0 + charde (1219)(1:15) = ' 1 2 7 8 11' + chnp1 (1219) = 1 + chnar (1219) = 16 + chnpy (1219) = 11 + chnte (1219) = 6 + chnhe (1219) = 0 + chperm (1219) = 0 + chbirf (1219) = 1219 + chetat (1219) = 612 + chtn2i (1219) = 210 + chbiet (612) = 1219 +c +c Aretes coupees : 1 2 7 9 11 + chclas (1347) = ' 5-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1347)(1:15) = ' 1 2 7 9 11' + chnp1 (1347) = 1 + chnar (1347) = 16 + chnpy (1347) = 11 + chnte (1347) = 6 + chnhe (1347) = 0 + chperm (1347) = 230 + chbirf (1347) = 1219 + chetat (1347) = 613 + chtn2i (1347) = 210 + chbiet (613) = 1347 +c +c Aretes coupees : 1 2 8 9 11 + chclas (1411) = ' 5-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1411)(1:15) = ' 1 2 8 9 11' + chnp1 (1411) = 1 + chnar (1411) = 16 + chnpy (1411) = 11 + chnte (1411) = 6 + chnhe (1411) = 0 + chperm (1411) = 210 + chbirf (1411) = 1219 + chetat (1411) = 614 + chtn2i (1411) = 210 + chbiet (614) = 1411 +c +c Aretes coupees : 1 3 5 7 12 + chclas (2133) = ' 5-01' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1 + charde (2133)(1:15) = ' 1 3 5 7 12' + chnp1 (2133) = 1 + chnar (2133) = 16 + chnpy (2133) = 11 + chnte (2133) = 6 + chnhe (2133) = 0 + chperm (2133) = 221 + chbirf (2133) = 1219 + chetat (2133) = 615 + chtn2i (2133) = 210 + chbiet (615) = 2133 +c +c Aretes coupees : 1 3 5 11 12 + chclas (3093) = ' 5-01' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3093)(1:15) = ' 1 3 5 11 12' + chnp1 (3093) = 1 + chnar (3093) = 16 + chnpy (3093) = 11 + chnte (3093) = 6 + chnhe (3093) = 0 + chperm (3093) = 101 + chbirf (3093) = 1219 + chetat (3093) = 616 + chtn2i (3093) = 210 + chbiet (616) = 3093 +c +c Aretes coupees : 1 3 7 11 12 + chclas (3141) = ' 5-01' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3141)(1:15) = ' 1 3 7 11 12' + chnp1 (3141) = 1 + chnar (3141) = 16 + chnpy (3141) = 11 + chnte (3141) = 6 + chnhe (3141) = 0 + chperm (3141) = 301 + chbirf (3141) = 1219 + chetat (3141) = 617 + chtn2i (3141) = 210 + chbiet (617) = 3141 +c +c Aretes coupees : 1 4 6 7 10 + chclas (617) = ' 5-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0 + charde (617)(1:15) = ' 1 4 6 7 10' + chnp1 (617) = 1 + chnar (617) = 16 + chnpy (617) = 11 + chnte (617) = 6 + chnhe (617) = 0 + chperm (617) = 130 + chbirf (617) = 1219 + chetat (617) = 618 + chtn2i (617) = 210 + chbiet (618) = 617 +c +c Aretes coupees : 1 4 6 7 11 + chclas (1129) = ' 5-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1129)(1:15) = ' 1 4 6 7 11' + chnp1 (1129) = 1 + chnar (1129) = 16 + chnpy (1129) = 11 + chnte (1129) = 6 + chnhe (1129) = 0 + chperm (1129) = 110 + chbirf (1129) = 1219 + chetat (1129) = 619 + chtn2i (1129) = 210 + chbiet (619) = 1129 +c +c Aretes coupees : 1 5 7 11 12 + chclas (3153) = ' 5-01' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 1 + charde (3153)(1:15) = ' 1 5 7 11 12' + chnp1 (3153) = 1 + chnar (3153) = 16 + chnpy (3153) = 11 + chnte (3153) = 6 + chnhe (3153) = 0 + chperm (3153) = 21 + chbirf (3153) = 1219 + chetat (3153) = 620 + chtn2i (3153) = 210 + chbiet (620) = 3153 +c +c Aretes coupees : 1 6 7 10 11 + chclas (1633) = ' 5-01' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0 + charde (1633)(1:15) = ' 1 6 7 10 11' + chnp1 (1633) = 1 + chnar (1633) = 16 + chnpy (1633) = 11 + chnte (1633) = 6 + chnhe (1633) = 0 + chperm (1633) = 320 + chbirf (1633) = 1219 + chetat (1633) = 621 + chtn2i (1633) = 210 + chbiet (621) = 1633 +c +c Aretes coupees : 2 3 5 8 9 + chclas (406) = ' 5-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0 + charde (406)(1:15) = ' 2 3 5 8 9' + chnp1 (406) = 1 + chnar (406) = 16 + chnpy (406) = 11 + chnte (406) = 6 + chnhe (406) = 0 + chperm (406) = 100 + chbirf (406) = 1219 + chetat (406) = 622 + chtn2i (406) = 210 + chbiet (622) = 406 +c +c Aretes coupees : 2 3 5 8 12 + chclas (2198) = ' 5-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2198)(1:15) = ' 2 3 5 8 12' + chnp1 (2198) = 1 + chnar (2198) = 16 + chnpy (2198) = 11 + chnte (2198) = 6 + chnhe (2198) = 0 + chperm (2198) = 120 + chbirf (2198) = 1219 + chetat (2198) = 623 + chtn2i (2198) = 210 + chbiet (623) = 2198 +c +c Aretes coupees : 2 4 6 8 9 + chclas (426) = ' 5-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0 + charde (426)(1:15) = ' 2 4 6 8 9' + chnp1 (426) = 1 + chnar (426) = 16 + chnpy (426) = 11 + chnte (426) = 6 + chnhe (426) = 0 + chperm (426) = 1 + chbirf (426) = 1219 + chetat (426) = 624 + chtn2i (426) = 210 + chbiet (624) = 426 +c +c Aretes coupees : 2 4 6 9 10 + chclas (810) = ' 5-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0 + charde (810)(1:15) = ' 2 4 6 9 10' + chnp1 (810) = 1 + chnar (810) = 16 + chnpy (810) = 11 + chnte (810) = 6 + chnhe (810) = 0 + chperm (810) = 321 + chbirf (810) = 1219 + chetat (810) = 625 + chtn2i (810) = 210 + chbiet (625) = 810 +c +c Aretes coupees : 2 4 8 9 10 + chclas (906) = ' 5-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0 + charde (906)(1:15) = ' 2 4 8 9 10' + chnp1 (906) = 1 + chnar (906) = 16 + chnpy (906) = 11 + chnte (906) = 6 + chnhe (906) = 0 + chperm (906) = 121 + chbirf (906) = 1219 + chetat (906) = 626 + chtn2i (906) = 210 + chbiet (626) = 906 +c +c Aretes coupees : 2 5 8 9 12 + chclas (2450) = ' 5-01' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1 + charde (2450)(1:15) = ' 2 5 8 9 12' + chnp1 (2450) = 1 + chnar (2450) = 16 + chnpy (2450) = 11 + chnte (2450) = 6 + chnhe (2450) = 0 + chperm (2450) = 330 + chbirf (2450) = 1219 + chetat (2450) = 627 + chtn2i (2450) = 210 + chbiet (627) = 2450 +c +c Aretes coupees : 2 7 8 9 11 + chclas (1474) = ' 5-01' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0 + charde (1474)(1:15) = ' 2 7 8 9 11' + chnp1 (1474) = 1 + chnar (1474) = 16 + chnpy (1474) = 11 + chnte (1474) = 6 + chnhe (1474) = 0 + chperm (1474) = 20 + chbirf (1474) = 1219 + chetat (1474) = 628 + chtn2i (1474) = 210 + chbiet (628) = 1474 +c +c Aretes coupees : 3 4 5 6 10 + chclas (572) = ' 5-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 0 + charde (572)(1:15) = ' 3 4 5 6 10' + chnp1 (572) = 1 + chnar (572) = 16 + chnpy (572) = 11 + chnte (572) = 6 + chnhe (572) = 0 + chperm (572) = 220 + chbirf (572) = 1219 + chetat (572) = 629 + chtn2i (572) = 210 + chbiet (629) = 572 +c +c Aretes coupees : 3 4 5 10 12 + chclas (2588) = ' 5-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2588)(1:15) = ' 3 4 5 10 12' + chnp1 (2588) = 1 + chnar (2588) = 16 + chnpy (2588) = 11 + chnte (2588) = 6 + chnhe (2588) = 0 + chperm (2588) = 30 + chbirf (2588) = 1219 + chetat (2588) = 630 + chtn2i (2588) = 210 + chbiet (630) = 2588 +c +c Aretes coupees : 3 4 6 10 12 + chclas (2604) = ' 5-01' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2604)(1:15) = ' 3 4 6 10 12' + chnp1 (2604) = 1 + chnar (2604) = 16 + chnpy (2604) = 11 + chnte (2604) = 6 + chnhe (2604) = 0 + chperm (2604) = 10 + chbirf (2604) = 1219 + chetat (2604) = 631 + chtn2i (2604) = 210 + chbiet (631) = 2604 +c +c Aretes coupees : 3 5 6 10 12 + chclas (2612) = ' 5-01' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 1 + charde (2612)(1:15) = ' 3 5 6 10 12' + chnp1 (2612) = 1 + chnar (2612) = 16 + chnpy (2612) = 11 + chnte (2612) = 6 + chnhe (2612) = 0 + chperm (2612) = 200 + chbirf (2612) = 1219 + chetat (2612) = 632 + chtn2i (2612) = 210 + chbiet (632) = 2612 +c +c Aretes coupees : 3 5 8 9 12 + chclas (2452) = ' 5-01' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1 + charde (2452)(1:15) = ' 3 5 8 9 12' + chnp1 (2452) = 1 + chnar (2452) = 16 + chnpy (2452) = 11 + chnte (2452) = 6 + chnhe (2452) = 0 + chperm (2452) = 310 + chbirf (2452) = 1219 + chetat (2452) = 633 + chtn2i (2452) = 210 + chbiet (633) = 2452 +c +c Aretes coupees : 4 6 7 10 11 + chclas (1640) = ' 5-01' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0 + charde (1640)(1:15) = ' 4 6 7 10 11' + chnp1 (1640) = 1 + chnar (1640) = 16 + chnpy (1640) = 11 + chnte (1640) = 6 + chnhe (1640) = 0 + chperm (1640) = 300 + chbirf (1640) = 1219 + chetat (1640) = 634 + chtn2i (1640) = 210 + chbiet (634) = 1640 +c +c Aretes coupees : 4 6 8 9 10 + chclas (936) = ' 5-01' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 1, 1, 1, 0, 0 + charde (936)(1:15) = ' 4 6 8 9 10' + chnp1 (936) = 1 + chnar (936) = 16 + chnpy (936) = 11 + chnte (936) = 6 + chnhe (936) = 0 + chperm (936) = 201 + chbirf (936) = 1219 + chetat (936) = 635 + chtn2i (936) = 210 + chbiet (635) = 936 +c +c =========================================== +c Classe d'equivalence 5-02 +c +c Aretes coupees : 1 2 8 9 12 + chclas (2435) = ' 5-02' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2435)(1:15) = ' 1 2 8 9 12' + chnp1 (2435) = 1 + chnar (2435) = 15 + chnpy (2435) = 10 + chnte (2435) = 6 + chnhe (2435) = 0 + chperm (2435) = 0 + chbirf (2435) = 2435 + chetat (2435) = 636 + chtn2i (2435) = 210 + chbiet (636) = 2435 +c +c Aretes coupees : 1 3 7 10 11 + chclas (1605) = ' 5-02' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1605)(1:15) = ' 1 3 7 10 11' + chnp1 (1605) = 1 + chnar (1605) = 15 + chnpy (1605) = 10 + chnte (1605) = 6 + chnhe (1605) = 0 + chperm (1605) = 130 + chbirf (1605) = 2435 + chetat (1605) = 637 + chtn2i (1605) = 210 + chbiet (637) = 1605 +c +c Aretes coupees : 1 4 6 10 12 + chclas (2601) = ' 5-02' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2601)(1:15) = ' 1 4 6 10 12' + chnp1 (2601) = 1 + chnar (2601) = 15 + chnpy (2601) = 10 + chnte (2601) = 6 + chnhe (2601) = 0 + chperm (2601) = 200 + chbirf (2601) = 2435 + chetat (2601) = 638 + chtn2i (2601) = 210 + chbiet (638) = 2601 +c +c Aretes coupees : 1 4 7 9 11 + chclas (1353) = ' 5-02' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1353)(1:15) = ' 1 4 7 9 11' + chnp1 (1353) = 1 + chnar (1353) = 15 + chnpy (1353) = 10 + chnte (1353) = 6 + chnhe (1353) = 0 + chperm (1353) = 300 + chbirf (1353) = 2435 + chetat (1353) = 639 + chtn2i (1353) = 210 + chbiet (639) = 1353 +c +c Aretes coupees : 1 5 7 8 11 + chclas (1233) = ' 5-02' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 0 + charde (1233)(1:15) = ' 1 5 7 8 11' + chnp1 (1233) = 1 + chnar (1233) = 15 + chnpy (1233) = 10 + chnte (1233) = 6 + chnhe (1233) = 0 + chperm (1233) = 210 + chbirf (1233) = 2435 + chetat (1233) = 640 + chtn2i (1233) = 210 + chbiet (640) = 1233 +c +c Aretes coupees : 2 3 5 11 12 + chclas (3094) = ' 5-02' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3094)(1:15) = ' 2 3 5 11 12' + chnp1 (3094) = 1 + chnar (3094) = 15 + chnpy (3094) = 10 + chnte (3094) = 6 + chnhe (3094) = 0 + chperm (3094) = 330 + chbirf (3094) = 2435 + chetat (3094) = 641 + chtn2i (3094) = 210 + chbiet (641) = 3094 +c +c Aretes coupees : 2 3 8 9 10 + chclas (902) = ' 5-02' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (902)(1:15) = ' 2 3 8 9 10' + chnp1 (902) = 1 + chnar (902) = 15 + chnpy (902) = 10 + chnte (902) = 6 + chnhe (902) = 0 + chperm (902) = 310 + chbirf (902) = 2435 + chetat (902) = 642 + chtn2i (902) = 210 + chbiet (642) = 902 +c +c Aretes coupees : 2 4 6 10 11 + chclas (1578) = ' 5-02' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1578)(1:15) = ' 2 4 6 10 11' + chnp1 (1578) = 1 + chnar (1578) = 15 + chnpy (1578) = 10 + chnte (1578) = 6 + chnhe (1578) = 0 + chperm (1578) = 110 + chbirf (1578) = 2435 + chetat (1578) = 643 + chtn2i (1578) = 210 + chbiet (643) = 1578 +c +c Aretes coupees : 2 6 7 8 9 + chclas (482) = ' 5-02' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0 + charde (482)(1:15) = ' 2 6 7 8 9' + chnp1 (482) = 1 + chnar (482) = 15 + chnpy (482) = 10 + chnte (482) = 6 + chnhe (482) = 0 + chperm (482) = 230 + chbirf (482) = 2435 + chetat (482) = 644 + chtn2i (482) = 210 + chbiet (644) = 482 +c +c Aretes coupees : 3 4 5 9 12 + chclas (2332) = ' 5-02' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2332)(1:15) = ' 3 4 5 9 12' + chnp1 (2332) = 1 + chnar (2332) = 15 + chnpy (2332) = 10 + chnte (2332) = 6 + chnhe (2332) = 0 + chperm (2332) = 100 + chbirf (2332) = 2435 + chetat (2332) = 645 + chtn2i (2332) = 210 + chbiet (645) = 2332 +c +c Aretes coupees : 3 5 6 7 12 + chclas (2164) = ' 5-02' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 1 + charde (2164)(1:15) = ' 3 5 6 7 12' + chnp1 (2164) = 1 + chnar (2164) = 15 + chnpy (2164) = 10 + chnte (2164) = 6 + chnhe (2164) = 0 + chperm (2164) = 10 + chbirf (2164) = 2435 + chetat (2164) = 646 + chtn2i (2164) = 210 + chbiet (646) = 2164 +c +c Aretes coupees : 4 5 6 8 10 + chclas (696) = ' 5-02' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0 + charde (696)(1:15) = ' 4 5 6 8 10' + chnp1 (696) = 1 + chnar (696) = 15 + chnpy (696) = 10 + chnte (696) = 6 + chnhe (696) = 0 + chperm (696) = 30 + chbirf (696) = 2435 + chetat (696) = 647 + chtn2i (696) = 210 + chbiet (647) = 696 +c +c =========================================== +c Classe d'equivalence 5-03 +c +c Aretes coupees : 1 2 8 10 11 + chclas (1667) = ' 5-03' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1667)(1:15) = ' 1 2 8 10 11' + chnp1 (1667) = 1 + chnar (1667) = 15 + chnpy (1667) = 10 + chnte (1667) = 6 + chnhe (1667) = 0 + chperm (1667) = 0 + chbirf (1667) = 1667 + chetat (1667) = 648 + chtn2i (1667) = 210 + chbiet (648) = 1667 +c +c Aretes coupees : 1 3 7 9 12 + chclas (2373) = ' 5-03' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2373)(1:15) = ' 1 3 7 9 12' + chnp1 (2373) = 1 + chnar (2373) = 15 + chnpy (2373) = 10 + chnte (2373) = 6 + chnhe (2373) = 0 + chperm (2373) = 301 + chbirf (2373) = 1667 + chetat (2373) = 649 + chtn2i (2373) = 210 + chbiet (649) = 2373 +c +c Aretes coupees : 1 4 5 11 12 + chclas (3097) = ' 5-03' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3097)(1:15) = ' 1 4 5 11 12' + chnp1 (3097) = 1 + chnar (3097) = 15 + chnpy (3097) = 10 + chnte (3097) = 6 + chnhe (3097) = 0 + chperm (3097) = 101 + chbirf (3097) = 1667 + chetat (3097) = 650 + chtn2i (3097) = 210 + chbiet (650) = 3097 +c +c Aretes coupees : 1 4 8 9 10 + chclas (905) = ' 5-03' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0 + charde (905)(1:15) = ' 1 4 8 9 10' + chnp1 (905) = 1 + chnar (905) = 15 + chnpy (905) = 10 + chnte (905) = 6 + chnhe (905) = 0 + chperm (905) = 201 + chbirf (905) = 1667 + chetat (905) = 651 + chtn2i (905) = 210 + chbiet (651) = 905 +c +c Aretes coupees : 1 6 7 8 10 + chclas (737) = ' 5-03' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0 + charde (737)(1:15) = ' 1 6 7 8 10' + chnp1 (737) = 1 + chnar (737) = 15 + chnpy (737) = 10 + chnte (737) = 6 + chnhe (737) = 0 + chperm (737) = 320 + chbirf (737) = 1667 + chetat (737) = 652 + chtn2i (737) = 210 + chbiet (652) = 737 +c +c Aretes coupees : 2 3 6 10 12 + chclas (2598) = ' 5-03' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2598)(1:15) = ' 2 3 6 10 12' + chnp1 (2598) = 1 + chnar (2598) = 15 + chnpy (2598) = 10 + chnte (2598) = 6 + chnhe (2598) = 0 + chperm (2598) = 200 + chbirf (2598) = 1667 + chetat (2598) = 653 + chtn2i (2598) = 210 + chbiet (653) = 2598 +c +c Aretes coupees : 2 3 7 9 11 + chclas (1350) = ' 5-03' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1350)(1:15) = ' 2 3 7 9 11' + chnp1 (1350) = 1 + chnar (1350) = 15 + chnpy (1350) = 10 + chnte (1350) = 6 + chnhe (1350) = 0 + chperm (1350) = 20 + chbirf (1350) = 1667 + chetat (1350) = 654 + chtn2i (1350) = 210 + chbiet (654) = 1350 +c +c Aretes coupees : 2 4 6 9 12 + chclas (2346) = ' 5-03' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2346)(1:15) = ' 2 4 6 9 12' + chnp1 (2346) = 1 + chnar (2346) = 15 + chnpy (2346) = 10 + chnte (2346) = 6 + chnhe (2346) = 0 + chperm (2346) = 1 + chbirf (2346) = 1667 + chetat (2346) = 655 + chtn2i (2346) = 210 + chbiet (655) = 2346 +c +c Aretes coupees : 2 5 6 8 12 + chclas (2226) = ' 5-03' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1 + charde (2226)(1:15) = ' 2 5 6 8 12' + chnp1 (2226) = 1 + chnar (2226) = 15 + chnpy (2226) = 10 + chnte (2226) = 6 + chnhe (2226) = 0 + chperm (2226) = 120 + chbirf (2226) = 1667 + chetat (2226) = 656 + chtn2i (2226) = 210 + chbiet (656) = 2226 +c +c Aretes coupees : 3 4 5 10 11 + chclas (1564) = ' 5-03' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1564)(1:15) = ' 3 4 5 10 11' + chnp1 (1564) = 1 + chnar (1564) = 15 + chnpy (1564) = 10 + chnte (1564) = 6 + chnhe (1564) = 0 + chperm (1564) = 220 + chbirf (1564) = 1667 + chetat (1564) = 657 + chtn2i (1564) = 210 + chbiet (657) = 1564 +c +c Aretes coupees : 3 5 7 8 9 + chclas (468) = ' 5-03' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 1, 1, 0, 0, 0 + charde (468)(1:15) = ' 3 5 7 8 9' + chnp1 (468) = 1 + chnar (468) = 15 + chnpy (468) = 10 + chnte (468) = 6 + chnhe (468) = 0 + chperm (468) = 100 + chbirf (468) = 1667 + chetat (468) = 658 + chtn2i (468) = 210 + chbiet (658) = 468 +c +c Aretes coupees : 4 5 6 7 11 + chclas (1144) = ' 5-03' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0 + charde (1144)(1:15) = ' 4 5 6 7 11' + chnp1 (1144) = 1 + chnar (1144) = 15 + chnpy (1144) = 10 + chnte (1144) = 6 + chnhe (1144) = 0 + chperm (1144) = 300 + chbirf (1144) = 1667 + chetat (1144) = 659 + chtn2i (1144) = 210 + chbiet (659) = 1144 +c +c =========================================== +c Classe d'equivalence 5-04 +c +c Aretes coupees : 1 2 6 7 8 + chclas (227) = ' 5-04' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0 + charde (227)(1:15) = ' 1 2 6 7 8' + chnp1 (227) = 1 + chnar (227) = 16 + chnpy (227) = 14 + chnte (227) = 0 + chnhe (227) = 0 + chperm (227) = 0 + chbirf (227) = 227 + chetat (227) = 660 + chtn2i (227) = 210 + chbiet (660) = 227 +c +c Aretes coupees : 1 2 6 10 11 + chclas (1571) = ' 5-04' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1571)(1:15) = ' 1 2 6 10 11' + chnp1 (1571) = 1 + chnar (1571) = 16 + chnpy (1571) = 14 + chnte (1571) = 0 + chnhe (1571) = 0 + chperm (1571) = 320 + chbirf (1571) = 227 + chetat (1571) = 661 + chtn2i (1571) = 210 + chbiet (661) = 1571 +c +c Aretes coupees : 1 2 7 9 12 + chclas (2371) = ' 5-04' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2371)(1:15) = ' 1 2 7 9 12' + chnp1 (2371) = 1 + chnar (2371) = 16 + chnpy (2371) = 14 + chnte (2371) = 0 + chnhe (2371) = 0 + chperm (2371) = 230 + chbirf (2371) = 227 + chetat (2371) = 662 + chtn2i (2371) = 210 + chbiet (662) = 2371 +c +c Aretes coupees : 1 3 5 7 8 + chclas (213) = ' 5-04' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0 + charde (213)(1:15) = ' 1 3 5 7 8' + chnp1 (213) = 1 + chnar (213) = 16 + chnpy (213) = 14 + chnte (213) = 0 + chnhe (213) = 0 + chperm (213) = 221 + chbirf (213) = 227 + chetat (213) = 663 + chtn2i (213) = 210 + chbiet (663) = 213 +c +c Aretes coupees : 1 3 5 10 11 + chclas (1557) = ' 5-04' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1557)(1:15) = ' 1 3 5 10 11' + chnp1 (1557) = 1 + chnar (1557) = 16 + chnpy (1557) = 14 + chnte (1557) = 0 + chnhe (1557) = 0 + chperm (1557) = 101 + chbirf (1557) = 227 + chetat (1557) = 664 + chtn2i (1557) = 210 + chbiet (664) = 1557 +c +c Aretes coupees : 1 3 8 9 12 + chclas (2437) = ' 5-04' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2437)(1:15) = ' 1 3 8 9 12' + chnp1 (2437) = 1 + chnar (2437) = 16 + chnpy (2437) = 14 + chnte (2437) = 0 + chnhe (2437) = 0 + chperm (2437) = 310 + chbirf (2437) = 227 + chetat (2437) = 665 + chtn2i (2437) = 210 + chbiet (665) = 2437 +c +c Aretes coupees : 1 4 5 10 12 + chclas (2585) = ' 5-04' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2585)(1:15) = ' 1 4 5 10 12' + chnp1 (2585) = 1 + chnar (2585) = 16 + chnpy (2585) = 14 + chnte (2585) = 0 + chnhe (2585) = 0 + chperm (2585) = 30 + chbirf (2585) = 227 + chetat (2585) = 666 + chtn2i (2585) = 210 + chbiet (666) = 2585 +c +c Aretes coupees : 1 4 6 11 12 + chclas (3113) = ' 5-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3113)(1:15) = ' 1 4 6 11 12' + chnp1 (3113) = 1 + chnar (3113) = 16 + chnpy (3113) = 14 + chnte (3113) = 0 + chnhe (3113) = 0 + chperm (3113) = 110 + chbirf (3113) = 227 + chetat (3113) = 667 + chtn2i (3113) = 210 + chbiet (667) = 3113 +c +c Aretes coupees : 1 4 7 9 10 + chclas (841) = ' 5-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0 + charde (841)(1:15) = ' 1 4 7 9 10' + chnp1 (841) = 1 + chnar (841) = 16 + chnpy (841) = 14 + chnte (841) = 0 + chnhe (841) = 0 + chperm (841) = 130 + chbirf (841) = 227 + chetat (841) = 668 + chtn2i (841) = 210 + chbiet (668) = 841 +c +c Aretes coupees : 1 4 8 9 11 + chclas (1417) = ' 5-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1417)(1:15) = ' 1 4 8 9 11' + chnp1 (1417) = 1 + chnar (1417) = 16 + chnpy (1417) = 14 + chnte (1417) = 0 + chnhe (1417) = 0 + chperm (1417) = 210 + chbirf (1417) = 227 + chetat (1417) = 669 + chtn2i (1417) = 210 + chbiet (669) = 1417 +c +c Aretes coupees : 2 3 5 9 11 + chclas (1302) = ' 5-04' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1302)(1:15) = ' 2 3 5 9 11' + chnp1 (1302) = 1 + chnar (1302) = 16 + chnpy (1302) = 14 + chnte (1302) = 0 + chnhe (1302) = 0 + chperm (1302) = 100 + chbirf (1302) = 227 + chetat (1302) = 670 + chtn2i (1302) = 210 + chbiet (670) = 1302 +c +c Aretes coupees : 2 3 6 9 10 + chclas (806) = ' 5-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 + charde (806)(1:15) = ' 2 3 6 9 10' + chnp1 (806) = 1 + chnar (806) = 16 + chnpy (806) = 14 + chnte (806) = 0 + chnhe (806) = 0 + chperm (806) = 321 + chbirf (806) = 227 + chetat (806) = 671 + chtn2i (806) = 210 + chbiet (671) = 806 +c +c Aretes coupees : 2 3 7 11 12 + chclas (3142) = ' 5-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3142)(1:15) = ' 2 3 7 11 12' + chnp1 (3142) = 1 + chnar (3142) = 16 + chnpy (3142) = 14 + chnte (3142) = 0 + chnhe (3142) = 0 + chperm (3142) = 301 + chbirf (3142) = 227 + chetat (3142) = 672 + chtn2i (3142) = 210 + chbiet (672) = 3142 +c +c Aretes coupees : 2 3 8 10 12 + chclas (2694) = ' 5-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2694)(1:15) = ' 2 3 8 10 12' + chnp1 (2694) = 1 + chnar (2694) = 16 + chnpy (2694) = 14 + chnte (2694) = 0 + chnhe (2694) = 0 + chperm (2694) = 120 + chbirf (2694) = 227 + chetat (2694) = 673 + chtn2i (2694) = 210 + chbiet (673) = 2694 +c +c Aretes coupees : 2 4 5 6 8 + chclas (186) = ' 5-04' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0, 0 + charde (186)(1:15) = ' 2 4 5 6 8' + chnp1 (186) = 1 + chnar (186) = 16 + chnpy (186) = 14 + chnte (186) = 0 + chnhe (186) = 0 + chperm (186) = 1 + chbirf (186) = 227 + chetat (186) = 674 + chtn2i (186) = 210 + chbiet (674) = 186 +c +c Aretes coupees : 2 4 5 9 12 + chclas (2330) = ' 5-04' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2330)(1:15) = ' 2 4 5 9 12' + chnp1 (2330) = 1 + chnar (2330) = 16 + chnpy (2330) = 14 + chnte (2330) = 0 + chnhe (2330) = 0 + chperm (2330) = 330 + chbirf (2330) = 227 + chetat (2330) = 675 + chtn2i (2330) = 210 + chbiet (675) = 2330 +c +c Aretes coupees : 2 4 8 10 11 + chclas (1674) = ' 5-04' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1674)(1:15) = ' 2 4 8 10 11' + chnp1 (1674) = 1 + chnar (1674) = 16 + chnpy (1674) = 14 + chnte (1674) = 0 + chnhe (1674) = 0 + chperm (1674) = 121 + chbirf (1674) = 227 + chetat (1674) = 676 + chtn2i (1674) = 210 + chbiet (676) = 1674 +c +c Aretes coupees : 3 4 5 6 7 + chclas (124) = ' 5-04' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 + charde (124)(1:15) = ' 3 4 5 6 7' + chnp1 (124) = 1 + chnar (124) = 16 + chnpy (124) = 14 + chnte (124) = 0 + chnhe (124) = 0 + chperm (124) = 220 + chbirf (124) = 227 + chetat (124) = 677 + chtn2i (124) = 210 + chbiet (677) = 124 +c +c Aretes coupees : 3 4 6 9 12 + chclas (2348) = ' 5-04' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2348)(1:15) = ' 3 4 6 9 12' + chnp1 (2348) = 1 + chnar (2348) = 16 + chnpy (2348) = 14 + chnte (2348) = 0 + chnhe (2348) = 0 + chperm (2348) = 10 + chbirf (2348) = 227 + chetat (2348) = 678 + chtn2i (2348) = 210 + chbiet (678) = 2348 +c +c Aretes coupees : 3 4 7 10 11 + chclas (1612) = ' 5-04' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1612)(1:15) = ' 3 4 7 10 11' + chnp1 (1612) = 1 + chnar (1612) = 16 + chnpy (1612) = 14 + chnte (1612) = 0 + chnhe (1612) = 0 + chperm (1612) = 300 + chbirf (1612) = 227 + chetat (1612) = 679 + chtn2i (1612) = 210 + chbiet (679) = 1612 +c +c Aretes coupees : 5 6 7 11 12 + chclas (3184) = ' 5-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1 + charde (3184)(1:15) = ' 5 6 7 11 12' + chnp1 (3184) = 1 + chnar (3184) = 16 + chnpy (3184) = 14 + chnte (3184) = 0 + chnhe (3184) = 0 + chperm (3184) = 21 + chbirf (3184) = 227 + chetat (3184) = 680 + chtn2i (3184) = 210 + chbiet (680) = 3184 +c +c Aretes coupees : 5 6 8 10 12 + chclas (2736) = ' 5-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0, 1 + charde (2736)(1:15) = ' 5 6 8 10 12' + chnp1 (2736) = 1 + chnar (2736) = 16 + chnpy (2736) = 14 + chnte (2736) = 0 + chnhe (2736) = 0 + chperm (2736) = 200 + chbirf (2736) = 227 + chetat (2736) = 681 + chtn2i (2736) = 210 + chbiet (681) = 2736 +c +c Aretes coupees : 5 7 8 9 11 + chclas (1488) = ' 5-04' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0 + charde (1488)(1:15) = ' 5 7 8 9 11' + chnp1 (1488) = 1 + chnar (1488) = 16 + chnpy (1488) = 14 + chnte (1488) = 0 + chnhe (1488) = 0 + chperm (1488) = 20 + chbirf (1488) = 227 + chetat (1488) = 682 + chtn2i (1488) = 210 + chbiet (682) = 1488 +c +c Aretes coupees : 6 7 8 9 10 + chclas (992) = ' 5-04' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0 + charde (992)(1:15) = ' 6 7 8 9 10' + chnp1 (992) = 1 + chnar (992) = 16 + chnpy (992) = 14 + chnte (992) = 0 + chnhe (992) = 0 + chperm (992) = 201 + chbirf (992) = 227 + chetat (992) = 683 + chtn2i (992) = 210 + chbiet (683) = 992 +c +c =========================================== +c Classe d'equivalence 5-05 +c +c Aretes coupees : 1 2 8 9 10 + chclas (899) = ' 5-05' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0 + charde (899)(1:15) = ' 1 2 8 9 10' + chnp1 (899) = 1 + chnar (899) = 15 + chnpy (899) = 10 + chnte (899) = 6 + chnhe (899) = 0 + chperm (899) = 0 + chbirf (899) = 899 + chetat (899) = 684 + chtn2i (899) = 210 + chbiet (684) = 899 +c +c Aretes coupees : 1 3 7 9 11 + chclas (1349) = ' 5-05' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1349)(1:15) = ' 1 3 7 9 11' + chnp1 (1349) = 1 + chnar (1349) = 15 + chnpy (1349) = 10 + chnte (1349) = 6 + chnhe (1349) = 0 + chperm (1349) = 20 + chbirf (1349) = 899 + chetat (1349) = 685 + chtn2i (1349) = 210 + chbiet (685) = 1349 +c +c Aretes coupees : 1 4 5 7 11 + chclas (1113) = ' 5-05' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1113)(1:15) = ' 1 4 5 7 11' + chnp1 (1113) = 1 + chnar (1113) = 15 + chnpy (1113) = 10 + chnte (1113) = 6 + chnhe (1113) = 0 + chperm (1113) = 300 + chbirf (1113) = 899 + chetat (1113) = 686 + chtn2i (1113) = 210 + chbiet (686) = 1113 +c +c Aretes coupees : 1 4 6 8 10 + chclas (681) = ' 5-05' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0 + charde (681)(1:15) = ' 1 4 6 8 10' + chnp1 (681) = 1 + chnar (681) = 15 + chnpy (681) = 10 + chnte (681) = 6 + chnhe (681) = 0 + chperm (681) = 320 + chbirf (681) = 899 + chetat (681) = 687 + chtn2i (681) = 210 + chbiet (687) = 681 +c +c Aretes coupees : 1 7 8 10 11 + chclas (1729) = ' 5-05' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0 + charde (1729)(1:15) = ' 1 7 8 10 11' + chnp1 (1729) = 1 + chnar (1729) = 15 + chnpy (1729) = 10 + chnte (1729) = 6 + chnhe (1729) = 0 + chperm (1729) = 210 + chbirf (1729) = 899 + chetat (1729) = 688 + chtn2i (1729) = 210 + chbiet (688) = 1729 +c +c Aretes coupees : 2 3 5 6 12 + chclas (2102) = ' 5-05' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2102)(1:15) = ' 2 3 5 6 12' + chnp1 (2102) = 1 + chnar (2102) = 15 + chnpy (2102) = 10 + chnte (2102) = 6 + chnhe (2102) = 0 + chperm (2102) = 10 + chbirf (2102) = 899 + chetat (2102) = 689 + chtn2i (2102) = 210 + chbiet (689) = 2102 +c +c Aretes coupees : 2 3 7 8 9 + chclas (454) = ' 5-05' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (454)(1:15) = ' 2 3 7 8 9' + chnp1 (454) = 1 + chnar (454) = 15 + chnpy (454) = 10 + chnte (454) = 6 + chnhe (454) = 0 + chperm (454) = 310 + chbirf (454) = 899 + chetat (454) = 690 + chtn2i (454) = 210 + chbiet (690) = 454 +c +c Aretes coupees : 2 4 6 10 12 + chclas (2602) = ' 5-05' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2602)(1:15) = ' 2 4 6 10 12' + chnp1 (2602) = 1 + chnar (2602) = 15 + chnpy (2602) = 10 + chnte (2602) = 6 + chnhe (2602) = 0 + chperm (2602) = 200 + chbirf (2602) = 899 + chetat (2602) = 691 + chtn2i (2602) = 210 + chbiet (691) = 2602 +c +c Aretes coupees : 2 6 8 9 12 + chclas (2466) = ' 5-05' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1 + charde (2466)(1:15) = ' 2 6 8 9 12' + chnp1 (2466) = 1 + chnar (2466) = 15 + chnpy (2466) = 10 + chnte (2466) = 6 + chnhe (2466) = 0 + chperm (2466) = 120 + chbirf (2466) = 899 + chetat (2466) = 692 + chtn2i (2466) = 210 + chbiet (692) = 2466 +c +c Aretes coupees : 3 4 5 11 12 + chclas (3100) = ' 5-05' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3100)(1:15) = ' 3 4 5 11 12' + chnp1 (3100) = 1 + chnar (3100) = 15 + chnpy (3100) = 10 + chnte (3100) = 6 + chnhe (3100) = 0 + chperm (3100) = 220 + chbirf (3100) = 899 + chetat (3100) = 693 + chtn2i (3100) = 210 + chbiet (693) = 3100 +c +c Aretes coupees : 3 5 7 9 12 + chclas (2388) = ' 5-05' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1 + charde (2388)(1:15) = ' 3 5 7 9 12' + chnp1 (2388) = 1 + chnar (2388) = 15 + chnpy (2388) = 10 + chnte (2388) = 6 + chnhe (2388) = 0 + chperm (2388) = 100 + chbirf (2388) = 899 + chetat (2388) = 694 + chtn2i (2388) = 210 + chbiet (694) = 2388 +c +c Aretes coupees : 4 5 6 10 11 + chclas (1592) = ' 5-05' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0 + charde (1592)(1:15) = ' 4 5 6 10 11' + chnp1 (1592) = 1 + chnar (1592) = 15 + chnpy (1592) = 10 + chnte (1592) = 6 + chnhe (1592) = 0 + chperm (1592) = 110 + chbirf (1592) = 899 + chetat (1592) = 695 + chtn2i (1592) = 210 + chbiet (695) = 1592 +c +c =========================================== +c Classe d'equivalence 5-06 +c +c Aretes coupees : 1 2 6 8 10 + chclas (675) = ' 5-06' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0 + charde (675)(1:15) = ' 1 2 6 8 10' + chnp1 (675) = 1 + chnar (675) = 15 + chnpy (675) = 10 + chnte (675) = 6 + chnhe (675) = 0 + chperm (675) = 0 + chbirf (675) = 675 + chetat (675) = 696 + chtn2i (675) = 210 + chbiet (696) = 675 +c +c Aretes coupees : 1 3 7 8 9 + chclas (453) = ' 5-06' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (453)(1:15) = ' 1 3 7 8 9' + chnp1 (453) = 1 + chnar (453) = 15 + chnpy (453) = 10 + chnte (453) = 6 + chnhe (453) = 0 + chperm (453) = 310 + chbirf (453) = 675 + chetat (453) = 697 + chtn2i (453) = 210 + chbiet (697) = 453 +c +c Aretes coupees : 1 4 5 10 11 + chclas (1561) = ' 5-06' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0 + charde (1561)(1:15) = ' 1 4 5 10 11' + chnp1 (1561) = 1 + chnar (1561) = 15 + chnpy (1561) = 10 + chnte (1561) = 6 + chnhe (1561) = 0 + chperm (1561) = 30 + chbirf (1561) = 675 + chetat (1561) = 698 + chtn2i (1561) = 210 + chbiet (698) = 1561 +c +c Aretes coupees : 1 4 8 10 11 + chclas (1673) = ' 5-06' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0 + charde (1673)(1:15) = ' 1 4 8 10 11' + chnp1 (1673) = 1 + chnar (1673) = 15 + chnpy (1673) = 10 + chnte (1673) = 6 + chnhe (1673) = 0 + chperm (1673) = 210 + chbirf (1673) = 675 + chetat (1673) = 699 + chtn2i (1673) = 210 + chbiet (699) = 1673 +c +c Aretes coupees : 1 7 8 9 10 + chclas (961) = ' 5-06' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0 + charde (961)(1:15) = ' 1 7 8 9 10' + chnp1 (961) = 1 + chnar (961) = 15 + chnpy (961) = 10 + chnte (961) = 6 + chnhe (961) = 0 + chperm (961) = 130 + chbirf (961) = 675 + chetat (961) = 700 + chtn2i (961) = 210 + chbiet (700) = 961 +c +c Aretes coupees : 2 3 6 9 12 + chclas (2342) = ' 5-06' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1 + charde (2342)(1:15) = ' 2 3 6 9 12' + chnp1 (2342) = 1 + chnar (2342) = 15 + chnpy (2342) = 10 + chnte (2342) = 6 + chnhe (2342) = 0 + chperm (2342) = 10 + chbirf (2342) = 675 + chetat (2342) = 701 + chtn2i (2342) = 210 + chbiet (701) = 2342 +c +c Aretes coupees : 2 3 7 9 12 + chclas (2374) = ' 5-06' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0, 1 + charde (2374)(1:15) = ' 2 3 7 9 12' + chnp1 (2374) = 1 + chnar (2374) = 15 + chnpy (2374) = 10 + chnte (2374) = 6 + chnhe (2374) = 0 + chperm (2374) = 230 + chbirf (2374) = 675 + chetat (2374) = 702 + chtn2i (2374) = 210 + chbiet (702) = 2374 +c +c Aretes coupees : 2 4 5 6 12 + chclas (2106) = ' 5-06' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2106)(1:15) = ' 2 4 5 6 12' + chnp1 (2106) = 1 + chnar (2106) = 15 + chnpy (2106) = 10 + chnte (2106) = 6 + chnhe (2106) = 0 + chperm (2106) = 330 + chbirf (2106) = 675 + chetat (2106) = 703 + chtn2i (2106) = 210 + chbiet (703) = 2106 +c +c Aretes coupees : 2 6 8 10 12 + chclas (2722) = ' 5-06' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1 + charde (2722)(1:15) = ' 2 6 8 10 12' + chnp1 (2722) = 1 + chnar (2722) = 15 + chnpy (2722) = 10 + chnte (2722) = 6 + chnhe (2722) = 0 + chperm (2722) = 200 + chbirf (2722) = 675 + chetat (2722) = 704 + chtn2i (2722) = 210 + chbiet (704) = 2722 +c +c Aretes coupees : 3 4 5 7 11 + chclas (1116) = ' 5-06' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1116)(1:15) = ' 3 4 5 7 11' + chnp1 (1116) = 1 + chnar (1116) = 15 + chnpy (1116) = 10 + chnte (1116) = 6 + chnhe (1116) = 0 + chperm (1116) = 300 + chbirf (1116) = 675 + chetat (1116) = 705 + chtn2i (1116) = 210 + chbiet (705) = 1116 +c +c Aretes coupees : 3 5 7 9 11 + chclas (1364) = ' 5-06' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0 + charde (1364)(1:15) = ' 3 5 7 9 11' + chnp1 (1364) = 1 + chnar (1364) = 15 + chnpy (1364) = 10 + chnte (1364) = 6 + chnhe (1364) = 0 + chperm (1364) = 100 + chbirf (1364) = 675 + chetat (1364) = 706 + chtn2i (1364) = 210 + chbiet (706) = 1364 +c +c Aretes coupees : 4 5 6 11 12 + chclas (3128) = ' 5-06' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1 + charde (3128)(1:15) = ' 4 5 6 11 12' + chnp1 (3128) = 1 + chnar (3128) = 15 + chnpy (3128) = 10 + chnte (3128) = 6 + chnhe (3128) = 0 + chperm (3128) = 110 + chbirf (3128) = 675 + chetat (3128) = 707 + chtn2i (3128) = 210 + chbiet (707) = 3128 +c +c =========================================== +c Classe d'equivalence 5-07 +c +c Aretes coupees : 1 2 7 8 9 + chclas (451) = ' 5-07' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0 + charde (451)(1:15) = ' 1 2 7 8 9' + chnp1 (451) = 1 + chnar (451) = 15 + chnpy (451) = 10 + chnte (451) = 6 + chnhe (451) = 0 + chperm (451) = 0 + chbirf (451) = 451 + chetat (451) = 708 + chtn2i (451) = 210 + chbiet (708) = 451 +c +c Aretes coupees : 1 3 5 7 11 + chclas (1109) = ' 5-07' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0 + charde (1109)(1:15) = ' 1 3 5 7 11' + chnp1 (1109) = 1 + chnar (1109) = 15 + chnpy (1109) = 10 + chnte (1109) = 6 + chnhe (1109) = 0 + chperm (1109) = 101 + chbirf (1109) = 451 + chetat (1109) = 709 + chtn2i (1109) = 210 + chbiet (709) = 1109 +c +c Aretes coupees : 1 4 6 10 11 + chclas (1577) = ' 5-07' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 0, 0, 0, 1, 1, 0 + charde (1577)(1:15) = ' 1 4 6 10 11' + chnp1 (1577) = 1 + chnar (1577) = 15 + chnpy (1577) = 10 + chnte (1577) = 6 + chnhe (1577) = 0 + chperm (1577) = 110 + chbirf (1577) = 451 + chetat (1577) = 710 + chtn2i (1577) = 210 + chbiet (710) = 1577 +c +c Aretes coupees : 1 4 7 10 11 + chclas (1609) = ' 5-07' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0 + charde (1609)(1:15) = ' 1 4 7 10 11' + chnp1 (1609) = 1 + chnar (1609) = 15 + chnpy (1609) = 10 + chnte (1609) = 6 + chnhe (1609) = 0 + chperm (1609) = 300 + chbirf (1609) = 451 + chetat (1609) = 711 + chtn2i (1609) = 210 + chbiet (711) = 1609 +c +c Aretes coupees : 1 7 8 9 11 + chclas (1473) = ' 5-07' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0 + charde (1473)(1:15) = ' 1 7 8 9 11' + chnp1 (1473) = 1 + chnar (1473) = 15 + chnpy (1473) = 10 + chnte (1473) = 6 + chnhe (1473) = 0 + chperm (1473) = 210 + chbirf (1473) = 451 + chetat (1473) = 712 + chtn2i (1473) = 210 + chbiet (712) = 1473 +c +c Aretes coupees : 2 3 5 9 12 + chclas (2326) = ' 5-07' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0, 1 + charde (2326)(1:15) = ' 2 3 5 9 12' + chnp1 (2326) = 1 + chnar (2326) = 15 + chnpy (2326) = 10 + chnte (2326) = 6 + chnhe (2326) = 0 + chperm (2326) = 100 + chbirf (2326) = 451 + chetat (2326) = 713 + chtn2i (2326) = 210 + chbiet (713) = 2326 +c +c Aretes coupees : 2 3 8 9 12 + chclas (2438) = ' 5-07' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1 + charde (2438)(1:15) = ' 2 3 8 9 12' + chnp1 (2438) = 1 + chnar (2438) = 15 + chnpy (2438) = 10 + chnte (2438) = 6 + chnhe (2438) = 0 + chperm (2438) = 310 + chbirf (2438) = 451 + chetat (2438) = 714 + chtn2i (2438) = 210 + chbiet (714) = 2438 +c +c Aretes coupees : 2 4 6 8 10 + chclas (682) = ' 5-07' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0 + charde (682)(1:15) = ' 2 4 6 8 10' + chnp1 (682) = 1 + chnar (682) = 15 + chnpy (682) = 10 + chnte (682) = 6 + chnhe (682) = 0 + chperm (682) = 1 + chbirf (682) = 451 + chetat (682) = 715 + chtn2i (682) = 210 + chbiet (715) = 682 +c +c Aretes coupees : 2 6 8 9 10 + chclas (930) = ' 5-07' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 1, 1, 1, 0, 0 + charde (930)(1:15) = ' 2 6 8 9 10' + chnp1 (930) = 1 + chnar (930) = 15 + chnpy (930) = 10 + chnte (930) = 6 + chnhe (930) = 0 + chperm (930) = 201 + chbirf (930) = 451 + chetat (930) = 716 + chtn2i (930) = 210 + chbiet (716) = 930 +c +c Aretes coupees : 3 4 5 6 12 + chclas (2108) = ' 5-07' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 1 + charde (2108)(1:15) = ' 3 4 5 6 12' + chnp1 (2108) = 1 + chnar (2108) = 15 + chnpy (2108) = 10 + chnte (2108) = 6 + chnhe (2108) = 0 + chperm (2108) = 10 + chbirf (2108) = 451 + chetat (2108) = 717 + chtn2i (2108) = 210 + chbiet (717) = 2108 +c +c Aretes coupees : 3 5 7 11 12 + chclas (3156) = ' 5-07' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1 + charde (3156)(1:15) = ' 3 5 7 11 12' + chnp1 (3156) = 1 + chnar (3156) = 15 + chnpy (3156) = 10 + chnte (3156) = 6 + chnhe (3156) = 0 + chperm (3156) = 301 + chbirf (3156) = 451 + chetat (3156) = 718 + chtn2i (3156) = 210 + chbiet (718) = 3156 +c +c Aretes coupees : 4 5 6 10 12 + chclas (2616) = ' 5-07' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 0, 1 + charde (2616)(1:15) = ' 4 5 6 10 12' + chnp1 (2616) = 1 + chnar (2616) = 15 + chnpy (2616) = 10 + chnte (2616) = 6 + chnhe (2616) = 0 + chperm (2616) = 200 + chbirf (2616) = 451 + chetat (2616) = 719 + chtn2i (2616) = 210 + chbiet (719) = 2616 +c +c =========================================== +c Classe d'equivalence 5-08 +c +c Aretes coupees : 1 2 6 7 11 + chclas (1123) = ' 5-08' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1123)(1:15) = ' 1 2 6 7 11' + chnp1 (1123) = 1 + chnar (1123) = 17 + chnpy (1123) = 12 + chnte (1123) = 6 + chnhe (1123) = 0 + chperm (1123) = 0 + chbirf (1123) = 1123 + chetat (1123) = 720 + chtn2i (1123) = 210 + chbiet (720) = 1123 +c +c Aretes coupees : 1 2 7 11 12 + chclas (3139) = ' 5-08' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 1 + charde (3139)(1:15) = ' 1 2 7 11 12' + chnp1 (3139) = 1 + chnar (3139) = 17 + chnpy (3139) = 12 + chnte (3139) = 6 + chnhe (3139) = 0 + chperm (3139) = 230 + chbirf (3139) = 1123 + chetat (3139) = 721 + chtn2i (3139) = 210 + chbiet (721) = 3139 +c +c Aretes coupees : 1 3 5 8 12 + chclas (2197) = ' 5-08' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2197)(1:15) = ' 1 3 5 8 12' + chnp1 (2197) = 1 + chnar (2197) = 17 + chnpy (2197) = 12 + chnte (2197) = 6 + chnhe (2197) = 0 + chperm (2197) = 310 + chbirf (2197) = 1123 + chetat (2197) = 722 + chtn2i (2197) = 210 + chbiet (722) = 2197 +c +c Aretes coupees : 1 3 5 10 12 + chclas (2581) = ' 5-08' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 0, 1 + charde (2581)(1:15) = ' 1 3 5 10 12' + chnp1 (2581) = 1 + chnar (2581) = 17 + chnpy (2581) = 12 + chnte (2581) = 6 + chnhe (2581) = 0 + chperm (2581) = 30 + chbirf (2581) = 1123 + chetat (2581) = 723 + chtn2i (2581) = 210 + chbiet (723) = 2581 +c +c Aretes coupees : 1 6 7 11 12 + chclas (3169) = ' 5-08' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1 + charde (3169)(1:15) = ' 1 6 7 11 12' + chnp1 (3169) = 1 + chnar (3169) = 17 + chnpy (3169) = 12 + chnte (3169) = 6 + chnhe (3169) = 0 + chperm (3169) = 110 + chbirf (3169) = 1123 + chetat (3169) = 724 + chtn2i (3169) = 210 + chbiet (724) = 3169 +c +c Aretes coupees : 2 4 5 8 9 + chclas (410) = ' 5-08' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0 + charde (410)(1:15) = ' 2 4 5 8 9' + chnp1 (410) = 1 + chnar (410) = 17 + chnpy (410) = 12 + chnte (410) = 6 + chnhe (410) = 0 + chperm (410) = 330 + chbirf (410) = 1123 + chetat (410) = 725 + chtn2i (410) = 210 + chbiet (725) = 410 +c +c Aretes coupees : 2 4 8 9 11 + chclas (1418) = ' 5-08' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0 + charde (1418)(1:15) = ' 2 4 8 9 11' + chnp1 (1418) = 1 + chnar (1418) = 17 + chnpy (1418) = 12 + chnte (1418) = 6 + chnhe (1418) = 0 + chperm (1418) = 210 + chbirf (1418) = 1123 + chetat (1418) = 726 + chtn2i (1418) = 210 + chbiet (726) = 1418 +c +c Aretes coupees : 2 5 8 9 11 + chclas (1426) = ' 5-08' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0 + charde (1426)(1:15) = ' 2 5 8 9 11' + chnp1 (1426) = 1 + chnar (1426) = 17 + chnpy (1426) = 12 + chnte (1426) = 6 + chnhe (1426) = 0 + chperm (1426) = 100 + chbirf (1426) = 1123 + chetat (1426) = 727 + chtn2i (1426) = 210 + chbiet (727) = 1426 +c +c Aretes coupees : 3 4 6 7 10 + chclas (620) = ' 5-08' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0 + charde (620)(1:15) = ' 3 4 6 7 10' + chnp1 (620) = 1 + chnar (620) = 17 + chnpy (620) = 12 + chnte (620) = 6 + chnhe (620) = 0 + chperm (620) = 300 + chbirf (620) = 1123 + chetat (620) = 728 + chtn2i (620) = 210 + chbiet (728) = 620 +c +c Aretes coupees : 3 4 6 9 10 + chclas (812) = ' 5-08' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0 + charde (812)(1:15) = ' 3 4 6 9 10' + chnp1 (812) = 1 + chnar (812) = 17 + chnpy (812) = 12 + chnte (812) = 6 + chnhe (812) = 0 + chperm (812) = 10 + chbirf (812) = 1123 + chetat (812) = 729 + chtn2i (812) = 210 + chbiet (729) = 812 +c +c Aretes coupees : 3 5 8 10 12 + chclas (2708) = ' 5-08' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1 + charde (2708)(1:15) = ' 3 5 8 10 12' + chnp1 (2708) = 1 + chnar (2708) = 17 + chnpy (2708) = 12 + chnte (2708) = 6 + chnhe (2708) = 0 + chperm (2708) = 200 + chbirf (2708) = 1123 + chetat (2708) = 730 + chtn2i (2708) = 210 + chbiet (730) = 2708 +c +c Aretes coupees : 4 6 7 9 10 + chclas (872) = ' 5-08' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0 + charde (872)(1:15) = ' 4 6 7 9 10' + chnp1 (872) = 1 + chnar (872) = 17 + chnpy (872) = 12 + chnte (872) = 6 + chnhe (872) = 0 + chperm (872) = 130 + chbirf (872) = 1123 + chetat (872) = 731 + chtn2i (872) = 210 + chbiet (731) = 872 +c +c =========================================== +c Classe d'equivalence 5-09 +c +c Aretes coupees : 1 2 6 7 12 + chclas (2147) = ' 5-09' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2147)(1:15) = ' 1 2 6 7 12' + chnp1 (2147) = 1 + chnar (2147) = 17 + chnpy (2147) = 12 + chnte (2147) = 6 + chnhe (2147) = 0 + chperm (2147) = 0 + chbirf (2147) = 2147 + chetat (2147) = 732 + chtn2i (2147) = 210 + chbiet (732) = 2147 +c +c Aretes coupees : 1 2 6 11 12 + chclas (3107) = ' 5-09' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1 + charde (3107)(1:15) = ' 1 2 6 11 12' + chnp1 (3107) = 1 + chnar (3107) = 17 + chnpy (3107) = 12 + chnte (3107) = 6 + chnhe (3107) = 0 + chperm (3107) = 110 + chbirf (3107) = 2147 + chetat (3107) = 733 + chtn2i (3107) = 210 + chbiet (733) = 3107 +c +c Aretes coupees : 1 3 5 8 10 + chclas (661) = ' 5-09' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0 + charde (661)(1:15) = ' 1 3 5 8 10' + chnp1 (661) = 1 + chnar (661) = 17 + chnpy (661) = 12 + chnte (661) = 6 + chnhe (661) = 0 + chperm (661) = 101 + chbirf (661) = 2147 + chetat (661) = 734 + chtn2i (661) = 210 + chbiet (734) = 661 +c +c Aretes coupees : 1 3 8 10 12 + chclas (2693) = ' 5-09' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1 + charde (2693)(1:15) = ' 1 3 8 10 12' + chnp1 (2693) = 1 + chnar (2693) = 17 + chnpy (2693) = 12 + chnte (2693) = 6 + chnhe (2693) = 0 + chperm (2693) = 310 + chbirf (2693) = 2147 + chetat (2693) = 735 + chtn2i (2693) = 210 + chbiet (735) = 2693 +c +c Aretes coupees : 1 5 8 10 12 + chclas (2705) = ' 5-09' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1 + charde (2705)(1:15) = ' 1 5 8 10 12' + chnp1 (2705) = 1 + chnar (2705) = 17 + chnpy (2705) = 12 + chnte (2705) = 6 + chnhe (2705) = 0 + chperm (2705) = 200 + chbirf (2705) = 2147 + chetat (2705) = 736 + chtn2i (2705) = 210 + chbiet (736) = 2705 +c +c Aretes coupees : 2 4 5 8 11 + chclas (1178) = ' 5-09' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1178)(1:15) = ' 2 4 5 8 11' + chnp1 (1178) = 1 + chnar (1178) = 17 + chnpy (1178) = 12 + chnte (1178) = 6 + chnhe (1178) = 0 + chperm (1178) = 1 + chbirf (1178) = 2147 + chetat (1178) = 737 + chtn2i (1178) = 210 + chbiet (737) = 1178 +c +c Aretes coupees : 2 4 5 9 11 + chclas (1306) = ' 5-09' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 1, 0 + charde (1306)(1:15) = ' 2 4 5 9 11' + chnp1 (1306) = 1 + chnar (1306) = 17 + chnpy (1306) = 12 + chnte (1306) = 6 + chnhe (1306) = 0 + chperm (1306) = 100 + chbirf (1306) = 2147 + chetat (1306) = 738 + chtn2i (1306) = 210 + chbiet (738) = 1306 +c +c Aretes coupees : 2 6 7 11 12 + chclas (3170) = ' 5-09' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1 + charde (3170)(1:15) = ' 2 6 7 11 12' + chnp1 (3170) = 1 + chnar (3170) = 17 + chnpy (3170) = 12 + chnte (3170) = 6 + chnhe (3170) = 0 + chperm (3170) = 301 + chbirf (3170) = 2147 + chetat (3170) = 739 + chtn2i (3170) = 210 + chbiet (739) = 3170 +c +c Aretes coupees : 3 4 6 7 9 + chclas (364) = ' 5-09' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 0 + charde (364)(1:15) = ' 3 4 6 7 9' + chnp1 (364) = 1 + chnar (364) = 17 + chnpy (364) = 12 + chnte (364) = 6 + chnhe (364) = 0 + chperm (364) = 10 + chbirf (364) = 2147 + chetat (364) = 740 + chtn2i (364) = 210 + chbiet (740) = 364 +c +c Aretes coupees : 3 4 7 9 10 + chclas (844) = ' 5-09' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0, 0 + charde (844)(1:15) = ' 3 4 7 9 10' + chnp1 (844) = 1 + chnar (844) = 17 + chnpy (844) = 12 + chnte (844) = 6 + chnhe (844) = 0 + chperm (844) = 300 + chbirf (844) = 2147 + chetat (844) = 741 + chtn2i (844) = 210 + chbiet (741) = 844 +c +c Aretes coupees : 3 6 7 9 10 + chclas (868) = ' 5-09' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0 + charde (868)(1:15) = ' 3 6 7 9 10' + chnp1 (868) = 1 + chnar (868) = 17 + chnpy (868) = 12 + chnte (868) = 6 + chnhe (868) = 0 + chperm (868) = 201 + chbirf (868) = 2147 + chetat (868) = 742 + chtn2i (868) = 210 + chbiet (742) = 868 +c +c Aretes coupees : 4 5 8 9 11 + chclas (1432) = ' 5-09' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0 + charde (1432)(1:15) = ' 4 5 8 9 11' + chnp1 (1432) = 1 + chnar (1432) = 17 + chnpy (1432) = 12 + chnte (1432) = 6 + chnhe (1432) = 0 + chperm (1432) = 210 + chbirf (1432) = 2147 + chetat (1432) = 743 + chtn2i (1432) = 210 + chbiet (743) = 1432 +c +c =========================================== +c Classe d'equivalence 5-10 +c +c Aretes coupees : 1 2 5 8 11 + chclas (1171) = ' 5-10' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0 + charde (1171)(1:15) = ' 1 2 5 8 11' + chnp1 (1171) = 1 + chnar (1171) = 17 + chnpy (1171) = 12 + chnte (1171) = 6 + chnhe (1171) = 0 + chperm (1171) = 0 + chbirf (1171) = 1171 + chetat (1171) = 744 + chtn2i (1171) = 210 + chbiet (744) = 1171 +c +c Aretes coupees : 1 2 5 8 12 + chclas (2195) = ' 5-10' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 + charde (2195)(1:15) = ' 1 2 5 8 12' + chnp1 (2195) = 1 + chnar (2195) = 17 + chnpy (2195) = 12 + chnte (2195) = 6 + chnhe (2195) = 0 + chperm (2195) = 330 + chbirf (2195) = 1171 + chetat (2195) = 745 + chtn2i (2195) = 210 + chbiet (745) = 2195 +c +c Aretes coupees : 1 2 5 11 12 + chclas (3091) = ' 5-10' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3091)(1:15) = ' 1 2 5 11 12' + chnp1 (3091) = 1 + chnar (3091) = 17 + chnpy (3091) = 12 + chnte (3091) = 6 + chnhe (3091) = 0 + chperm (3091) = 101 + chbirf (3091) = 1171 + chetat (3091) = 746 + chtn2i (3091) = 210 + chbiet (746) = 3091 +c +c Aretes coupees : 1 2 8 11 12 + chclas (3203) = ' 5-10' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1 + charde (3203)(1:15) = ' 1 2 8 11 12' + chnp1 (3203) = 1 + chnar (3203) = 17 + chnpy (3203) = 12 + chnte (3203) = 6 + chnhe (3203) = 0 + chperm (3203) = 210 + chbirf (3203) = 1171 + chetat (3203) = 747 + chtn2i (3203) = 210 + chbiet (747) = 3203 +c +c Aretes coupees : 1 3 6 7 10 + chclas (613) = ' 5-10' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0 + charde (613)(1:15) = ' 1 3 6 7 10' + chnp1 (613) = 1 + chnar (613) = 17 + chnpy (613) = 12 + chnte (613) = 6 + chnhe (613) = 0 + chperm (613) = 320 + chbirf (613) = 1171 + chetat (613) = 748 + chtn2i (613) = 210 + chbiet (748) = 613 +c +c Aretes coupees : 1 3 6 7 12 + chclas (2149) = ' 5-10' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 1 + charde (2149)(1:15) = ' 1 3 6 7 12' + chnp1 (2149) = 1 + chnar (2149) = 17 + chnpy (2149) = 12 + chnte (2149) = 6 + chnhe (2149) = 0 + chperm (2149) = 221 + chbirf (2149) = 1171 + chetat (2149) = 749 + chtn2i (2149) = 210 + chbiet (749) = 2149 +c +c Aretes coupees : 1 3 6 10 12 + chclas (2597) = ' 5-10' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2597)(1:15) = ' 1 3 6 10 12' + chnp1 (2597) = 1 + chnar (2597) = 17 + chnpy (2597) = 12 + chnte (2597) = 6 + chnhe (2597) = 0 + chperm (2597) = 10 + chbirf (2597) = 1171 + chetat (2597) = 750 + chtn2i (2597) = 210 + chbiet (750) = 2597 +c +c Aretes coupees : 1 3 7 10 12 + chclas (2629) = ' 5-10' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0, 1 + charde (2629)(1:15) = ' 1 3 7 10 12' + chnp1 (2629) = 1 + chnar (2629) = 17 + chnpy (2629) = 12 + chnte (2629) = 6 + chnhe (2629) = 0 + chperm (2629) = 301 + chbirf (2629) = 1171 + chetat (2629) = 751 + chtn2i (2629) = 210 + chbiet (751) = 2629 +c +c Aretes coupees : 1 5 8 11 12 + chclas (3217) = ' 5-10' +c Code des aretes coupees : 1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 + charde (3217)(1:15) = ' 1 5 8 11 12' + chnp1 (3217) = 1 + chnar (3217) = 17 + chnpy (3217) = 12 + chnte (3217) = 6 + chnhe (3217) = 0 + chperm (3217) = 21 + chbirf (3217) = 1171 + chetat (3217) = 752 + chtn2i (3217) = 210 + chbiet (752) = 3217 +c +c Aretes coupees : 1 6 7 10 12 + chclas (2657) = ' 5-10' +c Code des aretes coupees : 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 1 + charde (2657)(1:15) = ' 1 6 7 10 12' + chnp1 (2657) = 1 + chnar (2657) = 17 + chnpy (2657) = 12 + chnte (2657) = 6 + chnhe (2657) = 0 + chperm (2657) = 130 + chbirf (2657) = 1171 + chetat (2657) = 753 + chtn2i (2657) = 210 + chbiet (753) = 2657 +c +c Aretes coupees : 2 4 6 7 9 + chclas (362) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 0 + charde (362)(1:15) = ' 2 4 6 7 9' + chnp1 (362) = 1 + chnar (362) = 17 + chnpy (362) = 12 + chnte (362) = 6 + chnhe (362) = 0 + chperm (362) = 1 + chbirf (362) = 1171 + chetat (362) = 754 + chtn2i (362) = 210 + chbiet (754) = 362 +c +c Aretes coupees : 2 4 6 7 11 + chclas (1130) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0 + charde (1130)(1:15) = ' 2 4 6 7 11' + chnp1 (1130) = 1 + chnar (1130) = 17 + chnpy (1130) = 12 + chnte (1130) = 6 + chnhe (1130) = 0 + chperm (1130) = 300 + chbirf (1130) = 1171 + chetat (1130) = 755 + chtn2i (1130) = 210 + chbiet (755) = 1130 +c +c Aretes coupees : 2 4 6 9 11 + chclas (1322) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0 + charde (1322)(1:15) = ' 2 4 6 9 11' + chnp1 (1322) = 1 + chnar (1322) = 17 + chnpy (1322) = 12 + chnte (1322) = 6 + chnhe (1322) = 0 + chperm (1322) = 321 + chbirf (1322) = 1171 + chetat (1322) = 756 + chtn2i (1322) = 210 + chbiet (756) = 1322 +c +c Aretes coupees : 2 4 7 9 11 + chclas (1354) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1354)(1:15) = ' 2 4 7 9 11' + chnp1 (1354) = 1 + chnar (1354) = 17 + chnpy (1354) = 12 + chnte (1354) = 6 + chnhe (1354) = 0 + chperm (1354) = 230 + chbirf (1354) = 1171 + chetat (1354) = 757 + chtn2i (1354) = 210 + chbiet (757) = 1354 +c +c Aretes coupees : 2 5 8 11 12 + chclas (3218) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 + charde (3218)(1:15) = ' 2 5 8 11 12' + chnp1 (3218) = 1 + chnar (3218) = 17 + chnpy (3218) = 12 + chnte (3218) = 6 + chnhe (3218) = 0 + chperm (3218) = 120 + chbirf (3218) = 1171 + chetat (3218) = 758 + chtn2i (3218) = 210 + chbiet (758) = 3218 +c +c Aretes coupees : 2 6 7 9 11 + chclas (1378) = ' 5-10' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 1, 0 + charde (1378)(1:15) = ' 2 6 7 9 11' + chnp1 (1378) = 1 + chnar (1378) = 17 + chnpy (1378) = 12 + chnte (1378) = 6 + chnhe (1378) = 0 + chperm (1378) = 20 + chbirf (1378) = 1171 + chetat (1378) = 759 + chtn2i (1378) = 210 + chbiet (759) = 1378 +c +c Aretes coupees : 3 4 5 8 9 + chclas (412) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0 + charde (412)(1:15) = ' 3 4 5 8 9' + chnp1 (412) = 1 + chnar (412) = 17 + chnpy (412) = 12 + chnte (412) = 6 + chnhe (412) = 0 + chperm (412) = 310 + chbirf (412) = 1171 + chetat (412) = 760 + chtn2i (412) = 210 + chbiet (760) = 412 +c +c Aretes coupees : 3 4 5 8 10 + chclas (668) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0 + charde (668)(1:15) = ' 3 4 5 8 10' + chnp1 (668) = 1 + chnar (668) = 17 + chnpy (668) = 12 + chnte (668) = 6 + chnhe (668) = 0 + chperm (668) = 220 + chbirf (668) = 1171 + chetat (668) = 761 + chtn2i (668) = 210 + chbiet (761) = 668 +c +c Aretes coupees : 3 4 5 9 10 + chclas (796) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0 + charde (796)(1:15) = ' 3 4 5 9 10' + chnp1 (796) = 1 + chnar (796) = 17 + chnpy (796) = 12 + chnte (796) = 6 + chnhe (796) = 0 + chperm (796) = 30 + chbirf (796) = 1171 + chetat (796) = 762 + chtn2i (796) = 210 + chbiet (762) = 796 +c +c Aretes coupees : 3 4 8 9 10 + chclas (908) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0 + charde (908)(1:15) = ' 3 4 8 9 10' + chnp1 (908) = 1 + chnar (908) = 17 + chnpy (908) = 12 + chnte (908) = 6 + chnhe (908) = 0 + chperm (908) = 121 + chbirf (908) = 1171 + chetat (908) = 763 + chtn2i (908) = 210 + chbiet (763) = 908 +c +c Aretes coupees : 3 5 8 9 10 + chclas (916) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 1, 1, 1, 0, 0 + charde (916)(1:15) = ' 3 5 8 9 10' + chnp1 (916) = 1 + chnar (916) = 17 + chnpy (916) = 12 + chnte (916) = 6 + chnhe (916) = 0 + chperm (916) = 100 + chbirf (916) = 1171 + chetat (916) = 764 + chtn2i (916) = 210 + chbiet (764) = 916 +c +c Aretes coupees : 3 6 7 10 12 + chclas (2660) = ' 5-10' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1 + charde (2660)(1:15) = ' 3 6 7 10 12' + chnp1 (2660) = 1 + chnar (2660) = 17 + chnpy (2660) = 12 + chnte (2660) = 6 + chnhe (2660) = 0 + chperm (2660) = 200 + chbirf (2660) = 1171 + chetat (2660) = 765 + chtn2i (2660) = 210 + chbiet (765) = 2660 +c +c Aretes coupees : 4 5 8 9 10 + chclas (920) = ' 5-10' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 1, 1, 1, 0, 0 + charde (920)(1:15) = ' 4 5 8 9 10' + chnp1 (920) = 1 + chnar (920) = 17 + chnpy (920) = 12 + chnte (920) = 6 + chnhe (920) = 0 + chperm (920) = 201 + chbirf (920) = 1171 + chetat (920) = 766 + chtn2i (920) = 210 + chbiet (766) = 920 +c +c Aretes coupees : 4 6 7 9 11 + chclas (1384) = ' 5-10' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0 + charde (1384)(1:15) = ' 4 6 7 9 11' + chnp1 (1384) = 1 + chnar (1384) = 17 + chnpy (1384) = 12 + chnte (1384) = 6 + chnhe (1384) = 0 + chperm (1384) = 110 + chbirf (1384) = 1171 + chetat (1384) = 767 + chtn2i (1384) = 210 + chbiet (767) = 1384 +c +c =========================================== +c Classe d'equivalence 5-11 +c +c Aretes coupees : 1 2 3 4 5 + chclas (31) = ' 5-11' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0 + charde (31)(1:15) = ' 1 2 3 4 5' + chnp1 (31) = 1 + chnar (31) = 16 + chnpy (31) = 11 + chnte (31) = 6 + chnhe (31) = 0 + chperm (31) = 0 + chbirf (31) = 31 + chetat (31) = 768 + chtn2i (31) = 210 + chbiet (768) = 31 +c +c Aretes coupees : 1 2 3 4 6 + chclas (47) = ' 5-11' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0 + charde (47)(1:15) = ' 1 2 3 4 6' + chnp1 (47) = 1 + chnar (47) = 16 + chnpy (47) = 11 + chnte (47) = 6 + chnhe (47) = 0 + chperm (47) = 221 + chbirf (47) = 31 + chetat (47) = 769 + chtn2i (47) = 210 + chbiet (769) = 47 +c +c Aretes coupees : 1 2 3 4 7 + chclas (79) = ' 5-11' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0 + charde (79)(1:15) = ' 1 2 3 4 7' + chnp1 (79) = 1 + chnar (79) = 16 + chnpy (79) = 11 + chnte (79) = 6 + chnhe (79) = 0 + chperm (79) = 1 + chbirf (79) = 31 + chetat (79) = 770 + chtn2i (79) = 210 + chbiet (770) = 79 +c +c Aretes coupees : 1 2 3 4 8 + chclas (143) = ' 5-11' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0 + charde (143)(1:15) = ' 1 2 3 4 8' + chnp1 (143) = 1 + chnar (143) = 16 + chnpy (143) = 11 + chnte (143) = 6 + chnhe (143) = 0 + chperm (143) = 220 + chbirf (143) = 31 + chetat (143) = 771 + chtn2i (143) = 210 + chbiet (771) = 143 +c +c Aretes coupees : 1 2 5 6 9 + chclas (307) = ' 5-11' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0 + charde (307)(1:15) = ' 1 2 5 6 9' + chnp1 (307) = 1 + chnar (307) = 16 + chnpy (307) = 11 + chnte (307) = 6 + chnhe (307) = 0 + chperm (307) = 101 + chbirf (307) = 31 + chetat (307) = 772 + chtn2i (307) = 210 + chbiet (772) = 307 +c +c Aretes coupees : 1 2 5 7 10 + chclas (595) = ' 5-11' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0 + charde (595)(1:15) = ' 1 2 5 7 10' + chnp1 (595) = 1 + chnar (595) = 16 + chnpy (595) = 11 + chnte (595) = 6 + chnhe (595) = 0 + chperm (595) = 330 + chbirf (595) = 31 + chetat (595) = 773 + chtn2i (595) = 210 + chbiet (773) = 595 +c +c Aretes coupees : 1 3 5 6 9 + chclas (309) = ' 5-11' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0 + charde (309)(1:15) = ' 1 3 5 6 9' + chnp1 (309) = 1 + chnar (309) = 16 + chnpy (309) = 11 + chnte (309) = 6 + chnhe (309) = 0 + chperm (309) = 320 + chbirf (309) = 31 + chetat (309) = 774 + chtn2i (309) = 210 + chbiet (774) = 309 +c +c Aretes coupees : 1 3 6 8 11 + chclas (1189) = ' 5-11' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0 + charde (1189)(1:15) = ' 1 3 6 8 11' + chnp1 (1189) = 1 + chnar (1189) = 16 + chnpy (1189) = 11 + chnte (1189) = 6 + chnhe (1189) = 0 + chperm (1189) = 10 + chbirf (1189) = 31 + chetat (1189) = 775 + chtn2i (1189) = 210 + chbiet (775) = 1189 +c +c Aretes coupees : 1 5 6 9 10 + chclas (817) = ' 5-11' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0 + charde (817)(1:15) = ' 1 5 6 9 10' + chnp1 (817) = 1 + chnar (817) = 16 + chnpy (817) = 11 + chnte (817) = 6 + chnhe (817) = 0 + chperm (817) = 100 + chbirf (817) = 31 + chetat (817) = 776 + chtn2i (817) = 210 + chbiet (776) = 817 +c +c Aretes coupees : 1 5 6 9 11 + chclas (1329) = ' 5-11' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0 + charde (1329)(1:15) = ' 1 5 6 9 11' + chnp1 (1329) = 1 + chnar (1329) = 16 + chnpy (1329) = 11 + chnte (1329) = 6 + chnhe (1329) = 0 + chperm (1329) = 321 + chbirf (1329) = 31 + chetat (1329) = 777 + chtn2i (1329) = 210 + chbiet (777) = 1329 +c +c Aretes coupees : 2 4 5 7 10 + chclas (602) = ' 5-11' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0 + charde (602)(1:15) = ' 2 4 5 7 10' + chnp1 (602) = 1 + chnar (602) = 16 + chnpy (602) = 11 + chnte (602) = 6 + chnhe (602) = 0 + chperm (602) = 230 + chbirf (602) = 31 + chetat (602) = 778 + chtn2i (602) = 210 + chbiet (778) = 602 +c +c Aretes coupees : 2 4 7 8 12 + chclas (2250) = ' 5-11' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1 + charde (2250)(1:15) = ' 2 4 7 8 12' + chnp1 (2250) = 1 + chnar (2250) = 16 + chnpy (2250) = 11 + chnte (2250) = 6 + chnhe (2250) = 0 + chperm (2250) = 300 + chbirf (2250) = 31 + chetat (2250) = 779 + chtn2i (2250) = 210 + chbiet (779) = 2250 +c +c Aretes coupees : 2 5 7 9 10 + chclas (850) = ' 5-11' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0 + charde (850)(1:15) = ' 2 5 7 9 10' + chnp1 (850) = 1 + chnar (850) = 16 + chnpy (850) = 11 + chnte (850) = 6 + chnhe (850) = 0 + chperm (850) = 30 + chbirf (850) = 31 + chetat (850) = 780 + chtn2i (850) = 210 + chbiet (780) = 850 +c +c Aretes coupees : 2 5 7 10 12 + chclas (2642) = ' 5-11' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1 + charde (2642)(1:15) = ' 2 5 7 10 12' + chnp1 (2642) = 1 + chnar (2642) = 16 + chnpy (2642) = 11 + chnte (2642) = 6 + chnhe (2642) = 0 + chperm (2642) = 130 + chbirf (2642) = 31 + chetat (2642) = 781 + chtn2i (2642) = 210 + chbiet (781) = 2642 +c +c Aretes coupees : 3 4 6 8 11 + chclas (1196) = ' 5-11' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0 + charde (1196)(1:15) = ' 3 4 6 8 11' + chnp1 (1196) = 1 + chnar (1196) = 16 + chnpy (1196) = 11 + chnte (1196) = 6 + chnhe (1196) = 0 + chperm (1196) = 310 + chbirf (1196) = 31 + chetat (1196) = 782 + chtn2i (1196) = 210 + chbiet (782) = 1196 +c +c Aretes coupees : 3 4 7 8 12 + chclas (2252) = ' 5-11' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1 + charde (2252)(1:15) = ' 3 4 7 8 12' + chnp1 (2252) = 1 + chnar (2252) = 16 + chnpy (2252) = 11 + chnte (2252) = 6 + chnhe (2252) = 0 + chperm (2252) = 121 + chbirf (2252) = 31 + chetat (2252) = 783 + chtn2i (2252) = 210 + chbiet (783) = 2252 +c +c Aretes coupees : 3 6 8 9 11 + chclas (1444) = ' 5-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0 + charde (1444)(1:15) = ' 3 6 8 9 11' + chnp1 (1444) = 1 + chnar (1444) = 16 + chnpy (1444) = 11 + chnte (1444) = 6 + chnhe (1444) = 0 + chperm (1444) = 110 + chbirf (1444) = 31 + chetat (1444) = 784 + chtn2i (1444) = 210 + chbiet (784) = 1444 +c +c Aretes coupees : 3 6 8 11 12 + chclas (3236) = ' 5-11' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1 + charde (3236)(1:15) = ' 3 6 8 11 12' + chnp1 (3236) = 1 + chnar (3236) = 16 + chnpy (3236) = 11 + chnte (3236) = 6 + chnhe (3236) = 0 + chperm (3236) = 210 + chbirf (3236) = 31 + chetat (3236) = 785 + chtn2i (3236) = 210 + chbiet (785) = 3236 +c +c Aretes coupees : 4 7 8 10 12 + chclas (2760) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1 + charde (2760)(1:15) = ' 4 7 8 10 12' + chnp1 (2760) = 1 + chnar (2760) = 16 + chnpy (2760) = 11 + chnte (2760) = 6 + chnhe (2760) = 0 + chperm (2760) = 301 + chbirf (2760) = 31 + chetat (2760) = 786 + chtn2i (2760) = 210 + chbiet (786) = 2760 +c +c Aretes coupees : 4 7 8 11 12 + chclas (3272) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1 + charde (3272)(1:15) = ' 4 7 8 11 12' + chnp1 (3272) = 1 + chnar (3272) = 16 + chnpy (3272) = 11 + chnte (3272) = 6 + chnhe (3272) = 0 + chperm (3272) = 120 + chbirf (3272) = 31 + chetat (3272) = 787 + chtn2i (3272) = 210 + chbiet (787) = 3272 +c +c Aretes coupees : 5 9 10 11 12 + chclas (3856) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1 + charde (3856)(1:15) = ' 5 9 10 11 12' + chnp1 (3856) = 1 + chnar (3856) = 16 + chnpy (3856) = 11 + chnte (3856) = 6 + chnhe (3856) = 0 + chperm (3856) = 201 + chbirf (3856) = 31 + chetat (3856) = 788 + chtn2i (3856) = 210 + chbiet (788) = 3856 +c +c Aretes coupees : 6 9 10 11 12 + chclas (3872) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1 + charde (3872)(1:15) = ' 6 9 10 11 12' + chnp1 (3872) = 1 + chnar (3872) = 16 + chnpy (3872) = 11 + chnte (3872) = 6 + chnhe (3872) = 0 + chperm (3872) = 20 + chbirf (3872) = 31 + chetat (3872) = 789 + chtn2i (3872) = 210 + chbiet (789) = 3872 +c +c Aretes coupees : 7 9 10 11 12 + chclas (3904) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1 + charde (3904)(1:15) = ' 7 9 10 11 12' + chnp1 (3904) = 1 + chnar (3904) = 16 + chnpy (3904) = 11 + chnte (3904) = 6 + chnhe (3904) = 0 + chperm (3904) = 200 + chbirf (3904) = 31 + chetat (3904) = 790 + chtn2i (3904) = 210 + chbiet (790) = 3904 +c +c Aretes coupees : 8 9 10 11 12 + chclas (3968) = ' 5-11' +c Code des aretes coupees : 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1 + charde (3968)(1:15) = ' 8 9 10 11 12' + chnp1 (3968) = 1 + chnar (3968) = 16 + chnpy (3968) = 11 + chnte (3968) = 6 + chnhe (3968) = 0 + chperm (3968) = 21 + chbirf (3968) = 31 + chetat (3968) = 791 + chtn2i (3968) = 210 + chbiet (791) = 3968 +c +c =========================================== +c Classe d'equivalence 5-12 +c +c Aretes coupees : 1 2 3 4 9 + chclas (271) = ' 5-12' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0 + charde (271)(1:15) = ' 1 2 3 4 9' + chnp1 (271) = 1 + chnar (271) = 14 + chnpy (271) = 6 + chnte (271) = 12 + chnhe (271) = 0 + chperm (271) = 0 + chbirf (271) = 271 + chetat (271) = 792 + chtn2i (271) = 210 + chbiet (792) = 271 +c +c Aretes coupees : 1 2 3 4 10 + chclas (527) = ' 5-12' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0 + charde (527)(1:15) = ' 1 2 3 4 10' + chnp1 (527) = 1 + chnar (527) = 14 + chnpy (527) = 6 + chnte (527) = 12 + chnhe (527) = 0 + chperm (527) = 1 + chbirf (527) = 271 + chetat (527) = 793 + chtn2i (527) = 210 + chbiet (793) = 527 +c +c Aretes coupees : 1 2 3 4 11 + chclas (1039) = ' 5-12' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0 + charde (1039)(1:15) = ' 1 2 3 4 11' + chnp1 (1039) = 1 + chnar (1039) = 14 + chnpy (1039) = 6 + chnte (1039) = 12 + chnhe (1039) = 0 + chperm (1039) = 221 + chbirf (1039) = 271 + chetat (1039) = 794 + chtn2i (1039) = 210 + chbiet (794) = 1039 +c +c Aretes coupees : 1 2 3 4 12 + chclas (2063) = ' 5-12' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1 + charde (2063)(1:15) = ' 1 2 3 4 12' + chnp1 (2063) = 1 + chnar (2063) = 14 + chnpy (2063) = 6 + chnte (2063) = 12 + chnhe (2063) = 0 + chperm (2063) = 220 + chbirf (2063) = 271 + chetat (2063) = 795 + chtn2i (2063) = 210 + chbiet (795) = 2063 +c +c Aretes coupees : 1 4 5 6 9 + chclas (313) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0 + charde (313)(1:15) = ' 1 4 5 6 9' + chnp1 (313) = 1 + chnar (313) = 14 + chnpy (313) = 6 + chnte (313) = 12 + chnhe (313) = 0 + chperm (313) = 320 + chbirf (313) = 271 + chetat (313) = 796 + chtn2i (313) = 210 + chbiet (796) = 313 +c +c Aretes coupees : 1 4 7 8 12 + chclas (2249) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1 + charde (2249)(1:15) = ' 1 4 7 8 12' + chnp1 (2249) = 1 + chnar (2249) = 14 + chnpy (2249) = 6 + chnte (2249) = 12 + chnhe (2249) = 0 + chperm (2249) = 300 + chbirf (2249) = 271 + chetat (2249) = 797 + chtn2i (2249) = 210 + chbiet (797) = 2249 +c +c Aretes coupees : 1 5 6 7 9 + chclas (369) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0, 0 + charde (369)(1:15) = ' 1 5 6 7 9' + chnp1 (369) = 1 + chnar (369) = 14 + chnpy (369) = 6 + chnte (369) = 12 + chnhe (369) = 0 + chperm (369) = 101 + chbirf (369) = 271 + chetat (369) = 798 + chtn2i (369) = 210 + chbiet (798) = 369 +c +c Aretes coupees : 1 5 6 8 9 + chclas (433) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0 + charde (433)(1:15) = ' 1 5 6 8 9' + chnp1 (433) = 1 + chnar (433) = 14 + chnpy (433) = 6 + chnte (433) = 12 + chnhe (433) = 0 + chperm (433) = 321 + chbirf (433) = 271 + chetat (433) = 799 + chtn2i (433) = 210 + chbiet (799) = 433 +c +c Aretes coupees : 1 5 6 9 12 + chclas (2353) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1 + charde (2353)(1:15) = ' 1 5 6 9 12' + chnp1 (2353) = 1 + chnar (2353) = 14 + chnpy (2353) = 6 + chnte (2353) = 12 + chnhe (2353) = 0 + chperm (2353) = 100 + chbirf (2353) = 271 + chetat (2353) = 800 + chtn2i (2353) = 210 + chbiet (800) = 2353 +c +c Aretes coupees : 1 9 10 11 12 + chclas (3841) = ' 5-12' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3841)(1:15) = ' 1 9 10 11 12' + chnp1 (3841) = 1 + chnar (3841) = 14 + chnpy (3841) = 6 + chnte (3841) = 12 + chnhe (3841) = 0 + chperm (3841) = 20 + chbirf (3841) = 271 + chetat (3841) = 801 + chtn2i (3841) = 210 + chbiet (801) = 3841 +c +c Aretes coupees : 2 3 5 7 10 + chclas (598) = ' 5-12' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 0 + charde (598)(1:15) = ' 2 3 5 7 10' + chnp1 (598) = 1 + chnar (598) = 14 + chnpy (598) = 6 + chnte (598) = 12 + chnhe (598) = 0 + chperm (598) = 330 + chbirf (598) = 271 + chetat (598) = 802 + chtn2i (598) = 210 + chbiet (802) = 598 +c +c Aretes coupees : 2 3 6 8 11 + chclas (1190) = ' 5-12' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0 + charde (1190)(1:15) = ' 2 3 6 8 11' + chnp1 (1190) = 1 + chnar (1190) = 14 + chnpy (1190) = 6 + chnte (1190) = 12 + chnhe (1190) = 0 + chperm (1190) = 310 + chbirf (1190) = 271 + chetat (1190) = 803 + chtn2i (1190) = 210 + chbiet (803) = 1190 +c +c Aretes coupees : 2 5 6 7 10 + chclas (626) = ' 5-12' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0 + charde (626)(1:15) = ' 2 5 6 7 10' + chnp1 (626) = 1 + chnar (626) = 14 + chnpy (626) = 6 + chnte (626) = 12 + chnhe (626) = 0 + chperm (626) = 30 + chbirf (626) = 271 + chetat (626) = 804 + chtn2i (626) = 210 + chbiet (804) = 626 +c +c Aretes coupees : 2 5 7 8 10 + chclas (722) = ' 5-12' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0 + charde (722)(1:15) = ' 2 5 7 8 10' + chnp1 (722) = 1 + chnar (722) = 14 + chnpy (722) = 6 + chnte (722) = 12 + chnhe (722) = 0 + chperm (722) = 230 + chbirf (722) = 271 + chetat (722) = 805 + chtn2i (722) = 210 + chbiet (805) = 722 +c +c Aretes coupees : 2 5 7 10 11 + chclas (1618) = ' 5-12' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1, 0 + charde (1618)(1:15) = ' 2 5 7 10 11' + chnp1 (1618) = 1 + chnar (1618) = 14 + chnpy (1618) = 6 + chnte (1618) = 12 + chnhe (1618) = 0 + chperm (1618) = 130 + chbirf (1618) = 271 + chetat (1618) = 806 + chtn2i (1618) = 210 + chbiet (806) = 1618 +c +c Aretes coupees : 2 9 10 11 12 + chclas (3842) = ' 5-12' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3842)(1:15) = ' 2 9 10 11 12' + chnp1 (3842) = 1 + chnar (3842) = 14 + chnpy (3842) = 6 + chnte (3842) = 12 + chnhe (3842) = 0 + chperm (3842) = 201 + chbirf (3842) = 271 + chetat (3842) = 807 + chtn2i (3842) = 210 + chbiet (807) = 3842 +c +c Aretes coupees : 3 5 6 8 11 + chclas (1204) = ' 5-12' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0 + charde (1204)(1:15) = ' 3 5 6 8 11' + chnp1 (1204) = 1 + chnar (1204) = 14 + chnpy (1204) = 6 + chnte (1204) = 12 + chnhe (1204) = 0 + chperm (1204) = 10 + chbirf (1204) = 271 + chetat (1204) = 808 + chtn2i (1204) = 210 + chbiet (808) = 1204 +c +c Aretes coupees : 3 6 7 8 11 + chclas (1252) = ' 5-12' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0 + charde (1252)(1:15) = ' 3 6 7 8 11' + chnp1 (1252) = 1 + chnar (1252) = 14 + chnpy (1252) = 6 + chnte (1252) = 12 + chnhe (1252) = 0 + chperm (1252) = 210 + chbirf (1252) = 271 + chetat (1252) = 809 + chtn2i (1252) = 210 + chbiet (809) = 1252 +c +c Aretes coupees : 3 6 8 10 11 + chclas (1700) = ' 5-12' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0 + charde (1700)(1:15) = ' 3 6 8 10 11' + chnp1 (1700) = 1 + chnar (1700) = 14 + chnpy (1700) = 6 + chnte (1700) = 12 + chnhe (1700) = 0 + chperm (1700) = 110 + chbirf (1700) = 271 + chetat (1700) = 810 + chtn2i (1700) = 210 + chbiet (810) = 1700 +c +c Aretes coupees : 3 9 10 11 12 + chclas (3844) = ' 5-12' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3844)(1:15) = ' 3 9 10 11 12' + chnp1 (3844) = 1 + chnar (3844) = 14 + chnpy (3844) = 6 + chnte (3844) = 12 + chnhe (3844) = 0 + chperm (3844) = 21 + chbirf (3844) = 271 + chetat (3844) = 811 + chtn2i (3844) = 210 + chbiet (811) = 3844 +c +c Aretes coupees : 4 5 7 8 12 + chclas (2264) = ' 5-12' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 1 + charde (2264)(1:15) = ' 4 5 7 8 12' + chnp1 (2264) = 1 + chnar (2264) = 14 + chnpy (2264) = 6 + chnte (2264) = 12 + chnhe (2264) = 0 + chperm (2264) = 301 + chbirf (2264) = 271 + chetat (2264) = 812 + chtn2i (2264) = 210 + chbiet (812) = 2264 +c +c Aretes coupees : 4 6 7 8 12 + chclas (2280) = ' 5-12' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 1, 0, 0, 0, 1 + charde (2280)(1:15) = ' 4 6 7 8 12' + chnp1 (2280) = 1 + chnar (2280) = 14 + chnpy (2280) = 6 + chnte (2280) = 12 + chnhe (2280) = 0 + chperm (2280) = 121 + chbirf (2280) = 271 + chetat (2280) = 813 + chtn2i (2280) = 210 + chbiet (813) = 2280 +c +c Aretes coupees : 4 7 8 9 12 + chclas (2504) = ' 5-12' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 1 + charde (2504)(1:15) = ' 4 7 8 9 12' + chnp1 (2504) = 1 + chnar (2504) = 14 + chnpy (2504) = 6 + chnte (2504) = 12 + chnhe (2504) = 0 + chperm (2504) = 120 + chbirf (2504) = 271 + chetat (2504) = 814 + chtn2i (2504) = 210 + chbiet (814) = 2504 +c +c Aretes coupees : 4 9 10 11 12 + chclas (3848) = ' 5-12' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3848)(1:15) = ' 4 9 10 11 12' + chnp1 (3848) = 1 + chnar (3848) = 14 + chnpy (3848) = 6 + chnte (3848) = 12 + chnhe (3848) = 0 + chperm (3848) = 200 + chbirf (3848) = 271 + chetat (3848) = 815 + chtn2i (3848) = 210 + chbiet (815) = 3848 +c +c =========================================== +c Classe d'equivalence 6-00 +c +c Aretes coupees : 1 2 5 8 11 12 + chclas (3219) = ' 6-00' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 + charde (3219)(1:18) = ' 1 2 5 8 11 12' + chnp1 (3219) = 1 + chnar (3219) = 20 + chnpy (3219) = 18 + chnte (3219) = 0 + chnhe (3219) = 0 + chperm (3219) = 0 + chbirf (3219) = 3219 + chetat (3219) = 816 + chtn2i (3219) = 210 + chbiet (816) = 3219 +c +c Aretes coupees : 1 3 6 7 10 12 + chclas (2661) = ' 6-00' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1 + charde (2661)(1:18) = ' 1 3 6 7 10 12' + chnp1 (2661) = 1 + chnar (2661) = 20 + chnpy (2661) = 18 + chnte (2661) = 0 + chnhe (2661) = 0 + chperm (2661) = 200 + chbirf (2661) = 3219 + chetat (2661) = 817 + chtn2i (2661) = 210 + chbiet (817) = 2661 +c +c Aretes coupees : 2 4 6 7 9 11 + chclas (1386) = ' 6-00' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0 + charde (1386)(1:18) = ' 2 4 6 7 9 11' + chnp1 (1386) = 1 + chnar (1386) = 20 + chnpy (1386) = 18 + chnte (1386) = 0 + chnhe (1386) = 0 + chperm (1386) = 300 + chbirf (1386) = 3219 + chetat (1386) = 818 + chtn2i (1386) = 210 + chbiet (818) = 1386 +c +c Aretes coupees : 3 4 5 8 9 10 + chclas (924) = ' 6-00' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0 + charde (924)(1:18) = ' 3 4 5 8 9 10' + chnp1 (924) = 1 + chnar (924) = 20 + chnpy (924) = 18 + chnte (924) = 0 + chnhe (924) = 0 + chperm (924) = 100 + chbirf (924) = 3219 + chetat (924) = 819 + chtn2i (924) = 210 + chbiet (819) = 924 +c +c =========================================== +c Classe d'equivalence 6-01 +c +c Aretes coupees : 1 2 3 4 9 10 + chclas (783) = ' 6-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0 + charde (783)(1:18) = ' 1 2 3 4 9 10' + chnp1 (783) = 1 + chnar (783) = 16 + chnpy (783) = 11 + chnte (783) = 6 + chnhe (783) = 0 + chperm (783) = 0 + chbirf (783) = 783 + chetat (783) = 820 + chtn2i (783) = 210 + chbiet (820) = 783 +c +c Aretes coupees : 1 2 3 4 9 11 + chclas (1295) = ' 6-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 1, 0, 1, 0 + charde (1295)(1:18) = ' 1 2 3 4 9 11' + chnp1 (1295) = 1 + chnar (1295) = 16 + chnpy (1295) = 11 + chnte (1295) = 6 + chnhe (1295) = 0 + chperm (1295) = 221 + chbirf (1295) = 783 + chetat (1295) = 821 + chtn2i (1295) = 210 + chbiet (821) = 1295 +c +c Aretes coupees : 1 2 3 4 10 12 + chclas (2575) = ' 6-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 1, 0, 1 + charde (2575)(1:18) = ' 1 2 3 4 10 12' + chnp1 (2575) = 1 + chnar (2575) = 16 + chnpy (2575) = 11 + chnte (2575) = 6 + chnhe (2575) = 0 + chperm (2575) = 1 + chbirf (2575) = 783 + chetat (2575) = 822 + chtn2i (2575) = 210 + chbiet (822) = 2575 +c +c Aretes coupees : 1 2 3 4 11 12 + chclas (3087) = ' 6-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1 + charde (3087)(1:18) = ' 1 2 3 4 11 12' + chnp1 (3087) = 1 + chnar (3087) = 16 + chnpy (3087) = 11 + chnte (3087) = 6 + chnhe (3087) = 0 + chperm (3087) = 220 + chbirf (3087) = 783 + chetat (3087) = 823 + chtn2i (3087) = 210 + chbiet (823) = 3087 +c +c Aretes coupees : 1 2 9 10 11 12 + chclas (3843) = ' 6-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3843)(1:18) = ' 1 2 9 10 11 12' + chnp1 (3843) = 1 + chnar (3843) = 16 + chnpy (3843) = 11 + chnte (3843) = 6 + chnhe (3843) = 0 + chperm (3843) = 201 + chbirf (3843) = 783 + chetat (3843) = 824 + chtn2i (3843) = 210 + chbiet (824) = 3843 +c +c Aretes coupees : 1 3 9 10 11 12 + chclas (3845) = ' 6-01' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3845)(1:18) = ' 1 3 9 10 11 12' + chnp1 (3845) = 1 + chnar (3845) = 16 + chnpy (3845) = 11 + chnte (3845) = 6 + chnhe (3845) = 0 + chperm (3845) = 20 + chbirf (3845) = 783 + chetat (3845) = 825 + chtn2i (3845) = 210 + chbiet (825) = 3845 +c +c Aretes coupees : 1 4 5 6 7 9 + chclas (377) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 1, 0, 1, 0, 0, 0 + charde (377)(1:18) = ' 1 4 5 6 7 9' + chnp1 (377) = 1 + chnar (377) = 16 + chnpy (377) = 11 + chnte (377) = 6 + chnhe (377) = 0 + chperm (377) = 101 + chbirf (377) = 783 + chetat (377) = 826 + chtn2i (377) = 210 + chbiet (826) = 377 +c +c Aretes coupees : 1 4 5 6 8 9 + chclas (441) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0 + charde (441)(1:18) = ' 1 4 5 6 8 9' + chnp1 (441) = 1 + chnar (441) = 16 + chnpy (441) = 11 + chnte (441) = 6 + chnhe (441) = 0 + chperm (441) = 320 + chbirf (441) = 783 + chetat (441) = 827 + chtn2i (441) = 210 + chbiet (827) = 441 +c +c Aretes coupees : 1 4 5 7 8 12 + chclas (2265) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 1 + charde (2265)(1:18) = ' 1 4 5 7 8 12' + chnp1 (2265) = 1 + chnar (2265) = 16 + chnpy (2265) = 11 + chnte (2265) = 6 + chnhe (2265) = 0 + chperm (2265) = 300 + chbirf (2265) = 783 + chetat (2265) = 828 + chtn2i (2265) = 210 + chbiet (828) = 2265 +c +c Aretes coupees : 1 4 6 7 8 12 + chclas (2281) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 1, 0, 0, 0, 1 + charde (2281)(1:18) = ' 1 4 6 7 8 12' + chnp1 (2281) = 1 + chnar (2281) = 16 + chnpy (2281) = 11 + chnte (2281) = 6 + chnhe (2281) = 0 + chperm (2281) = 121 + chbirf (2281) = 783 + chetat (2281) = 829 + chtn2i (2281) = 210 + chbiet (829) = 2281 +c +c Aretes coupees : 1 5 6 7 9 12 + chclas (2417) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0, 1 + charde (2417)(1:18) = ' 1 5 6 7 9 12' + chnp1 (2417) = 1 + chnar (2417) = 16 + chnpy (2417) = 11 + chnte (2417) = 6 + chnhe (2417) = 0 + chperm (2417) = 100 + chbirf (2417) = 783 + chetat (2417) = 830 + chtn2i (2417) = 210 + chbiet (830) = 2417 +c +c Aretes coupees : 1 5 6 8 9 12 + chclas (2481) = ' 6-01' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1 + charde (2481)(1:18) = ' 1 5 6 8 9 12' + chnp1 (2481) = 1 + chnar (2481) = 16 + chnpy (2481) = 11 + chnte (2481) = 6 + chnhe (2481) = 0 + chperm (2481) = 321 + chbirf (2481) = 783 + chetat (2481) = 831 + chtn2i (2481) = 210 + chbiet (831) = 2481 +c +c Aretes coupees : 2 3 5 6 7 10 + chclas (630) = ' 6-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 1, 0, 0, 1, 0, 0 + charde (630)(1:18) = ' 2 3 5 6 7 10' + chnp1 (630) = 1 + chnar (630) = 16 + chnpy (630) = 11 + chnte (630) = 6 + chnhe (630) = 0 + chperm (630) = 330 + chbirf (630) = 783 + chetat (630) = 832 + chtn2i (630) = 210 + chbiet (832) = 630 +c +c Aretes coupees : 2 3 5 6 8 11 + chclas (1206) = ' 6-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0 + charde (1206)(1:18) = ' 2 3 5 6 8 11' + chnp1 (1206) = 1 + chnar (1206) = 16 + chnpy (1206) = 11 + chnte (1206) = 6 + chnhe (1206) = 0 + chperm (1206) = 10 + chbirf (1206) = 783 + chetat (1206) = 833 + chtn2i (1206) = 210 + chbiet (833) = 1206 +c +c Aretes coupees : 2 3 5 7 8 10 + chclas (726) = ' 6-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0 + charde (726)(1:18) = ' 2 3 5 7 8 10' + chnp1 (726) = 1 + chnar (726) = 16 + chnpy (726) = 11 + chnte (726) = 6 + chnhe (726) = 0 + chperm (726) = 230 + chbirf (726) = 783 + chetat (726) = 834 + chtn2i (726) = 210 + chbiet (834) = 726 +c +c Aretes coupees : 2 3 6 7 8 11 + chclas (1254) = ' 6-01' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0 + charde (1254)(1:18) = ' 2 3 6 7 8 11' + chnp1 (1254) = 1 + chnar (1254) = 16 + chnpy (1254) = 11 + chnte (1254) = 6 + chnhe (1254) = 0 + chperm (1254) = 310 + chbirf (1254) = 783 + chetat (1254) = 835 + chtn2i (1254) = 210 + chbiet (835) = 1254 +c +c Aretes coupees : 2 4 9 10 11 12 + chclas (3850) = ' 6-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3850)(1:18) = ' 2 4 9 10 11 12' + chnp1 (3850) = 1 + chnar (3850) = 16 + chnpy (3850) = 11 + chnte (3850) = 6 + chnhe (3850) = 0 + chperm (3850) = 200 + chbirf (3850) = 783 + chetat (3850) = 836 + chtn2i (3850) = 210 + chbiet (836) = 3850 +c +c Aretes coupees : 2 5 6 7 10 11 + chclas (1650) = ' 6-01' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0 + charde (1650)(1:18) = ' 2 5 6 7 10 11' + chnp1 (1650) = 1 + chnar (1650) = 16 + chnpy (1650) = 11 + chnte (1650) = 6 + chnhe (1650) = 0 + chperm (1650) = 30 + chbirf (1650) = 783 + chetat (1650) = 837 + chtn2i (1650) = 210 + chbiet (837) = 1650 +c +c Aretes coupees : 2 5 7 8 10 11 + chclas (1746) = ' 6-01' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 0 + charde (1746)(1:18) = ' 2 5 7 8 10 11' + chnp1 (1746) = 1 + chnar (1746) = 16 + chnpy (1746) = 11 + chnte (1746) = 6 + chnhe (1746) = 0 + chperm (1746) = 130 + chbirf (1746) = 783 + chetat (1746) = 838 + chtn2i (1746) = 210 + chbiet (838) = 1746 +c +c Aretes coupees : 3 4 9 10 11 12 + chclas (3852) = ' 6-01' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3852)(1:18) = ' 3 4 9 10 11 12' + chnp1 (3852) = 1 + chnar (3852) = 16 + chnpy (3852) = 11 + chnte (3852) = 6 + chnhe (3852) = 0 + chperm (3852) = 21 + chbirf (3852) = 783 + chetat (3852) = 839 + chtn2i (3852) = 210 + chbiet (839) = 3852 +c +c Aretes coupees : 3 5 6 8 10 11 + chclas (1716) = ' 6-01' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 1, 0, 1, 1, 0 + charde (1716)(1:18) = ' 3 5 6 8 10 11' + chnp1 (1716) = 1 + chnar (1716) = 16 + chnpy (1716) = 11 + chnte (1716) = 6 + chnhe (1716) = 0 + chperm (1716) = 110 + chbirf (1716) = 783 + chetat (1716) = 840 + chtn2i (1716) = 210 + chbiet (840) = 1716 +c +c Aretes coupees : 3 6 7 8 10 11 + chclas (1764) = ' 6-01' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0 + charde (1764)(1:18) = ' 3 6 7 8 10 11' + chnp1 (1764) = 1 + chnar (1764) = 16 + chnpy (1764) = 11 + chnte (1764) = 6 + chnhe (1764) = 0 + chperm (1764) = 210 + chbirf (1764) = 783 + chetat (1764) = 841 + chtn2i (1764) = 210 + chbiet (841) = 1764 +c +c Aretes coupees : 4 5 7 8 9 12 + chclas (2520) = ' 6-01' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 1 + charde (2520)(1:18) = ' 4 5 7 8 9 12' + chnp1 (2520) = 1 + chnar (2520) = 16 + chnpy (2520) = 11 + chnte (2520) = 6 + chnhe (2520) = 0 + chperm (2520) = 301 + chbirf (2520) = 783 + chetat (2520) = 842 + chtn2i (2520) = 210 + chbiet (842) = 2520 +c +c Aretes coupees : 4 6 7 8 9 12 + chclas (2536) = ' 6-01' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, 1 + charde (2536)(1:18) = ' 4 6 7 8 9 12' + chnp1 (2536) = 1 + chnar (2536) = 16 + chnpy (2536) = 11 + chnte (2536) = 6 + chnhe (2536) = 0 + chperm (2536) = 120 + chbirf (2536) = 783 + chetat (2536) = 843 + chtn2i (2536) = 210 + chbiet (843) = 2536 +c +c =========================================== +c Classe d'equivalence 6-02 +c +c Aretes coupees : 1 2 3 4 9 12 + chclas (2319) = ' 6-02' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1 + charde (2319)(1:18) = ' 1 2 3 4 9 12' + chnp1 (2319) = 1 + chnar (2319) = 15 + chnpy (2319) = 10 + chnte (2319) = 6 + chnhe (2319) = 0 + chperm (2319) = 0 + chbirf (2319) = 2319 + chetat (2319) = 844 + chtn2i (2319) = 210 + chbiet (844) = 2319 +c +c Aretes coupees : 1 2 3 4 10 11 + chclas (1551) = ' 6-02' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 0 + charde (1551)(1:18) = ' 1 2 3 4 10 11' + chnp1 (1551) = 1 + chnar (1551) = 15 + chnpy (1551) = 10 + chnte (1551) = 6 + chnhe (1551) = 0 + chperm (1551) = 1 + chbirf (1551) = 2319 + chetat (1551) = 845 + chtn2i (1551) = 210 + chbiet (845) = 1551 +c +c Aretes coupees : 1 4 5 6 9 12 + chclas (2361) = ' 6-02' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 1 + charde (2361)(1:18) = ' 1 4 5 6 9 12' + chnp1 (2361) = 1 + chnar (2361) = 15 + chnpy (2361) = 10 + chnte (2361) = 6 + chnhe (2361) = 0 + chperm (2361) = 100 + chbirf (2361) = 2319 + chetat (2361) = 846 + chtn2i (2361) = 210 + chbiet (846) = 2361 +c +c Aretes coupees : 1 4 7 8 9 12 + chclas (2505) = ' 6-02' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 1 + charde (2505)(1:18) = ' 1 4 7 8 9 12' + chnp1 (2505) = 1 + chnar (2505) = 15 + chnpy (2505) = 10 + chnte (2505) = 6 + chnhe (2505) = 0 + chperm (2505) = 300 + chbirf (2505) = 2319 + chetat (2505) = 847 + chtn2i (2505) = 210 + chbiet (847) = 2505 +c +c Aretes coupees : 1 4 9 10 11 12 + chclas (3849) = ' 6-02' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3849)(1:18) = ' 1 4 9 10 11 12' + chnp1 (3849) = 1 + chnar (3849) = 15 + chnpy (3849) = 10 + chnte (3849) = 6 + chnhe (3849) = 0 + chperm (3849) = 200 + chbirf (3849) = 2319 + chetat (3849) = 848 + chtn2i (3849) = 210 + chbiet (848) = 3849 +c +c Aretes coupees : 1 5 6 7 8 9 + chclas (497) = ' 6-02' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0 + charde (497)(1:18) = ' 1 5 6 7 8 9' + chnp1 (497) = 1 + chnar (497) = 15 + chnpy (497) = 10 + chnte (497) = 6 + chnhe (497) = 0 + chperm (497) = 101 + chbirf (497) = 2319 + chetat (497) = 849 + chtn2i (497) = 210 + chbiet (849) = 497 +c +c Aretes coupees : 2 3 5 7 10 11 + chclas (1622) = ' 6-02' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0 + charde (1622)(1:18) = ' 2 3 5 7 10 11' + chnp1 (1622) = 1 + chnar (1622) = 15 + chnpy (1622) = 10 + chnte (1622) = 6 + chnhe (1622) = 0 + chperm (1622) = 130 + chbirf (1622) = 2319 + chetat (1622) = 850 + chtn2i (1622) = 210 + chbiet (850) = 1622 +c +c Aretes coupees : 2 3 6 8 10 11 + chclas (1702) = ' 6-02' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0 + charde (1702)(1:18) = ' 2 3 6 8 10 11' + chnp1 (1702) = 1 + chnar (1702) = 15 + chnpy (1702) = 10 + chnte (1702) = 6 + chnhe (1702) = 0 + chperm (1702) = 110 + chbirf (1702) = 2319 + chetat (1702) = 851 + chtn2i (1702) = 210 + chbiet (851) = 1702 +c +c Aretes coupees : 2 3 9 10 11 12 + chclas (3846) = ' 6-02' +c Code des aretes coupees : 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3846)(1:18) = ' 2 3 9 10 11 12' + chnp1 (3846) = 1 + chnar (3846) = 15 + chnpy (3846) = 10 + chnte (3846) = 6 + chnhe (3846) = 0 + chperm (3846) = 201 + chbirf (3846) = 2319 + chetat (3846) = 852 + chtn2i (3846) = 210 + chbiet (852) = 3846 +c +c Aretes coupees : 2 5 6 7 8 10 + chclas (754) = ' 6-02' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 1, 1, 0, 1, 0, 0 + charde (754)(1:18) = ' 2 5 6 7 8 10' + chnp1 (754) = 1 + chnar (754) = 15 + chnpy (754) = 10 + chnte (754) = 6 + chnhe (754) = 0 + chperm (754) = 30 + chbirf (754) = 2319 + chetat (754) = 853 + chtn2i (754) = 210 + chbiet (853) = 754 +c +c Aretes coupees : 3 5 6 7 8 11 + chclas (1268) = ' 6-02' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, 1, 0 + charde (1268)(1:18) = ' 3 5 6 7 8 11' + chnp1 (1268) = 1 + chnar (1268) = 15 + chnpy (1268) = 10 + chnte (1268) = 6 + chnhe (1268) = 0 + chperm (1268) = 10 + chbirf (1268) = 2319 + chetat (1268) = 854 + chtn2i (1268) = 210 + chbiet (854) = 1268 +c +c Aretes coupees : 4 5 6 7 8 12 + chclas (2296) = ' 6-02' +c Code des aretes coupees : 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 1 + charde (2296)(1:18) = ' 4 5 6 7 8 12' + chnp1 (2296) = 1 + chnar (2296) = 15 + chnpy (2296) = 10 + chnte (2296) = 6 + chnhe (2296) = 0 + chperm (2296) = 301 + chbirf (2296) = 2319 + chetat (2296) = 855 + chtn2i (2296) = 210 + chbiet (855) = 2296 +c +c =========================================== +c Classe d'equivalence 6-03 +c +c Aretes coupees : 1 2 3 4 5 11 + chclas (1055) = ' 6-03' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 1, 0 + charde (1055)(1:18) = ' 1 2 3 4 5 11' + chnp1 (1055) = 1 + chnar (1055) = 17 + chnpy (1055) = 12 + chnte (1055) = 6 + chnhe (1055) = 0 + chperm (1055) = 0 + chbirf (1055) = 1055 + chetat (1055) = 856 + chtn2i (1055) = 210 + chbiet (856) = 1055 +c +c Aretes coupees : 1 2 3 4 6 12 + chclas (2095) = ' 6-03' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1 + charde (2095)(1:18) = ' 1 2 3 4 6 12' + chnp1 (2095) = 1 + chnar (2095) = 17 + chnpy (2095) = 12 + chnte (2095) = 6 + chnhe (2095) = 0 + chperm (2095) = 221 + chbirf (2095) = 1055 + chetat (2095) = 857 + chtn2i (2095) = 210 + chbiet (857) = 2095 +c +c Aretes coupees : 1 2 3 4 7 9 + chclas (335) = ' 6-03' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 0, 0 + charde (335)(1:18) = ' 1 2 3 4 7 9' + chnp1 (335) = 1 + chnar (335) = 17 + chnpy (335) = 12 + chnte (335) = 6 + chnhe (335) = 0 + chperm (335) = 1 + chbirf (335) = 1055 + chetat (335) = 858 + chtn2i (335) = 210 + chbiet (858) = 335 +c +c Aretes coupees : 1 2 3 4 8 10 + chclas (655) = ' 6-03' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 0, 0 + charde (655)(1:18) = ' 1 2 3 4 8 10' + chnp1 (655) = 1 + chnar (655) = 17 + chnpy (655) = 12 + chnte (655) = 6 + chnhe (655) = 0 + chperm (655) = 220 + chbirf (655) = 1055 + chetat (655) = 859 + chtn2i (655) = 210 + chbiet (859) = 655 +c +c Aretes coupees : 1 2 5 6 9 12 + chclas (2355) = ' 6-03' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1 + charde (2355)(1:18) = ' 1 2 5 6 9 12' + chnp1 (2355) = 1 + chnar (2355) = 17 + chnpy (2355) = 12 + chnte (2355) = 6 + chnhe (2355) = 0 + chperm (2355) = 101 + chbirf (2355) = 1055 + chetat (2355) = 860 + chtn2i (2355) = 210 + chbiet (860) = 2355 +c +c Aretes coupees : 1 2 5 7 8 10 + chclas (723) = ' 6-03' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0 + charde (723)(1:18) = ' 1 2 5 7 8 10' + chnp1 (723) = 1 + chnar (723) = 17 + chnpy (723) = 12 + chnte (723) = 6 + chnhe (723) = 0 + chperm (723) = 330 + chbirf (723) = 1055 + chetat (723) = 861 + chtn2i (723) = 210 + chbiet (861) = 723 +c +c Aretes coupees : 1 3 5 6 7 9 + chclas (373) = ' 6-03' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0 + charde (373)(1:18) = ' 1 3 5 6 7 9' + chnp1 (373) = 1 + chnar (373) = 17 + chnpy (373) = 12 + chnte (373) = 6 + chnhe (373) = 0 + chperm (373) = 320 + chbirf (373) = 1055 + chetat (373) = 862 + chtn2i (373) = 210 + chbiet (862) = 373 +c +c Aretes coupees : 1 3 6 8 10 11 + chclas (1701) = ' 6-03' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0 + charde (1701)(1:18) = ' 1 3 6 8 10 11' + chnp1 (1701) = 1 + chnar (1701) = 17 + chnpy (1701) = 12 + chnte (1701) = 6 + chnhe (1701) = 0 + chperm (1701) = 10 + chbirf (1701) = 1055 + chetat (1701) = 863 + chtn2i (1701) = 210 + chbiet (863) = 1701 +c +c Aretes coupees : 1 4 5 6 9 11 + chclas (1337) = ' 6-03' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0 + charde (1337)(1:18) = ' 1 4 5 6 9 11' + chnp1 (1337) = 1 + chnar (1337) = 17 + chnpy (1337) = 12 + chnte (1337) = 6 + chnhe (1337) = 0 + chperm (1337) = 321 + chbirf (1337) = 1055 + chetat (1337) = 864 + chtn2i (1337) = 210 + chbiet (864) = 1337 +c +c Aretes coupees : 1 4 7 8 10 12 + chclas (2761) = ' 6-03' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1 + charde (2761)(1:18) = ' 1 4 7 8 10 12' + chnp1 (2761) = 1 + chnar (2761) = 17 + chnpy (2761) = 12 + chnte (2761) = 6 + chnhe (2761) = 0 + chperm (2761) = 301 + chbirf (2761) = 1055 + chetat (2761) = 865 + chtn2i (2761) = 210 + chbiet (865) = 2761 +c +c Aretes coupees : 1 5 6 8 9 10 + chclas (945) = ' 6-03' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 0 + charde (945)(1:18) = ' 1 5 6 8 9 10' + chnp1 (945) = 1 + chnar (945) = 17 + chnpy (945) = 12 + chnte (945) = 6 + chnhe (945) = 0 + chperm (945) = 100 + chbirf (945) = 1055 + chetat (945) = 866 + chtn2i (945) = 210 + chbiet (866) = 945 +c +c Aretes coupees : 1 8 9 10 11 12 + chclas (3969) = ' 6-03' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1 + charde (3969)(1:18) = ' 1 8 9 10 11 12' + chnp1 (3969) = 1 + chnar (3969) = 17 + chnpy (3969) = 12 + chnte (3969) = 6 + chnhe (3969) = 0 + chperm (3969) = 21 + chbirf (3969) = 1055 + chetat (3969) = 867 + chtn2i (3969) = 210 + chbiet (867) = 3969 +c +c Aretes coupees : 2 3 5 7 9 10 + chclas (854) = ' 6-03' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0, 0 + charde (854)(1:18) = ' 2 3 5 7 9 10' + chnp1 (854) = 1 + chnar (854) = 17 + chnpy (854) = 12 + chnte (854) = 6 + chnhe (854) = 0 + chperm (854) = 30 + chbirf (854) = 1055 + chetat (854) = 868 + chtn2i (854) = 210 + chbiet (868) = 854 +c +c Aretes coupees : 2 3 6 8 11 12 + chclas (3238) = ' 6-03' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1 + charde (3238)(1:18) = ' 2 3 6 8 11 12' + chnp1 (3238) = 1 + chnar (3238) = 17 + chnpy (3238) = 12 + chnte (3238) = 6 + chnhe (3238) = 0 + chperm (3238) = 210 + chbirf (3238) = 1055 + chetat (3238) = 869 + chtn2i (3238) = 210 + chbiet (869) = 3238 +c +c Aretes coupees : 2 4 5 7 10 11 + chclas (1626) = ' 6-03' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0 + charde (1626)(1:18) = ' 2 4 5 7 10 11' + chnp1 (1626) = 1 + chnar (1626) = 17 + chnpy (1626) = 12 + chnte (1626) = 6 + chnhe (1626) = 0 + chperm (1626) = 230 + chbirf (1626) = 1055 + chetat (1626) = 870 + chtn2i (1626) = 210 + chbiet (870) = 1626 +c +c Aretes coupees : 2 4 6 7 8 12 + chclas (2282) = ' 6-03' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 1, 0, 0, 0, 1 + charde (2282)(1:18) = ' 2 4 6 7 8 12' + chnp1 (2282) = 1 + chnar (2282) = 17 + chnpy (2282) = 12 + chnte (2282) = 6 + chnhe (2282) = 0 + chperm (2282) = 300 + chbirf (2282) = 1055 + chetat (2282) = 871 + chtn2i (2282) = 210 + chbiet (871) = 2282 +c +c Aretes coupees : 2 5 6 7 10 12 + chclas (2674) = ' 6-03' +c Code des aretes coupees : 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1 + charde (2674)(1:18) = ' 2 5 6 7 10 12' + chnp1 (2674) = 1 + chnar (2674) = 17 + chnpy (2674) = 12 + chnte (2674) = 6 + chnhe (2674) = 0 + chperm (2674) = 130 + chbirf (2674) = 1055 + chetat (2674) = 872 + chtn2i (2674) = 210 + chbiet (872) = 2674 +c +c Aretes coupees : 2 6 9 10 11 12 + chclas (3874) = ' 6-03' +c Code des aretes coupees : 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1 + charde (3874)(1:18) = ' 2 6 9 10 11 12' + chnp1 (3874) = 1 + chnar (3874) = 17 + chnpy (3874) = 12 + chnte (3874) = 6 + chnhe (3874) = 0 + chperm (3874) = 20 + chbirf (3874) = 1055 + chetat (3874) = 873 + chtn2i (3874) = 210 + chbiet (873) = 3874 +c +c Aretes coupees : 3 4 5 6 8 11 + chclas (1212) = ' 6-03' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 1, 0, 0, 1, 0 + charde (1212)(1:18) = ' 3 4 5 6 8 11' + chnp1 (1212) = 1 + chnar (1212) = 17 + chnpy (1212) = 12 + chnte (1212) = 6 + chnhe (1212) = 0 + chperm (1212) = 310 + chbirf (1212) = 1055 + chetat (1212) = 874 + chtn2i (1212) = 210 + chbiet (874) = 1212 +c +c Aretes coupees : 3 4 7 8 9 12 + chclas (2508) = ' 6-03' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1 + charde (2508)(1:18) = ' 3 4 7 8 9 12' + chnp1 (2508) = 1 + chnar (2508) = 17 + chnpy (2508) = 12 + chnte (2508) = 6 + chnhe (2508) = 0 + chperm (2508) = 121 + chbirf (2508) = 1055 + chetat (2508) = 875 + chtn2i (2508) = 210 + chbiet (875) = 2508 +c +c Aretes coupees : 3 6 7 8 9 11 + chclas (1508) = ' 6-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 1, 1, 1, 0, 1, 0 + charde (1508)(1:18) = ' 3 6 7 8 9 11' + chnp1 (1508) = 1 + chnar (1508) = 17 + chnpy (1508) = 12 + chnte (1508) = 6 + chnhe (1508) = 0 + chperm (1508) = 110 + chbirf (1508) = 1055 + chetat (1508) = 876 + chtn2i (1508) = 210 + chbiet (876) = 1508 +c +c Aretes coupees : 3 7 9 10 11 12 + chclas (3908) = ' 6-03' +c Code des aretes coupees : 0, 0, 1, 0, 0, 0, 1, 0, 1, 1, 1, 1 + charde (3908)(1:18) = ' 3 7 9 10 11 12' + chnp1 (3908) = 1 + chnar (3908) = 17 + chnpy (3908) = 12 + chnte (3908) = 6 + chnhe (3908) = 0 + chperm (3908) = 200 + chbirf (3908) = 1055 + chetat (3908) = 877 + chtn2i (3908) = 210 + chbiet (877) = 3908 +c +c Aretes coupees : 4 5 7 8 11 12 + chclas (3288) = ' 6-03' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1 + charde (3288)(1:18) = ' 4 5 7 8 11 12' + chnp1 (3288) = 1 + chnar (3288) = 17 + chnpy (3288) = 12 + chnte (3288) = 6 + chnhe (3288) = 0 + chperm (3288) = 120 + chbirf (3288) = 1055 + chetat (3288) = 878 + chtn2i (3288) = 210 + chbiet (878) = 3288 +c +c Aretes coupees : 4 5 9 10 11 12 + chclas (3864) = ' 6-03' +c Code des aretes coupees : 0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 1 + charde (3864)(1:18) = ' 4 5 9 10 11 12' + chnp1 (3864) = 1 + chnar (3864) = 17 + chnpy (3864) = 12 + chnte (3864) = 6 + chnhe (3864) = 0 + chperm (3864) = 201 + chbirf (3864) = 1055 + chetat (3864) = 879 + chtn2i (3864) = 210 + chbiet (879) = 3864 +c +c =========================================== +c Classe d'equivalence 6-04 +c +c Aretes coupees : 1 2 3 4 5 12 + chclas (2079) = ' 6-04' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1 + charde (2079)(1:18) = ' 1 2 3 4 5 12' + chnp1 (2079) = 1 + chnar (2079) = 17 + chnpy (2079) = 12 + chnte (2079) = 6 + chnhe (2079) = 0 + chperm (2079) = 0 + chbirf (2079) = 2079 + chetat (2079) = 880 + chtn2i (2079) = 210 + chbiet (880) = 2079 +c +c Aretes coupees : 1 2 3 4 6 10 + chclas (559) = ' 6-04' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 0, 0, 1, 0, 0 + charde (559)(1:18) = ' 1 2 3 4 6 10' + chnp1 (559) = 1 + chnar (559) = 17 + chnpy (559) = 12 + chnte (559) = 6 + chnhe (559) = 0 + chperm (559) = 221 + chbirf (559) = 2079 + chetat (559) = 881 + chtn2i (559) = 210 + chbiet (881) = 559 +c +c Aretes coupees : 1 2 3 4 7 11 + chclas (1103) = ' 6-04' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0 + charde (1103)(1:18) = ' 1 2 3 4 7 11' + chnp1 (1103) = 1 + chnar (1103) = 17 + chnpy (1103) = 12 + chnte (1103) = 6 + chnhe (1103) = 0 + chperm (1103) = 1 + chbirf (1103) = 2079 + chetat (1103) = 882 + chtn2i (1103) = 210 + chbiet (882) = 1103 +c +c Aretes coupees : 1 2 3 4 8 9 + chclas (399) = ' 6-04' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0 + charde (399)(1:18) = ' 1 2 3 4 8 9' + chnp1 (399) = 1 + chnar (399) = 17 + chnpy (399) = 12 + chnte (399) = 6 + chnhe (399) = 0 + chperm (399) = 220 + chbirf (399) = 2079 + chetat (399) = 883 + chtn2i (399) = 210 + chbiet (883) = 399 +c +c Aretes coupees : 1 2 5 6 8 9 + chclas (435) = ' 6-04' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0 + charde (435)(1:18) = ' 1 2 5 6 8 9' + chnp1 (435) = 1 + chnar (435) = 17 + chnpy (435) = 12 + chnte (435) = 6 + chnhe (435) = 0 + chperm (435) = 101 + chbirf (435) = 2079 + chetat (435) = 884 + chtn2i (435) = 210 + chbiet (884) = 435 +c +c Aretes coupees : 1 2 5 7 10 11 + chclas (1619) = ' 6-04' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1, 0 + charde (1619)(1:18) = ' 1 2 5 7 10 11' + chnp1 (1619) = 1 + chnar (1619) = 17 + chnpy (1619) = 12 + chnte (1619) = 6 + chnhe (1619) = 0 + chperm (1619) = 330 + chbirf (1619) = 2079 + chetat (1619) = 885 + chtn2i (1619) = 210 + chbiet (885) = 1619 +c +c Aretes coupees : 1 3 5 6 9 12 + chclas (2357) = ' 6-04' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1 + charde (2357)(1:18) = ' 1 3 5 6 9 12' + chnp1 (2357) = 1 + chnar (2357) = 17 + chnpy (2357) = 12 + chnte (2357) = 6 + chnhe (2357) = 0 + chperm (2357) = 320 + chbirf (2357) = 2079 + chetat (2357) = 886 + chtn2i (2357) = 210 + chbiet (886) = 2357 +c +c Aretes coupees : 1 3 6 7 8 11 + chclas (1253) = ' 6-04' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0 + charde (1253)(1:18) = ' 1 3 6 7 8 11' + chnp1 (1253) = 1 + chnar (1253) = 17 + chnpy (1253) = 12 + chnte (1253) = 6 + chnhe (1253) = 0 + chperm (1253) = 10 + chbirf (1253) = 2079 + chetat (1253) = 887 + chtn2i (1253) = 210 + chbiet (887) = 1253 +c +c Aretes coupees : 1 4 5 6 9 10 + chclas (825) = ' 6-04' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0 + charde (825)(1:18) = ' 1 4 5 6 9 10' + chnp1 (825) = 1 + chnar (825) = 17 + chnpy (825) = 12 + chnte (825) = 6 + chnhe (825) = 0 + chperm (825) = 100 + chbirf (825) = 2079 + chetat (825) = 888 + chtn2i (825) = 210 + chbiet (888) = 825 +c +c Aretes coupees : 1 4 7 8 11 12 + chclas (3273) = ' 6-04' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1 + charde (3273)(1:18) = ' 1 4 7 8 11 12' + chnp1 (3273) = 1 + chnar (3273) = 17 + chnpy (3273) = 12 + chnte (3273) = 6 + chnhe (3273) = 0 + chperm (3273) = 120 + chbirf (3273) = 2079 + chetat (3273) = 889 + chtn2i (3273) = 210 + chbiet (889) = 3273 +c +c Aretes coupees : 1 5 6 7 9 11 + chclas (1393) = ' 6-04' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0 + charde (1393)(1:18) = ' 1 5 6 7 9 11' + chnp1 (1393) = 1 + chnar (1393) = 17 + chnpy (1393) = 12 + chnte (1393) = 6 + chnhe (1393) = 0 + chperm (1393) = 321 + chbirf (1393) = 2079 + chetat (1393) = 890 + chtn2i (1393) = 210 + chbiet (890) = 1393 +c +c Aretes coupees : 1 7 9 10 11 12 + chclas (3905) = ' 6-04' +c Code des aretes coupees : 1, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1 + charde (3905)(1:18) = ' 1 7 9 10 11 12' + chnp1 (3905) = 1 + chnar (3905) = 17 + chnpy (3905) = 12 + chnte (3905) = 6 + chnhe (3905) = 0 + chperm (3905) = 200 + chbirf (3905) = 2079 + chetat (3905) = 891 + chtn2i (3905) = 210 + chbiet (891) = 3905 +c +c Aretes coupees : 2 3 5 7 10 12 + chclas (2646) = ' 6-04' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1 + charde (2646)(1:18) = ' 2 3 5 7 10 12' + chnp1 (2646) = 1 + chnar (2646) = 17 + chnpy (2646) = 12 + chnte (2646) = 6 + chnhe (2646) = 0 + chperm (2646) = 130 + chbirf (2646) = 2079 + chetat (2646) = 892 + chtn2i (2646) = 210 + chbiet (892) = 2646 +c +c Aretes coupees : 2 3 6 8 9 11 + chclas (1446) = ' 6-04' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0 + charde (1446)(1:18) = ' 2 3 6 8 9 11' + chnp1 (1446) = 1 + chnar (1446) = 17 + chnpy (1446) = 12 + chnte (1446) = 6 + chnhe (1446) = 0 + chperm (1446) = 110 + chbirf (1446) = 2079 + chetat (1446) = 893 + chtn2i (1446) = 210 + chbiet (893) = 1446 +c +c Aretes coupees : 2 4 5 6 7 10 + chclas (634) = ' 6-04' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 1, 0, 0, 1, 0, 0 + charde (634)(1:18) = ' 2 4 5 6 7 10' + chnp1 (634) = 1 + chnar (634) = 17 + chnpy (634) = 12 + chnte (634) = 6 + chnhe (634) = 0 + chperm (634) = 230 + chbirf (634) = 2079 + chetat (634) = 894 + chtn2i (634) = 210 + chbiet (894) = 634 +c +c Aretes coupees : 2 4 7 8 9 12 + chclas (2506) = ' 6-04' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 1, 1, 0, 0, 1 + charde (2506)(1:18) = ' 2 4 7 8 9 12' + chnp1 (2506) = 1 + chnar (2506) = 17 + chnpy (2506) = 12 + chnte (2506) = 6 + chnhe (2506) = 0 + chperm (2506) = 300 + chbirf (2506) = 2079 + chetat (2506) = 895 + chtn2i (2506) = 210 + chbiet (895) = 2506 +c +c Aretes coupees : 2 5 7 8 9 10 + chclas (978) = ' 6-04' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0 + charde (978)(1:18) = ' 2 5 7 8 9 10' + chnp1 (978) = 1 + chnar (978) = 17 + chnpy (978) = 12 + chnte (978) = 6 + chnhe (978) = 0 + chperm (978) = 30 + chbirf (978) = 2079 + chetat (978) = 896 + chtn2i (978) = 210 + chbiet (896) = 978 +c +c Aretes coupees : 2 8 9 10 11 12 + chclas (3970) = ' 6-04' +c Code des aretes coupees : 0, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1 + charde (3970)(1:18) = ' 2 8 9 10 11 12' + chnp1 (3970) = 1 + chnar (3970) = 17 + chnpy (3970) = 12 + chnte (3970) = 6 + chnhe (3970) = 0 + chperm (3970) = 21 + chbirf (3970) = 2079 + chetat (3970) = 897 + chtn2i (3970) = 210 + chbiet (897) = 3970 +c +c Aretes coupees : 3 4 5 7 8 12 + chclas (2268) = ' 6-04' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 1 + charde (2268)(1:18) = ' 3 4 5 7 8 12' + chnp1 (2268) = 1 + chnar (2268) = 17 + chnpy (2268) = 12 + chnte (2268) = 6 + chnhe (2268) = 0 + chperm (2268) = 121 + chbirf (2268) = 2079 + chetat (2268) = 898 + chtn2i (2268) = 210 + chbiet (898) = 2268 +c +c Aretes coupees : 3 4 6 8 10 11 + chclas (1708) = ' 6-04' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0 + charde (1708)(1:18) = ' 3 4 6 8 10 11' + chnp1 (1708) = 1 + chnar (1708) = 17 + chnpy (1708) = 12 + chnte (1708) = 6 + chnhe (1708) = 0 + chperm (1708) = 310 + chbirf (1708) = 2079 + chetat (1708) = 899 + chtn2i (1708) = 210 + chbiet (899) = 1708 +c +c Aretes coupees : 3 5 6 8 11 12 + chclas (3252) = ' 6-04' +c Code des aretes coupees : 0, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 1 + charde (3252)(1:18) = ' 3 5 6 8 11 12' + chnp1 (3252) = 1 + chnar (3252) = 17 + chnpy (3252) = 12 + chnte (3252) = 6 + chnhe (3252) = 0 + chperm (3252) = 210 + chbirf (3252) = 2079 + chetat (3252) = 900 + chtn2i (3252) = 210 + chbiet (900) = 3252 +c +c Aretes coupees : 3 5 9 10 11 12 + chclas (3860) = ' 6-04' +c Code des aretes coupees : 0, 0, 1, 0, 1, 0, 0, 0, 1, 1, 1, 1 + charde (3860)(1:18) = ' 3 5 9 10 11 12' + chnp1 (3860) = 1 + chnar (3860) = 17 + chnpy (3860) = 12 + chnte (3860) = 6 + chnhe (3860) = 0 + chperm (3860) = 201 + chbirf (3860) = 2079 + chetat (3860) = 901 + chtn2i (3860) = 210 + chbiet (901) = 3860 +c +c Aretes coupees : 4 6 7 8 10 12 + chclas (2792) = ' 6-04' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1 + charde (2792)(1:18) = ' 4 6 7 8 10 12' + chnp1 (2792) = 1 + chnar (2792) = 17 + chnpy (2792) = 12 + chnte (2792) = 6 + chnhe (2792) = 0 + chperm (2792) = 301 + chbirf (2792) = 2079 + chetat (2792) = 902 + chtn2i (2792) = 210 + chbiet (902) = 2792 +c +c Aretes coupees : 4 6 9 10 11 12 + chclas (3880) = ' 6-04' +c Code des aretes coupees : 0, 0, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1 + charde (3880)(1:18) = ' 4 6 9 10 11 12' + chnp1 (3880) = 1 + chnar (3880) = 17 + chnpy (3880) = 12 + chnte (3880) = 6 + chnhe (3880) = 0 + chperm (3880) = 20 + chbirf (3880) = 2079 + chetat (3880) = 903 + chtn2i (3880) = 210 + chbiet (903) = 3880 +c +c =========================================== +c Classe d'equivalence 6-05 +c +c Aretes coupees : 1 2 3 4 5 8 + chclas (159) = ' 6-05' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0 + charde (159)(1:18) = ' 1 2 3 4 5 8' + chnp1 (159) = 1 + chnar (159) = 19 + chnpy (159) = 17 + chnte (159) = 0 + chnhe (159) = 0 + chperm (159) = 0 + chbirf (159) = 159 + chetat (159) = 904 + chtn2i (159) = 210 + chbiet (904) = 159 +c +c Aretes coupees : 1 2 3 4 6 7 + chclas (111) = ' 6-05' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 0 + charde (111)(1:18) = ' 1 2 3 4 6 7' + chnp1 (111) = 1 + chnar (111) = 19 + chnpy (111) = 17 + chnte (111) = 0 + chnhe (111) = 0 + chperm (111) = 1 + chbirf (111) = 159 + chetat (111) = 905 + chtn2i (111) = 210 + chbiet (905) = 111 +c +c Aretes coupees : 1 2 5 6 9 11 + chclas (1331) = ' 6-05' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 0 + charde (1331)(1:18) = ' 1 2 5 6 9 11' + chnp1 (1331) = 1 + chnar (1331) = 19 + chnpy (1331) = 17 + chnte (1331) = 0 + chnhe (1331) = 0 + chperm (1331) = 101 + chbirf (1331) = 159 + chetat (1331) = 906 + chtn2i (1331) = 210 + chbiet (906) = 1331 +c +c Aretes coupees : 1 2 5 7 10 12 + chclas (2643) = ' 6-05' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1 + charde (2643)(1:18) = ' 1 2 5 7 10 12' + chnp1 (2643) = 1 + chnar (2643) = 19 + chnpy (2643) = 17 + chnte (2643) = 0 + chnhe (2643) = 0 + chperm (2643) = 130 + chbirf (2643) = 159 + chetat (2643) = 907 + chtn2i (2643) = 210 + chbiet (907) = 2643 +c +c Aretes coupees : 1 3 5 6 9 10 + chclas (821) = ' 6-05' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 0 + charde (821)(1:18) = ' 1 3 5 6 9 10' + chnp1 (821) = 1 + chnar (821) = 19 + chnpy (821) = 17 + chnte (821) = 0 + chnhe (821) = 0 + chperm (821) = 100 + chbirf (821) = 159 + chetat (821) = 908 + chtn2i (821) = 210 + chbiet (908) = 821 +c +c Aretes coupees : 1 3 6 8 11 12 + chclas (3237) = ' 6-05' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 1 + charde (3237)(1:18) = ' 1 3 6 8 11 12' + chnp1 (3237) = 1 + chnar (3237) = 19 + chnpy (3237) = 17 + chnte (3237) = 0 + chnhe (3237) = 0 + chperm (3237) = 10 + chbirf (3237) = 159 + chetat (3237) = 909 + chtn2i (3237) = 210 + chbiet (909) = 3237 +c +c Aretes coupees : 2 4 5 7 9 10 + chclas (858) = ' 6-05' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 1, 0, 1, 1, 0, 0 + charde (858)(1:18) = ' 2 4 5 7 9 10' + chnp1 (858) = 1 + chnar (858) = 19 + chnpy (858) = 17 + chnte (858) = 0 + chnhe (858) = 0 + chperm (858) = 30 + chbirf (858) = 159 + chetat (858) = 910 + chtn2i (858) = 210 + chbiet (910) = 858 +c +c Aretes coupees : 2 4 7 8 11 12 + chclas (3274) = ' 6-05' +c Code des aretes coupees : 0, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1 + charde (3274)(1:18) = ' 2 4 7 8 11 12' + chnp1 (3274) = 1 + chnar (3274) = 19 + chnpy (3274) = 17 + chnte (3274) = 0 + chnhe (3274) = 0 + chperm (3274) = 300 + chbirf (3274) = 159 + chetat (3274) = 911 + chtn2i (3274) = 210 + chbiet (911) = 3274 +c +c Aretes coupees : 3 4 6 8 9 11 + chclas (1452) = ' 6-05' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0 + charde (1452)(1:18) = ' 3 4 6 8 9 11' + chnp1 (1452) = 1 + chnar (1452) = 19 + chnpy (1452) = 17 + chnte (1452) = 0 + chnhe (1452) = 0 + chperm (1452) = 110 + chbirf (1452) = 159 + chetat (1452) = 912 + chtn2i (1452) = 210 + chbiet (912) = 1452 +c +c Aretes coupees : 3 4 7 8 10 12 + chclas (2764) = ' 6-05' +c Code des aretes coupees : 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 1 + charde (2764)(1:18) = ' 3 4 7 8 10 12' + chnp1 (2764) = 1 + chnar (2764) = 19 + chnpy (2764) = 17 + chnte (2764) = 0 + chnhe (2764) = 0 + chperm (2764) = 301 + chbirf (2764) = 159 + chetat (2764) = 913 + chtn2i (2764) = 210 + chbiet (913) = 2764 +c +c Aretes coupees : 5 8 9 10 11 12 + chclas (3984) = ' 6-05' +c Code des aretes coupees : 0, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1 + charde (3984)(1:18) = ' 5 8 9 10 11 12' + chnp1 (3984) = 1 + chnar (3984) = 19 + chnpy (3984) = 17 + chnte (3984) = 0 + chnhe (3984) = 0 + chperm (3984) = 201 + chbirf (3984) = 159 + chetat (3984) = 914 + chtn2i (3984) = 210 + chbiet (914) = 3984 +c +c Aretes coupees : 6 7 9 10 11 12 + chclas (3936) = ' 6-05' +c Code des aretes coupees : 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1 + charde (3936)(1:18) = ' 6 7 9 10 11 12' + chnp1 (3936) = 1 + chnar (3936) = 19 + chnpy (3936) = 17 + chnte (3936) = 0 + chnhe (3936) = 0 + chperm (3936) = 200 + chbirf (3936) = 159 + chetat (3936) = 915 + chtn2i (3936) = 210 + chbiet (915) = 3936 +c +c =========================================== +c Classe d'equivalence 6-06 +c +c Aretes coupees : 1 2 6 7 11 12 + chclas (3171) = ' 6-06' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 1 + charde (3171)(1:18) = ' 1 2 6 7 11 12' + chnp1 (3171) = 1 + chnar (3171) = 20 + chnpy (3171) = 18 + chnte (3171) = 0 + chnhe (3171) = 0 + chperm (3171) = 0 + chbirf (3171) = 3171 + chetat (3171) = 916 + chtn2i (3171) = 210 + chbiet (916) = 3171 +c +c Aretes coupees : 1 3 5 8 10 12 + chclas (2709) = ' 6-06' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1 + charde (2709)(1:18) = ' 1 3 5 8 10 12' + chnp1 (2709) = 1 + chnar (2709) = 20 + chnpy (2709) = 18 + chnte (2709) = 0 + chnhe (2709) = 0 + chperm (2709) = 200 + chbirf (2709) = 3171 + chetat (2709) = 917 + chtn2i (2709) = 210 + chbiet (917) = 2709 +c +c Aretes coupees : 2 4 5 8 9 11 + chclas (1434) = ' 6-06' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0 + charde (1434)(1:18) = ' 2 4 5 8 9 11' + chnp1 (1434) = 1 + chnar (1434) = 20 + chnpy (1434) = 18 + chnte (1434) = 0 + chnhe (1434) = 0 + chperm (1434) = 100 + chbirf (1434) = 3171 + chetat (1434) = 918 + chtn2i (1434) = 210 + chbiet (918) = 1434 +c +c Aretes coupees : 3 4 6 7 9 10 + chclas (876) = ' 6-06' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 0 + charde (876)(1:18) = ' 3 4 6 7 9 10' + chnp1 (876) = 1 + chnar (876) = 20 + chnpy (876) = 18 + chnte (876) = 0 + chnhe (876) = 0 + chperm (876) = 300 + chbirf (876) = 3171 + chetat (876) = 919 + chtn2i (876) = 210 + chbiet (919) = 876 +c +c =========================================== +c Classe d'equivalence 6-07 +c +c Aretes coupees : 1 2 6 8 10 12 + chclas (2723) = ' 6-07' +c Code des aretes coupees : 1, 1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1 + charde (2723)(1:18) = ' 1 2 6 8 10 12' + chnp1 (2723) = 1 + chnar (2723) = 18 + chnpy (2723) = 16 + chnte (2723) = 0 + chnhe (2723) = 0 + chperm (2723) = 0 + chbirf (2723) = 2723 + chetat (2723) = 920 + chtn2i (2723) = 210 + chbiet (920) = 2723 +c +c Aretes coupees : 1 3 7 8 9 10 + chclas (965) = ' 6-07' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0 + charde (965)(1:18) = ' 1 3 7 8 9 10' + chnp1 (965) = 1 + chnar (965) = 18 + chnpy (965) = 16 + chnte (965) = 0 + chnhe (965) = 0 + chperm (965) = 310 + chbirf (965) = 2723 + chetat (965) = 921 + chtn2i (965) = 210 + chbiet (921) = 965 +c +c Aretes coupees : 1 4 5 8 10 11 + chclas (1689) = ' 6-07' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 0 + charde (1689)(1:18) = ' 1 4 5 8 10 11' + chnp1 (1689) = 1 + chnar (1689) = 18 + chnpy (1689) = 16 + chnte (1689) = 0 + chnhe (1689) = 0 + chperm (1689) = 210 + chbirf (1689) = 2723 + chetat (1689) = 922 + chtn2i (1689) = 210 + chbiet (922) = 1689 +c +c Aretes coupees : 2 3 6 7 9 12 + chclas (2406) = ' 6-07' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1 + charde (2406)(1:18) = ' 2 3 6 7 9 12' + chnp1 (2406) = 1 + chnar (2406) = 18 + chnpy (2406) = 16 + chnte (2406) = 0 + chnhe (2406) = 0 + chperm (2406) = 10 + chbirf (2406) = 2723 + chetat (2406) = 923 + chtn2i (2406) = 210 + chbiet (923) = 2406 +c +c Aretes coupees : 2 4 5 6 11 12 + chclas (3130) = ' 6-07' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1 + charde (3130)(1:18) = ' 2 4 5 6 11 12' + chnp1 (3130) = 1 + chnar (3130) = 18 + chnpy (3130) = 16 + chnte (3130) = 0 + chnhe (3130) = 0 + chperm (3130) = 110 + chbirf (3130) = 2723 + chetat (3130) = 924 + chtn2i (3130) = 210 + chbiet (924) = 3130 +c +c Aretes coupees : 3 4 5 7 9 11 + chclas (1372) = ' 6-07' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0 + charde (1372)(1:18) = ' 3 4 5 7 9 11' + chnp1 (1372) = 1 + chnar (1372) = 18 + chnpy (1372) = 16 + chnte (1372) = 0 + chnhe (1372) = 0 + chperm (1372) = 100 + chbirf (1372) = 2723 + chetat (1372) = 925 + chtn2i (1372) = 210 + chbiet (925) = 1372 +c +c =========================================== +c Classe d'equivalence 6-08 +c +c Aretes coupees : 1 2 7 8 9 11 + chclas (1475) = ' 6-08' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0 + charde (1475)(1:18) = ' 1 2 7 8 9 11' + chnp1 (1475) = 1 + chnar (1475) = 18 + chnpy (1475) = 16 + chnte (1475) = 0 + chnhe (1475) = 0 + chperm (1475) = 0 + chbirf (1475) = 1475 + chetat (1475) = 926 + chtn2i (1475) = 210 + chbiet (926) = 1475 +c +c Aretes coupees : 1 3 5 7 11 12 + chclas (3157) = ' 6-08' +c Code des aretes coupees : 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1 + charde (3157)(1:18) = ' 1 3 5 7 11 12' + chnp1 (3157) = 1 + chnar (3157) = 18 + chnpy (3157) = 16 + chnte (3157) = 0 + chnhe (3157) = 0 + chperm (3157) = 101 + chbirf (3157) = 1475 + chetat (3157) = 927 + chtn2i (3157) = 210 + chbiet (927) = 3157 +c +c Aretes coupees : 1 4 6 7 10 11 + chclas (1641) = ' 6-08' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0 + charde (1641)(1:18) = ' 1 4 6 7 10 11' + chnp1 (1641) = 1 + chnar (1641) = 18 + chnpy (1641) = 16 + chnte (1641) = 0 + chnhe (1641) = 0 + chperm (1641) = 300 + chbirf (1641) = 1475 + chetat (1641) = 928 + chtn2i (1641) = 210 + chbiet (928) = 1641 +c +c Aretes coupees : 2 3 5 8 9 12 + chclas (2454) = ' 6-08' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1 + charde (2454)(1:18) = ' 2 3 5 8 9 12' + chnp1 (2454) = 1 + chnar (2454) = 18 + chnpy (2454) = 16 + chnte (2454) = 0 + chnhe (2454) = 0 + chperm (2454) = 100 + chbirf (2454) = 1475 + chetat (2454) = 929 + chtn2i (2454) = 210 + chbiet (929) = 2454 +c +c Aretes coupees : 2 4 6 8 9 10 + chclas (938) = ' 6-08' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 0, 0 + charde (938)(1:18) = ' 2 4 6 8 9 10' + chnp1 (938) = 1 + chnar (938) = 18 + chnpy (938) = 16 + chnte (938) = 0 + chnhe (938) = 0 + chperm (938) = 1 + chbirf (938) = 1475 + chetat (938) = 930 + chtn2i (938) = 210 + chbiet (930) = 938 +c +c Aretes coupees : 3 4 5 6 10 12 + chclas (2620) = ' 6-08' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1 + charde (2620)(1:18) = ' 3 4 5 6 10 12' + chnp1 (2620) = 1 + chnar (2620) = 18 + chnpy (2620) = 16 + chnte (2620) = 0 + chnhe (2620) = 0 + chperm (2620) = 200 + chbirf (2620) = 1475 + chetat (2620) = 931 + chtn2i (2620) = 210 + chbiet (931) = 2620 +c +c =========================================== +c Classe d'equivalence 7-00 +c +c Aretes coupees : 1 2 3 4 5 6 9 + chclas (319) = ' 7-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0, 0 + charde (319)(1:21) = ' 1 2 3 4 5 6 9' + chnp1 (319) = 1 + chnar (319) = 19 + chnpy (319) = 14 + chnte (319) = 6 + chnhe (319) = 0 + chperm (319) = 0 + chbirf (319) = 319 + chetat (319) = 932 + chtn2i (319) = 210 + chbiet (932) = 319 +c +c Aretes coupees : 1 2 3 4 5 7 10 + chclas (607) = ' 7-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0 + charde (607)(1:21) = ' 1 2 3 4 5 7 10' + chnp1 (607) = 1 + chnar (607) = 19 + chnpy (607) = 14 + chnte (607) = 6 + chnhe (607) = 0 + chperm (607) = 330 + chbirf (607) = 319 + chetat (607) = 933 + chtn2i (607) = 210 + chbiet (933) = 607 +c +c Aretes coupees : 1 2 3 4 6 8 11 + chclas (1199) = ' 7-00' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0 + charde (1199)(1:21) = ' 1 2 3 4 6 8 11' + chnp1 (1199) = 1 + chnar (1199) = 19 + chnpy (1199) = 14 + chnte (1199) = 6 + chnhe (1199) = 0 + chperm (1199) = 310 + chbirf (1199) = 319 + chetat (1199) = 934 + chtn2i (1199) = 210 + chbiet (934) = 1199 +c +c Aretes coupees : 1 2 3 4 7 8 12 + chclas (2255) = ' 7-00' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1 + charde (2255)(1:21) = ' 1 2 3 4 7 8 12' + chnp1 (2255) = 1 + chnar (2255) = 19 + chnpy (2255) = 14 + chnte (2255) = 6 + chnhe (2255) = 0 + chperm (2255) = 300 + chbirf (2255) = 319 + chetat (2255) = 935 + chtn2i (2255) = 210 + chbiet (935) = 2255 +c +c Aretes coupees : 1 2 5 6 7 9 10 + chclas (883) = ' 7-00' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0, 0 + charde (883)(1:21) = ' 1 2 5 6 7 9 10' + chnp1 (883) = 1 + chnar (883) = 19 + chnpy (883) = 14 + chnte (883) = 6 + chnhe (883) = 0 + chperm (883) = 30 + chbirf (883) = 319 + chetat (883) = 936 + chtn2i (883) = 210 + chbiet (936) = 883 +c +c Aretes coupees : 1 3 5 6 8 9 11 + chclas (1461) = ' 7-00' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0 + charde (1461)(1:21) = ' 1 3 5 6 8 9 11' + chnp1 (1461) = 1 + chnar (1461) = 19 + chnpy (1461) = 14 + chnte (1461) = 6 + chnhe (1461) = 0 + chperm (1461) = 10 + chbirf (1461) = 319 + chetat (1461) = 937 + chtn2i (1461) = 210 + chbiet (937) = 1461 +c +c Aretes coupees : 1 5 6 9 10 11 12 + chclas (3889) = ' 7-00' +c Code des aretes coupees : 1, 0, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1 + charde (3889)(1:21) = ' 1 5 6 9 10 11 12' + chnp1 (3889) = 1 + chnar (3889) = 19 + chnpy (3889) = 14 + chnte (3889) = 6 + chnhe (3889) = 0 + chperm (3889) = 100 + chbirf (3889) = 319 + chetat (3889) = 938 + chtn2i (3889) = 210 + chbiet (938) = 3889 +c +c Aretes coupees : 2 4 5 7 8 10 12 + chclas (2778) = ' 7-00' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1 + charde (2778)(1:21) = ' 2 4 5 7 8 10 12' + chnp1 (2778) = 1 + chnar (2778) = 19 + chnpy (2778) = 14 + chnte (2778) = 6 + chnhe (2778) = 0 + chperm (2778) = 230 + chbirf (2778) = 319 + chetat (2778) = 939 + chtn2i (2778) = 210 + chbiet (939) = 2778 +c +c Aretes coupees : 2 5 7 9 10 11 12 + chclas (3922) = ' 7-00' +c Code des aretes coupees : 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1 + charde (3922)(1:21) = ' 2 5 7 9 10 11 12' + chnp1 (3922) = 1 + chnar (3922) = 19 + chnpy (3922) = 14 + chnte (3922) = 6 + chnhe (3922) = 0 + chperm (3922) = 130 + chbirf (3922) = 319 + chetat (3922) = 940 + chtn2i (3922) = 210 + chbiet (940) = 3922 +c +c Aretes coupees : 3 4 6 7 8 11 12 + chclas (3308) = ' 7-00' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 1, 0, 0, 1, 1 + charde (3308)(1:21) = ' 3 4 6 7 8 11 12' + chnp1 (3308) = 1 + chnar (3308) = 19 + chnpy (3308) = 14 + chnte (3308) = 6 + chnhe (3308) = 0 + chperm (3308) = 210 + chbirf (3308) = 319 + chetat (3308) = 941 + chtn2i (3308) = 210 + chbiet (941) = 3308 +c +c Aretes coupees : 3 6 8 9 10 11 12 + chclas (4004) = ' 7-00' +c Code des aretes coupees : 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1 + charde (4004)(1:21) = ' 3 6 8 9 10 11 12' + chnp1 (4004) = 1 + chnar (4004) = 19 + chnpy (4004) = 14 + chnte (4004) = 6 + chnhe (4004) = 0 + chperm (4004) = 110 + chbirf (4004) = 319 + chetat (4004) = 942 + chtn2i (4004) = 210 + chbiet (942) = 4004 +c +c Aretes coupees : 4 7 8 9 10 11 12 + chclas (4040) = ' 7-00' +c Code des aretes coupees : 0, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1 + charde (4040)(1:21) = ' 4 7 8 9 10 11 12' + chnp1 (4040) = 1 + chnar (4040) = 19 + chnpy (4040) = 14 + chnte (4040) = 6 + chnhe (4040) = 0 + chperm (4040) = 200 + chbirf (4040) = 319 + chetat (4040) = 943 + chtn2i (4040) = 210 + chbiet (943) = 4040 +c +c =========================================== +c Classe d'equivalence 7-01 +c +c Aretes coupees : 1 2 3 4 5 11 12 + chclas (3103) = ' 7-01' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 1, 1 + charde (3103)(1:21) = ' 1 2 3 4 5 11 12' + chnp1 (3103) = 1 + chnar (3103) = 19 + chnpy (3103) = 17 + chnte (3103) = 0 + chnhe (3103) = 0 + chperm (3103) = 0 + chbirf (3103) = 3103 + chetat (3103) = 944 + chtn2i (3103) = 210 + chbiet (944) = 3103 +c +c Aretes coupees : 1 2 3 4 6 10 12 + chclas (2607) = ' 7-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 0, 0, 1, 0, 1 + charde (2607)(1:21) = ' 1 2 3 4 6 10 12' + chnp1 (2607) = 1 + chnar (2607) = 19 + chnpy (2607) = 17 + chnte (2607) = 0 + chnhe (2607) = 0 + chperm (2607) = 221 + chbirf (2607) = 3103 + chetat (2607) = 945 + chtn2i (2607) = 210 + chbiet (945) = 2607 +c +c Aretes coupees : 1 2 3 4 7 9 11 + chclas (1359) = ' 7-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0 + charde (1359)(1:21) = ' 1 2 3 4 7 9 11' + chnp1 (1359) = 1 + chnar (1359) = 19 + chnpy (1359) = 17 + chnte (1359) = 0 + chnhe (1359) = 0 + chperm (1359) = 1 + chbirf (1359) = 3103 + chetat (1359) = 946 + chtn2i (1359) = 210 + chbiet (946) = 1359 +c +c Aretes coupees : 1 2 3 4 8 9 10 + chclas (911) = ' 7-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0 + charde (911)(1:21) = ' 1 2 3 4 8 9 10' + chnp1 (911) = 1 + chnar (911) = 19 + chnpy (911) = 17 + chnte (911) = 0 + chnhe (911) = 0 + chperm (911) = 220 + chbirf (911) = 3103 + chetat (911) = 947 + chtn2i (911) = 210 + chbiet (947) = 911 +c +c Aretes coupees : 1 2 5 6 8 9 12 + chclas (2483) = ' 7-01' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1 + charde (2483)(1:21) = ' 1 2 5 6 8 9 12' + chnp1 (2483) = 1 + chnar (2483) = 19 + chnpy (2483) = 17 + chnte (2483) = 0 + chnhe (2483) = 0 + chperm (2483) = 101 + chbirf (2483) = 3103 + chetat (2483) = 948 + chtn2i (2483) = 210 + chbiet (948) = 2483 +c +c Aretes coupees : 1 2 5 7 8 10 11 + chclas (1747) = ' 7-01' +c Code des aretes coupees : 1, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 0 + charde (1747)(1:21) = ' 1 2 5 7 8 10 11' + chnp1 (1747) = 1 + chnar (1747) = 19 + chnpy (1747) = 17 + chnte (1747) = 0 + chnhe (1747) = 0 + chperm (1747) = 330 + chbirf (1747) = 3103 + chetat (1747) = 949 + chtn2i (1747) = 210 + chbiet (949) = 1747 +c +c Aretes coupees : 1 2 8 9 10 11 12 + chclas (3971) = ' 7-01' +c Code des aretes coupees : 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1 + charde (3971)(1:21) = ' 1 2 8 9 10 11 12' + chnp1 (3971) = 1 + chnar (3971) = 19 + chnpy (3971) = 17 + chnte (3971) = 0 + chnhe (3971) = 0 + chperm (3971) = 21 + chbirf (3971) = 3103 + chetat (3971) = 950 + chtn2i (3971) = 210 + chbiet (950) = 3971 +c +c Aretes coupees : 1 3 5 6 7 9 12 + chclas (2421) = ' 7-01' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0, 1 + charde (2421)(1:21) = ' 1 3 5 6 7 9 12' + chnp1 (2421) = 1 + chnar (2421) = 19 + chnpy (2421) = 17 + chnte (2421) = 0 + chnhe (2421) = 0 + chperm (2421) = 320 + chbirf (2421) = 3103 + chetat (2421) = 951 + chtn2i (2421) = 210 + chbiet (951) = 2421 +c +c Aretes coupees : 1 3 6 7 8 10 11 + chclas (1765) = ' 7-01' +c Code des aretes coupees : 1, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1, 0 + charde (1765)(1:21) = ' 1 3 6 7 8 10 11' + chnp1 (1765) = 1 + chnar (1765) = 19 + chnpy (1765) = 17 + chnte (1765) = 0 + chnhe (1765) = 0 + chperm (1765) = 10 + chbirf (1765) = 3103 + chetat (1765) = 952 + chtn2i (1765) = 210 + chbiet (952) = 1765 +c +c Aretes coupees : 1 3 7 9 10 11 12 + chclas (3909) = ' 7-01' +c Code des aretes coupees : 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 1, 1 + charde (3909)(1:21) = ' 1 3 7 9 10 11 12' + chnp1 (3909) = 1 + chnar (3909) = 19 + chnpy (3909) = 17 + chnte (3909) = 0 + chnhe (3909) = 0 + chperm (3909) = 200 + chbirf (3909) = 3103 + chetat (3909) = 953 + chtn2i (3909) = 210 + chbiet (953) = 3909 +c +c Aretes coupees : 1 4 5 6 7 9 11 + chclas (1401) = ' 7-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0 + charde (1401)(1:21) = ' 1 4 5 6 7 9 11' + chnp1 (1401) = 1 + chnar (1401) = 19 + chnpy (1401) = 17 + chnte (1401) = 0 + chnhe (1401) = 0 + chperm (1401) = 321 + chbirf (1401) = 3103 + chetat (1401) = 954 + chtn2i (1401) = 210 + chbiet (954) = 1401 +c +c Aretes coupees : 1 4 5 6 8 9 10 + chclas (953) = ' 7-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 1, 1, 1, 0, 0 + charde (953)(1:21) = ' 1 4 5 6 8 9 10' + chnp1 (953) = 1 + chnar (953) = 19 + chnpy (953) = 17 + chnte (953) = 0 + chnhe (953) = 0 + chperm (953) = 100 + chbirf (953) = 3103 + chetat (953) = 955 + chtn2i (953) = 210 + chbiet (955) = 953 +c +c Aretes coupees : 1 4 5 7 8 11 12 + chclas (3289) = ' 7-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1 + charde (3289)(1:21) = ' 1 4 5 7 8 11 12' + chnp1 (3289) = 1 + chnar (3289) = 19 + chnpy (3289) = 17 + chnte (3289) = 0 + chnhe (3289) = 0 + chperm (3289) = 120 + chbirf (3289) = 3103 + chetat (3289) = 956 + chtn2i (3289) = 210 + chbiet (956) = 3289 +c +c Aretes coupees : 1 4 6 7 8 10 12 + chclas (2793) = ' 7-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1 + charde (2793)(1:21) = ' 1 4 6 7 8 10 12' + chnp1 (2793) = 1 + chnar (2793) = 19 + chnpy (2793) = 17 + chnte (2793) = 0 + chnhe (2793) = 0 + chperm (2793) = 301 + chbirf (2793) = 3103 + chetat (2793) = 957 + chtn2i (2793) = 210 + chbiet (957) = 2793 +c +c Aretes coupees : 2 3 5 6 7 10 12 + chclas (2678) = ' 7-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 1, 0, 0, 1, 0, 1 + charde (2678)(1:21) = ' 2 3 5 6 7 10 12' + chnp1 (2678) = 1 + chnar (2678) = 19 + chnpy (2678) = 17 + chnte (2678) = 0 + chnhe (2678) = 0 + chperm (2678) = 130 + chbirf (2678) = 3103 + chetat (2678) = 958 + chtn2i (2678) = 210 + chbiet (958) = 2678 +c +c Aretes coupees : 2 3 5 6 8 11 12 + chclas (3254) = ' 7-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 1, 1 + charde (3254)(1:21) = ' 2 3 5 6 8 11 12' + chnp1 (3254) = 1 + chnar (3254) = 19 + chnpy (3254) = 17 + chnte (3254) = 0 + chnhe (3254) = 0 + chperm (3254) = 210 + chbirf (3254) = 3103 + chetat (3254) = 959 + chtn2i (3254) = 210 + chbiet (959) = 3254 +c +c Aretes coupees : 2 3 5 7 8 9 10 + chclas (982) = ' 7-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 0, 0 + charde (982)(1:21) = ' 2 3 5 7 8 9 10' + chnp1 (982) = 1 + chnar (982) = 19 + chnpy (982) = 17 + chnte (982) = 0 + chnhe (982) = 0 + chperm (982) = 30 + chbirf (982) = 3103 + chetat (982) = 960 + chtn2i (982) = 210 + chbiet (960) = 982 +c +c Aretes coupees : 2 3 6 7 8 9 11 + chclas (1510) = ' 7-01' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 1, 1, 1, 0, 1, 0 + charde (1510)(1:21) = ' 2 3 6 7 8 9 11' + chnp1 (1510) = 1 + chnar (1510) = 19 + chnpy (1510) = 17 + chnte (1510) = 0 + chnhe (1510) = 0 + chperm (1510) = 110 + chbirf (1510) = 3103 + chetat (1510) = 961 + chtn2i (1510) = 210 + chbiet (961) = 1510 +c +c Aretes coupees : 2 4 5 6 7 10 11 + chclas (1658) = ' 7-01' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 1, 0, 0, 1, 1, 0 + charde (1658)(1:21) = ' 2 4 5 6 7 10 11' + chnp1 (1658) = 1 + chnar (1658) = 19 + chnpy (1658) = 17 + chnte (1658) = 0 + chnhe (1658) = 0 + chperm (1658) = 230 + chbirf (1658) = 3103 + chetat (1658) = 962 + chtn2i (1658) = 210 + chbiet (962) = 1658 +c +c Aretes coupees : 2 4 6 7 8 9 12 + chclas (2538) = ' 7-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 1, 1, 1, 0, 0, 1 + charde (2538)(1:21) = ' 2 4 6 7 8 9 12' + chnp1 (2538) = 1 + chnar (2538) = 19 + chnpy (2538) = 17 + chnte (2538) = 0 + chnhe (2538) = 0 + chperm (2538) = 300 + chbirf (2538) = 3103 + chetat (2538) = 963 + chtn2i (2538) = 210 + chbiet (963) = 2538 +c +c Aretes coupees : 2 4 6 9 10 11 12 + chclas (3882) = ' 7-01' +c Code des aretes coupees : 0, 1, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1 + charde (3882)(1:21) = ' 2 4 6 9 10 11 12' + chnp1 (3882) = 1 + chnar (3882) = 19 + chnpy (3882) = 17 + chnte (3882) = 0 + chnhe (3882) = 0 + chperm (3882) = 20 + chbirf (3882) = 3103 + chetat (3882) = 964 + chtn2i (3882) = 210 + chbiet (964) = 3882 +c +c Aretes coupees : 3 4 5 6 8 10 11 + chclas (1724) = ' 7-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0 + charde (1724)(1:21) = ' 3 4 5 6 8 10 11' + chnp1 (1724) = 1 + chnar (1724) = 19 + chnpy (1724) = 17 + chnte (1724) = 0 + chnhe (1724) = 0 + chperm (1724) = 310 + chbirf (1724) = 3103 + chetat (1724) = 965 + chtn2i (1724) = 210 + chbiet (965) = 1724 +c +c Aretes coupees : 3 4 5 7 8 9 12 + chclas (2524) = ' 7-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 1, 1, 1, 0, 0, 1 + charde (2524)(1:21) = ' 3 4 5 7 8 9 12' + chnp1 (2524) = 1 + chnar (2524) = 19 + chnpy (2524) = 17 + chnte (2524) = 0 + chnhe (2524) = 0 + chperm (2524) = 121 + chbirf (2524) = 3103 + chetat (2524) = 966 + chtn2i (2524) = 210 + chbiet (966) = 2524 +c +c Aretes coupees : 3 4 5 9 10 11 12 + chclas (3868) = ' 7-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 1 + charde (3868)(1:21) = ' 3 4 5 9 10 11 12' + chnp1 (3868) = 1 + chnar (3868) = 19 + chnpy (3868) = 17 + chnte (3868) = 0 + chnhe (3868) = 0 + chperm (3868) = 201 + chbirf (3868) = 3103 + chetat (3868) = 967 + chtn2i (3868) = 210 + chbiet (967) = 3868 +c +c =========================================== +c Classe d'equivalence 8-00 +c +c Aretes coupees : 1 2 3 4 9 10 11 12 + chclas (3855) = ' 8-00' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1 + charde (3855)(1:24) = ' 1 2 3 4 9 10 11 12' + chnp1 (3855) = 0 + chnar (3855) = 1 + chnpy (3855) = 0 + chnte (3855) = 0 + chnhe (3855) = 4 + chperm (3855) = 0 + chbirf (3855) = 3855 + chetat (3855) = 968 + chtn2i (3855) = 17 + chbiet (968) = 3855 +c +c Aretes coupees : 1 4 5 6 7 8 9 12 + chclas (2553) = ' 8-00' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1 + charde (2553)(1:24) = ' 1 4 5 6 7 8 9 12' + chnp1 (2553) = 0 + chnar (2553) = 1 + chnpy (2553) = 0 + chnte (2553) = 0 + chnhe (2553) = 4 + chperm (2553) = 100 + chbirf (2553) = 3855 + chetat (2553) = 969 + chtn2i (2553) = 17 + chbiet (969) = 2553 +c +c Aretes coupees : 2 3 5 6 7 8 10 11 + chclas (1782) = ' 8-00' +c Code des aretes coupees : 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 0 + charde (1782)(1:24) = ' 2 3 5 6 7 8 10 11' + chnp1 (1782) = 0 + chnar (1782) = 1 + chnpy (1782) = 0 + chnte (1782) = 0 + chnhe (1782) = 4 + chperm (1782) = 10 + chbirf (1782) = 3855 + chetat (1782) = 970 + chtn2i (1782) = 17 + chbiet (970) = 1782 +c +c =========================================== +c Classe d'equivalence 8-01 +c +c Aretes coupees : 1 2 3 4 5 6 9 12 + chclas (2367) = ' 8-01' +c Code des aretes coupees : 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0, 1 + charde (2367)(1:24) = ' 1 2 3 4 5 6 9 12' + chnp1 (2367) = 1 + chnar (2367) = 20 + chnpy (2367) = 18 + chnte (2367) = 0 + chnhe (2367) = 0 + chperm (2367) = 0 + chbirf (2367) = 2367 + chetat (2367) = 971 + chtn2i (2367) = 210 + chbiet (971) = 2367 +c +c Aretes coupees : 1 2 3 4 5 7 10 11 + chclas (1631) = ' 8-01' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 0 + charde (1631)(1:24) = ' 1 2 3 4 5 7 10 11' + chnp1 (1631) = 1 + chnar (1631) = 20 + chnpy (1631) = 18 + chnte (1631) = 0 + chnhe (1631) = 0 + chperm (1631) = 330 + chbirf (1631) = 2367 + chetat (1631) = 972 + chtn2i (1631) = 210 + chbiet (972) = 1631 +c +c Aretes coupees : 1 2 3 4 6 8 10 11 + chclas (1711) = ' 8-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0 + charde (1711)(1:24) = ' 1 2 3 4 6 8 10 11' + chnp1 (1711) = 1 + chnar (1711) = 20 + chnpy (1711) = 18 + chnte (1711) = 0 + chnhe (1711) = 0 + chperm (1711) = 310 + chbirf (1711) = 2367 + chetat (1711) = 973 + chtn2i (1711) = 210 + chbiet (973) = 1711 +c +c Aretes coupees : 1 2 3 4 7 8 9 12 + chclas (2511) = ' 8-01' +c Code des aretes coupees : 1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1 + charde (2511)(1:24) = ' 1 2 3 4 7 8 9 12' + chnp1 (2511) = 1 + chnar (2511) = 20 + chnpy (2511) = 18 + chnte (2511) = 0 + chnhe (2511) = 0 + chperm (2511) = 300 + chbirf (2511) = 2367 + chetat (2511) = 974 + chtn2i (2511) = 210 + chbiet (974) = 2511 +c +c Aretes coupees : 1 2 5 6 7 8 9 10 + chclas (1011) = ' 8-01' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0 + charde (1011)(1:24) = ' 1 2 5 6 7 8 9 10' + chnp1 (1011) = 1 + chnar (1011) = 20 + chnpy (1011) = 18 + chnte (1011) = 0 + chnhe (1011) = 0 + chperm (1011) = 30 + chbirf (1011) = 2367 + chetat (1011) = 975 + chtn2i (1011) = 210 + chbiet (975) = 1011 +c +c Aretes coupees : 1 3 5 6 7 8 9 11 + chclas (1525) = ' 8-01' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0 + charde (1525)(1:24) = ' 1 3 5 6 7 8 9 11' + chnp1 (1525) = 1 + chnar (1525) = 20 + chnpy (1525) = 18 + chnte (1525) = 0 + chnhe (1525) = 0 + chperm (1525) = 10 + chbirf (1525) = 2367 + chetat (1525) = 976 + chtn2i (1525) = 210 + chbiet (976) = 1525 +c +c Aretes coupees : 1 4 5 6 9 10 11 12 + chclas (3897) = ' 8-01' +c Code des aretes coupees : 1, 0, 0, 1, 1, 1, 0, 0, 1, 1, 1, 1 + charde (3897)(1:24) = ' 1 4 5 6 9 10 11 12' + chnp1 (3897) = 1 + chnar (3897) = 20 + chnpy (3897) = 18 + chnte (3897) = 0 + chnhe (3897) = 0 + chperm (3897) = 100 + chbirf (3897) = 2367 + chetat (3897) = 977 + chtn2i (3897) = 210 + chbiet (977) = 3897 +c +c Aretes coupees : 1 4 7 8 9 10 11 12 + chclas (4041) = ' 8-01' +c Code des aretes coupees : 1, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1 + charde (4041)(1:24) = ' 1 4 7 8 9 10 11 12' + chnp1 (4041) = 1 + chnar (4041) = 20 + chnpy (4041) = 18 + chnte (4041) = 0 + chnhe (4041) = 0 + chperm (4041) = 200 + chbirf (4041) = 2367 + chetat (4041) = 978 + chtn2i (4041) = 210 + chbiet (978) = 4041 +c +c Aretes coupees : 2 3 5 7 9 10 11 12 + chclas (3926) = ' 8-01' +c Code des aretes coupees : 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1 + charde (3926)(1:24) = ' 2 3 5 7 9 10 11 12' + chnp1 (3926) = 1 + chnar (3926) = 20 + chnpy (3926) = 18 + chnte (3926) = 0 + chnhe (3926) = 0 + chperm (3926) = 130 + chbirf (3926) = 2367 + chetat (3926) = 979 + chtn2i (3926) = 210 + chbiet (979) = 3926 +c +c Aretes coupees : 2 3 6 8 9 10 11 12 + chclas (4006) = ' 8-01' +c Code des aretes coupees : 0, 1, 1, 0, 0, 1, 0, 1, 1, 1, 1, 1 + charde (4006)(1:24) = ' 2 3 6 8 9 10 11 12' + chnp1 (4006) = 1 + chnar (4006) = 20 + chnpy (4006) = 18 + chnte (4006) = 0 + chnhe (4006) = 0 + chperm (4006) = 110 + chbirf (4006) = 2367 + chetat (4006) = 980 + chtn2i (4006) = 210 + chbiet (980) = 4006 +c +c Aretes coupees : 2 4 5 6 7 8 10 12 + chclas (2810) = ' 8-01' +c Code des aretes coupees : 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0, 1 + charde (2810)(1:24) = ' 2 4 5 6 7 8 10 12' + chnp1 (2810) = 1 + chnar (2810) = 20 + chnpy (2810) = 18 + chnte (2810) = 0 + chnhe (2810) = 0 + chperm (2810) = 230 + chbirf (2810) = 2367 + chetat (2810) = 981 + chtn2i (2810) = 210 + chbiet (981) = 2810 +c +c Aretes coupees : 3 4 5 6 7 8 11 12 + chclas (3324) = ' 8-01' +c Code des aretes coupees : 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1 + charde (3324)(1:24) = ' 3 4 5 6 7 8 11 12' + chnp1 (3324) = 1 + chnar (3324) = 20 + chnpy (3324) = 18 + chnte (3324) = 0 + chnhe (3324) = 0 + chperm (3324) = 210 + chbirf (3324) = 2367 + chetat (3324) = 982 + chtn2i (3324) = 210 + chbiet (982) = 3324 +c +c =========================================== +c Classe d'equivalence 9-00 +c +c Aretes coupees : 1 2 3 4 5 6 7 9 10 + chclas (895) = ' 9-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 0 + charde (895)(1:27) = ' 1 2 3 4 5 6 7 9 10' + chnp1 (895) = 1 + chnar (895) = 23 + chnpy (895) = 21 + chnte (895) = 0 + chnhe (895) = 0 + chperm (895) = 0 + chbirf (895) = 895 + chetat (895) = 983 + chtn2i (895) = 210 + chbiet (983) = 895 +c +c Aretes coupees : 1 2 3 4 5 6 8 9 11 + chclas (1471) = ' 9-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0 + charde (1471)(1:27) = ' 1 2 3 4 5 6 8 9 11' + chnp1 (1471) = 1 + chnar (1471) = 23 + chnpy (1471) = 21 + chnte (1471) = 0 + chnhe (1471) = 0 + chperm (1471) = 10 + chbirf (1471) = 895 + chetat (1471) = 984 + chtn2i (1471) = 210 + chbiet (984) = 1471 +c +c Aretes coupees : 1 2 3 4 5 7 8 10 12 + chclas (2783) = ' 9-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 1 + charde (2783)(1:27) = ' 1 2 3 4 5 7 8 10 12' + chnp1 (2783) = 1 + chnar (2783) = 23 + chnpy (2783) = 21 + chnte (2783) = 0 + chnhe (2783) = 0 + chperm (2783) = 300 + chbirf (2783) = 895 + chetat (2783) = 985 + chtn2i (2783) = 210 + chbiet (985) = 2783 +c +c Aretes coupees : 1 2 3 4 6 7 8 11 12 + chclas (3311) = ' 9-00' +c Code des aretes coupees : 1, 1, 1, 1, 0, 1, 1, 1, 0, 0, 1, 1 + charde (3311)(1:27) = ' 1 2 3 4 6 7 8 11 12' + chnp1 (3311) = 1 + chnar (3311) = 23 + chnpy (3311) = 21 + chnte (3311) = 0 + chnhe (3311) = 0 + chperm (3311) = 310 + chbirf (3311) = 895 + chetat (3311) = 986 + chtn2i (3311) = 210 + chbiet (986) = 3311 +c +c Aretes coupees : 1 2 5 6 7 9 10 11 12 + chclas (3955) = ' 9-00' +c Code des aretes coupees : 1, 1, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1 + charde (3955)(1:27) = ' 1 2 5 6 7 9 10 11 12' + chnp1 (3955) = 1 + chnar (3955) = 23 + chnpy (3955) = 21 + chnte (3955) = 0 + chnhe (3955) = 0 + chperm (3955) = 100 + chbirf (3955) = 895 + chetat (3955) = 987 + chtn2i (3955) = 210 + chbiet (987) = 3955 +c +c Aretes coupees : 1 3 5 6 8 9 10 11 12 + chclas (4021) = ' 9-00' +c Code des aretes coupees : 1, 0, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1 + charde (4021)(1:27) = ' 1 3 5 6 8 9 10 11 12' + chnp1 (4021) = 1 + chnar (4021) = 23 + chnpy (4021) = 21 + chnte (4021) = 0 + chnhe (4021) = 0 + chperm (4021) = 110 + chbirf (4021) = 895 + chetat (4021) = 988 + chtn2i (4021) = 210 + chbiet (988) = 4021 +c +c Aretes coupees : 2 4 5 7 8 9 10 11 12 + chclas (4058) = ' 9-00' +c Code des aretes coupees : 0, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1 + charde (4058)(1:27) = ' 2 4 5 7 8 9 10 11 12' + chnp1 (4058) = 1 + chnar (4058) = 23 + chnpy (4058) = 21 + chnte (4058) = 0 + chnhe (4058) = 0 + chperm (4058) = 200 + chbirf (4058) = 895 + chetat (4058) = 989 + chtn2i (4058) = 210 + chbiet (989) = 4058 +c +c Aretes coupees : 3 4 6 7 8 9 10 11 12 + chclas (4076) = ' 9-00' +c Code des aretes coupees : 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1 + charde (4076)(1:27) = ' 3 4 6 7 8 9 10 11 12' + chnp1 (4076) = 1 + chnar (4076) = 23 + chnpy (4076) = 21 + chnte (4076) = 0 + chnhe (4076) = 0 + chperm (4076) = 210 + chbirf (4076) = 895 + chetat (4076) = 990 + chtn2i (4076) = 210 + chbiet (990) = 4076 +c +c =========================================== +c Classe d'equivalence 12-00 +c +c Aretes coupees : 1 2 3 4 5 6 7 8 9 10 11 12 + chclas (4095) = '12-00' +c Code des aretes coupees : 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 + charde (4095)(1:36) = ' 1 2 3 4 5 6 7 8 9 10 11 12' + chnp1 (4095) = 1 + chnar (4095) = 6 + chnpy (4095) = 0 + chnte (4095) = 0 + chnhe (4095) = 8 + chperm (4095) = 0 + chbirf (4095) = 4095 + chetat (4095) = 8 + chtn2i (4095) = 6 + chbiet (8) = 4095 diff --git a/src/tool/Includes_Generaux/hexcf3.h b/src/tool/Includes_Generaux/hexcf3.h new file mode 100644 index 00000000..13edf6f8 --- /dev/null +++ b/src/tool/Includes_Generaux/hexcf3.h @@ -0,0 +1,6 @@ +c + integer hepers(8,0:330) + integer hepera(12,0:330) + integer heperf(6,0:330) + integer heperc(6,0:330) +c diff --git a/src/tool/Includes_Generaux/hexcf4.h b/src/tool/Includes_Generaux/hexcf4.h new file mode 100644 index 00000000..798c9a35 --- /dev/null +++ b/src/tool/Includes_Generaux/hexcf4.h @@ -0,0 +1,894 @@ +c +c Pour la permutation p : +c hepers(n,p) = numero global du sommet dans l'hexaedre courant +c correspondant au n-eme dans l'hexaedre de reference +c hepera = pour les aretes +c heperf, heperc = pour les faces et leurs codes +c +c Permutation 0 +c + hepers(1,0) = listso(1) + hepers(2,0) = listso(2) + hepers(3,0) = listso(3) + hepers(4,0) = listso(4) + hepers(5,0) = listso(5) + hepers(6,0) = listso(6) + hepers(7,0) = listso(7) + hepers(8,0) = listso(8) +c + hepera(1,0) = listar(1) + hepera(2,0) = listar(2) + hepera(3,0) = listar(3) + hepera(4,0) = listar(4) + hepera(5,0) = listar(5) + hepera(6,0) = listar(6) + hepera(7,0) = listar(7) + hepera(8,0) = listar(8) + hepera(9,0) = listar(9) + hepera(10,0) = listar(10) + hepera(11,0) = listar(11) + hepera(12,0) = listar(12) +c + heperf(1,0) = quahex(lehexa,1) + heperc(1,0) = per002(1,coquhe(lehexa,1)) + heperf(2,0) = quahex(lehexa,2) + heperc(2,0) = per002(1,coquhe(lehexa,2)) + heperf(3,0) = quahex(lehexa,3) + heperc(3,0) = per002(1,coquhe(lehexa,3)) + heperf(4,0) = quahex(lehexa,4) + heperc(4,0) = per002(1,coquhe(lehexa,4)) + heperf(5,0) = quahex(lehexa,5) + heperc(5,0) = per002(1,coquhe(lehexa,5)) + heperf(6,0) = quahex(lehexa,6) + heperc(6,0) = per002(1,coquhe(lehexa,6)) +c +c Permutation 1 +c + hepers(1,1) = listso(4) + hepers(2,1) = listso(1) + hepers(3,1) = listso(2) + hepers(4,1) = listso(3) + hepers(5,1) = listso(6) + hepers(6,1) = listso(7) + hepers(7,1) = listso(8) + hepers(8,1) = listso(5) +c + hepera(1,1) = listar(2) + hepera(2,1) = listar(4) + hepera(3,1) = listar(1) + hepera(4,1) = listar(3) + hepera(5,1) = listar(7) + hepera(6,1) = listar(5) + hepera(7,1) = listar(8) + hepera(8,1) = listar(6) + hepera(9,1) = listar(10) + hepera(10,1) = listar(12) + hepera(11,1) = listar(9) + hepera(12,1) = listar(11) +c + heperf(1,1) = quahex(lehexa,1) + heperc(1,1) = per002(1,coquhe(lehexa,1)) + heperf(2,1) = quahex(lehexa,3) + heperc(2,1) = per002(1,coquhe(lehexa,3)) + heperf(3,1) = quahex(lehexa,5) + heperc(3,1) = per002(1,coquhe(lehexa,5)) + heperf(4,1) = quahex(lehexa,2) + heperc(4,1) = per002(1,coquhe(lehexa,2)) + heperf(5,1) = quahex(lehexa,4) + heperc(5,1) = per002(1,coquhe(lehexa,4)) + heperf(6,1) = quahex(lehexa,6) + heperc(6,1) = per002(1,coquhe(lehexa,6)) +c +c Permutation 10 +c + hepers(1,10) = listso(2) + hepers(2,10) = listso(5) + hepers(3,10) = listso(8) + hepers(4,10) = listso(3) + hepers(5,10) = listso(6) + hepers(6,10) = listso(1) + hepers(7,10) = listso(4) + hepers(8,10) = listso(7) +c + hepera(1,10) = listar(6) + hepera(2,10) = listar(3) + hepera(3,10) = listar(11) + hepera(4,10) = listar(8) + hepera(5,10) = listar(1) + hepera(6,10) = listar(9) + hepera(7,10) = listar(4) + hepera(8,10) = listar(12) + hepera(9,10) = listar(5) + hepera(10,10) = listar(2) + hepera(11,10) = listar(10) + hepera(12,10) = listar(7) +c + heperf(1,10) = quahex(lehexa,4) + heperc(1,10) = per002(2,coquhe(lehexa,4)) + heperf(2,10) = quahex(lehexa,2) + heperc(2,10) = per002(1,coquhe(lehexa,2)) + heperf(3,10) = quahex(lehexa,1) + heperc(3,10) = per002(1,coquhe(lehexa,1)) + heperf(4,10) = quahex(lehexa,6) + heperc(4,10) = per002(1,coquhe(lehexa,6)) + heperf(5,10) = quahex(lehexa,5) + heperc(5,10) = per002(1,coquhe(lehexa,5)) + heperf(6,10) = quahex(lehexa,3) + heperc(6,10) = per002(1,coquhe(lehexa,3)) +c +c Permutation 20 +c + hepers(1,20) = listso(5) + hepers(2,20) = listso(6) + hepers(3,20) = listso(7) + hepers(4,20) = listso(8) + hepers(5,20) = listso(1) + hepers(6,20) = listso(2) + hepers(7,20) = listso(3) + hepers(8,20) = listso(4) +c + hepera(1,20) = listar(9) + hepera(2,20) = listar(11) + hepera(3,20) = listar(10) + hepera(4,20) = listar(12) + hepera(5,20) = listar(6) + hepera(6,20) = listar(5) + hepera(7,20) = listar(8) + hepera(8,20) = listar(7) + hepera(9,20) = listar(1) + hepera(10,20) = listar(3) + hepera(11,20) = listar(2) + hepera(12,20) = listar(4) +c + heperf(1,20) = quahex(lehexa,6) + heperc(1,20) = per002(1,coquhe(lehexa,6)) + heperf(2,20) = quahex(lehexa,2) + heperc(2,20) = per002(1,coquhe(lehexa,2)) + heperf(3,20) = quahex(lehexa,4) + heperc(3,20) = per002(1,coquhe(lehexa,4)) + heperf(4,20) = quahex(lehexa,3) + heperc(4,20) = per002(1,coquhe(lehexa,3)) + heperf(5,20) = quahex(lehexa,5) + heperc(5,20) = per002(1,coquhe(lehexa,5)) + heperf(6,20) = quahex(lehexa,1) + heperc(6,20) = per002(1,coquhe(lehexa,1)) +c +c Permutation 21 +c + hepers(1,21) = listso(8) + hepers(2,21) = listso(5) + hepers(3,21) = listso(6) + hepers(4,21) = listso(7) + hepers(5,21) = listso(2) + hepers(6,21) = listso(3) + hepers(7,21) = listso(4) + hepers(8,21) = listso(1) +c + hepera(1,21) = listar(11) + hepera(2,21) = listar(12) + hepera(3,21) = listar(9) + hepera(4,21) = listar(10) + hepera(5,21) = listar(8) + hepera(6,21) = listar(6) + hepera(7,21) = listar(7) + hepera(8,21) = listar(5) + hepera(9,21) = listar(3) + hepera(10,21) = listar(4) + hepera(11,21) = listar(1) + hepera(12,21) = listar(2) +c + heperf(1,21) = quahex(lehexa,6) + heperc(1,21) = per002(4,coquhe(lehexa,6)) + heperf(2,21) = quahex(lehexa,4) + heperc(2,21) = per002(1,coquhe(lehexa,4)) + heperf(3,21) = quahex(lehexa,5) + heperc(3,21) = per002(1,coquhe(lehexa,5)) + heperf(4,21) = quahex(lehexa,2) + heperc(4,21) = per002(1,coquhe(lehexa,2)) + heperf(5,21) = quahex(lehexa,3) + heperc(5,21) = per002(1,coquhe(lehexa,3)) + heperf(6,21) = quahex(lehexa,1) + heperc(6,21) = per002(1,coquhe(lehexa,1)) +c +c Permutation 30 +c + hepers(1,30) = listso(6) + hepers(2,30) = listso(1) + hepers(3,30) = listso(4) + hepers(4,30) = listso(7) + hepers(5,30) = listso(2) + hepers(6,30) = listso(5) + hepers(7,30) = listso(8) + hepers(8,30) = listso(3) +c + hepera(1,30) = listar(5) + hepera(2,30) = listar(10) + hepera(3,30) = listar(2) + hepera(4,30) = listar(7) + hepera(5,30) = listar(9) + hepera(6,30) = listar(1) + hepera(7,30) = listar(12) + hepera(8,30) = listar(4) + hepera(9,30) = listar(6) + hepera(10,30) = listar(11) + hepera(11,30) = listar(3) + hepera(12,30) = listar(8) +c + heperf(1,30) = quahex(lehexa,3) + heperc(1,30) = per002(4,coquhe(lehexa,3)) + heperf(2,30) = quahex(lehexa,2) + heperc(2,30) = per002(1,coquhe(lehexa,2)) + heperf(3,30) = quahex(lehexa,6) + heperc(3,30) = per002(1,coquhe(lehexa,6)) + heperf(4,30) = quahex(lehexa,1) + heperc(4,30) = per002(1,coquhe(lehexa,1)) + heperf(5,30) = quahex(lehexa,5) + heperc(5,30) = per002(1,coquhe(lehexa,5)) + heperf(6,30) = quahex(lehexa,4) + heperc(6,30) = per002(1,coquhe(lehexa,4)) +c +c Permutation 100 +c + hepers(1,100) = listso(6) + hepers(2,100) = listso(5) + hepers(3,100) = listso(2) + hepers(4,100) = listso(1) + hepers(5,100) = listso(8) + hepers(6,100) = listso(7) + hepers(7,100) = listso(4) + hepers(8,100) = listso(3) +c + hepera(1,100) = listar(9) + hepera(2,100) = listar(5) + hepera(3,100) = listar(6) + hepera(4,100) = listar(1) + hepera(5,100) = listar(10) + hepera(6,100) = listar(11) + hepera(7,100) = listar(2) + hepera(8,100) = listar(3) + hepera(9,100) = listar(12) + hepera(10,100) = listar(7) + hepera(11,100) = listar(8) + hepera(12,100) = listar(4) +c + heperf(1,100) = quahex(lehexa,2) + heperc(1,100) = per002(3,coquhe(lehexa,2)) + heperf(2,100) = quahex(lehexa,6) + heperc(2,100) = per002(1,coquhe(lehexa,6)) + heperf(3,100) = quahex(lehexa,3) + heperc(3,100) = per002(1,coquhe(lehexa,3)) + heperf(4,100) = quahex(lehexa,4) + heperc(4,100) = per002(1,coquhe(lehexa,4)) + heperf(5,100) = quahex(lehexa,1) + heperc(5,100) = per002(1,coquhe(lehexa,1)) + heperf(6,100) = quahex(lehexa,5) + heperc(6,100) = per002(1,coquhe(lehexa,5)) +c +c Permutation 101 +c + hepers(1,101) = listso(1) + hepers(2,101) = listso(6) + hepers(3,101) = listso(5) + hepers(4,101) = listso(2) + hepers(5,101) = listso(7) + hepers(6,101) = listso(4) + hepers(7,101) = listso(3) + hepers(8,101) = listso(8) +c + hepera(1,101) = listar(5) + hepera(2,101) = listar(1) + hepera(3,101) = listar(9) + hepera(4,101) = listar(6) + hepera(5,101) = listar(2) + hepera(6,101) = listar(10) + hepera(7,101) = listar(3) + hepera(8,101) = listar(11) + hepera(9,101) = listar(7) + hepera(10,101) = listar(4) + hepera(11,101) = listar(12) + hepera(12,101) = listar(8) +c + heperf(1,101) = quahex(lehexa,2) + heperc(1,101) = per002(2,coquhe(lehexa,2)) + heperf(2,101) = quahex(lehexa,3) + heperc(2,101) = per002(1,coquhe(lehexa,3)) + heperf(3,101) = quahex(lehexa,1) + heperc(3,101) = per002(1,coquhe(lehexa,1)) + heperf(4,101) = quahex(lehexa,6) + heperc(4,101) = per002(1,coquhe(lehexa,6)) + heperf(5,101) = quahex(lehexa,4) + heperc(5,101) = per002(1,coquhe(lehexa,4)) + heperf(6,101) = quahex(lehexa,5) + heperc(6,101) = per002(1,coquhe(lehexa,5)) +c +c Permutation 110 +c + hepers(1,110) = listso(5) + hepers(2,110) = listso(8) + hepers(3,110) = listso(3) + hepers(4,110) = listso(2) + hepers(5,110) = listso(7) + hepers(6,110) = listso(6) + hepers(7,110) = listso(1) + hepers(8,110) = listso(4) +c + hepera(1,110) = listar(11) + hepera(2,110) = listar(6) + hepera(3,110) = listar(8) + hepera(4,110) = listar(3) + hepera(5,110) = listar(9) + hepera(6,110) = listar(12) + hepera(7,110) = listar(1) + hepera(8,110) = listar(4) + hepera(9,110) = listar(10) + hepera(10,110) = listar(5) + hepera(11,110) = listar(7) + hepera(12,110) = listar(2) +c + heperf(1,110) = quahex(lehexa,4) + heperc(1,110) = per002(3,coquhe(lehexa,4)) + heperf(2,110) = quahex(lehexa,6) + heperc(2,110) = per002(1,coquhe(lehexa,6)) + heperf(3,110) = quahex(lehexa,2) + heperc(3,110) = per002(1,coquhe(lehexa,2)) + heperf(4,110) = quahex(lehexa,5) + heperc(4,110) = per002(1,coquhe(lehexa,5)) + heperf(5,110) = quahex(lehexa,1) + heperc(5,110) = per002(1,coquhe(lehexa,1)) + heperf(6,110) = quahex(lehexa,3) + heperc(6,110) = per002(1,coquhe(lehexa,3)) +c +c Permutation 120 +c + hepers(1,120) = listso(8) + hepers(2,120) = listso(7) + hepers(3,120) = listso(4) + hepers(4,120) = listso(3) + hepers(5,120) = listso(6) + hepers(6,120) = listso(5) + hepers(7,120) = listso(2) + hepers(8,120) = listso(1) +c + hepera(1,120) = listar(12) + hepera(2,120) = listar(8) + hepera(3,120) = listar(7) + hepera(4,120) = listar(4) + hepera(5,120) = listar(11) + hepera(6,120) = listar(10) + hepera(7,120) = listar(3) + hepera(8,120) = listar(2) + hepera(9,120) = listar(9) + hepera(10,120) = listar(6) + hepera(11,120) = listar(5) + hepera(12,120) = listar(1) +c + heperf(1,120) = quahex(lehexa,5) + heperc(1,120) = per002(3,coquhe(lehexa,5)) + heperf(2,120) = quahex(lehexa,6) + heperc(2,120) = per002(1,coquhe(lehexa,6)) + heperf(3,120) = quahex(lehexa,4) + heperc(3,120) = per002(1,coquhe(lehexa,4)) + heperf(4,120) = quahex(lehexa,3) + heperc(4,120) = per002(1,coquhe(lehexa,3)) + heperf(5,120) = quahex(lehexa,1) + heperc(5,120) = per002(1,coquhe(lehexa,1)) + heperf(6,120) = quahex(lehexa,2) + heperc(6,120) = per002(1,coquhe(lehexa,2)) +c +c Permutation 121 +c + hepers(1,121) = listso(3) + hepers(2,121) = listso(8) + hepers(3,121) = listso(7) + hepers(4,121) = listso(4) + hepers(5,121) = listso(5) + hepers(6,121) = listso(2) + hepers(7,121) = listso(1) + hepers(8,121) = listso(6) +c + hepera(1,121) = listar(8) + hepera(2,121) = listar(4) + hepera(3,121) = listar(12) + hepera(4,121) = listar(7) + hepera(5,121) = listar(3) + hepera(6,121) = listar(11) + hepera(7,121) = listar(2) + hepera(8,121) = listar(10) + hepera(9,121) = listar(6) + hepera(10,121) = listar(1) + hepera(11,121) = listar(9) + hepera(12,121) = listar(5) +c + heperf(1,121) = quahex(lehexa,5) + heperc(1,121) = per002(2,coquhe(lehexa,5)) + heperf(2,121) = quahex(lehexa,4) + heperc(2,121) = per002(1,coquhe(lehexa,4)) + heperf(3,121) = quahex(lehexa,1) + heperc(3,121) = per002(1,coquhe(lehexa,1)) + heperf(4,121) = quahex(lehexa,6) + heperc(4,121) = per002(1,coquhe(lehexa,6)) + heperf(5,121) = quahex(lehexa,3) + heperc(5,121) = per002(1,coquhe(lehexa,3)) + heperf(6,121) = quahex(lehexa,2) + heperc(6,121) = per002(1,coquhe(lehexa,2)) +c +c Permutation 130 +c + hepers(1,130) = listso(7) + hepers(2,130) = listso(6) + hepers(3,130) = listso(1) + hepers(4,130) = listso(4) + hepers(5,130) = listso(5) + hepers(6,130) = listso(8) + hepers(7,130) = listso(3) + hepers(8,130) = listso(2) +c + hepera(1,130) = listar(10) + hepera(2,130) = listar(7) + hepera(3,130) = listar(5) + hepera(4,130) = listar(2) + hepera(5,130) = listar(12) + hepera(6,130) = listar(9) + hepera(7,130) = listar(4) + hepera(8,130) = listar(1) + hepera(9,130) = listar(11) + hepera(10,130) = listar(8) + hepera(11,130) = listar(6) + hepera(12,130) = listar(3) +c + heperf(1,130) = quahex(lehexa,3) + heperc(1,130) = per002(3,coquhe(lehexa,3)) + heperf(2,130) = quahex(lehexa,6) + heperc(2,130) = per002(1,coquhe(lehexa,6)) + heperf(3,130) = quahex(lehexa,5) + heperc(3,130) = per002(1,coquhe(lehexa,5)) + heperf(4,130) = quahex(lehexa,2) + heperc(4,130) = per002(1,coquhe(lehexa,2)) + heperf(5,130) = quahex(lehexa,1) + heperc(5,130) = per002(1,coquhe(lehexa,1)) + heperf(6,130) = quahex(lehexa,4) + heperc(6,130) = per002(1,coquhe(lehexa,4)) +c +c Permutation 200 +c + hepers(1,200) = listso(7) + hepers(2,200) = listso(8) + hepers(3,200) = listso(5) + hepers(4,200) = listso(6) + hepers(5,200) = listso(3) + hepers(6,200) = listso(4) + hepers(7,200) = listso(1) + hepers(8,200) = listso(2) +c + hepera(1,200) = listar(12) + hepera(2,200) = listar(10) + hepera(3,200) = listar(11) + hepera(4,200) = listar(9) + hepera(5,200) = listar(7) + hepera(6,200) = listar(8) + hepera(7,200) = listar(5) + hepera(8,200) = listar(6) + hepera(9,200) = listar(4) + hepera(10,200) = listar(2) + hepera(11,200) = listar(3) + hepera(12,200) = listar(1) +c + heperf(1,200) = quahex(lehexa,6) + heperc(1,200) = per002(3,coquhe(lehexa,6)) + heperf(2,200) = quahex(lehexa,5) + heperc(2,200) = per002(1,coquhe(lehexa,5)) + heperf(3,200) = quahex(lehexa,3) + heperc(3,200) = per002(1,coquhe(lehexa,3)) + heperf(4,200) = quahex(lehexa,4) + heperc(4,200) = per002(1,coquhe(lehexa,4)) + heperf(5,200) = quahex(lehexa,2) + heperc(5,200) = per002(1,coquhe(lehexa,2)) + heperf(6,200) = quahex(lehexa,1) + heperc(6,200) = per002(1,coquhe(lehexa,1)) +c +c Permutation 201 +c + hepers(1,201) = listso(6) + hepers(2,201) = listso(7) + hepers(3,201) = listso(8) + hepers(4,201) = listso(5) + hepers(5,201) = listso(4) + hepers(6,201) = listso(1) + hepers(7,201) = listso(2) + hepers(8,201) = listso(3) +c + hepera(1,201) = listar(10) + hepera(2,201) = listar(9) + hepera(3,201) = listar(12) + hepera(4,201) = listar(11) + hepera(5,201) = listar(5) + hepera(6,201) = listar(7) + hepera(7,201) = listar(6) + hepera(8,201) = listar(8) + hepera(9,201) = listar(2) + hepera(10,201) = listar(1) + hepera(11,201) = listar(4) + hepera(12,201) = listar(3) +c + heperf(1,201) = quahex(lehexa,6) + heperc(1,201) = per002(2,coquhe(lehexa,6)) + heperf(2,201) = quahex(lehexa,3) + heperc(2,201) = per002(1,coquhe(lehexa,3)) + heperf(3,201) = quahex(lehexa,2) + heperc(3,201) = per002(1,coquhe(lehexa,2)) + heperf(4,201) = quahex(lehexa,5) + heperc(4,201) = per002(1,coquhe(lehexa,5)) + heperf(5,201) = quahex(lehexa,4) + heperc(5,201) = per002(1,coquhe(lehexa,4)) + heperf(6,201) = quahex(lehexa,1) + heperc(6,201) = per002(1,coquhe(lehexa,1)) +c +c Permutation 210 +c + hepers(1,210) = listso(8) + hepers(2,210) = listso(3) + hepers(3,210) = listso(2) + hepers(4,210) = listso(5) + hepers(5,210) = listso(4) + hepers(6,210) = listso(7) + hepers(7,210) = listso(6) + hepers(8,210) = listso(1) +c + hepera(1,210) = listar(8) + hepera(2,210) = listar(11) + hepera(3,210) = listar(3) + hepera(4,210) = listar(6) + hepera(5,210) = listar(12) + hepera(6,210) = listar(4) + hepera(7,210) = listar(9) + hepera(8,210) = listar(1) + hepera(9,210) = listar(7) + hepera(10,210) = listar(10) + hepera(11,210) = listar(2) + hepera(12,210) = listar(5) +c + heperf(1,210) = quahex(lehexa,4) + heperc(1,210) = per002(4,coquhe(lehexa,4)) + heperf(2,210) = quahex(lehexa,5) + heperc(2,210) = per002(1,coquhe(lehexa,5)) + heperf(3,210) = quahex(lehexa,6) + heperc(3,210) = per002(1,coquhe(lehexa,6)) + heperf(4,210) = quahex(lehexa,1) + heperc(4,210) = per002(1,coquhe(lehexa,1)) + heperf(5,210) = quahex(lehexa,2) + heperc(5,210) = per002(1,coquhe(lehexa,2)) + heperf(6,210) = quahex(lehexa,3) + heperc(6,210) = per002(1,coquhe(lehexa,3)) +c +c Permutation 220 +c + hepers(1,220) = listso(3) + hepers(2,220) = listso(4) + hepers(3,220) = listso(1) + hepers(4,220) = listso(2) + hepers(5,220) = listso(7) + hepers(6,220) = listso(8) + hepers(7,220) = listso(5) + hepers(8,220) = listso(6) +c + hepera(1,220) = listar(4) + hepera(2,220) = listar(3) + hepera(3,220) = listar(2) + hepera(4,220) = listar(1) + hepera(5,220) = listar(8) + hepera(6,220) = listar(7) + hepera(7,220) = listar(6) + hepera(8,220) = listar(5) + hepera(9,220) = listar(12) + hepera(10,220) = listar(11) + hepera(11,220) = listar(10) + hepera(12,220) = listar(9) +c + heperf(1,220) = quahex(lehexa,1) + heperc(1,220) = per002(1,coquhe(lehexa,1)) + heperf(2,220) = quahex(lehexa,5) + heperc(2,220) = per002(1,coquhe(lehexa,5)) + heperf(3,220) = quahex(lehexa,4) + heperc(3,220) = per002(1,coquhe(lehexa,4)) + heperf(4,220) = quahex(lehexa,3) + heperc(4,220) = per002(1,coquhe(lehexa,3)) + heperf(5,220) = quahex(lehexa,2) + heperc(5,220) = per002(1,coquhe(lehexa,2)) + heperf(6,220) = quahex(lehexa,6) + heperc(6,220) = per002(1,coquhe(lehexa,6)) +c +c Permutation 221 +c + hepers(1,221) = listso(2) + hepers(2,221) = listso(3) + hepers(3,221) = listso(4) + hepers(4,221) = listso(1) + hepers(5,221) = listso(8) + hepers(6,221) = listso(5) + hepers(7,221) = listso(6) + hepers(8,221) = listso(7) +c + hepera(1,221) = listar(3) + hepera(2,221) = listar(1) + hepera(3,221) = listar(4) + hepera(4,221) = listar(2) + hepera(5,221) = listar(6) + hepera(6,221) = listar(8) + hepera(7,221) = listar(5) + hepera(8,221) = listar(7) + hepera(9,221) = listar(11) + hepera(10,221) = listar(9) + hepera(11,221) = listar(12) + hepera(12,221) = listar(10) +c + heperf(1,221) = quahex(lehexa,1) + heperc(1,221) = per002(1,coquhe(lehexa,1)) + heperf(2,221) = quahex(lehexa,4) + heperc(2,221) = per002(1,coquhe(lehexa,4)) + heperf(3,221) = quahex(lehexa,2) + heperc(3,221) = per002(1,coquhe(lehexa,2)) + heperf(4,221) = quahex(lehexa,5) + heperc(4,221) = per002(1,coquhe(lehexa,5)) + heperf(5,221) = quahex(lehexa,3) + heperc(5,221) = per002(1,coquhe(lehexa,3)) + heperf(6,221) = quahex(lehexa,6) + heperc(6,221) = per002(1,coquhe(lehexa,6)) +c +c Permutation 230 +c + hepers(1,230) = listso(4) + hepers(2,230) = listso(7) + hepers(3,230) = listso(6) + hepers(4,230) = listso(1) + hepers(5,230) = listso(8) + hepers(6,230) = listso(3) + hepers(7,230) = listso(2) + hepers(8,230) = listso(5) +c + hepera(1,230) = listar(7) + hepera(2,230) = listar(2) + hepera(3,230) = listar(10) + hepera(4,230) = listar(5) + hepera(5,230) = listar(4) + hepera(6,230) = listar(12) + hepera(7,230) = listar(1) + hepera(8,230) = listar(9) + hepera(9,230) = listar(8) + hepera(10,230) = listar(3) + hepera(11,230) = listar(11) + hepera(12,230) = listar(6) +c + heperf(1,230) = quahex(lehexa,3) + heperc(1,230) = per002(2,coquhe(lehexa,3)) + heperf(2,230) = quahex(lehexa,5) + heperc(2,230) = per002(1,coquhe(lehexa,5)) + heperf(3,230) = quahex(lehexa,1) + heperc(3,230) = per002(1,coquhe(lehexa,1)) + heperf(4,230) = quahex(lehexa,6) + heperc(4,230) = per002(1,coquhe(lehexa,6)) + heperf(5,230) = quahex(lehexa,2) + heperc(5,230) = per002(1,coquhe(lehexa,2)) + heperf(6,230) = quahex(lehexa,4) + heperc(6,230) = per002(1,coquhe(lehexa,4)) +c +c Permutation 300 +c + hepers(1,300) = listso(4) + hepers(2,300) = listso(3) + hepers(3,300) = listso(8) + hepers(4,300) = listso(7) + hepers(5,300) = listso(2) + hepers(6,300) = listso(1) + hepers(7,300) = listso(6) + hepers(8,300) = listso(5) +c + hepera(1,300) = listar(4) + hepera(2,300) = listar(7) + hepera(3,300) = listar(8) + hepera(4,300) = listar(12) + hepera(5,300) = listar(2) + hepera(6,300) = listar(3) + hepera(7,300) = listar(10) + hepera(8,300) = listar(11) + hepera(9,300) = listar(1) + hepera(10,300) = listar(5) + hepera(11,300) = listar(6) + hepera(12,300) = listar(9) +c + heperf(1,300) = quahex(lehexa,5) + heperc(1,300) = per002(1,coquhe(lehexa,5)) + heperf(2,300) = quahex(lehexa,1) + heperc(2,300) = per002(1,coquhe(lehexa,1)) + heperf(3,300) = quahex(lehexa,3) + heperc(3,300) = per002(1,coquhe(lehexa,3)) + heperf(4,300) = quahex(lehexa,4) + heperc(4,300) = per002(1,coquhe(lehexa,4)) + heperf(5,300) = quahex(lehexa,6) + heperc(5,300) = per002(1,coquhe(lehexa,6)) + heperf(6,300) = quahex(lehexa,2) + heperc(6,300) = per002(1,coquhe(lehexa,2)) +c +c Permutation 301 +c + hepers(1,301) = listso(7) + hepers(2,301) = listso(4) + hepers(3,301) = listso(3) + hepers(4,301) = listso(8) + hepers(5,301) = listso(1) + hepers(6,301) = listso(6) + hepers(7,301) = listso(5) + hepers(8,301) = listso(2) +c + hepera(1,301) = listar(7) + hepera(2,301) = listar(12) + hepera(3,301) = listar(4) + hepera(4,301) = listar(8) + hepera(5,301) = listar(10) + hepera(6,301) = listar(2) + hepera(7,301) = listar(11) + hepera(8,301) = listar(3) + hepera(9,301) = listar(5) + hepera(10,301) = listar(9) + hepera(11,301) = listar(1) + hepera(12,301) = listar(6) +c + heperf(1,301) = quahex(lehexa,5) + heperc(1,301) = per002(4,coquhe(lehexa,5)) + heperf(2,301) = quahex(lehexa,3) + heperc(2,301) = per002(1,coquhe(lehexa,3)) + heperf(3,301) = quahex(lehexa,6) + heperc(3,301) = per002(1,coquhe(lehexa,6)) + heperf(4,301) = quahex(lehexa,1) + heperc(4,301) = per002(1,coquhe(lehexa,1)) + heperf(5,301) = quahex(lehexa,4) + heperc(5,301) = per002(1,coquhe(lehexa,4)) + heperf(6,301) = quahex(lehexa,2) + heperc(6,301) = per002(1,coquhe(lehexa,2)) +c +c Permutation 310 +c + hepers(1,310) = listso(3) + hepers(2,310) = listso(2) + hepers(3,310) = listso(5) + hepers(4,310) = listso(8) + hepers(5,310) = listso(1) + hepers(6,310) = listso(4) + hepers(7,310) = listso(7) + hepers(8,310) = listso(6) +c + hepera(1,310) = listar(3) + hepera(2,310) = listar(8) + hepera(3,310) = listar(6) + hepera(4,310) = listar(11) + hepera(5,310) = listar(4) + hepera(6,310) = listar(1) + hepera(7,310) = listar(12) + hepera(8,310) = listar(9) + hepera(9,310) = listar(2) + hepera(10,310) = listar(7) + hepera(11,310) = listar(5) + hepera(12,310) = listar(10) +c + heperf(1,310) = quahex(lehexa,4) + heperc(1,310) = per002(1,coquhe(lehexa,4)) + heperf(2,310) = quahex(lehexa,1) + heperc(2,310) = per002(1,coquhe(lehexa,1)) + heperf(3,310) = quahex(lehexa,5) + heperc(3,310) = per002(1,coquhe(lehexa,5)) + heperf(4,310) = quahex(lehexa,2) + heperc(4,310) = per002(1,coquhe(lehexa,2)) + heperf(5,310) = quahex(lehexa,6) + heperc(5,310) = per002(1,coquhe(lehexa,6)) + heperf(6,310) = quahex(lehexa,3) + heperc(6,310) = per002(1,coquhe(lehexa,3)) +c +c Permutation 320 +c + hepers(1,320) = listso(2) + hepers(2,320) = listso(1) + hepers(3,320) = listso(6) + hepers(4,320) = listso(5) + hepers(5,320) = listso(4) + hepers(6,320) = listso(3) + hepers(7,320) = listso(8) + hepers(8,320) = listso(7) +c + hepera(1,320) = listar(1) + hepera(2,320) = listar(6) + hepera(3,320) = listar(5) + hepera(4,320) = listar(9) + hepera(5,320) = listar(3) + hepera(6,320) = listar(2) + hepera(7,320) = listar(11) + hepera(8,320) = listar(10) + hepera(9,320) = listar(4) + hepera(10,320) = listar(8) + hepera(11,320) = listar(7) + hepera(12,320) = listar(12) +c + heperf(1,320) = quahex(lehexa,2) + heperc(1,320) = per002(1,coquhe(lehexa,2)) + heperf(2,320) = quahex(lehexa,1) + heperc(2,320) = per002(1,coquhe(lehexa,1)) + heperf(3,320) = quahex(lehexa,4) + heperc(3,320) = per002(1,coquhe(lehexa,4)) + heperf(4,320) = quahex(lehexa,3) + heperc(4,320) = per002(1,coquhe(lehexa,3)) + heperf(5,320) = quahex(lehexa,6) + heperc(5,320) = per002(1,coquhe(lehexa,6)) + heperf(6,320) = quahex(lehexa,5) + heperc(6,320) = per002(1,coquhe(lehexa,5)) +c +c Permutation 321 +c + hepers(1,321) = listso(5) + hepers(2,321) = listso(2) + hepers(3,321) = listso(1) + hepers(4,321) = listso(6) + hepers(5,321) = listso(3) + hepers(6,321) = listso(8) + hepers(7,321) = listso(7) + hepers(8,321) = listso(4) +c + hepera(1,321) = listar(6) + hepera(2,321) = listar(9) + hepera(3,321) = listar(1) + hepera(4,321) = listar(5) + hepera(5,321) = listar(11) + hepera(6,321) = listar(3) + hepera(7,321) = listar(10) + hepera(8,321) = listar(2) + hepera(9,321) = listar(8) + hepera(10,321) = listar(12) + hepera(11,321) = listar(4) + hepera(12,321) = listar(7) +c + heperf(1,321) = quahex(lehexa,2) + heperc(1,321) = per002(4,coquhe(lehexa,2)) + heperf(2,321) = quahex(lehexa,4) + heperc(2,321) = per002(1,coquhe(lehexa,4)) + heperf(3,321) = quahex(lehexa,6) + heperc(3,321) = per002(1,coquhe(lehexa,6)) + heperf(4,321) = quahex(lehexa,1) + heperc(4,321) = per002(1,coquhe(lehexa,1)) + heperf(5,321) = quahex(lehexa,3) + heperc(5,321) = per002(1,coquhe(lehexa,3)) + heperf(6,321) = quahex(lehexa,5) + heperc(6,321) = per002(1,coquhe(lehexa,5)) +c +c Permutation 330 +c + hepers(1,330) = listso(1) + hepers(2,330) = listso(4) + hepers(3,330) = listso(7) + hepers(4,330) = listso(6) + hepers(5,330) = listso(3) + hepers(6,330) = listso(2) + hepers(7,330) = listso(5) + hepers(8,330) = listso(8) +c + hepera(1,330) = listar(2) + hepera(2,330) = listar(5) + hepera(3,330) = listar(7) + hepera(4,330) = listar(10) + hepera(5,330) = listar(1) + hepera(6,330) = listar(4) + hepera(7,330) = listar(9) + hepera(8,330) = listar(12) + hepera(9,330) = listar(3) + hepera(10,330) = listar(6) + hepera(11,330) = listar(8) + hepera(12,330) = listar(11) +c + heperf(1,330) = quahex(lehexa,3) + heperc(1,330) = per002(1,coquhe(lehexa,3)) + heperf(2,330) = quahex(lehexa,1) + heperc(2,330) = per002(1,coquhe(lehexa,1)) + heperf(3,330) = quahex(lehexa,2) + heperc(3,330) = per002(1,coquhe(lehexa,2)) + heperf(4,330) = quahex(lehexa,5) + heperc(4,330) = per002(1,coquhe(lehexa,5)) + heperf(5,330) = quahex(lehexa,6) + heperc(5,330) = per002(1,coquhe(lehexa,6)) + heperf(6,330) = quahex(lehexa,4) + heperc(6,330) = per002(1,coquhe(lehexa,4)) diff --git a/src/tool/Includes_Generaux/i1i2i3.h b/src/tool/Includes_Generaux/i1i2i3.h new file mode 100644 index 00000000..8affd570 --- /dev/null +++ b/src/tool/Includes_Generaux/i1i2i3.h @@ -0,0 +1,11 @@ +c +c======================================================================= +c correspondance entre le code d'une face dans un tetraedre et les +c numeros locaux des aretes de cette face +c----------------------------------------------------------------------- +c i1(c) : numero local de la premiere arete d'une face de code c +c i2(c) : numero local de la deuxieme arete d'une face de code c +c i3(c) : numero local de la troisieme arete d'une face de code c +c----------------------------------------------------------------------- + integer i1(6), i2(6), i3(6) + common /i1i2i3/ i1, i2, i3 diff --git a/src/tool/Includes_Generaux/impr01.h b/src/tool/Includes_Generaux/impr01.h new file mode 100644 index 00000000..17bad716 --- /dev/null +++ b/src/tool/Includes_Generaux/impr01.h @@ -0,0 +1,7 @@ + texte(1,1) = '(/,a,'' du sous-programme '',a,/)' + texte(1,2) = '(''Probleme : code retour ='',i6,/)' + texte(1,3) = '(a,'' est appele par '',a)' +c + texte(2,1) = '(/,a,'' of '',a,'' subroutine'',/)' + texte(2,2) = '(''Problem : error code ='',i6,/)' + texte(2,3) = '(a,'' is called by '',a)' diff --git a/src/tool/Includes_Generaux/impr02.h b/src/tool/Includes_Generaux/impr02.h new file mode 100644 index 00000000..e7999d68 --- /dev/null +++ b/src/tool/Includes_Generaux/impr02.h @@ -0,0 +1,2 @@ + character*14 mess14(2,5,-1:13) + common /impr02/ mess14 diff --git a/src/tool/Includes_Generaux/impr03.h b/src/tool/Includes_Generaux/impr03.h new file mode 100644 index 00000000..c784d9ef --- /dev/null +++ b/src/tool/Includes_Generaux/impr03.h @@ -0,0 +1,48 @@ +c +90000 format(/,80('*')) +c Caracteres + Entiers +90001 format(a,i10,' : ',10i10) +90002 format('... ',a,' : ',10i10) +90012 format('... ',a,i10,' : ',10i10) +90022 format('... ',a,i10,' : ',20i10) +90032 format(/,'... ',a,' : ',10i10) +90112 format('... ',a,'(',i10,') : ',20i10) +90122 format('... ',a,'(',i10,',',i10,') : ',20i10) +90064 format('... ',i6,' : ',a,a) +90005 format('... ',a,' : ',20i10) +90015 format('... ',a,i10,a,20i10) +90016 format('... ',a,'(',i10,') : ',a) +90006 format(5(a,i10,', ')) +90007 format(a,'(',i5,',',i5,') =',i10) +c Caracteres + Logiques +99001 format('... ',a,' :',10l2) +99002 format('... ',a,' : ',10(l1,', ')) +c Caracteres + Reels +90004 format('... ',a,' : ',10g13.5) +90104 format(a,' : ',10g13.5) +90034 format('... ',5(a,' : ',g15.7,', ')) +c Entiers + Reels +90014 format('... ',i6,' : ',10g13.5) +c Caracteres + Entiers + Reels +90024 format('... ',a,i10,' : ',10g13.5) +90044 format('... ',a,g13.5,a,i10) +90054 format('... ',a,i10,a,10g13.5) +90114 format('... ',a,'(',i10,') : ',10g13.5) +90124 format('... ',a,'(',i10,',',i10,') : ',10g13.5) +c Caracteres +90003 format('... ',a,' :',10(1x,a)) +93010 format(10(a,', ')) +93020 format('... ',a,' : ',10(a,', ')) +93030 format('... ',a) +93080 format(10a8) +c Entiers +91010 format(10i10) +91011 format(10i2,' -',10i2) +91020 format(20i6) +91030 format(30i2) +91040 format(25i3) +91140 format(10(i5,' : ',i3)) +91141 format(5(i5,' : ',i15)) +c Reels +92010 format(10g16.8) +c diff --git a/src/tool/Includes_Generaux/impr04.h b/src/tool/Includes_Generaux/impr04.h new file mode 100644 index 00000000..07001753 --- /dev/null +++ b/src/tool/Includes_Generaux/impr04.h @@ -0,0 +1,10 @@ +91000 format('.. aretes de',i10,' a',i10) +92000 format('.. triangles de',i10,' a',i10) +93000 format('.. tetraedres de',i10,' a',i10) +94000 format('.. quadrangles de',i10,' a',i10) +95000 format('.. pyramides de',i10,' a',i10) +96000 format('.. hexaedres de',i10,' a',i10) +97000 format('.. pentaedres de',i10,' a',i10) +98000 format('.. noeuds de',i10,' a',i10) +91001 format('.. arete',i2,' :',i10,', etat =',i10) +91002 format('.. arete',i2,' :',i10,', de',i10,' a',i10,', etat =',i10) diff --git a/src/tool/Includes_Generaux/impr05.h b/src/tool/Includes_Generaux/impr05.h new file mode 100644 index 00000000..b6e424fa --- /dev/null +++ b/src/tool/Includes_Generaux/impr05.h @@ -0,0 +1,21 @@ +c + texte(1,4) = '(/,5x,''Indications sur les '',a)' + texte(1,5) = '(5x,''. Traitement du raffinement.'')' + texte(1,6) = '(5x,''. Traitement du deraffinement.'')' + texte(1,7) = + > '(5x,''Raffinement : niveau maximum autorise :'',i4)' + texte(1,8) = + > '(5x,''Deraffinement : niveau minimum autorise :'',i4)' + texte(1,9) = + > '(5x,i6,'' decisions ignorees par depassement de niveau.'')' + texte(1,10) = '(/,5x,''Apres initialisation des decisions :'')' +c + texte(2,4) = '(/,5x,''Indications over '',a)' + texte(2,5) = '(5x,''. Refinement examination'')' + texte(2,6) = '(5x,''. Unrefinement examination.'')' + texte(2,7) = '(5x,''Refinement : maximum authorized level :'',i4)' + texte(2,8) = + > '(5x,''Unrefinement : minimum authorized level :'',i4)' + texte(2,9) = + > '(5x,i6,'' decisions are ignored because of level.'')' + texte(2,10) = '(/,5x,''After initialisation of decisions :'')' diff --git a/src/tool/Includes_Generaux/impr06.h b/src/tool/Includes_Generaux/impr06.h new file mode 100644 index 00000000..a9923abc --- /dev/null +++ b/src/tool/Includes_Generaux/impr06.h @@ -0,0 +1,23 @@ +c + texte(1,11) = '(/,a,i12)' + texte(1,12) = + > '(''. Caracteristique '',i2,'' de la famille : '',i6)' + texte(1,13) = '(''. Historique = '',i6,'' ==> etat = '',i6)' + texte(1,14) = '(''. Creation de la maille '',i12)' + texte(1,15) = + >'(''Noeuds de la maille (numerotation du calcul) : '',/,10i12)' + texte(1,16) ='(''. Numero de la famille : '',i6)' + texte(1,17) = '(''Coordonnee constante incorrecte :'',i7)' + texte(1,18) = '(''Nombre de '',a,''du calcul :'',i10)' + texte(1,20) = '(''Les deux doivent etre egaux ...'')' +c + texte(2,11) = '(/,a,i12)' + texte(2,12) = '(''. Characterisc '',i2,'' of the family : '',i6)' + texte(2,13) = '(''. Historic = '',i6,'' ==> status = '',i6)' + texte(2,14) = '(''. Creation of mesh # '',i12)' + texte(2,15) = + > '(''Nodes of the mesh with calculation #: '',/,10i12)' + texte(2,16) ='(''. # for the family: '',i6)' + texte(2,17) = '(''Constant coordinate is wrong:'',i7)' + texte(2,18) = '(''Number of '',a,''for calculation:'',i10)' + texte(2,20) = '(''Both numbers should be equal ...'')' diff --git a/src/tool/Includes_Generaux/indefi.h b/src/tool/Includes_Generaux/indefi.h new file mode 100644 index 00000000..7912675a --- /dev/null +++ b/src/tool/Includes_Generaux/indefi.h @@ -0,0 +1,6 @@ +c +c iindef : valeur non definie pour les entiers +c + integer iindef +c + common /indefi/ iindef diff --git a/src/tool/Includes_Generaux/indefr.h b/src/tool/Includes_Generaux/indefr.h new file mode 100644 index 00000000..2b883e23 --- /dev/null +++ b/src/tool/Includes_Generaux/indefr.h @@ -0,0 +1,6 @@ +c +c rindef : valeur non definie pour les reels double precision +c + double precision rindef +c + common /indefr/ rindef diff --git a/src/tool/Includes_Generaux/indefs.h b/src/tool/Includes_Generaux/indefs.h new file mode 100644 index 00000000..c13bf058 --- /dev/null +++ b/src/tool/Includes_Generaux/indefs.h @@ -0,0 +1,6 @@ +c +c sindef : valeur non definie pour les caracteres +c + character*8 sindef +c + common /vindef/ sindef diff --git a/src/tool/Includes_Generaux/infini.h b/src/tool/Includes_Generaux/infini.h new file mode 100644 index 00000000..5e1db3d2 --- /dev/null +++ b/src/tool/Includes_Generaux/infini.h @@ -0,0 +1,10 @@ +c +c======================================================================= +c valeurs extremes pour une machine donnee +c----------------------------------------------------------------------- +c vinfne : la plus grande valeur negative +c vinfpo : la plus grande valeur positive +c zeroma : le zero de la machine +c----------------------------------------------------------------------- + double precision vinfne, vinfpo, zeroma + common /infini/ vinfne, vinfpo, zeroma diff --git a/src/tool/Includes_Generaux/j1234j.h b/src/tool/Includes_Generaux/j1234j.h new file mode 100644 index 00000000..e64026c6 --- /dev/null +++ b/src/tool/Includes_Generaux/j1234j.h @@ -0,0 +1,12 @@ +c +c======================================================================= +c correspondance entre le code d'une face dans un hexaaedre ou un +c pentaedre et les numeros locaux des aretes de cette face +c Pour une face de code c : +c j1(c) : numero local de l'arete I1 +c j2(c) : numero local de l'arete I2 +c j3(c) : numero local de l'arete I3 +c j4(c) : numero local de l'arete I4 +c----------------------------------------------------------------------- + integer j1(8), j2(8), j3(8), j4(8) + common /j1234j/ j1, j2, j3, j4 diff --git a/src/tool/Includes_Generaux/langue.h b/src/tool/Includes_Generaux/langue.h new file mode 100644 index 00000000..cecee947 --- /dev/null +++ b/src/tool/Includes_Generaux/langue.h @@ -0,0 +1,9 @@ +c +c Le parametre entier "langue" repere la langue d'affichage des +c messages, selon la codification suivante : +c +c 1 : francais +c 2 : anglais +c + integer langue + parameter ( langue = 1 ) diff --git a/src/tool/Includes_Generaux/litme0.h b/src/tool/Includes_Generaux/litme0.h new file mode 100644 index 00000000..39547e52 --- /dev/null +++ b/src/tool/Includes_Generaux/litme0.h @@ -0,0 +1,4 @@ + integer nbtmed + parameter ( nbtmed = 18 ) +c + integer litmed(0:nbtmed) diff --git a/src/tool/Includes_Generaux/litmed.h b/src/tool/Includes_Generaux/litmed.h new file mode 100644 index 00000000..2229a5e2 --- /dev/null +++ b/src/tool/Includes_Generaux/litmed.h @@ -0,0 +1,23 @@ +c +c Attention a conserver cet ordre pour les interpolations +c de solutions (pcsoqu et pcsohe en particulier) +c + litmed(0) = 0 + litmed(1) = edpoi1 + litmed(2) = edseg2 + litmed(3) = edseg3 + litmed(4) = edtri3 + litmed(5) = edtri6 + litmed(6) = edqua4 + litmed(7) = edqua8 + litmed(8) = edtet4 + litmed(9) = edte10 + litmed(10) = edpyr5 + litmed(11) = edpy13 + litmed(12) = edhex8 + litmed(13) = edhe20 + litmed(14) = edpen6 + litmed(15) = edpe15 + litmed(16) = edtri7 + litmed(17) = edqua9 + litmed(18) = edhe27 diff --git a/src/tool/Includes_Generaux/meddc0.h b/src/tool/Includes_Generaux/meddc0.h new file mode 100644 index 00000000..9b53b522 --- /dev/null +++ b/src/tool/Includes_Generaux/meddc0.h @@ -0,0 +1,280 @@ +c +c======================================================================= +c declaration de variables du format MED +c cet include est deduit de l'include med.h de la bibliotheque med 4.0 +c +c MED_FULL_INTERLACE/edfuin : +c Exemple avec 3 composantes X,Y,Z : X1Y1Z1X2Y2Z2X3Y3Z3... +c Exemple avec 3 MED_TRIA3 T1,T2,T3 : N11N12N13 N21N22N23 N31N32N33 +c MED_NO_INTERLACE/ednoin : +c Exemple avec 3 composantes X,Y,Z : X1X2X3Y1Y2Y3Z1Z2Z3... +c Exemple avec 3 MED_TRIA3 T1,T2,T3 : N11N21N31 N12N22N32 N13N23N33 +c + integer edfuin, ednoin + parameter ( + > edfuin = 0, + > ednoin = 1 + > ) +c +c Indique le mode de stockage utilise par l'application. +c MED_UNDEF_STMODE/edstmo : +c Mode de stockage en memoire non initialise +c MED_GLOBAL_STMODE/edstgl : +c Le stockage utilise contient en memoire toutes les valeurs +c relatives a toutes les entites d'un meme type +c MED_COMPACT_STMODE/edstco : +c Le stockage utilise contient en memoire contigüe un sous-ensemble +c de valeurs relatives a un sous-ensemble d'entites d'un meme type. +c + integer edstmo, edstgl, edstco + parameter ( + > edstmo = 0, + > edstgl = 1, + > edstco = 2 + > ) +c +c MED_ACC_RDONLY/edlect : Ouverture en lecture seule +c MED_ACC_RDWR/edrdwr : Ouverture en lecture/ecriture +c . si un element existe, il est ecrase +c MED_ACC_RDEXT/edrdex : Ouverture en lecture/ecriture +c . l'ecriture d'un objet existant provoque une erreur +c MED_ACC_CREAT/edcrea : Cree le fichier s'il n'existe pas, l'ecrase +c sinon +c + integer edlect, edrdwr, edrdex, edcrea + parameter ( + > edlect = 0, + > edrdwr = 1, + > edrdex = 2, + > edcrea = 3 + > ) +c +c MED_NON_STRUCTURE/ednost : maillage non structure +c MED_STRUCTURE/edmast : maillage structure +c + integer ednost, edmast + parameter ( + > ednost = 0, + > edmast = 1 + > ) +c +c MED_MAIL/edmail +c MED_FACE/edface +c MED_ARET/edaret +c MED_NOEU/ednoeu +c MED_NOEU_MAILLE/ednoma + integer edmail, edface, edaret, ednoeu, ednoma + parameter ( + > edmail = 0, + > edface = 1, + > edaret = 2, + > ednoeu = 3, + > ednoma = 4 + > ) +c +c MED_COOR/edcoor +c MED_CONN/edconn +c MED_NOM/ednom +c MED_NUM/ednum +c MED_FAM/edfam + integer edcoor, edconn, ednom, ednum, edfam + parameter ( + > edcoor = 0, + > edconn = 1, + > ednom = 2, + > ednum = 3, + > edfam = 4 + > ) +c +c MED_FLOAT64/edfl64 +c MED_INT32/edin32 +c MED_INT64/edin64 +c MED_INT/edint + integer edfl64, edin32, edin64, edint + parameter ( + > edfl64 = 6, + > edin32 = 24, + > edin64 = 26, + > edint = 28 + > ) +c +c MED_NBR_GEOMETRIE_MAILLE/edgema +c MED_NBR_GEOMETRIE_FACE/edgefa +c MED_NBR_GEOMETRIE_ARETE/edgear + integer edgema, edgefa, edgear + parameter ( + > edgema = 15, + > edgefa = 4, + > edgear = 2 + > ) +c +c MED_POINT1 +c MED_SEG2 +c MED_SEG3 +c MED_SEG4 +c MED_TRIA3, MED_QUAD4 +c MED_TRIA6, MED_QUAD8 +c MED_TETRA4, MED_PYRA5, MED_PENTA6, MED_HEXA8 +c MED_TETRA10, MED_PYRA13, MED_PENTA15, MED_HEXA20 +c MED_POLYGONE, MED_POLYEDRE +c + integer edpoi1, + > edseg2, edseg3, edseg4, + > edtri3, edtri6, edtri7, + > edqua4, edqua8, edqua9, + > edtet4, edte10, + > edpyr5, edpy13, + > edpen6, edpe15, edpe18, + > edhex8, edhe20, edhe27 + parameter ( + > edpoi1 = 1, + > edseg2 = 102, + > edseg3 = 103, + > edseg4 = 104, + > edtri3 = 203, + > edtri6 = 206, + > edtri7 = 207, + > edqua4 = 204, + > edqua8 = 208, + > edqua9 = 209, + > edtet4 = 304, + > edte10 = 310, + > edpyr5 = 305, + > edpy13 = 313, + > edpen6 = 306, + > edpe15 = 315, + > edpe18 = 318, + > edhex8 = 308, + > edhe20 = 320, + > edhe27 = 327 + > ) +c +c MED_NOD/ednoda +c MED_DESC/eddesc + integer ednoda, eddesc + parameter ( + > ednoda = 0, + > eddesc = 1 + > ) +c +c MED_CART/edcart +c MED_CYL/edcyli +c MED_SPHER/edsphe + integer edcart, edcyli, edsphe + parameter ( + > edcart = 0, + > edcyli = 1, + > edsphe = 2 + > ) +c +c MED_COMP/edcomp +c MED_DTYPE/eddtyp + integer edcomp, eddtyp + parameter ( + > edcomp = 0, + > eddtyp = 1 + > ) +c +c MED_GROUPE/edgrou +c MED_ATTR/edattr +c MED_FAMILLE/edfami + integer edgrou, edattr, edfami + parameter ( + > edgrou = 0, + > edattr = 1, + > edfami = 2 + > ) +c +c MED_HDF_VERSION/edhdve +c MED_VERSION/ededve +c MED_FICH_DES/edfide + integer edhdve, ededve, edfide + parameter ( + > edhdve = 0, + > ededve = 1, + > edfide = 2 + > ) +c +c MED_NOPG/ednopg +c MED_NOGAUSS/ednoga +c MED_GAUSS_ELNO/edngen +c MED_NOPF/ednopf +c MED_NOPFL/ednopl +c MED_NONOR/ednonr +c MED_ALL/edall + character*64 ednoga, edngen, ednopl + integer ednopg, ednopf, ednonr, edall + parameter ( + > ednopg = 1, + > ednoga = blan64, + > edngen = + >'MED_GAUSS_ELNO ' + > , + > ednopf = 0, + > ednopl = blan64, + > ednonr = -1, + > edall = 0 + > ) +c 1234567890123456789012345678901234567890123456789012345678901234 +c +c MED_NO_DT/ednodt +c MED_NO_IT/ednoit +c MED_UNDEF_DT/edundt + integer ednodt, ednoit + double precision edundt + parameter ( + > ednodt = -1, + > ednoit = -1, + > edundt = 1.7921958d15 + > ) +c +c MED_SORT_DTIT/edsodi +c MED_SORT_ITDT/edsoid +c MED_SORT_UNDEF/edsoun + integer edsodi, edsoid, edsoun + parameter ( + > edsodi = 0, + > edsoid = 1, + > edsoun = -1 + > ) +c +c MED_COORDINATE/edda00 +c MED_CONNECTIVITY/edda01 +c MED_NAME/ +c MED_NUMBER/edda03 +c MED_FAMILY_NUMBER/edda04 +c MED_COORDINATE_AXIS1 +c MED_COORDINATE_AXIS2 +c MED_COORDINATE_AXIS3 +c MED_INDEX_FACE +c MED_INDEX_NODE +c MED_GLOBAL_STMODE_NUMBER/edda10 +c MED_VARIABLE_ATTRIBUTE +c MED_COORDINATE_TRSF +c MED_UNDEF_DATATYPE/eddaty + integer edda00, edda01, edda03, edda04, edda10 + integer eddaty + parameter ( + > edda00 = 0, + > edda01 = 1, + > edda03 = 3, + > edda04 = 4, + > edda10 = 10, + > eddaty = -1 + > ) +c +c MED_FALSE/edfals +c MED_TRUE/edtrue + integer edfals, edtrue + parameter ( + > edfals = 0, + > edtrue = 1 + > ) +c +c MED_RETERREUR/edreer +c MED_EXIT/edexit + integer edreer, edexit + parameter ( + > edreer = 0, + > edexit = 1 + > ) diff --git a/src/tool/Includes_Generaux/melopt.h b/src/tool/Includes_Generaux/melopt.h new file mode 100644 index 00000000..0dd35955 --- /dev/null +++ b/src/tool/Includes_Generaux/melopt.h @@ -0,0 +1,18 @@ +c + texte(1,4) = '(/,a6,'' LECTURE DES OPTIONS'')' + texte(1,5) = '(26(''=''),/)' + texte(1,6) ='(''Option associee au mot-cle '',a8)' + texte(1,7) = '(''Illisible.'')' + texte(1,8) = '(''Defini plusieurs fois.'')' + texte(1,9) = '(''==> Valeur :'',i8)' + texte(1,10) = '(''==> Valeur :'',g15.7)' + texte(1,11) = '(''==> Valeur :'',a)' +c + texte(2,4) = '(/,a6,'' READINGS OF OPTIONS'')' + texte(2,5) = '(26(''=''),/)' + texte(2,6) = '(''Option related to keyword '',a8)' + texte(2,7) = '(''Unreadable.'')' + texte(2,8) = '(''Multiple definition.'')' + texte(2,9) = '(''==> Value :'',i8)' + texte(2,10) = '(''==> Value :'',g15.7)' + texte(2,11) = '(''==> Value :'',a)' diff --git a/src/tool/Includes_Generaux/mesutp.h b/src/tool/Includes_Generaux/mesutp.h new file mode 100644 index 00000000..f0382cca --- /dev/null +++ b/src/tool/Includes_Generaux/mesutp.h @@ -0,0 +1,12 @@ +c +c dimensionnement des tableaux des mesures de temps de calcul +c nbsect = nombre de section de mseures (<= 200) +c numsec(i) = numero de la i-eme section +c titsec(i) = nom de la i-eme section +c + integer nbsect + parameter ( nbsect = 200 ) +c + integer numsec (nbsect) +c + character*24 titsec (nbsect) diff --git a/src/tool/Includes_Generaux/motcle.h b/src/tool/Includes_Generaux/motcle.h new file mode 100644 index 00000000..ed2d5485 --- /dev/null +++ b/src/tool/Includes_Generaux/motcle.h @@ -0,0 +1,718 @@ +c +c La liste qui suit decrit les mots-cles reconnus pour reperer +c les objets et les fichiers dans le fichier de configuration. +c +c 1. La base +c=========== +c +c 1.1. Les fichiers generaux +c=========================== +c +c mcdico : dictionnaire des objets structures +c + character*8 mcdico + parameter ( mcdico = 'DicoOSGM' ) +c +c mclist : liste de sortie standard +c + character*8 mclist + parameter ( mclist = 'ListeStd' ) +c +c mcrept : repertoire de travail pour les fichiers temporaires +c + character*8 mcrept + parameter ( mcrept = 'RepeTrav' ) +c +c 1.2. Les fichiers au format du code de calcul associe +c====================================================== +c +c mccman : maillage a l'iteration n +c + character*8 mccman + parameter ( mccman = 'CCMaiN__' ) +c +c mccmap : maillage a l'iteration n+1 +c + character*8 mccmap + parameter ( mccmap = 'CCMaiNP1' ) +c +c mccmaa : maillage annexe +c + character*8 mccmaa + parameter ( mccmaa = 'CCMaiAnn' ) +c +c mccson : solution a l'iteration n +c + character*8 mccson + parameter ( mccson = 'CCSolN__' ) +c +c mccsop : solution a l'iteration n+1 +c + character*8 mccsop + parameter ( mccsop = 'CCSolNP1' ) +c +c mccind : indicateur d'erreur +c + character*8 mccind + parameter ( mccind = 'CCIndica' ) +c +c mccdfr : description de la frontiere discrete +c + character*8 mccdfr + parameter ( mccdfr = 'CCFronti' ) +c +c 1.3. Les noms des maillages dans les fichiers du code de calcul +c================================================================ +c +c mccnmn : maillage a l'iteration n +c + character*8 mccnmn + parameter ( mccnmn = 'CCNoMN__' ) +c +c mccnmp : maillage a l'iteration n+1 +c + character*8 mccnmp + parameter ( mccnmp = 'CCNoMNP1' ) +c +c mccnma : maillage annexe +c + character*8 mccnma + parameter ( mccnma = 'CCNoMAnn' ) +c +c mccnmf : maillage de la frontiere discrete +c + character*8 mccnmf + parameter ( mccnmf = 'CCNoMFro' ) +c +c 1.4. L'indicateur d'erreur +c=========================== +c +c mccnin : nom du champ de l'indicateur d'erreur +c + character*8 mccnin + parameter ( mccnin = 'CCNoChaI' ) +c +c mccnin : nom de la composante de l'indicateur d'erreur +c + character*8 mcccin + parameter ( mcccin = 'CCCoChaI' ) +c +c mcntin : numero du pas de temps de l'indicateur d'erreur +c + character*8 mcntin + parameter ( mcntin = 'CCNumPTI' ) +c +c mcnoin : numero d'ordre de l'indicateur d'erreur +c + character*8 mcnoin + parameter ( mcnoin = 'CCNumOrI' ) +c +c mcinin : instant de l'indicateur d'erreur +c + character*8 mcinin + parameter ( mcinin = 'CCInstaI' ) +c +c mcmfi1 : mode de fonctionnement de l'indicateur d'erreur - 1 +c + character*8 mcmfi1 + parameter ( mcmfi1 = 'CCUsCmpI' ) +c +c mcmfi2 : mode de fonctionnement de l'indicateur d'erreur - 2 +c + character*8 mcmfi2 + parameter ( mcmfi2 = 'CCModeFI' ) +c +c 1.5. Les champs a mettre a jour +c================================ +c +c mcchno : nom d'un champ de solution a mettre a jour +c + character*8 mcchno + parameter ( mcchno = 'CCChaNom' ) +c +c mcchti : type d'interpolation +c + character*8 mcchti + parameter ( mcchti = 'CCChaTIn' ) +c +c mcchpt : numero du pas de temps d'un champ de solution a mettre a jour +c + character*8 mcchpt + parameter ( mcchpt = 'CCChaPdT' ) +c +c mcchnu : numero d'ordre d'un champ de solution a mettre a jour +c + character*8 mcchnu + parameter ( mcchnu = 'CCChaNuO' ) +c +c mcchin : instant d'un champ de solution a mettre a jour +c + character*8 mcchin + parameter ( mcchin = 'CCChaIns' ) +c +c mcchcs : caracteristique du support d'un champ de solution a mettre +c a jour +c + character*8 mcchcs + parameter ( mcchcs = 'CCChaCaS' ) +c +c mcchnc : numero du champ aux noeuds par element associe +c + character*8 mcchnc + parameter ( mcchnc = 'CCChaNCN' ) +c +c mcchto : mise a jour de tous les champs de solution +c + character*8 mcchto + parameter ( mcchto = 'CCChaTou' ) +c +c 1.6. Les informations complementaires +c====================================== +c +c mcicni : nom du champ MED qui contiendra le niveau +c + character*8 mcicni + parameter ( mcicni = 'NCNiveau' ) +c +c mcicqu : nom du champ MED qui contiendra la qualite +c + character*8 mcicqu + parameter ( mcicqu = 'NCQualit' ) +c +c mcicdi : nom du champ MED qui contiendra le diametre +c + character*8 mcicdi + parameter ( mcicdi = 'NCDiamet' ) +c +c mcicpa : nom du champ MED qui contiendra la parente +c + character*8 mcicpa + parameter ( mcicpa = 'NCParent' ) +c +c mcicvr : nom du champ MED qui contiendra les voisins des recollements +c + character*8 mcicvr + parameter ( mcicvr = 'NCVoisRc' ) +c +c 2. Les objets HOMARD +c===================== +c +c 2.1. Les maillages au format HOMARD +c==================================== +c +c mchman : maillage a l'iteration n +c + character*8 mchman + parameter ( mchman = 'HOMaiN__' ) +c +c mchmap : maillage a l'iteration n+1 +c + character*8 mchmap + parameter ( mchmap = 'HOMaiNP1' ) +c +c 2.2. L'indicateur au format HOMARD +c=================================== +c +c mchind : indicateur a l'iteration n +c + character*8 mchind + parameter ( mchind = 'HOIndica' ) +c +c 2.3. Les utilitaires +c===================== +c +c mcauxi : mot-cle auxiliaire +c il sert pour des operations de test +c + character*8 mcauxi + parameter ( mcauxi = 'MCAuxili' ) +c +c La liste qui suit decrit les mots-cles reconnus pour reperer +c deux objets a comparer, par exemple +c +c mcobj1 : objet numero 1 +c + character*8 mcobj1 + parameter ( mcobj1 = 'Objet__1' ) +c +c mcobj2 : objet numero 2 +c + character*8 mcobj2 + parameter ( mcobj2 = 'Objet__2' ) +c +c 3. Les options de pilotage +c=========================== +c +c 3.1. les options generales +c=========================== +c +c mcmoho : mode de fonctionnement de HOMARD +c + character*8 mcmoho + parameter ( mcmoho = 'ModeHOMA' ) +c +c mcecfh : ecriture des fichiers au format HOMARD +c + character*8 mcecfh + parameter ( mcecfh = 'EcriFiHO' ) +c +c mctyel : type d'elements autorises +c + character*8 mctyel + parameter ( mctyel = 'TypeElem' ) +c +c 3.2. les options de l'adaptation +c================================= +c 3.2.1. l'iteration +c------------------- +c +c mcnuit : numero d'iteration du maillage avant adaptation +c + character*8 mcnuit + parameter ( mcnuit = 'NumeIter' ) +c +c 3.2.2. le raffinement +c---------------------- +c +c mctyco : type de conformite +c + character*8 mctyco + parameter ( mctyco = 'TypeConf' ) +c +c mctyra : type de raffinement +c + character*8 mctyra + parameter ( mctyra = 'TypeRaff' ) +c +c mcnvma : niveau maximum pour le raffinement +c + character*8 mcnvma + parameter ( mcnvma = 'NiveauMa' ) +c +c mcnbme : nombre maximum d'elements apres raffinement +c + character*8 mcnbme + parameter ( mcnbme = 'NbrMaxEl' ) +c +c mccora : contraintes de raffinement +c + character*8 mccora + parameter ( mccora = 'ContRaff' ) +c +c mcseuh : seuil haut absolu pour le raffinement +c + character*8 mcseuh + parameter ( mcseuh = 'SeuilHau' ) +c +c mcserh : seuil haut relatif pour le raffinement +c + character*8 mcserh + parameter ( mcserh = 'SeuilHRe' ) +c +c mcseph : seuil haut en pourcentage pour le raffinement +c + character*8 mcseph + parameter ( mcseph = 'SeuilHPE' ) +c +c mcsesh : seuil haut en mu+n.sigma pour le raffinement +c + character*8 mcsesh + parameter ( mcsesh = 'SeuilHMS' ) +c +c mcdimi : diametre minimum pour le raffinement +c + character*8 mcdimi + parameter ( mcdimi = 'DiametMi' ) +c +c 3.2.3. le deraffinement +c---------------------- +c +c mctyde : type de deraffinement +c + character*8 mctyde + parameter ( mctyde = 'TypeDera' ) +c +c mcnvmi : niveau minimum pour le deraffinement +c + character*8 mcnvmi + parameter ( mcnvmi = 'NiveauMi' ) +c +c mcseub : seuil bas absolu pour le deraffinement +c + character*8 mcseub + parameter ( mcseub = 'SeuilBas' ) +c +c mcserb : seuil bas relatif pour le deraffinement +c + character*8 mcserb + parameter ( mcserb = 'SeuilBRe' ) +c +c mcsepb : seuil bas en pourcentage pour le deraffinement +c + character*8 mcsepb + parameter ( mcsepb = 'SeuilBPE' ) +c +c mcsesb : seuil bas en mu-n.sigma pour le deraffinement +c + character*8 mcsesb + parameter ( mcsesb = 'SeuilBMS' ) +c +c 3.2.4. les zones de raffinement +c-------------------------------- +c +c mczrty : type de la zone de raffinement +c + character*8 mczrty + parameter ( mczrty = 'ZoRaType' ) +c +c mcrxmi : zone a raffiner : x mini +c + character*8 mcrxmi + parameter ( mcrxmi = 'ZoRaXmin' ) +c +c mcrxma : zone a raffiner : x maxi +c + character*8 mcrxma + parameter ( mcrxma = 'ZoRaXmax' ) +c +c mcrymi : zone a raffiner : y mini +c + character*8 mcrymi + parameter ( mcrymi = 'ZoRaYmin' ) +c +c mcryma : zone a raffiner : y maxi +c + character*8 mcryma + parameter ( mcryma = 'ZoRaYmax' ) +c +c mcrzmi : zone a raffiner : z mini +c + character*8 mcrzmi + parameter ( mcrzmi = 'ZoRaZmin' ) +c +c mcrzma : zone a raffiner : y maxi +c + character*8 mcrzma + parameter ( mcrzma = 'ZoRaZmax' ) +c +c mcrxce : zone a raffiner : x du centre +c + character*8 mcrxce + parameter ( mcrxce = 'ZoRaXCen' ) +c +c mcryce : zone a raffiner : y du centre +c + character*8 mcryce + parameter ( mcryce = 'ZoRaYCen' ) +c +c mcrzce : zone a raffiner : z du centre +c + character*8 mcrzce + parameter ( mcrzce = 'ZoRaZCen' ) +c +c mcrxba : zone a raffiner : x de la base +c + character*8 mcrxba + parameter ( mcrxba = 'ZoRaXBas' ) +c +c mcryba : zone a raffiner : y de la base +c + character*8 mcryba + parameter ( mcryba = 'ZoRaYBas' ) +c +c mcrzba : zone a raffiner : z de la base +c + character*8 mcrzba + parameter ( mcrzba = 'ZoRaZBas' ) +c +c mcrhau : zone a raffiner : hauteur +c + character*8 mcrhau + parameter ( mcrhau = 'ZoRaHaut' ) +c +c mcrxax : zone a raffiner : x de l'axe +c + character*8 mcrxax + parameter ( mcrxax = 'ZoRaXAxe' ) +c +c mcryax : zone a raffiner : y de l'axe +c + character*8 mcryax + parameter ( mcryax = 'ZoRaYAxe' ) +c +c mcrzax : zone a raffiner : z de l'axe +c + character*8 mcrzax + parameter ( mcrzax = 'ZoRaZAxe' ) +c +c mcrray : zone a raffiner : rayon +c + character*8 mcrray + parameter ( mcrray = 'ZoRaRayo' ) +c +c mcrrai : zone a raffiner : rayon interieur +c + character*8 mcrrai + parameter ( mcrrai = 'ZoRaRayI' ) +c +c mcrrae : zone a raffiner : rayon exterieur +c + character*8 mcrrae + parameter ( mcrrae = 'ZoRaRayE' ) +c +c 3.2.5. les groupes pour l'adaptation +c------------------------------------- +c +c mcgrad : groupes ou a lieu l'adaptation +c + character*8 mcgrad + parameter ( mcgrad = 'CCGroAda' ) +c +c 3.2.6. l'initialisation +c------------------------------------- +c +c mcinad : initialisation de l'adaptation +c + character*8 mcinad + parameter ( mcinad = 'AdapInit' ) +c +c 3.2.7. la cible en nombre de sommets +c------------------------------------ +c +c mcpacm : nombre de passages maximum pour atteindre la cible +c + character*8 mcpacm + parameter ( mcpacm = 'CiblePaM' ) +c +c mcnbsc : nombre de sommets cible +c + character*8 mcnbsc + parameter ( mcnbsc = 'CibleNbS' ) +c +c 3.3. liens avec le code de calcul +c================================== +c +c mcccas : code de calcul associe +c + character*8 mcccas + parameter ( mcccas = 'CCAssoci' ) +c +c mcvman : conversion de maillage a l'iteration n +c + character*8 mcvman + parameter ( mcvman = 'CVMaiN__' ) +c +c mcvmap : conversion de maillage a l'iteration n+1 +c + character*8 mcvmap + parameter ( mcvmap = 'CVMaiNP1' ) +c +c mcvind : conversion de l'indicateur +c + character*8 mcvind + parameter ( mcvind = 'CVIndN__' ) +c +c mcvsol : conversion de la solution +c + character*8 mcvsol + parameter ( mcvsol = 'CVSolNP1' ) +c +c mcsufr : suivi de la frontiere +c + character*8 mcsufr + parameter ( mcsufr = 'SuivFron' ) +c +c mcgrfr : groupes de la frontiere CAO +c + character*8 mcgrfr + parameter ( mcgrfr = 'GrFroCAO' ) +c +c mcgrfd : groupes de la frontiere discrete +c + character*8 mcgrfd + parameter ( mcgrfd = 'CCGroFro' ) +c +c mcfanm : nom de la frontiere analytique +c + character*8 mcfanm + parameter ( mcfanm = 'FANom ' ) +c +c mcfaty : type de la frontiere analytique +c + character*8 mcfaty + parameter ( mcfaty = 'FAType ' ) +c +c mcfaxc : frontiere analytique : x du centre +c + character*8 mcfaxc + parameter ( mcfaxc = 'FAXCen ' ) +c +c mcfayc : frontiere analytique : y du centre +c + character*8 mcfayc + parameter ( mcfayc = 'FAYCen ' ) +c +c mcfazc : frontiere analytique : z du centre +c + character*8 mcfazc + parameter ( mcfazc = 'FAZCen ' ) +c +c mcfaxa : frontiere analytique : x de l'axe +c + character*8 mcfaxa + parameter ( mcfaxa = 'FAXAxe ' ) +c +c mcfaya : frontiere analytique : y de l'axe +c + character*8 mcfaya + parameter ( mcfaya = 'FAYAxe ' ) +c +c mcfaza : frontiere analytique : z de l'axe +c + character*8 mcfaza + parameter ( mcfaza = 'FAZAxe ' ) +c +c mcfara : frontiere analytique : rayon +c + character*8 mcfara + parameter ( mcfara = 'FARayon ' ) +c +c mcfaxc : frontiere analytique : x du centre numero 2 +c + character*8 mcfax2 + parameter ( mcfax2 = 'FAXCen2 ' ) +c +c mcfayc : frontiere analytique : y du centre numero 2 +c + character*8 mcfay2 + parameter ( mcfay2 = 'FAYCen2 ' ) +c +c mcfazc : frontiere analytique : z du centre numero 2 +c + character*8 mcfaz2 + parameter ( mcfaz2 = 'FAZCen2 ' ) +c +c mcfara : frontiere analytique : rayon numero 2 +c + character*8 mcfar2 + parameter ( mcfar2 = 'FARayon2' ) +c +c mcfara : frontiere analytique : angle +c + character*8 mcfaan + parameter ( mcfaan = 'FAAngle ' ) +c +c mcfgfr : nom de la frontiere liee a un groupe +c + character*8 mcfgfr + parameter ( mcfgfr = 'FGNomFro' ) +c +c mcfggr : nom du groupe lie a une frontiere +c + character*8 mcfggr + parameter ( mcfggr = 'FGNomGro' ) +c +c mctybi : type de bilan sur le maillage +c + character*8 mctybi + parameter ( mctybi = 'TypeBila' ) +c +c mcmext : le maillage est un maillage extrude +c + character*8 mcmext + parameter ( mcmext = 'M_Extrud' ) +c +c mccex1 : choix de la gestion de la coordonnee constante pour +c les maillages extrudes +c + character*8 mccex1 + parameter ( mccex1 = 'Coo_Extr' ) +c +c mccex2 : valeur du delta de coordonnee si impose +c + character*8 mccex2 + parameter ( mccex2 = 'DC_impos' ) +c +c 3.4. les options de la modification de maillage +c================================================ +c +c mcmdeg : modification du degre du maillage (1<->2) +c + character*8 mcmdeg + parameter ( mcmdeg = 'ModDegre' ) +c +c mcjoin : creation de joint entre des groupes de volumes +c + character*8 mcjoin + parameter ( mcjoin = 'CreJoint' ) +c +c 4. la memoire +c============== +c +c mcmogm : mode de gestion de la memoire +c + character*8 mcmogm + parameter ( mcmogm = 'ModeGM ' ) +c +c mcgmen : nombre d'entiers en statique +c + character*8 mcgmen + parameter ( mcgmen = 'ModeGMEN' ) +c +c mcgmre : nombre de reels en statique +c + character*8 mcgmre + parameter ( mcgmre = 'ModeGMRE' ) +c +c mcgmc8 : nombre de caracteres8 en statique +c + character*8 mcgmc8 + parameter ( mcgmc8 = 'ModeGMC8' ) +c +c mcgmco : nombre de complexes en statique +c + character*8 mcgmco + parameter ( mcgmco = 'ModeGMCO' ) +c +c mcgmsi : nombre de reels simple precision en statique +c + character*8 mcgmsi + parameter ( mcgmsi = 'ModeGMSI' ) +c +c mcgmta : type d'arret de la gestion de la memoire +c + character*8 mcgmta + parameter ( mcgmta = 'ModeGMTA' ) +c +c 5. Autres options de pilotage +c============================== +c +c mcguta : type d'arret de la gestion des unites logiques +c + character*8 mcguta + parameter ( mcguta = 'ModeGUTA' ) +c +c mclang : la langue des messages +c + character*8 mclang + parameter ( mclang = 'Langue ' ) +c +c mcppty : type de post-processeur +c + character*8 mcppty + parameter ( mcppty = 'PPType ' ) +c +c mcrepi : repertoire de travail pour les fichiers d'information +c + character*8 mcrepi + parameter ( mcrepi = 'RepeInfo' ) +c +c mcacti : l'action en cours +c + character*8 mcacti + parameter ( mcacti = 'Action ' ) +c +c mcinfo : les informations a ecrire +c + character*8 mcinfo + parameter ( mcinfo = 'MessInfo' ) diff --git a/src/tool/Includes_Generaux/mslv10.h b/src/tool/Includes_Generaux/mslv10.h new file mode 100644 index 00000000..23cbe8d3 --- /dev/null +++ b/src/tool/Includes_Generaux/mslv10.h @@ -0,0 +1,24 @@ + if ( taopti(10).gt.0 ) then +c + if ( taopti(37).eq.0 ) then +c + if ( taopti(31).gt.0 .and. taopti(32).gt.0 ) then +c + if ( ( taopti(6).eq.1 .and. taopti(7).eq.1 ) .or. + > ( taopti(6).eq.2 .and. taopti(7).eq.2 ) ) then + if ( taoptr(2).gt.taoptr(1) ) then + write(ulsort,texte(langue,93)) + nbrepb = nbrepb + 1 + endif + elseif ( taopti(6).eq.3 .and. taopti(7).eq.3 ) then + if ( taoptr(1)+taoptr(2).gt.100.d0 ) then + write(ulsort,texte(langue,93)) + nbrepb = nbrepb + 1 + endif + endif +c + endif +c + endif +c + endif diff --git a/src/tool/Includes_Generaux/mslv11.h b/src/tool/Includes_Generaux/mslv11.h new file mode 100644 index 00000000..29313973 --- /dev/null +++ b/src/tool/Includes_Generaux/mslv11.h @@ -0,0 +1,35 @@ +c +c Message du suivi de frontiere +c On l'interdit pour du maillage SATURNE/NEPTUNE 3D +c Pour du MED, on ne sait pas car il faudrait savoir si 2D ou 3D. +c + write(ulsort,texte(langue,27)) +c + if ( taopti(11).eq.36 .or. + > taopti(11).eq.56 ) then + if ( taopti(29).ne.1 ) then + write(ulsort,texte(langue,27)) + write(ulsort,texte(langue,28)) + write(ulsort,texte(langue,11)) taopti(29) + nbrepb = nbrepb + 1 + else + write(ulsort,texte(langue,14)) + endif +c + else + if ( taopti(29).eq.1 ) then + write(ulsort,texte(langue,14)) + elseif ( ( mod(taopti(29),2).eq.0 .or. + > mod(taopti(29),3).eq.0 ) .and. + > mod(taopti(29),5).eq.0 ) then + write(ulsort,texte(langue,11)) taopti(29) + nbrepb = nbrepb + 1 + elseif ( mod(taopti(29),2).eq.0 .or. + > mod(taopti(29),3).eq.0 .or. + > mod(taopti(29),5).eq.0 ) then + write(ulsort,texte(langue,15)) + else + write(ulsort,texte(langue,11)) taopti(29) + nbrepb = nbrepb + 1 + endif + endif diff --git a/src/tool/Includes_Generaux/mslv12.h b/src/tool/Includes_Generaux/mslv12.h new file mode 100644 index 00000000..e8b73d95 --- /dev/null +++ b/src/tool/Includes_Generaux/mslv12.h @@ -0,0 +1,56 @@ +c +c 15 : -2, aucun numero de pas de temps n'a ete fourni +c 1, un numero de pas de temps est fourni +c 2, on prend le dernier pas de temps +c 16 : -2, aucun numero d'ordre n'a ete fourni +c 1, un numero est fourni +c 17 : -2, aucune valeur d'instant n'a ete fournie +c 1, une valeur d'instant est fournie +c 2, on prend le dernier instant +c +c +c rien n'a ete demande, on met le pas de temps par defaut +c + if ( taopti(15).eq.-2 .and. + > taopti(16).eq.-2 .and. + > taopti(17).eq.-2 ) then +c + taopti(15) = 0 + taopti(16) = 0 + taopti(17) = 0 +c + else +c +c on ne peut pas demander le dernier sur une des rubriques +c et autre chose sur une autre +c + do 35 , iaux = 1 , 3 +c + if ( taopti(14+iaux).eq.2 ) then +c + do 351, jaux = 1 , 2 + if ( taopti(14+per1a3(jaux,iaux)).eq.-2 ) then + goto 351 + elseif ( taopti(14+per1a3(jaux,iaux)).ne.2 ) then + nbrepb = nbrepb + 1 + write(ulsort,texte(langue,101)) + write(ulsort,texte(langue,102)) + endif + 351 continue +c + endif +c + 35 continue +c +c on ne peut pas demander une valeur d'instant et une valeur +c de numero de pas de temps +c + if ( taopti(15).eq.0 .or. taopti(15).eq.1 ) then + if ( taopti(17).eq.0 .or. taopti(17).eq.1 ) then + nbrepb = nbrepb + 1 + write(ulsort,texte(langue,101)) + write(ulsort,texte(langue,103)) + endif + endif +c + endif diff --git a/src/tool/Includes_Generaux/mslv13.h b/src/tool/Includes_Generaux/mslv13.h new file mode 100644 index 00000000..7caa8b03 --- /dev/null +++ b/src/tool/Includes_Generaux/mslv13.h @@ -0,0 +1,24 @@ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpacm', taopti(43) + write (ulsort,90002) 'nbnoci', taopti(44) + write (ulsort,90002) 'nbmaci', taopti(45) +#endif +c + if ( taopti(44).gt.0 .or. taopti(45).gt.0 ) then +c + if ( taopti(31).ne.1 .and. taopti(31).ne. 2 ) then + write(ulsort,texte(langue,120)) + write(ulsort,texte(langue,121)) + nbrepb = nbrepb + 1 + endif +c + if ( taopti(32).ne.0 ) then + write(ulsort,texte(langue,120)) + write(ulsort,texte(langue,122)) + nbrepb = nbrepb + 1 + endif +c + taopti(6) = 5 +c + endif diff --git a/src/tool/Includes_Generaux/mslve0.h b/src/tool/Includes_Generaux/mslve0.h new file mode 100644 index 00000000..100465da --- /dev/null +++ b/src/tool/Includes_Generaux/mslve0.h @@ -0,0 +1,2 @@ + if ( taopti(11).eq.1 ) then + write(ulsort,texte(langue,26)) 'HOMARD ' diff --git a/src/tool/Includes_Generaux/mslve1.h b/src/tool/Includes_Generaux/mslve1.h new file mode 100644 index 00000000..be7c6929 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve1.h @@ -0,0 +1,23 @@ + elseif ( taopti(11).eq.6 ) then + write(ulsort,texte(langue,26)) 'MED ' + elseif ( taopti(11).eq.16 ) then + write(ulsort,texte(langue,26)) 'ATHENA ' + elseif ( taopti(11).eq.26 ) then + write(ulsort,texte(langue,26)) 'SATURNE 2D ' + elseif ( taopti(11).eq.36 ) then + write(ulsort,texte(langue,26)) 'SATURNE ' + elseif ( taopti(11).eq.46 ) then + write(ulsort,texte(langue,26)) 'NEPTUNE 2D ' + elseif ( taopti(11).eq.56 ) then + write(ulsort,texte(langue,26)) 'NEPTUNE ' + elseif ( taopti(11).eq.66 ) then + write(ulsort,texte(langue,26)) 'CARMEL 2D ' + elseif ( taopti(11).eq.76 ) then + write(ulsort,texte(langue,26)) 'CARMEL ' + elseif ( taopti(11).eq.106 ) then + write(ulsort,texte(langue,26)) 'NON-CONFORME ' + else + write(ulsort,texte(langue,26)) ' ' + write(ulsort,texte(langue,11)) taopti(11) + nbrepb = nbrepb + 1 + endif diff --git a/src/tool/Includes_Generaux/mslve2.h b/src/tool/Includes_Generaux/mslve2.h new file mode 100644 index 00000000..4de7f904 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve2.h @@ -0,0 +1,10 @@ + write(ulsort,texte(langue,110)) +c + if ( taopti(30).ge.-2 .and.taopti(30).le.3 ) then + write(ulsort,texte(langue,113+taopti(30))) +c + else + write(ulsort,texte(langue,11)) taopti(30) + nbrepb = nbrepb + 1 +c + endif diff --git a/src/tool/Includes_Generaux/mslve3.h b/src/tool/Includes_Generaux/mslve3.h new file mode 100644 index 00000000..a37227a6 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve3.h @@ -0,0 +1,18 @@ + saux = ' ' +c + if ( taopti(39).eq.1 ) then + saux(1:1) = 'X' + elseif ( taopti(39).eq.2 ) then + saux(1:1) = 'Y' + elseif ( taopti(39).eq.3 ) then + saux(1:1) = 'Z' +c + elseif ( taopti(39).ne.0 ) then + write(ulsort,texte(langue,11)) taopti(39) + nbrepb = nbrepb + 1 +c + endif +c + if ( saux.ne.' ' ) then + write(ulsort,texte(langue,119)) saux(1:1) + endif diff --git a/src/tool/Includes_Generaux/mslve4.h b/src/tool/Includes_Generaux/mslve4.h new file mode 100644 index 00000000..019d43a3 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve4.h @@ -0,0 +1,26 @@ + texte(1,6) = '(''Mauvais code de calcul :'',i5)' +c + texte(2,6) = '(''Bad related code :'',i5)' +c + if ( typcca.eq.6 ) then + write(ulsort,texte(langue,7)) 'MED ' + elseif ( typcca.eq.16 ) then + write(ulsort,texte(langue,7)) 'ATHENA ' + elseif ( typcca.eq.26 ) then + write(ulsort,texte(langue,7)) 'SATURNE 2D ' + elseif ( typcca.eq.36 ) then + write(ulsort,texte(langue,7)) 'SATURNE ' + elseif ( typcca.eq.46 ) then + write(ulsort,texte(langue,7)) 'NEPTUNE 2D ' + elseif ( typcca.eq.56 ) then + write(ulsort,texte(langue,7)) 'NEPTUNE ' + elseif ( typcca.eq.66 ) then + write(ulsort,texte(langue,7)) 'CARMEL 2D ' + elseif ( typcca.eq.76 ) then + write(ulsort,texte(langue,7)) 'CARMEL ' + elseif ( typcca.eq.106 ) then + write(ulsort,texte(langue,7)) 'NON-CONFORME ' + else + write(ulsort,texte(langue,6)) typcca + codret = 5 + endif diff --git a/src/tool/Includes_Generaux/mslve5.h b/src/tool/Includes_Generaux/mslve5.h new file mode 100644 index 00000000..bd99b90a --- /dev/null +++ b/src/tool/Includes_Generaux/mslve5.h @@ -0,0 +1,33 @@ + write(ulsort,texte(langue,30)) +c +#ifdef _DEBUG_HOMARD_ + if ( taopti(49).eq.1 ) then + write(ulsort,texte(langue,31)) + endif +#endif +c + if ( taopti(31).ge.-1 .and.taopti(31).le.2 ) then +c + if ( taopti(37).eq.0 ) then +c + write(ulsort,texte(langue,33+taopti(31))) +c + if ( taopti(31).eq.2 ) then + write(ulsort,texte(langue,34)) + endif +c + endif +c + else + write(ulsort,texte(langue,11)) taopti(31) + nbrepb = nbrepb + 1 +c + endif +c + if ( mod(taopti(36),2).eq.0 ) then + write(ulsort,texte(langue,39)) + endif +c + if ( mod(taopti(36),3).eq.0 ) then + write(ulsort,texte(langue,40)) + endif diff --git a/src/tool/Includes_Generaux/mslve6.h b/src/tool/Includes_Generaux/mslve6.h new file mode 100644 index 00000000..5298ba2d --- /dev/null +++ b/src/tool/Includes_Generaux/mslve6.h @@ -0,0 +1,43 @@ + if ( taopti(31).gt.0 ) then +c + if ( taopti(37).eq.0 ) then +c + if ( taopti(6).eq.1 ) then + write(ulsort,texte(langue,81)) taoptr(1) + elseif ( taopti(6).eq.2 ) then + write(ulsort,texte(langue,82)) taoptr(1) + if ( taoptr(1).lt.0.d0 .or. taoptr(1).gt.100.d0 ) then + write(ulsort,texte(langue,87)) + nbrepb = nbrepb + 1 + endif + elseif ( taopti(6).eq.3 ) then + write(ulsort,texte(langue,83)) taoptr(1) + if ( taoptr(1).lt.0.d0 .or. taoptr(1).gt.100.d0 ) then + write(ulsort,texte(langue,87)) + nbrepb = nbrepb + 1 + endif + elseif ( taopti(6).eq.4 ) then + write(ulsort,texte(langue,88)) '+', taoptr(1) + elseif ( taopti(6).eq.5 ) then + if ( taopti(44).gt.0 ) then + write(ulsort,texte(langue,123)) taopti(44) + endif + if ( taopti(43).gt.0 ) then + write(ulsort,texte(langue,124)) taopti(43) + endif + else + write(ulsort,texte(langue,80)) + nbrepb = nbrepb + 1 + endif +c + else +c + write(ulsort,texte(langue,94)) +c + endif +c + endif +c + if ( taopti(31).ne.0 .and. taopti(33).ge.0 ) then + write(ulsort,texte(langue,51)) taopti(33) + endif diff --git a/src/tool/Includes_Generaux/mslve7.h b/src/tool/Includes_Generaux/mslve7.h new file mode 100644 index 00000000..9da76da9 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve7.h @@ -0,0 +1,18 @@ + if ( taopti(10).gt.0 ) then +c + if ( taopti(37).eq.0 ) then +c + write(ulsort,texte(langue,41)) +c + if ( taopti(32).ge.-1 .and.taopti(32).le.1 ) then + write(ulsort,texte(langue,43+taopti(32))) +c + else + write(ulsort,texte(langue,11)) taopti(32) + nbrepb = nbrepb + 1 +c + endif +c + endif +c + endif diff --git a/src/tool/Includes_Generaux/mslve8.h b/src/tool/Includes_Generaux/mslve8.h new file mode 100644 index 00000000..718b8f9b --- /dev/null +++ b/src/tool/Includes_Generaux/mslve8.h @@ -0,0 +1,36 @@ + if ( taopti(10).gt.0 ) then +c + if ( taopti(32).gt.0 ) then +c + if ( taopti(37).eq.0 ) then +c + if ( taopti(7).eq.1 ) then + write(ulsort,texte(langue,84)) taoptr(2) + elseif ( taopti(7).eq.2 ) then + write(ulsort,texte(langue,85)) taoptr(2) + if ( taoptr(2).lt.0.d0 .or. taoptr(2).gt.100.d0 ) then + write(ulsort,texte(langue,88)) + nbrepb = nbrepb + 1 + endif + elseif ( taopti(7).eq.3 ) then + write(ulsort,texte(langue,86)) taoptr(2) + if ( taoptr(2).lt.0.d0 .or. taoptr(2).gt.100.d0 ) then + write(ulsort,texte(langue,88)) + nbrepb = nbrepb + 1 + endif + elseif ( taopti(7).eq.4 ) then + write(ulsort,texte(langue,88)) '-', taoptr(2) + else + write(ulsort,texte(langue,80)) + nbrepb = nbrepb + 1 + endif +c + endif +c + endif +c + if ( taopti(32).ne.0 .and. taopti(34).gt.0 ) then + write(ulsort,texte(langue,52)) taopti(34) + endif +c + endif diff --git a/src/tool/Includes_Generaux/mslve9.h b/src/tool/Includes_Generaux/mslve9.h new file mode 100644 index 00000000..8f1b8fc0 --- /dev/null +++ b/src/tool/Includes_Generaux/mslve9.h @@ -0,0 +1,13 @@ + if ( taopti(10).gt.0 ) then +c + if ( taopti(31).eq.-1 .and. taopti(32).ne.0 ) then + write(ulsort,texte(langue,53)) + nbrepb = nbrepb + 1 + endif +c + if ( taopti(31).ne.0 .and. taopti(32).eq.-1 ) then + write(ulsort,texte(langue,54)) + nbrepb = nbrepb + 1 + endif +c + endif diff --git a/src/tool/Includes_Generaux/mslver.h b/src/tool/Includes_Generaux/mslver.h new file mode 100644 index 00000000..04784c44 --- /dev/null +++ b/src/tool/Includes_Generaux/mslver.h @@ -0,0 +1,227 @@ + texte(1,6) = + > '(/,1x,''Une ERREUR dans les mots-cles des options !'')' + texte(1,7) = '(/,1x,''ERREURS dans les mots-cles des options !'')' +c + texte(1,11) = '(7x,''--> OPTION INVALIDE :'',i10)' + texte(1,12) = '(7x,''--> pas de conversion'',/)' + texte(1,13) = '(7x,''--> conversion'',/)' + texte(1,14) = '(7x,''--> inactif'')' + texte(1,15) = '(7x,''--> actif'')' +c + texte(1,20) = '(5x,''Maillage initial'')' + texte(1,21) = '(5x,''Maillage apres une iteration'')' + texte(1,22) = '(5x,''Maillage apres'',i4,'' iterations'')' + texte(1,23) = '(/,5x,''Point de depart :'',/,5x,17(''-''))' + texte(1,24) = '(7x,''Maillage a analyser :'')' + texte(1,25) = '(7x,''Maillage a modifier :'')' +c + texte(1,26) = + > '(/,5x,''Code de calcul associe : '',a18,/,5x,24(''-''))' +c + texte(1,27) = '(/,5x,''Suivi de frontiere :'',/,5x,20(''-''))' + texte(1,28) = '( 5x,''Impossible en 3D'')' + texte(1,29) = '( 5x,''Non disponible avec ce code de calcul'')' +c + texte(1,30) = + > '(/,5x,''Pilotage du raffinement :'',/,5x,25(''-''))' + texte(1,31) = + > '(/,7x,''--> Les mailles incompatibles sont ignorees'')' +c remarque : l'indice vaut 33 + code du type de raffinement + texte(1,32) = '(7x,''--> raffinement uniforme'',/)' + texte(1,33) = '(7x,''--> pas de raffinement'')' + texte(1,34) = '(7x,''--> raffinement libre'',/)' + texte(1,35) = + > '(7x,'' avec conservation des types de mailles'',/)' +c + texte(1,39) = + > '(7x,''--> decalage d''''au moins 2 mailles pour 2 zones a ni'', + > ''veau different'',/)' + texte(1,40) = '(7x,''--> bande interdite'',/)' +c + texte(1,41) = + > '(/,5x,''Pilotage du deraffinement :'',/,5x,27(''-''))' +c remarque : l'indice vaut 43 + code du type de raffinement + texte(1,42) = '(7x,''--> deraffinement uniforme'',/)' + texte(1,43) = '(7x,''--> pas de deraffinement'')' + texte(1,44) = '(7x,''--> deraffinement libre'',/)' +c + texte(1,51) = '(7x,''--> niveau maximum autorise :'',i4)' + texte(1,52) = '(7x,''--> niveau minimum autorise :'',i4)' + texte(1,53) = + > '(/,7x,''Deraffinement interdit si le raffinement est uniforme.'' + >)' + texte(1,54) = + > '(/,7x,''Raffinement interdit si le deraffinement est uniforme.'' + >)' +c + texte(1,61) = '(/,5x,''Les conversions :'',/,5x,17(''-''))' +c + texte(1,70) = + > '(/,5x,''Options pour Code_Saturne :'',/,5x,27(''-''))' + texte(1,71) = + > '(/,7x,''--> Il faut definir le delta z voulu.'')' + texte(1,72) = + > '(/,7x,''--> Le delta z voulu doit etre strictement positif.'')' +c + texte(1,80) = + > '(/,7x,''--> Mauvaise definition des seuils d''''erreur.'')' + texte(1,81) = + > '(7x,''--> borne superieure absolue de l''''erreur : '',g15.6,/)' + texte(1,82) = + >'(7x,''--> borne superieure relative de l''''erreur : '',g11.3,/)' + texte(1,83) = + > '(7x,''--> pourcentage de mailles a raffiner : '',g11.3,/)' + texte(1,84) = + > '(7x,''--> borne inferieure absolue de l''''erreur : '',g15.6,/)' + texte(1,85) = + >'(7x,''--> borne inferieure relative de l''''erreur : '',g11.3,/)' + texte(1,86) = + > '(7x,''--> pourcentage de mailles a deraffiner : '',g11.3,/)' + texte(1,87) = + > '(/,7x,''Le pourcentage doit etre entre 0 et 100.'')' + texte(1,88) = + > '(7x,''--> seuil en moyenne '',a,'' '',g11.3,''*sigma'',/)' + texte(1,93) = '(/,7x,''Les seuils sont incompatibles.'')' + texte(1,94) = '(7x,''--> selon des zones geometriques'')' +c + texte(1,101) = + >'(''Choix de l''''instant de l''''indicateur d''''errreur'')' + texte(1,102) = + >'(''Impossible de demander un ''''dernier'''' et autre chose'',/)' + texte(1,103) = + >'(''Impossible de demander un instant et un pas de temps'',/)' +c + texte(1,110) = + > '(/,5x,''Mode de conformite :'',/,5x,20(''-''))' + texte(1,111) = + > '(7x,''--> non conforme avec 1 seule arete decoupee'')' + texte(1,112) = + > '(7x,''--> Adaptation conforme avec des boites'')' + texte(1,113) = + > '(7x,''--> Adaptation conforme'')' + texte(1,114) = + > '(7x,''--> Adaptation non conforme'')' + texte(1,115) = + > '(7x,''--> non conforme avec 1 seul noeud pendant par arete'',/)' + texte(1,116) = + > '(7x,''--> non conforme fidele a l''''indicateur'',/)' +c + texte(1,119) = + > '(/,5x,''Maillage extrude selon '',a1,/,5x,24(''-''))' +c + texte(1,120) = + > '(7x,''--> Cible en nombre de sommets possible exclusivement'')' + texte(1,121) = '(11x,''avec du raffinement libre'')' + texte(1,122) = '(11x,''sans deraffinement'')' + texte(1,123) = + > '(7x,''--> cible en nombre de sommets : '',i11,/)' + texte(1,124) = + > '(7x,''--> nombre maximum de passages :'',i5,/)' +c + texte(2,6) = '(/,1x,''One ERROR in keywords of options !'')' + texte(2,7) = '(/,1x,''ERRORS in keywords of options !'')' +c + texte(2,11) = '(7x,''--> UNCORRECT OPTION :'',i10)' + texte(2,12) = '(7x,''--> no conversion'',/)' + texte(2,13) = '(7x,''--> conversion'',/)' + texte(2,14) = '(7x,''--> non active'')' + texte(2,15) = '(7x,''--> active'')' +c + texte(2,20) = '(5x,''Initial mesh'')' + texte(2,21) = '(5x,''Mesh after one iteration'')' + texte(2,22) = '(5x,''Mesh after'',i4,'' iterations'')' + texte(2,23) = '(/,5x,''Start point:'',/,5x,13(''-''))' + texte(2,24) = '(7x,''Mesh to be checked:'')' + texte(2,25) = '(7x,''Mesh to be modified:'')' +c + texte(2,26) = '(/,5x,''Related code: '',a18,/,5x,14(''-''))' +c + texte(2,27) = '(/,5x,''Boundary following:'',/,5x,20(''-''))' + texte(2,28) = '( 5x,''Impossible for 3D'')' + texte(2,29) = '( 5x,''Non available with this connected code'')' +c + texte(2,30) = '(/,5x,''Control of refinement:'',/,5x,23(''-''))' + texte(2,31) = '(/,7x,''--> Incompatible meshes are ignored'')' +c remarque : l'indice vaut 33 + code du type de raffinement + texte(2,32) = '(7x,''--> uniform refinement'',/)' + texte(2,33) = '(7x,''--> no refinement'')' + texte(2,34) = '(7x,''--> free refinement'',/)' +c + texte(2,39) = '(7x,''--> shift of at least 2 meshes'',/)' + texte(2,40) = '(7x,''--> stripes are forbidden'',/)' +c + texte(2,41) = + > '(/,5x,''Control of unrefinement:'',/,5x,25(''-''))' +c remarque : l'indice vaut 43 + code du type de raffinement + texte(2,42) = '(7x,''--> uniform unrefinement'',/)' + texte(2,43) = '(7x,''--> no unrefinement'')' + texte(2,44) = '(7x,''--> free unrefinement'',/)' +c + texte(2,51) = '(7x,''--> maximum authorized level:'',i4)' + texte(2,52) = '(7x,''--> minimum authorized level:'',i4)' + texte(2,53) = + >'(/,7x,''Unrefinement is forbidden when refinement is uniform.'')' + texte(2,54) = + >'(/,7x,''Refinement is forbidden when unrefinement is uniform.'')' +c + texte(2,61) = '(/,5x,''Conversions:'',/,5x,13(''-''))' +c + texte(2,70) = + > '(/,5x,''Options for Code_Saturne:'',/,5x,26(''-''))' + texte(2,71) = + > '(/,7x,''--> Wanted delta z should be defined.'')' + texte(2,72) = + > '(/,7x,''--> Wanted delta z should be positive.'')' +c + texte(2,80) = + > '(/,7x,''--> Error threshold ill-defined.'')' + texte(2,81) = + >'(7x,''--> high absolute threshold for error: '',g15.6,/)' + texte(2,82) = + >'(7x,''--> high relative threshold for error: '',g11.3,/)' + texte(2,83) = + >'(7x,''--> percentage of meshes to refine: '',g11.3,/)' + texte(2,84) = + >'(7x,''--> low absolute threshold for error : '',g15.6,/)' + texte(2,85) = + >'(7x,''--> low relative threshold for error : '',g11.3,/)' + texte(2,86) = + >'(7x,''--> percentage of meshes to coarsen: '',g11.3,/)' + texte(2,87) = '(/,7x,''Percentage should be between 0 and 100.'')' + texte(2,88) = + > '(7x,''--> threshold by mean '',a,'' '',g11.3,''*sigma'',/)' + texte(2,93) = '(/,7x,''The thresholds do not fit together.'')' + texte(2,94) = '(7x,''--> by geometrical zones'')' +c + texte(2,101) = '(''Choice for error indicator'')' + texte(2,102) = + >'(''''Last'''' and something else cannot be both required'',/)' + texte(2,103) = + >'(''A time step and an instant cannot be both required'',/)' +c + texte(2,110) = + > '(/,5x,''Type of conformal situations:'',/,5x,30(''-''))' + texte(2,111) = + > '(7x,''--> hanging node refinement with a single cut edge'',/)' + texte(2,112) = + > '(7x,''--> Conformal adaptation with boxes'')' + texte(2,113) = + > '(7x,''--> Conformal adaptation'')' + texte(2,114) = + > '(7x,''--> Non conformal adaptation'')' + texte(2,115) = + > '(7x,''--> hanging node refinement, a single node per edge'',/)' + texte(2,116) = + > '(7x,''--> hanging node refinement from indicator'',/)' +c + texte(2,119) = + > '(/,5x,''Extruded mesh along '',a1,/,5x,21(''-''))' +c + texte(2,120) = + > '(7x,''--> Target for the number of vertices is possible only'')' + texte(2,121) = '(11x,''with free refinement'')' + texte(2,122) = '(11x,''without unrefinement'')' + texte(2,123) = + > '(7x,''--> target for the number of vertices: '',i11,/)' + texte(2,124) = + > '(7x,''--> maximal number of iterations:'',i5,/)' diff --git a/src/tool/Includes_Generaux/nancnb.h b/src/tool/Includes_Generaux/nancnb.h new file mode 100644 index 00000000..1d4b21b3 --- /dev/null +++ b/src/tool/Includes_Generaux/nancnb.h @@ -0,0 +1,27 @@ +c +c======================================================================= +c nombres d'entites du maillage initial avec la conformite +c----------------------------------------------------------------------- +c nancno : nombre de noeuds du maillage adapte +c nancar : nombre d'aretes du maillage adapte +c nanctr : nombre de triangles du maillage adapte +c nancqu : nombre de quadrangles du maillage adapte +c nancte : nombre de tetraedres du maillage adapte +c nanctf : nombre de tetraedres du maillage adapte decrits par faces +c nancta : nombre de tetraedres du maillage adapte decrits par aretes +c nancpy : nombre de pyramides du maillage adapte +c nancyf : nombre de pyramides du maillage adapte decrites par faces +c nancya : nombre de pyramides du maillage adapte decrites par aretes +c nanche : nombre d'hexaedres du maillage adapte +c nanchf : nombre d'hexaedres du maillage adapte decrits par faces +c nancha : nombre d'hexaedres du maillage adapte decrits par aretes +c nancpe : nombre de pentaedres du maillage adapte +c nancpf : nombre de pentaedres du maillage adapte decrits par faces +c nancpa : nombre de pentaedres du maillage adapte decrits par aretes +c----------------------------------------------------------------------- + integer nancno, nancar, nanctr, nancqu, + > nancte, nanctf, nancta, nancpy, nancyf, nancya, + > nanche, nanchf, nancha, nancpe, nancpf, nancpa + common /nancnb/ nancno, nancar, nanctr, nancqu, + > nancte, nanctf, nancta, nancpy, nancyf, nancya, + > nanche, nanchf, nancha, nancpe, nancpf, nancpa diff --git a/src/tool/Includes_Generaux/nbfami.h b/src/tool/Includes_Generaux/nbfami.h new file mode 100644 index 00000000..b1c23fdb --- /dev/null +++ b/src/tool/Includes_Generaux/nbfami.h @@ -0,0 +1,22 @@ +c +c======================================================================= +c nombres de familles d'entites +c----------------------------------------------------------------------- +c nbfnoe : nombre total de familles de noeuds +c nbfmpo : nombre total de familles de mailles-points +c nbfare : nombre total de familles d'aretes +c nbftri : nombre total de familles de triangles +c nbfqua : nombre total de familles de quadrangles +c nbftet : nombre total de familles de tetraedres +c nbfhex : nombre total de familles d'hexaedres +c nbfpyr : nombre total de familles de pyramides +c nbfpen : nombre total de familles de pentaedres +c----------------------------------------------------------------------- + integer nbfnoe, nbfmpo, + > nbfare, + > nbftri, nbfqua, + > nbftet, nbfhex, nbfpyr, nbfpen + common /nbfami/ nbfnoe, nbfmpo, + > nbfare, + > nbftri, nbfqua, + > nbftet, nbfhex, nbfpyr, nbfpen diff --git a/src/tool/Includes_Generaux/nbfamm.h b/src/tool/Includes_Generaux/nbfamm.h new file mode 100644 index 00000000..f080bba0 --- /dev/null +++ b/src/tool/Includes_Generaux/nbfamm.h @@ -0,0 +1,22 @@ +c +c======================================================================= +c nombres maximum de familles d'entites +c----------------------------------------------------------------------- +c nbfnom : nombre maximum de familles de noeuds +c nbfmpm : nombre maximum de familles de mailles-points +c nbfarm : nombre maximum de familles d'aretes +c nbftrm : nombre maximum de familles de triangles +c nbfqum : nombre maximum de familles de quadrangles +c nbftem : nombre maximum de familles de tetraedres +c nbfhem : nombre maximum de familles d'hexaedres +c nbfpym : nombre maximum de familles de pyramides +c nbfpem : nombre maximum de familles de pentaedres +c----------------------------------------------------------------------- + integer nbfnom, nbfmpm, + > nbfarm, + > nbftrm, nbfqum, + > nbftem, nbfhem, nbfpym, nbfpem + common /nbfamm/ nbfnom, nbfmpm, + > nbfarm, + > nbftrm, nbfqum, + > nbftem, nbfhem, nbfpym, nbfpem diff --git a/src/tool/Includes_Generaux/nbgrou.h b/src/tool/Includes_Generaux/nbgrou.h new file mode 100644 index 00000000..15fa7058 --- /dev/null +++ b/src/tool/Includes_Generaux/nbgrou.h @@ -0,0 +1,23 @@ +c +c======================================================================= +c nombres de groupes dans chaque categorie +c----------------------------------------------------------------------- +c nbgrno : nombre de groupes de noeuds +c nbgrel : nombre de groupes d'elements, tous types confondus +c nbgrmp : nombre de groupes de mailles-points +c nbgrar : nombre de groupes d'aretes +c nbgrtr : nombre de groupes de triangles +c nbgrqu : nombre de groupes de quadrangles +c nbgrte : nombre de groupes de tetraedres +c nbgrhe : nombre de groupes d'hexaedres +c nbgrpy : nombre de groupes de pyramides +c nbgrpe : nombre de groupes de pentaedres +c----------------------------------------------------------------------- + integer nbgrno, nbgrel, + > nbgrmp, nbgrar, + > nbgrtr, nbgrqu, + > nbgrte, nbgrhe, nbgrpy, nbgrpe + common /nbgrou/ nbgrno, nbgrel, + > nbgrmp, nbgrar, + > nbgrtr, nbgrqu, + > nbgrte, nbgrhe, nbgrpy, nbgrpe diff --git a/src/tool/Includes_Generaux/nblang.h b/src/tool/Includes_Generaux/nblang.h new file mode 100644 index 00000000..4e56ec74 --- /dev/null +++ b/src/tool/Includes_Generaux/nblang.h @@ -0,0 +1,5 @@ +c +c nblang = nombre maximum de langues autorisees +c + integer nblang + parameter ( nblang = 2 ) diff --git a/src/tool/Includes_Generaux/nbrmax.h b/src/tool/Includes_Generaux/nbrmax.h new file mode 100644 index 00000000..0f454097 --- /dev/null +++ b/src/tool/Includes_Generaux/nbrmax.h @@ -0,0 +1,12 @@ +c AUTORISATION debut +c +c nombre maximum de noeuds pour un maillage +c dans le cas d'une version de demonstration +c on distingue le 2d et le 3d +c + integer nbnmx2 + parameter ( nbnmx2 = 2 500 ) +c + integer nbnmx3 + parameter ( nbnmx3 = 10 000 ) +c AUTORISATION fin diff --git a/src/tool/Includes_Generaux/nbutil.h b/src/tool/Includes_Generaux/nbutil.h new file mode 100644 index 00000000..8498d725 --- /dev/null +++ b/src/tool/Includes_Generaux/nbutil.h @@ -0,0 +1,57 @@ +c +c======================================================================= +c nombres utiles au maillage de calcul +c cela correspond a peu pres a la branche Nombres de l'objet +c Maillage de calcul +c----------------------------------------------------------------------- +c sdimca : dimension de l'espace (2 ou 3) +c mdimca : dimension du maillage (1, 2 ou 3) +c nbelem : nombre d'elements dans le maillage +c nbmaae : nombre maximum d'aretes par element +c nbmafe : nombre maximum de faces par element +c nbmnei : nombre maximum de noeuds par element elimine +c nbmapo : nombre de mailles-points dans le maillage +c nbsegm : nombre de segments dans le maillage +c nbtria : nombre de triangles dans le maillage +c nbtetr : nombre de tetraedres dans le maillage +c nbquad : nombre de quadrangles dans le maillage +c nbhexa : nombre d'hexaedres dans le maillage +c nbpent : nombre de pentaedres dans le maillage +c nbpyra : nombre de pyramides dans le maillage +c nbelig : nombre d'elements a eliminer de l'adaptation +c numael : numero maximum d'element dans le maillage +c numano : numero maximum de noeud dans le maillage +c nbma2d : nombre total de mailles 2D +c nbma3d : nombre total de mailles 3D +c nvoare : nombre cumule d'elements voisins d'aretes du maillage +c nvosom : nombre cumule d'elements voisins des sommets du maillage +c nbfmed : nombre total de familles MED pour toutes les entites +c nbfmen : nombre de familles MED pour les noeuds +c ngrouc : nombre de groupes cumules dans les familles +c nbequi : nombre total d'equivalences +c nbeqno : nombre total de paires equivalentes de noeuds +c nbeqmp : nombre total de paires equivalentes de mailles-points +c nbeqar : nombre total de paires equivalentes d'aretes +c nbeqtr : nombre total de paires equivalentes de triangles +c nbeqqu : nombre total de paires equivalentes de quadrangles +c nbeqte : nombre total de paires equivalentes de tetraedres +c nbeqhe : nombre total de paires equivalentes d'hexaedres +c----------------------------------------------------------------------- + integer sdimca, mdimca, + > nbelem, nbmaae, nbmafe, nbmnei, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, nbelig, + > nbma2d, nbma3d, + > numael, numano, nvoare, nvosom, + > nbfmed, nbfmen, ngrouc, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe + common /nbutil/ sdimca, mdimca, + > nbelem, nbmaae, nbmafe, nbmnei, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, nbelig, + > nbma2d, nbma3d, + > numael, numano, nvoare, nvosom, + > nbfmed, nbfmen, ngrouc, + > nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe diff --git a/src/tool/Includes_Generaux/nombar.h b/src/tool/Includes_Generaux/nombar.h new file mode 100644 index 00000000..8140d3eb --- /dev/null +++ b/src/tool/Includes_Generaux/nombar.h @@ -0,0 +1,28 @@ +c +c======================================================================= +c nombres propres aux aretes +c----------------------------------------------------------------------- +c nbarac : nombre d'aretes actives +c nbarde : nombre d'aretes crees pour le decoupage standard du maillage, +c soit au decoupage des faces en 4, soit en interne aux +c tetraedres, hexaedres, pentaedres coupes en 8 +c nbart2 : nombre d'aretes internes des triangles decoupes en 2 +c nbarq2 : nombre d'aretes internes des quadrangles decoupes en 2 +c nbarq3 : nombre d'aretes internes des quadrangles decoupes en 3 tria +c nbarq5 : nombre d'aretes internes des quadrangles decoupes en 3 quad +c nbarin : nombre d'aretes internes aux volumes coupees par conformite +c nbarma : nombre d'aretes du macro-maillage +c nbarpe : nombre d'aretes permanentes du maillage (nbarma+nbarde) +c nbarto : nombre total d'aretes du maillage +c = nbarpe + nbart2 + nbarq2 + nbarq3 + nbarq5 + nbarin +c nbfaar : nombre cumule des faces autour des aretes +c nbpaho : nombre de paires d'aretes homologues +c----------------------------------------------------------------------- + integer nbarac, nbarde, nbart2, + > nbarq2, nbarq3, nbarq5, + > nbarin, + > nbarma, nbarpe, nbarto, nbfaar, nbpaho + common /nombar/ nbarac, nbarde, nbart2, + > nbarq2, nbarq3, nbarq5, + > nbarin, + > nbarma, nbarpe, nbarto, nbfaar, nbpaho diff --git a/src/tool/Includes_Generaux/nomber.h b/src/tool/Includes_Generaux/nomber.h new file mode 100644 index 00000000..1a955ab9 --- /dev/null +++ b/src/tool/Includes_Generaux/nomber.h @@ -0,0 +1,51 @@ +c +c======================================================================= +c nombres propres a la renumerotation des entites en entree +c----------------------------------------------------------------------- +c renois : nombre de noeuds isoles +c renoei : nombre de noeuds elements ignores uniquement +c renomp : nombre de noeuds support de maille-point uniquement +c renop1 : nombre de noeuds sommets +c renop2 : nombre de noeuds milieux d'aretes +c renoim : nombre de noeuds internes aux mailles +c renoac : nombre de noeuds actifs dans le calcul +c renoto : nombre total de noeuds +c = renois+renoei+renomp+renop1+renop2+renoim +c reno1i : nombre de noeuds p1 et isoles (renois+renoei+renomp+renop1) +c rempac : nombre d'el. utiles au calcul et contenant des mailles-points +c rempto : nombre total de mailles-points +c rearac : nombre d'elements utiles au calcul et contenant des aretes +c rearto : nombre total d'aretes +c retrac : nombre d'elements utiles au calcul et contenant des triangles +c retrto : nombre total de triangles +c requac : nombre d'elements utiles au calcul et contenant des quads +c requto : nombre total de quadrangles +c reteac : nombre d'elements utiles au calcul et contenant des tetras +c reteto : nombre total de tetraedres +c reheac : nombre d'elements utiles au calcul et contenant des hexaas +c reheto : nombre total d'hexaedres +c repyac : nombre d'elements utiles au calcul et contenant des pyras +c repyto : nombre total de pyramides +c repeac : nombre d'elements utiles au calcul et contenant des pentas +c repeto : nombre total de pentaedres +c----------------------------------------------------------------------- + integer renois, renoei, renomp, renop1, renop2, renoim, + > renoac, renoto, reno1i, + > rempac, rempto, + > rearac, rearto, + > retrac, retrto, + > requac, requto, + > reteac, reteto, + > reheac, reheto, + > repyac, repyto, + > repeac, repeto + common /nomber/ renois, renoei, renomp, renop1, renop2, renoim, + > renoac, renoto, reno1i, + > rempac, rempto, + > rearac, rearto, + > retrac, retrto, + > requac, requto, + > reteac, reteto, + > reheac, reheto, + > repyac, repyto, + > repeac, repeto diff --git a/src/tool/Includes_Generaux/nombhe.h b/src/tool/Includes_Generaux/nombhe.h new file mode 100644 index 00000000..868bfbda --- /dev/null +++ b/src/tool/Includes_Generaux/nombhe.h @@ -0,0 +1,20 @@ +c +c======================================================================= +c nombres propres aux hexaedres +c----------------------------------------------------------------------- +c nbheac : nombre d'hexaedres actifs +c nbheco : nombre d'hexaedres decoupes par conformite en pyramides +c et/ou tetraedres +c nbhede : nombre d'hexaedres issus d'un decoupage en 8 d'un +c hexaedres +c nbhedh : issus d'un decoupage de conformite d'un hexaedre +c nbhema : nombre d'hexaedres du macro-maillage. +c nbhepe : nombre d'hexaedres permanents du maillage (nbhema+nbhede). +c nbheto : nombre total d'hexaedres du maillage (nbhecf+nbheca) +c nbhecf : nombre d'hexaedres en connectivite par faces (=nbhepe) +c nbheca : nombre d'hexaedres en connectivite par aretes (=nbhedh) +c----------------------------------------------------------------------- + integer nbheac, nbheco, nbhede, nbhedh, nbhema, + > nbhepe, nbheto, nbhecf, nbheca + common /nombhe/ nbheac, nbheco, nbhede, nbhedh, nbhema, + > nbhepe, nbheto, nbhecf, nbheca diff --git a/src/tool/Includes_Generaux/nombmp.h b/src/tool/Includes_Generaux/nombmp.h new file mode 100644 index 00000000..715f1178 --- /dev/null +++ b/src/tool/Includes_Generaux/nombmp.h @@ -0,0 +1,9 @@ +c +c======================================================================= +c nombres propres aux mailles-points +c----------------------------------------------------------------------- +c nbmpto : nombre total de mailles-points du maillage +c nbppho : nombre de paires de mailles-points homologues +c----------------------------------------------------------------------- + integer nbmpto, nbppho + common /nombmp/ nbmpto, nbppho diff --git a/src/tool/Includes_Generaux/nombno.h b/src/tool/Includes_Generaux/nombno.h new file mode 100644 index 00000000..b8792624 --- /dev/null +++ b/src/tool/Includes_Generaux/nombno.h @@ -0,0 +1,23 @@ +c +c======================================================================= +c nombres propres aux noeuds +c----------------------------------------------------------------------- +c nbnois : nombre de noeuds isoles +c nbnoei : nombre de noeuds d'elements ignores +c nbnoma : nombre de noeuds du macro-maillage +c nbnomp : nombre de noeuds support de maille-point uniquement +c nbnop1 : nombre de sommets du maillage (noeuds p1) +c nbnop2 : nombre de noeuds milieux d'aretes du maillage (noeuds p2) +c nbnoim : nombre de noeuds internes aux mailles +c nbnoto : nombre total de noeuds du maillage (nbnop1+nbnop2+nbnoim) +c nbpnho : nombre de paires de noeuds homologues +c numip1 : numero minimum pour un sommet du maillage (noeud p1) +c numap1 : numero maximum pour un sommet du maillage (noeud p1) +c nbnoin : nombre de noeuds internes aux volumes coupees par conformite +c----------------------------------------------------------------------- + integer nbnois, nbnoei, nbnoma, nbnomp, + > nbnop1, nbnop2, nbnoim, nbnoto, + > nbpnho, numip1, numap1, nbnoin + common /nombno/ nbnois, nbnoei, nbnoma, nbnomp, + > nbnop1, nbnop2, nbnoim, nbnoto, + > nbpnho, numip1, numap1, nbnoin diff --git a/src/tool/Includes_Generaux/nombpe.h b/src/tool/Includes_Generaux/nombpe.h new file mode 100644 index 00000000..ab969752 --- /dev/null +++ b/src/tool/Includes_Generaux/nombpe.h @@ -0,0 +1,19 @@ +c +c======================================================================= +c nombres propres aux pentaedres +c----------------------------------------------------------------------- +c nbpeac : nombre de pentaedres actifs +c nbpeco : nombre de pentaedres decoupes par conformite +c nbpede : nombre de pentaedres issus d'un decoupage en 8 des +c pentaedres +c nbpedp : issus d'un decoupage de conformite d'un pentaedre +c nbpema : nombre de pentaedres du macro-maillage. +c nbpepe : nombre de pentaedres permanents du maillage (nbpema+nbpede). +c nbpeto : nombre total de pentaedres du maillage +c nbpecf : nombre de pentaedres en connectivite par faces +c nbpeca : nombre de pentas en connectivite par aretes +c----------------------------------------------------------------------- + integer nbpeac, nbpeco, nbpede, nbpedp, nbpema, + > nbpepe, nbpeto, nbpecf, nbpeca + common /nombpe/ nbpeac, nbpeco, nbpede, nbpedp, nbpema, + > nbpepe, nbpeto, nbpecf, nbpeca diff --git a/src/tool/Includes_Generaux/nombpy.h b/src/tool/Includes_Generaux/nombpy.h new file mode 100644 index 00000000..2da41ebb --- /dev/null +++ b/src/tool/Includes_Generaux/nombpy.h @@ -0,0 +1,36 @@ +c +c======================================================================= +c nombres propres aux pyramides +c----------------------------------------------------------------------- +c nbpyac : nombre de pyramides actives +c nbpyde : nombre de pyramides issues du decoupage de pyramides +c Pour un raffinement selon des boites : +c nbpyh1 : issues d'un decoupage d'un hexaedre a partir d'une face +c nbpyh2 : issues d'un decoupage d'un hexaedre a partir de 3 aretes +c nbpyh3 : issues d'un decoupage d'un hexaedre a partir de 2 aretes +c nbpyh4 : issues d'un decoupage d'un hexaedre a partir d'1 arete +c nbpyp0 : issues d'un decoupage d'un pentaedre a partir d'1 ar tr +c nbpyp1 : issues d'un decoupage d'un pentaedre a partir d'1 ar qu +c nbpyp2 : issues d'un decoupage d'un pentaedre a partir de 2 ar tr/qu +c nbpyp3 : issues d'un decoupage d'un pentaedre a partir de 2 ar qu/qu +c nbpyp4 : issues d'un decoupage d'un pentaedre a partir d'1 face qu +c nbpyp5 : issues d'un decoupage d'un pentaedre a partir d'1 face tr +c Sinon : +c nbpydh : issues d'un decoupage d'un hexaedre +c nbpydp : issues d'un decoupage d'un pentaedre +c nbpyma : nombre de pyramides du macro-maillage. +c nbpype : nombre de pyramides permanents du maillage (nbpyma+nbpyde). +c nbpyto : nombre total de pyramides du maillage (nbpycf+nbpyca) +c nbpycf : nombre de pyramides en connectivite par faces +c nbpyca : nombre de pyras en connectivite par aretes (nbpydh+nbpydp) +c----------------------------------------------------------------------- + integer nbpyac, nbpyde, + > nbpyh1, nbpyh2, nbpyh3, nbpyh4, + > nbpyp0, nbpyp1, nbpyp2, nbpyp3, nbpyp4, nbpyp5, + > nbpydh, nbpydp, + > nbpyma, nbpype, nbpyto, nbpycf, nbpyca + common /nombpy/ nbpyac, nbpyde, + > nbpyh1, nbpyh2, nbpyh3, nbpyh4, + > nbpyp0, nbpyp1, nbpyp2, nbpyp3, nbpyp4, nbpyp5, + > nbpydh, nbpydp, + > nbpyma, nbpype, nbpyto, nbpycf, nbpyca diff --git a/src/tool/Includes_Generaux/nombqu.h b/src/tool/Includes_Generaux/nombqu.h new file mode 100644 index 00000000..21b56d87 --- /dev/null +++ b/src/tool/Includes_Generaux/nombqu.h @@ -0,0 +1,24 @@ +c +c======================================================================= +c nombres propres aux quadrangles +c----------------------------------------------------------------------- +c nbquac : nombre de quadrangles actifs +c nbqude : nombre de quadrangles issus d'un decoupage en 4 des +c quadrangles +c nbquq2 : nombre de quadrangles issus d'un decoupage en 2 des +c quadrangles +c nbquq5 : nombre de quadrangles issus d'un decoupage en 3 des +c quadrangles +c nbquma : nombre de quadrangles du macro-maillage. +c nbqupe : nombre de quadrangles permanents du maillage (nbquma+nbqude). +c nbquto : nombre total de quadrangles du maillage +c = nbqupe + nbquq2 + nbquq3 +c nbpqho : nombre de paires de quadrangles homologues. +c nbquri : nombre de quadrangles recolles dans le maillage initial +c----------------------------------------------------------------------- + integer nbquac, nbqude, nbquma, + > nbquq2, nbquq5, + > nbqupe, nbquto, nbpqho, nbquri + common /nombqu/ nbquac, nbqude, nbquma, + > nbquq2, nbquq5, + > nbqupe, nbquto, nbpqho, nbquri diff --git a/src/tool/Includes_Generaux/nombsr.h b/src/tool/Includes_Generaux/nombsr.h new file mode 100644 index 00000000..e8559107 --- /dev/null +++ b/src/tool/Includes_Generaux/nombsr.h @@ -0,0 +1,55 @@ +c +c======================================================================= +c nombres propres a la renumerotation des entites en sortie +c----------------------------------------------------------------------- +c rsnois : nombre de noeuds isoles +c rsnoei : nombre de noeuds elements ignores uniquement +c rsnomp : nombre de noeuds support de maille-point uniquement +c rsnop1 : nombre de noeuds sommets +c rsnop2 : nombre de noeuds milieux d'aretes +c rsnoim : nombre de noeuds internes aux mailles +c rsnoac : nombre de noeuds actifs dans le calcul +c rsnoto : nombre total de noeuds +c = rsnois+rsnoei+rsnomp+rsnop1+rsnop2+rsnoim +c rsmpac : nombre d'el. utiles au calcul et contenant des mailles-points +c rsmpto : nombre total de mailles-points +c rsarac : nombre d'elements utiles au calcul et contenant des aretes +c rsarto : nombre total d'aretes +c rstrac : nombre d'elements utiles au calcul et contenant des triangles +c rstrto : nombre total de triangles +c rsquac : nombre d'elements utiles au calcul et contenant des quads +c rsquto : nombre total de quadrangles +c rsteac : nombre d'elements utiles au calcul et contenant des tetras +c rsteto : nombre total de tetraedres +c rsheac : nombre d'elements utiles au calcul et contenant des hexas +c rsheto : nombre total d'hexaedres +c rspyac : nombre d'elements utiles au calcul et contenant des pyras +c rspyto : nombre total de pyramides +c rspeac : nombre d'elements utiles au calcul et contenant des pentas +c rspeto : nombre total de pentaedres +c rseutc : nombre total d'elements utiles au calcul +c rsevca : nombre d'elements volumiques dans le maillage de calcul +c rsevto : nombre total d'elements utiles au calcul +c----------------------------------------------------------------------- + integer rsnois, rsnoei, rsnomp, rsnop1, rsnop2, rsnoim, + > rsnoac, rsnoto, + > rsmpac, rsmpto, + > rsarac, rsarto, + > rstrac, rstrto, + > rsquac, rsquto, + > rsteac, rsteto, + > rsheac, rsheto, + > rspyac, rspyto, + > rspeac, rspeto, + > rseutc, rsevca, rsevto + common /nombsr/ rsnois, rsnoei, rsnomp, rsnop1, rsnop2, rsnoim, + > rsnoac, rsnoto, + > rsmpac, rsmpto, + > rsarac, rsarto, + > rstrac, rstrto, + > rsquac, rsquto, + > rsteac, rsteto, + > rsheac, rsheto, + > rspyac, rspyto, + > rspeac, rspeto, + > rseutc, rsevca, rsevto diff --git a/src/tool/Includes_Generaux/nombte.h b/src/tool/Includes_Generaux/nombte.h new file mode 100644 index 00000000..5e4ce6c1 --- /dev/null +++ b/src/tool/Includes_Generaux/nombte.h @@ -0,0 +1,39 @@ +c +c======================================================================= +c nombres propres aux tetraedres +c----------------------------------------------------------------------- +c nbteac : actifs +c nbtea2 : issus d'un decoupage en 2 d'un tetraedre +c nbtea4 : issus d'un decoupage en 4 (par 2 aretes) d'un tetraedre +c nbtede : issus du decoupage standard du maillage +c nbtef4 : issus d'un decoupage en 4 (par 1 face) d'un tetraedre +c Pour un raffinement selon des boites : +c nbteh1 : issus d'un decoupage d'un hexaedre a partir d'une face +c nbteh2 : issus d'un decoupage d'un hexaedre a partir de 3 aretes +c nbteh3 : issus d'un decoupage d'un hexaedre a partir de 2 aretes +c nbteh4 : issus d'un decoupage d'un hexaedre a partir d'1 arete +c nbtep0 : issus d'un decoupage d'un pentaedre a partir d'1 ar tr +c nbtep1 : issus d'un decoupage d'un pentaedre a partir d'1 ar qu +c nbtep2 : issus d'un decoupage d'un pentaedre a partir de 2 ar tr/qu +c nbtep3 : issus d'un decoupage d'un pentaedre a partir de 2 ar qu/qu +c nbtep4 : issus d'un decoupage d'un pentaedre a partir d'1 face qu +c nbtep5 : issus d'un decoupage d'un pentaedre a partir d'1 face tr +c Sinon : +c nbtedh : issus d'un decoupage d'un hexaedre +c nbtedp : issus d'un decoupage d'un pentaedre +c nbtema : du macro-maillage +c nbtepe : permanents du maillage (nbtema+nbtede) +c nbteto : nombre total de tetraedres (nbtecf+nbteca) +c nbtecf : nombre de tetraedres en connectivite par faces +c nbteca : nombre de tetras en connectivite par aretes (nbtedh+nbtedp) +c----------------------------------------------------------------------- + integer nbteac, nbtea2, nbtea4, nbtede, nbtef4, + > nbteh1, nbteh2, nbteh3, nbteh4, + > nbtep0, nbtep1, nbtep2, nbtep3, nbtep4, nbtep5, + > nbtedh, nbtedp, + > nbtema, nbtepe, nbteto, nbtecf, nbteca + common /nombte/ nbteac, nbtea2, nbtea4, nbtede, nbtef4, + > nbteh1, nbteh2, nbteh3, nbteh4, + > nbtep0, nbtep1, nbtep2, nbtep3, nbtep4, nbtep5, + > nbtedh, nbtedp, + > nbtema, nbtepe, nbteto, nbtecf, nbteca diff --git a/src/tool/Includes_Generaux/nombtr.h b/src/tool/Includes_Generaux/nombtr.h new file mode 100644 index 00000000..4633fed1 --- /dev/null +++ b/src/tool/Includes_Generaux/nombtr.h @@ -0,0 +1,25 @@ +c +c======================================================================= +c nombres propres aux triangles +c----------------------------------------------------------------------- +c nbtrac : nombre de triangles actifs +c nbtrde : nombre de triangles issus d'un decoupage en 4 des triangles +c ou internes a un tetraedre ou pentaedre coupe en 8. +c nbtrt2 : nombre de triangles issus d'un decoupage en 2 des triangles. +c nbtrq3 : nombre de triangles issus d'un decoupage en 3 des quadrangles +c nbtrhc : nombre de triangles internes aux hexa coupes par conformite +c nbtrpc : nombre de triangles internes aux penta coupes par conformite +c nbtrtc : nombre de triangles internes aux tetra coupes par conformite +c nbtrma : nombre de triangles du macro-maillage. +c nbtrpe : nombre de triangles permanents du maillage (nbtrma+nbtrde). +c nbtrto : nombre total de triangles du maillage +c = nbtrpe + nbtrt2 + nbtrhc + nbtrpc + nbtrtc + nbtrq3 +c nbptho : nombre de paires de triangles homologues. +c nbtrri : nombre de triangles recolles dans le maillage initial +c----------------------------------------------------------------------- + integer nbtrac, nbtrde, nbtrt2, nbtrq3, + > nbtrhc, nbtrpc, nbtrtc, + > nbtrma, nbtrpe, nbtrto, nbptho, nbtrri + common /nombtr/ nbtrac, nbtrde, nbtrt2, nbtrq3, + > nbtrhc, nbtrpc, nbtrtc, + > nbtrma, nbtrpe, nbtrto, nbptho, nbtrri diff --git a/src/tool/Includes_Generaux/nomest.h b/src/tool/Includes_Generaux/nomest.h new file mode 100644 index 00000000..dfe7961b --- /dev/null +++ b/src/tool/Includes_Generaux/nomest.h @@ -0,0 +1,15 @@ +c +c======================================================================= +c estimation des nombres d'entites +c----------------------------------------------------------------------- +c nbar00 : estimation du nombre total d'aretes +c nbtr00 : estimation du nombre total de triangles +c nbqu00 : estimation du nombre total de quadrangles +c rbar00 : estimation du nombre total d'aretes si elles sont du calcul +c rbtr00 : estimation du nombre total de triangles s'ils sont du calcul +c rbtr00 : estimation du nombre total de quads s'ils sont du calcul +c----------------------------------------------------------------------- + integer nbar00, nbtr00, nbqu00, + > rbar00, rbtr00, rbqu00 + common /nomest/ nbar00, nbtr00, nbqu00, + > rbar00, rbtr00, rbqu00 diff --git a/src/tool/Includes_Generaux/nouvnb.h b/src/tool/Includes_Generaux/nouvnb.h new file mode 100644 index 00000000..aa1297ad --- /dev/null +++ b/src/tool/Includes_Generaux/nouvnb.h @@ -0,0 +1,80 @@ +c +c======================================================================= +c nombres d'entites du maillage adapte +c----------------------------------------------------------------------- +c nouvno : nombre de noeuds du maillage adapte +c permno : nombre de noeuds permanents du maillage adapte (nouvno en p1) +c permp1 : nombre de noeuds p1 permanents du maillage adapte +c provp1 : nombre de noeuds p1 provisoires du maillage adapte +c nouvp2 : nombre de noeuds p2 (milieux) du maillage adapte +c permp2 : nombre de noeuds p2 (milieux) permanents du maillage adapte +c provp2 : nombre de noeuds p2 (milieux) provisoires du maillage adapte +c nouvim : nombre de noeuds internes aux mailles du maillage adapte +c permim : nombre de noeuds internes permanents du maillage adapte +c provim : nombre de noeuds internes provisoires du maillage adapte +c nouvar : nombre d'aretes du maillage adapte +c permar : nombre d'aretes permanentes du maillage adapte +c provar : nombre d'aretes provisoires du maillage adapte +c nouvtr : nombre de triangles du maillage adapte +c permtr : nombre de triangles permanents du maillage adapte +c provtr : nombre de triangles provisoires du maillage adapte +c nouvqu : nombre de quadrangles du maillage adapte +c permqu : nombre de quadrangles permanents du maillage adapte +c provqu : nombre de quadangles provisoires du maillage adapte +c nouvte : nombre de tetraedres du maillage adapte +c nouvtf : nombre de tetraedres du maillage adapte decrits par face +c nouvta : nombre de tetraedres du maillage adapte decrits par arete +c permte : nombre de tetraedres permanents du maillage adapte +c provte : nombre de tetraedres provisoires du maillage adapte +c provtf : nombre de tetraedres provisoires decrits par face +c provta : nombre de tetraedres provisoires decrits par arete +c nouvhe : nombre d'hexaedres du maillage adapte +c permhe : nombre d'hexaedres permanents du maillage adapte +c nouvhf : nombre d'hexaedres du maillage adapte decrits par face +c nouvha : nombre d'hexaedres du maillage adapte decrits par arete +c provhe : nombre d'hexaedres provisoires du maillage adapte +c provhf : nombre d'hexaedres provisoires decrits par face +c provha : nombre d'hexaedres provisoires decrits par arete +c nouvpy : nombre de pyramides du maillage adapte +c permpy : nombre de pyramides permanentes du maillage adapte +c nouvyf : nombre de pyramides du maillage adapte decrits par face +c nouvya : nombre de pyramides du maillage adapte decrits par arete +c provpy : nombre de pyramides provisoires du maillage adapte +c provyf : nombre de pyramides provisoires decrits par face +c provya : nombre de pyramides provisoires decrits par arete +c nouvpe : nombre de pentaedres du maillage adapte +c nouvpf : nombre de pentaedres du maillage adapte decrits par face +c nouvpa : nombre de pentaedres du maillage adapte decrits par arete +c permpe : nombre de pentaedres permanents du maillage adapte +c provpe : nombre de pentaedres provisoires du maillage adapte +c provpf : nombre de pentaedres provisoires decrits par face +c provpa : nombre de pentaedres provisoires decrits par arete +c----------------------------------------------------------------------- + integer nouvno, permno, permp1, provp1, + > nouvp2, permp2, provp2, + > nouvim, permim, provim, + > nouvar, permar, provar, + > nouvtr, permtr, provtr, + > nouvqu, permqu, provqu, + > nouvte, permte, nouvtf, nouvta, + > provte, provtf, provta, + > nouvhe, permhe, nouvhf, nouvha, + > provhe, provhf, provha, + > nouvpy, permpy, nouvyf, nouvya, + > provpy, provyf, provya, + > nouvpe, permpe, nouvpf, nouvpa, + > provpe, provpf, provpa + common /nouvnb/ nouvno, permno, permp1, provp1, + > nouvp2, permp2, provp2, + > nouvim, permim, provim, + > nouvar, permar, provar, + > nouvtr, permtr, provtr, + > nouvqu, permqu, provqu, + > nouvte, permte, nouvtf, nouvta, + > provte, provtf, provta, + > nouvhe, permhe, nouvhf, nouvha, + > provhe, provhf, provha, + > nouvpy, permpy, nouvyf, nouvya, + > provpy, provyf, provya, + > nouvpe, permpe, nouvpf, nouvpa, + > provpe, provpf, provpa diff --git a/src/tool/Includes_Generaux/nuvers.h b/src/tool/Includes_Generaux/nuvers.h new file mode 100644 index 00000000..3c0e93bb --- /dev/null +++ b/src/tool/Includes_Generaux/nuvers.h @@ -0,0 +1,5 @@ +c +c Numero de version +c + character*8 nuvers + parameter ( nuvers = 'V11.n ' ) diff --git a/src/tool/Includes_Generaux/op0012.h b/src/tool/Includes_Generaux/op0012.h new file mode 100644 index 00000000..dac9da0e --- /dev/null +++ b/src/tool/Includes_Generaux/op0012.h @@ -0,0 +1,6 @@ +c +c======================================================================= +c choix du 2nd chiffre entre 1 et 2 +c----------------------------------------------------------------------- + integer fp0012(2) + common /op0012/ fp0012 diff --git a/src/tool/Includes_Generaux/op0123.h b/src/tool/Includes_Generaux/op0123.h new file mode 100644 index 00000000..d5dac46f --- /dev/null +++ b/src/tool/Includes_Generaux/op0123.h @@ -0,0 +1,6 @@ +c +c======================================================================= +c choix du 3eme chiffre entre 1, 2 et 3 +c----------------------------------------------------------------------- + integer fp0123(3,3) + common /op0123/ fp0123 diff --git a/src/tool/Includes_Generaux/op1234.h b/src/tool/Includes_Generaux/op1234.h new file mode 100644 index 00000000..58865ca8 --- /dev/null +++ b/src/tool/Includes_Generaux/op1234.h @@ -0,0 +1,6 @@ +c +c======================================================================= +c choix du 4eme chiffre entre 1, 2, 3 et 4 +c----------------------------------------------------------------------- + integer fp1234(4,4,4) + common /op1234/ fp1234 diff --git a/src/tool/Includes_Generaux/op1aa6.h b/src/tool/Includes_Generaux/op1aa6.h new file mode 100644 index 00000000..2c777be1 --- /dev/null +++ b/src/tool/Includes_Generaux/op1aa6.h @@ -0,0 +1,6 @@ +c +c======================================================================= +c choix du 6eme chiffre entre 1, 2, 3, 4, 5 et 6 +c----------------------------------------------------------------------- + integer fp1aa6(6,6,6,6,6) + common /op1aa6/ fp1aa6 diff --git a/src/tool/Includes_Generaux/ope001.h b/src/tool/Includes_Generaux/ope001.h new file mode 100644 index 00000000..cb2dfe15 --- /dev/null +++ b/src/tool/Includes_Generaux/ope001.h @@ -0,0 +1,8 @@ +C +c diverses operations sur les entiers 1, 2, 3, 4, 5, 6 +c======================================================================= +c ope001 : etablissement des codes pour les raffinements +c conformes des pentaedres +c----------------------------------------------------------------------- + integer per001(6,6) + common /ope001/ per001 diff --git a/src/tool/Includes_Generaux/ope002.h b/src/tool/Includes_Generaux/ope002.h new file mode 100644 index 00000000..41a619e0 --- /dev/null +++ b/src/tool/Includes_Generaux/ope002.h @@ -0,0 +1,8 @@ +C +c diverses operations sur les entiers 1, 2, 3, 4, 5, 6, 7, 8 +c======================================================================= +c ope002 : etablissement des codes pour les raffinements +c conformes des pentaedres +c----------------------------------------------------------------------- + integer per002(8,8) + common /ope002/ per002 diff --git a/src/tool/Includes_Generaux/ope1a3.h b/src/tool/Includes_Generaux/ope1a3.h new file mode 100644 index 00000000..b3d3be19 --- /dev/null +++ b/src/tool/Includes_Generaux/ope1a3.h @@ -0,0 +1,15 @@ +C +c diverses operations sur les entiers 1, 2, 3 +c======================================================================= +c per1a3 : entier pour la permutation circulaire (1,2,3) +c per1a3(-1,i) = entier avant i +c per1a3( 0,i) = i +c per1a3( 1,i) = entier apres i +c per1a3( 2,i) = entier 2 places apres i = per1a3(-1,i) +c per1a3(-1,1) = 3, per1a3(-1,2) = 1, per1a3(-1,3) = 2 +c per1a3( 0,1) = 1, per1a3( 0,2) = 2, per1a3( 0,3) = 3 +c per1a3( 1,1) = 2, per1a3( 1,2) = 3, per1a3( 1,3) = 1 +c per1a3( 2,1) = 3, per1a3( 2,2) = 1, per1a3( 2,3) = 2 +c----------------------------------------------------------------------- + integer per1a3(-1:2,3) + common /ope1a3/ per1a3 diff --git a/src/tool/Includes_Generaux/ope1a4.h b/src/tool/Includes_Generaux/ope1a4.h new file mode 100644 index 00000000..112b43c6 --- /dev/null +++ b/src/tool/Includes_Generaux/ope1a4.h @@ -0,0 +1,32 @@ +C +c diverses operations sur les entiers 1, 2, 3, 4 +c======================================================================= +c per1a4 : entiers pour la permutation circulaire (1,.,4) +c . Pour i de 1 a 4 : +c per1a4(-5,i) = 1 devient 2, puis sens inverse +c per1a4(-4,i) = 1 devient 3, puis sens inverse +c per1a4(-3,i) = 1 devient 4, puis sens inverse +c per1a4(-2,i) = 1 idem, puis sens inverse +c per1a4(-1,i) = entier avant i (= per1a4(3,i)) +c per1a4( 0,i) = i +c per1a4( 1,i) = entier apres i +c per1a4( 2,i) = entier 2 cases apres i +c per1a4( 3,i) = entier 3 cases apres i (= per1a4(-1,i)) +c per1a4(-5,1) = 2, per1a4(-5,2) = 1, per1a4(-5,3) = 4, per1a4(-5,4) = 3 +c per1a4(-4,1) = 3, per1a4(-4,2) = 2, per1a4(-4,3) = 1, per1a4(-4,4) = 4 +c per1a4(-3,1) = 4, per1a4(-3,2) = 3, per1a4(-3,3) = 2, per1a4(-3,4) = 1 +c per1a4(-2,1) = 1, per1a4(-2,2) = 4, per1a4(-2,3) = 3, per1a4(-2,4) = 2 +c per1a4(-1,1) = 4, per1a4(-1,2) = 1, per1a4(-1,3) = 2, per1a4(-1,4) = 3 +c per1a4( 0,1) = 1, per1a4( 0,2) = 2, per1a4( 0,3) = 3, per1a4( 0,4) = 4 +c per1a4( 1,1) = 2, per1a4( 1,2) = 3, per1a4( 1,3) = 4, per1a4( 1,4) = 1 +c per1a4( 2,1) = 3, per1a4( 2,2) = 4, per1a4( 2,3) = 1, per1a4( 2,4) = 2 +c per1a4( 3,1) = 4, per1a4( 3,2) = 1, per1a4( 3,3) = 2, per1a4( 3,4) = 3 +c +c . Pour i =5 : +c per1a4(j,5) = le reciproque de per1a4(j,*) +c Les reciproques : +c Eux-memes pour j = 0, -2, -3, -4, -5, 2 : per1a4(j,per1a4(j,i)) = i +c -1/1, 3/1 : per1a4(-1,per1a4(1,i)) = per1a4(1,per1a4(-1,i)) = i +c----------------------------------------------------------------------- + integer per1a4(-5:3,5) + common /ope1a4/ per1a4 diff --git a/src/tool/Includes_Generaux/ope4a6.h b/src/tool/Includes_Generaux/ope4a6.h new file mode 100644 index 00000000..5900d3b6 --- /dev/null +++ b/src/tool/Includes_Generaux/ope4a6.h @@ -0,0 +1,15 @@ +C +c diverses operations sur les entiers 4, 5, 6 +c======================================================================= +c per4a6 : entier pour la permutation circulaire (4,5,6) +c per4a6(-1,i) = entier avant i +c per4a6( 0,i) = i +c per4a6( 1,i) = entier apres i +c per4a6( 2,i) = entier 2 places apres i = per4a6(-1,i) +c per4a6(-1,4) = 6, per4a6(-1,5) = 4, per4a6(-1,6) = 5 +c per4a6( 0,4) = 4, per4a6( 0,5) = 5, per4a6( 0,6) = 6 +c per4a6( 1,4) = 5, per4a6( 1,5) = 6, per4a6( 1,6) = 4 +c per4a6( 2,4) = 6, per4a6( 2,5) = 4, per4a6( 2,6) = 5 +c----------------------------------------------------------------------- + integer per4a6(-1:2,4:6) + common /ope4a6/ per4a6 diff --git a/src/tool/Includes_Generaux/oriefp.h b/src/tool/Includes_Generaux/oriefp.h new file mode 100644 index 00000000..d8eaf16c --- /dev/null +++ b/src/tool/Includes_Generaux/oriefp.h @@ -0,0 +1,11 @@ +c +c======================================================================= +c memorisation de la convention de l'orientation locale des faces +c dans un pentaedre suivant le code des faces +c----------------------------------------------------------------------- +c pour la face i de code c : +c orcofp(i,c) : 1, la face est sortante +c -1, la face est entrante +c----------------------------------------------------------------------- + integer orcofp(5,8) + common /oriefp/ orcofp diff --git a/src/tool/Includes_Generaux/oriefy.h b/src/tool/Includes_Generaux/oriefy.h new file mode 100644 index 00000000..066b666b --- /dev/null +++ b/src/tool/Includes_Generaux/oriefy.h @@ -0,0 +1,11 @@ +c +c======================================================================= +c memorisation de la convention de l'orientation locale des faces +c dans une pyramide suivant le code des faces +c----------------------------------------------------------------------- +c pour la face i de code c : +c orcofy(i,c) : 1, la face est sortante +c -1, la face est entrante +c----------------------------------------------------------------------- + integer orcofy(5,8) + common /oriefy/ orcofy diff --git a/src/tool/Includes_Generaux/orieqh.h b/src/tool/Includes_Generaux/orieqh.h new file mode 100644 index 00000000..354a3b2f --- /dev/null +++ b/src/tool/Includes_Generaux/orieqh.h @@ -0,0 +1,11 @@ +c +c======================================================================= +c memorisation de la convention de l'orientation locale des quadrangles +c dans un hexaedre suivant le code des quadrangles +c----------------------------------------------------------------------- +c pour le quadrangle i de code c : +c orcoqh(i,c) : 1, le quadrangle est sortant +c -1, le quadrangle est entrant +c----------------------------------------------------------------------- + integer orcoqh(6,8) + common /orieqh/ orcoqh diff --git a/src/tool/Includes_Generaux/oriett.h b/src/tool/Includes_Generaux/oriett.h new file mode 100644 index 00000000..ce38a2ee --- /dev/null +++ b/src/tool/Includes_Generaux/oriett.h @@ -0,0 +1,11 @@ +c +c======================================================================= +c memorisation de la convention de l'orientation locale des triangles +c dans un tetraedre suivant le code des triangles +c----------------------------------------------------------------------- +c pour le triangle i de code c : +c orcott(i,c) : 1, le triangle est sortant +c -1, le triangle est entrant +c----------------------------------------------------------------------- + integer orcott(4,6) + common /oriett/ orcott diff --git a/src/tool/Includes_Generaux/permut.h b/src/tool/Includes_Generaux/permut.h new file mode 100644 index 00000000..8a774c19 --- /dev/null +++ b/src/tool/Includes_Generaux/permut.h @@ -0,0 +1,10 @@ +c +c======================================================================= +c permutations des codes des faces dans les tetraedres +c----------------------------------------------------------------------- +c perm1 : permutation laissant la premiere fonction, i1, invariante +c perm2 : permutation laissant la deuxieme fonction, i2, invariante +c perm3 : permutation laissant la troisieme fonction, i3, invariante +c----------------------------------------------------------------------- + integer perm1(6), perm2(6), perm3(6) + common /permut/ perm1, perm2, perm3 diff --git a/src/tool/Includes_Generaux/precis.h b/src/tool/Includes_Generaux/precis.h new file mode 100644 index 00000000..e6f7a267 --- /dev/null +++ b/src/tool/Includes_Generaux/precis.h @@ -0,0 +1,9 @@ +c +c======================================================================= +c precision pour une machine donnee +c----------------------------------------------------------------------- +c epsima : la precision de la machine +c dmxent : plus grand entier +c----------------------------------------------------------------------- + double precision epsima, dmxent + common /precis/ epsima, dmxent diff --git a/src/tool/Includes_Generaux/refere.h b/src/tool/Includes_Generaux/refere.h new file mode 100644 index 00000000..df5c7615 --- /dev/null +++ b/src/tool/Includes_Generaux/refere.h @@ -0,0 +1,40 @@ +c +c======================================================================= +c description des elements de reference +c----------------------------------------------------------------------- +c tyeref : precise le type d'element en fonction du type de reference +c 0 si compatible avec le mode d'utilisation de HOMARD +c 1 sinon +c nbnref : donne le nombre de noeuds en fonction du type de reference ; +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : 1 : sommets +c 2 : sommets + milieux d'aretes +c 3 : total (sommets+milieux+internes) +c nbaref : donne le nombre d'aretes en fonction du type de reference +c nasref : donne le nombre d'aretes reliees a chaque sommet, sans +c se preoccuper d'orientation, en fonction du type +c nfaref : donne le nombre de faces qui s'appuient sur chaque arete +c sans se preoccuper d'orientation +c nafref : donne le nombre d'aretes de chaque face de l'element +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de la face envisagee +c defref : pour chaque arete de chaque face, donne le numero local +c de l'arete dans la description de reference de l'element +c ce qui correspond aux tableaux de definitions de I1 I2 I3 I4 +c dans la doc. +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de la face envisagee +c 3eme champ : 1, 2, 3 et 4 pour chaque arete +c faaref : donne le numero local de la face s'appuyant sur une arete +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de l'arete concernee +c 3eme champ : rang de la face envisagee +c----------------------------------------------------------------------- +c + integer tyeref(0:tehmax), nbnref(0:tehmax,3), nbaref(0:tehmax) + integer nasref(0:tehmax), nfaref(0:tehmax) + integer nafref(0:tehmax,6), defref(0:tehmax,6,4) + integer faaref(0:tehmax,12,2) + common /refere/ tyeref, nbnref, nbaref, + > nasref, nfaref, + > nafref, defref, faaref diff --git a/src/tool/Includes_Generaux/refert.h b/src/tool/Includes_Generaux/refert.h new file mode 100644 index 00000000..056b940b --- /dev/null +++ b/src/tool/Includes_Generaux/refert.h @@ -0,0 +1,23 @@ +c +c======================================================================= +c description des types des elements de reference +c----------------------------------------------------------------------- +c tyhxxx : type HOMARD de l'element xxx (de 0 a tehmax) +c----------------------------------------------------------------------- +c + integer tyhnoe, + > tyhmpo, + > tyhse1, tyhse2, + > tyhtr1, tyhtr2, tyhtr3, + > tyhte1, tyhte2, + > tyhqu1, tyhqu2, tyhqu3, + > tyhhe1, tyhhe2, tyhhe3, + > tyhpe1, tyhpe2, tyhpy1, tyhpy2 + common /refert/ tyhnoe, + > tyhmpo, + > tyhse1, tyhse2, + > tyhtr1, tyhtr2, tyhtr3, + > tyhte1, tyhte2, + > tyhqu1, tyhqu2, tyhqu3, + > tyhhe1, tyhhe2, tyhhe3, + > tyhpe1, tyhpe2, tyhpy1, tyhpy2 diff --git a/src/tool/Includes_Generaux/referx.h b/src/tool/Includes_Generaux/referx.h new file mode 100644 index 00000000..c7d1980d --- /dev/null +++ b/src/tool/Includes_Generaux/referx.h @@ -0,0 +1,5 @@ +c +c tehmax : numero maximum des types d'elements au sens HOMARD +c + integer tehmax + parameter ( tehmax = 17 ) diff --git a/src/tool/Includes_Generaux/rfamed.h b/src/tool/Includes_Generaux/rfamed.h new file mode 100644 index 00000000..460b4248 --- /dev/null +++ b/src/tool/Includes_Generaux/rfamed.h @@ -0,0 +1,18 @@ +c +c======================================================================= +c description des mailles de reference pour une connectivite a la med +c----------------------------------------------------------------------- +c arsmed : donne le numero local de l'arete reliee a un sommet +c 1er champ : type HOMARD de la maille de reference +c 2eme champ : numero local du sommet concerne +c 3eme champ : rang de l'arete envisagee +c deamed : description des aretes par les numeros locaux des noeuds +c sans se preoccuper d'orientation +c 1er champ : type HOMARD de la maille de reference +c 2eme champ : numero local de l'arete envisagee +c 3eme champ : 1 et 2 pour chaque extremite, 3 pour le milieu +c----------------------------------------------------------------------- +c + integer arsmed(0:tehmax,10,4) + integer deamed(0:tehmax,12,3) + common /rfamed/ arsmed, deamed diff --git a/src/tool/Includes_Generaux/rftmax.h b/src/tool/Includes_Generaux/rftmax.h new file mode 100644 index 00000000..2b30e480 --- /dev/null +++ b/src/tool/Includes_Generaux/rftmax.h @@ -0,0 +1,5 @@ +c +c nbtmax doit etre le maximum de chacun des nombres de type + integer nbtmax + parameter ( nbtmax = 1043 ) +c diff --git a/src/tool/Includes_Generaux/rftmed.h b/src/tool/Includes_Generaux/rftmed.h new file mode 100644 index 00000000..f99d058c --- /dev/null +++ b/src/tool/Includes_Generaux/rftmed.h @@ -0,0 +1,33 @@ +c +c======================================================================= +c description des types d'entites a partir du format MED +c----------------------------------------------------------------------- +c medtrf : donne le type de reference en fonction du code MED +c -1 : noeud +c 0 : maille-point +c 1 : poutre lineaire +c 2 : poutre quadratique +c 3 : triangle lineaire +c 4 : triangle quadratique +c 5 : tetraedre lineaire +c 6 : tetraedre quadratique +c 7 : quadrangle lineaire +c 8 : quadrangle quadratique +c 9 : pyramide lineaire +c 10 : pyramide quadratique +c 11 : hexaedre lineaire +c 12 : hexaedre quadratique +c 13 : pentaedre lineaire +c 14 : pentaedre quadratique +c medt12 : donne le code med de la maille apres echange du degre +c mednnm : donne le nombre de noeuds de la maille med +c----------------------------------------------------------------------- +c + integer nbtmed + parameter ( nbtmed = 400 ) +c + integer mednnm(0:nbtmed) + integer medtrf(0:nbtmed) + integer medt12(0:nbtmed) + common /rftmed/ mednnm, medtrf, medt12 +c diff --git a/src/tool/Includes_Generaux/tbdim0.h b/src/tool/Includes_Generaux/tbdim0.h new file mode 100644 index 00000000..6b999eb9 --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim0.h @@ -0,0 +1,5 @@ +c +c Dimension des tableaux auxiliaires pour l'information +c + integer tbdim + parameter ( tbdim = 200 ) diff --git a/src/tool/Includes_Generaux/tbdim1.h b/src/tool/Includes_Generaux/tbdim1.h new file mode 100644 index 00000000..5859cdfc --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim1.h @@ -0,0 +1,4 @@ +99999 format( + > 'Programme ',a, + >/,'La valeur de dimensionnement tbdim',i4,' est trop petite.', + >/,'Erreur de programmation') diff --git a/src/tool/Includes_Generaux/tbdim2.h b/src/tool/Includes_Generaux/tbdim2.h new file mode 100644 index 00000000..02da5e8c --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim2.h @@ -0,0 +1,4 @@ + if ( iaux.gt.tbdim ) then + write(ulsort,99999) nompro, tbdim + stop + endif diff --git a/src/tool/Includes_Generaux/tbdim3.h b/src/tool/Includes_Generaux/tbdim3.h new file mode 100644 index 00000000..6da203bd --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim3.h @@ -0,0 +1,4 @@ + if ( jaux.gt.tbdim ) then + write(ulsort,99999) nompro, tbdim + stop + endif diff --git a/src/tool/Includes_Generaux/tbdim4.h b/src/tool/Includes_Generaux/tbdim4.h new file mode 100644 index 00000000..e22a398b --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim4.h @@ -0,0 +1,4 @@ + if ( ntrniv+nquniv.gt.tbdim ) then + write(ulsort,99999) nompro, tbdim + stop + endif diff --git a/src/tool/Includes_Generaux/tbdim5.h b/src/tool/Includes_Generaux/tbdim5.h new file mode 100644 index 00000000..d62beea5 --- /dev/null +++ b/src/tool/Includes_Generaux/tbdim5.h @@ -0,0 +1,4 @@ + if ( nbar+ntraut+nquaut.gt.tbdim ) then + write(ulsort,99999) nompro, tbdim + stop + endif diff --git a/src/tool/Includes_Generaux/webweb.h b/src/tool/Includes_Generaux/webweb.h new file mode 100644 index 00000000..997a7a71 --- /dev/null +++ b/src/tool/Includes_Generaux/webweb.h @@ -0,0 +1,9 @@ + character*40 weba + parameter ( weba = 'http://www.code-aster.org/outils/homard ' ) +c 1234567890123456789012345678901234567890 +c + character*40 web1 + parameter ( web1 = ' ' ) +c + character*40 web2 + parameter ( web2 = ' /menu_homard.en.htm ' ) diff --git a/src/tool/Information/CMakeLists.txt b/src/tool/Information/CMakeLists.txt new file mode 100644 index 00000000..f25b6d84 --- /dev/null +++ b/src/tool/Information/CMakeLists.txt @@ -0,0 +1,76 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Information + +SET(Information_SOURCES + ./inconv.F + ./infami.F + ./infc00.F + ./infc01.F + ./infc02.F + ./infc03.F + ./infc32.F + ./infc33.F + ./infc34.F + ./infc35.F + ./infc36.F + ./infc37.F + ./infca1.F + ./infca2.F + ./infcas.F + ./infcom.F + ./inffre.F + ./infoar.F + ./infofo.F + ./infohe.F + ./infomp.F + ./infono.F + ./infope.F + ./infopf.F + ./infopy.F + ./infoqu.F + ./infote.F + ./infotr.F + ./infova.F + ./infovi.F + ./infovo.F + ./infqen.F + ./infve0.F + ./infve1.F + ./infve2.F + ./infve3.F + ./infve4.F + ./infve5.F + ./infve6.F + ./infve7.F + ./infvec.F + ./ininfm.F + ./initer.F + ./inqur1.F + ./inqur2.F + ./inqure.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Information ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Information ${Information_SOURCES}) + +INSTALL(TARGETS Information EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Information/inconv.F b/src/tool/Information/inconv.F new file mode 100644 index 00000000..00b94cf3 --- /dev/null +++ b/src/tool/Information/inconv.F @@ -0,0 +1,329 @@ + subroutine inconv ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : CONVersions +c -- ---- +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INCONV' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "envca2.h" +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 nocman +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.1. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.2. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + if ( imem(adopti+20) .eq. 1 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + endif + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c + if ( imem(adopti+20) .eq. 1 ) then +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'' C O N V E R S I O N D U M A I L L A G E'')' + texte(1,5) = '(50(''=''),/)' +c + texte(2,4) = '(//,a6,'' M E S H C O N V E R S I O N'')' + texte(2,5) = '(36(''=''),/)' +c +#include "impr03.h" +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.8. ==> la date courante +c + call utdhlg ( ladate, langue ) +c +c==== +c 2. conversion du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. conversion ; codret', codret +#endif +cgn write (ulsort,90002) 'imem(adopti+38)', imem(adopti+38) +cgn write (ulsort,90002) 'imem(adopti+10)', imem(adopti+10) +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c +c 2.1. ==> prealable pour le suivi de frontiere +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. prealable frontiere ; codret', codret +#endif +c + if ( mod(imem(adopti+28),2).eq.0 .or. + > mod(imem(adopti+28),5).eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFDEFG', nompro +#endif +c + call sfdefg ( imem(adopti+28), + > smem(adopts), smem(adopts+15), smem(adopts+16), + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.2. ==> prealable pour le cas saturne/neptune 2D +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. prealable sat/nep ; codret', codret +#endif +c + if ( imem(adopti+10).eq.26 .or. + > imem(adopti+10).eq.46 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS2D', nompro +#endif +c + call vcms2d ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> conversion +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. conversion ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMAIL', nompro +#endif + call vcmail ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> le cas extrude, non saturne, non neptune +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. cas extrude ; codret', codret +#endif +c + if ( imem(adopti+38).ne.0 .and. + > imem(adopti+10).ne.26 .and. + > imem(adopti+10).ne.46 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMEXT', nompro +#endif +c + call vcmext ( lgopti, imem(adopti), lgopts, smem(adopts), + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + call gtfims (nrssse) +c +c==== +c 3. menage des structures liees au calcul +c==== +c + if ( codret.eq.0 ) then + nocman = smem(adopts) + call gmsgoj ( nocman, codret ) + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Information/infami.F b/src/tool/Information/infami.F new file mode 100644 index 00000000..a6cecb55 --- /dev/null +++ b/src/tool/Information/infami.F @@ -0,0 +1,349 @@ + subroutine infami ( nomail, maext0, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : FAMIlles +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iteration n . +c . maext0 . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFAMI' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "meddc0.h" +#include "envca1.h" +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + integer maext0 +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte, pcfate + integer pfamhe, pcfahe + integer pfampy, pcfapy + integer pfampe, pcfape +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. tableaux ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 7 + call utad01 ( iaux, nhnoeu, + > jaux, + > pfamno, pcfano, jaux, + > jaux, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbmpto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhmapo, + > jaux, jaux, jaux, jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 259 + call utad02 ( iaux, nharet, + > jaux, jaux, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 37 + if ( nbtrto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, jaux, + > pfamtr, pcfatr, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 37 + if ( nbquto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbftet.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 37 + if ( nbteto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhtetr, + > jaux, jaux, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfhex.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 37 + if ( nbheto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhhexa, + > jaux, jaux, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpyr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 37 + if ( nbpyto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhpyra, + > jaux, jaux, jaux, jaux, + > pfampy, pcfapy, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfpen.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 37 + if ( nbpeto.ne.0 ) then + iaux = iaux*7 + endif + call utad02 ( iaux, nhpent, + > jaux, jaux, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. impression de la description des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. impressions familles ; codret', codret +#endif + + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif +c + call utecfe ( maext0, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc00.F b/src/tool/Information/infc00.F new file mode 100644 index 00000000..3caefb9b --- /dev/null +++ b/src/tool/Information/infc00.F @@ -0,0 +1,260 @@ + subroutine infc00 ( nbrcas, caopti, nbcham, + > tab, + > nocsol, nbpafo, + > adinch, adinpf, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 00 +c -- - - -- +c ______________________________________________________________________ +c Allocation de la structure de l'objet solution +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbrcas . e . 1 . nombre de cas : . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . caopti . e . nbrcas . 0/1 selon que le cas est retenu . +c . nbcham . e . 1 . nombre de champs associes . +c . tab . s .(-2:7)* . i = -2 : nombre de paquets concernes . +c . . . nbrcas . i > -2 : nombre de valeurs pour l'entite i . +c . nocsol . s . 1 . nom de l'objet solution cree . +c . nbpafo . s . 1 . nombre d'inf. sur les paquets de fonctions . +c . adinch . s . 1 . adresse de l'information sur les champs . +c . adinpf . s . 1 . adresse de l'inf. sur paquets de fonctions . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC00' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombqu.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + integer nbrcas, nbcham + integer caopti(nbrcas) + integer tab(-2:7,nbrcas) + integer nbpafo + integer adinch, adinpf +c + character*8 nocsol +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer tabaux(6,2) + integer nbprof, nblopg + integer adinpr, adinlg + integer ladim +c + integer nucas +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''Creation de l''''objet '', a8)' +c + texte(2,4) = '(''Creation of the object '', a8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbrcas', nbrcas + write (ulsort,90002) 'caopti', caopti + write (ulsort,90002) 'nbcham', nbcham +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtria', nbtria + write (ulsort,90002) 'nbquad', nbquad + write (ulsort,90002) 'nbtetr', nbtetr + write (ulsort,90002) 'nbpyra', nbpyra + write (ulsort,90002) 'nbhexa', nbhexa + write (ulsort,90002) 'nbpent', nbpent +#endif +c + codret = 0 +c +c==== +c 2. Nombre de valeurs +c==== +c 2.1. ==> Dimension a prendre en compte +c + if ( nbteto.ne.0 .or. nbheto.ne.0 .or. + > nbpeto.ne.0 .or. nbpyto.ne.0 ) then + ladim = 3 + elseif ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + ladim = 2 + else + ladim = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ladim', ladim +#endif +c +c 2.2. ==> Decompte du nombre de valeurs +c + if ( ladim.le.1 ) then + kaux = 0 + elseif ( ladim.eq.3 ) then + kaux = 4 + tabaux(1,1) = nbtetr + tabaux(1,2) = 3 + tabaux(2,1) = nbpyra + tabaux(2,2) = 5 + tabaux(3,1) = nbhexa + tabaux(3,2) = 6 + tabaux(4,1) = nbpent + tabaux(4,2) = 7 + endif + if ( ladim.ge.2 ) then + kaux = kaux+1 + tabaux(kaux,1) = nbtria + tabaux(kaux,2) = 2 + kaux = kaux+1 + tabaux(kaux,1) = nbquad + tabaux(kaux,2) = 4 + endif +c +c 2.3. ==> Transfert +c + do 231 , iaux = -2, 7 + do 2311 , nucas = 1, nbrcas + tab(iaux,nucas) = 0 + tab(iaux,nucas) = 0 + 2311 continue + 231 continue +c + do 232 , nucas = 1, nbrcas + if ( ( ladim.eq.3 .and. nucas.eq.1 ) .or. ( nucas.eq.5 ) ) then + laux = kaux - 2 + else + laux = kaux + endif + do 2321 , iaux = 1, laux + if ( tabaux(iaux,1).gt.0 ) then + jaux = tabaux(iaux,2) + tab(-2,nucas) = tab(-2,nucas) + caopti(nucas) + tab(jaux,nucas) = tabaux(iaux,1)*caopti(nucas) + endif + 2321 continue + 232 continue +c +#ifdef _DEBUG_HOMARD_ + do 2333 , iaux = 1, nbrcas + write (ulsort,90015) 'tab de', iaux,' :', + > (tab(jaux,iaux),jaux=-2,7) + 2333 continue +#endif +c +c==== +c 3. allocation de la structure de tete +c==== +c + nbpafo = 0 + do 31 , nucas = 1, nbrcas + do 311 , jaux = -1, 7 + if ( tab(jaux,nucas).gt.0 ) then + nbpafo = nbpafo + 1 + endif + 311 continue + 31 continue +c + nbprof = 0 + nblopg = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALSO', nompro +#endif + call utalso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nocsol + call gmprsx ( nompro, nocsol ) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc01.F b/src/tool/Information/infc01.F new file mode 100644 index 00000000..2900b324 --- /dev/null +++ b/src/tool/Information/infc01.F @@ -0,0 +1,241 @@ + subroutine infc01 ( nbtvch, + > adinch, + > nrcham, nomcha, typcha, + > nbcomp, nomcom, unicom, + > obcham, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 01 +c -- - - -- +c ______________________________________________________________________ +c Allocation de la branche des champs +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtvch . e . 1 . nombre de tableaux de valeurs du champ . +c . adinch . e . 1 . adresse de l'information sur les champs . +c . adinpf . e . 1 . adresse de l'inf. sur paquets de fonctions . +c . nrcham . e . 1 . numero du champ a traiter . +c . nomcha . e . char64 . nom du champ a traiter . +c . typcha . e . 1 . edin64/edfl64 selon entier/reel . +c . nbcomp . e . 1 . nombre de composantes . +c . nomcom . e . char16 . nom des composantes . +c . unicom . e . char16 . unite des composantes . +c . obcham . s . 1 . nom de l'objet InfoCham cree . +c . adcaen . s . 1 . adresse des caract. entieres du champ . +c . adcare . s . 1 . adresse des caract. reelles du champ . +c . adcaca . s . 1 . adresse des caract. caracteres du champ . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC01' ) +c +#include "nblang.h" +#include "consts.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbtvch + integer adinch + integer nrcham, typcha + integer nbcomp + integer adcaen, adcare, adcaca +c + character*8 obcham + character*16 nomcom(nbcomp), unicom(nbcomp) + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer adnocp +c + integer codre1, codre2, codre3 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''Creation de la branche du champ '', a8)' +c + texte(2,4) = '(''Creation of the field '', a8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha + write (ulsort,90002) 'nbtvch', nbtvch + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'nbcomp', nbcomp +#endif +c + codret = 0 +c +c==== +c 2. Allocation de la structure decrivant le champ +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Allocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( obcham, 'InfoCham', 0, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adinch+nrcham-1) = obcham +c + call gmecat ( obcham, 2, nbtvch, codre1 ) + call gmecat ( obcham, 3, typcha, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. Composantes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Composantes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( obcham, 1, nbcomp, codre1 ) + iaux = 8 + 4*nbcomp + 2 + call gmaloj ( obcham//'.Nom_Comp', ' ', iaux, adnocp, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1, 8 + smem(adnocp+iaux-1) = nomcha(8*(iaux-1)+1:8*iaux) + 31 continue +c + do 32 , iaux = 1, nbcomp + smem(adnocp+7+2*iaux-1) = nomcom(iaux)(1: 8) + smem(adnocp+7+2*iaux ) = nomcom(iaux)(9:16) + smem(adnocp+7+2*nbcomp+2*iaux-1) = unicom(iaux)(1: 8) + smem(adnocp+7+2*nbcomp+2*iaux ) = unicom(iaux)(9:16) + 32 continue +c + smem(adnocp+8+4*nbcomp) = blan08 + smem(adnocp+9+4*nbcomp) = blan08 +c + endif +c +c==== +c 4. Info +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Info ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbtvch*nbinec + call gmaloj ( obcham//'.Cham_Ent', ' ', iaux, adcaen, codre1 ) + iaux = nbtvch + call gmaloj ( obcham//'.Cham_Ree', ' ', iaux, adcare, codre2 ) + iaux = nbtvch*nbincc + call gmaloj ( obcham//'.Cham_Car', ' ', iaux, adcaca, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx ( nompro, obcham ) + call gmprsx ( nompro, obcham//'.Nom_Comp' ) + endif +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc02.F b/src/tool/Information/infc02.F new file mode 100644 index 00000000..e6b6f6d6 --- /dev/null +++ b/src/tool/Information/infc02.F @@ -0,0 +1,653 @@ + subroutine infc02 ( numcas, + > typenh, nhenti, nbenti, nbentf, nbenta, + > nbtvch, nutvch, + > nbcomp, nbench, typgeo, + > obcham, nupafo, infopf, + > nhnoeu, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > caraen, carare, caraca, + > npenrc, entrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 02 +c -- - - -- +c ______________________________________________________________________ +c Creation de la fonction et du paquet +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . typenh . e . 1 . type d'entites concernees . +c . . . . 0 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenti . e . char*8 . structure de l'entite . +c . nbenti . e . 1 . nombre total d'entites concernees . +c . nbentf . e . 1 . nombre d'entites concernees - par faces . +c . nbenta . e . 1 . nombre d'entites concernees - par aretes . +c . nbtvch . e . 1 . nombre de tableaux associes . +c . nutvch . e . 1 . numero du tableau en cours . +c . nbcomp . e . 1 . nombre de composantes . +c . nbench . e . 1 . nombre d'entites du champ . +c . typgeo . e . 1 . type geometrique au sens med . +c . obcham . e . 1 . nom de l'objet InfoCham associe . +c . infopf . e . * . informations sur les paquets de fonctions . +c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhhexa . e . char8 . nom de l'objet decrivant les hexaedres . +c . nhpent . e . char8 . nom de l'objet decrivant les pentaedres . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . caraen . e . nbinec*. caracteristiques entieres des tableaux du . +c . . . nbtvch . champ en cours d'examen . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. numero du pas de temps . +c . . . . 3. numero d'ordre . +c . . . . 4. nombre de points de Gauss . +c . . . . 5. nombre d'entites support . +c . . . . 6. nombre de valeurs du profil eventuel . +c . . . . 7. nombre de supports associes . +c . . . . 8. 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . un champ aux noeuds par elements . +c . . . . 3, si aux points de Gauss autonome . +c . . . . 0, sinon . +c . . . . 9. numero du 1er tableau dans la fonction . +c . . . . 10. si champ elga, numero du champ elno . +c . . . . si champ elno, numero du champ elga si . +c . . . . il existe, sinon -1 . +c . . . . 11. type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . . . . 12. type de champ edfl64/edin64 . +c . . . . 21-nbinec. type des supports associes . +c . carare . e . nbtvch . caracteristiques reelles du champ . +c . . . . 1. valeur du pas de temps . +c . caraca . e . nbincc*. caracteristiques caracteres des tableaux . +c . . . nbsqch . du champ en cours d'examen . +c . . . . 1. nom de l'objet fonction . +c . . . . 2. nom de l'objet profil, blanc sinon . +c . . . . 3. nom de l'objet localisation des points . +c . . . . de Gauss, blanc sinon . +c . npenrc . e . 2*x . nombre de paires d'entites recollees . +c . entrec . e .2*npenrc. paires des entites voisines faces a recol. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC02' ) +c +#include "nblang.h" +#include "consts.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "nombsr.h" +c +#include "nombhe.h" +#include "nombpe.h" +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer numcas + integer typenh, nbenti, nbentf, nbenta + integer nbtvch, nutvch, nupafo + integer nbcomp, nbench, typgeo + integer caraen(nbinec,nbtvch) +c + integer npenrc, entrec(2,npenrc) +c + double precision carare(nbtvch) +c + character*8 nhenti + character*8 nhnoeu, nharet, nhtria, nhquad + character*8 nhhexa, nhpent, norenu + character*8 infopf(*) + character*8 obcham + character*8 caraca(nbincc,nbtvch) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + integer adhist, adcode, adinsu, adcoar, admere, adins2 + integer pcoono + integer phetar, psomar, pmerar + integer phettr, paretr, ppertr, pnivtr + integer phetqu, parequ, pperqu, pnivqu + integer phethe, pquahe + integer phetpe, pfacpe + integer adencn +c + integer ngauss, nbtyas + integer carsup, typint, typcha + integer nbvapr + integer advale, advalr, adobch, adprpg, adtyas + integer adobfo, adtyge + integer adprof, advatt +c + integer codre1, codre2 + integer codre0 +c + character*8 nofonc, nopafo + character*8 ntrav1, ntrav2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Examen des'',i10,1x,a)' + texte(1,5) = '(''.. Nombre de tableau du champ :'',i10)' +c + texte(2,4) = '(''.. Examination of the'',i10,1x,a)' + texte(2,5) = '(''.. Number of arrays for this field:'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbench, mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) nbtvch + write (ulsort,90002) 'numcas', numcas +#endif +c + codret = 0 +c +c==== +c 2. Decodage de la structure +c==== +c 2.1. ==> La structure principale +c + if ( codret.eq.0 ) then +c + if ( typenh.ne.2 .and. typenh.ne.4 ) then +c + iaux = 2 + if ( typenh.eq.3 .or. typenh.eq.5 .or. + > typenh.eq.6 .or. typenh.eq.7 ) then + iaux = iaux*5*13 +c quand des hexaedres et/ou des pentaedres sont coupes par +c conformite, il faut recuperer un tableau sur les parentes +c pour les tetraedres et les pyramides + if ( ( typenh.eq.3 .or. typenh.eq.5 ) .and. + > ( nbheco.gt.0 .or. nbpeco.gt.0 ) ) then + iaux = iaux*17 + endif + endif + if ( nbenta.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_'//mess14(1,5,typenh), + > nompro +#endif + call utad02 ( iaux, nhenti, + > adhist, adcode, jaux, admere, + > jaux, jaux, jaux, + > jaux, adinsu, adins2, + > jaux, jaux, adcoar, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2. ==> Les coordonnees des noeuds si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( numcas.eq.2 .or. numcas.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 3 + call utad01 ( iaux, nhnoeu, + > jaux, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> Les aretes si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( numcas.eq.2 .or. numcas.eq.3 .or. numcas.eq.7 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_aret', nompro +#endif + iaux = 10 + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, pmerar, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.4. ==> Les triangles si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.2 .or. + > typenh.eq.3 .or. typenh.eq.5 .or. typenh.eq.7 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tria', nompro +#endif + iaux = 110 + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, ppertr, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.5. ==> Les quadrangles si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.4 .or. + > typenh.eq.5 .or. typenh.eq.6 .or. typenh.eq.7 .or. + > ( typenh.eq.3 .and. ( nbheco.gt.0 .or. nbpeco.gt.0 ) ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_quad', nompro +#endif + iaux = 110 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, pperqu, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.6. ==> Les hexaedres si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.6. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.gt.0 ) then +c + if ( typenh.eq.3 .or. typenh.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_hexa', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 2.7. ==> Les pentaedres si besoin +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.7. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.gt.0 ) then +c + if ( typenh.eq.3 .or. typenh.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pent', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 3. Creation de la fonction +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Creation fonction ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( numcas.le.3 ) then + typcha = edfl64 + else + typcha = edint + endif + ngauss = ednopg + nbvapr = -1 + nbtyas = 0 + carsup = 0 + typint = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFO', nompro +#endif + call utalfo ( nofonc, typcha, + > typgeo, ngauss, nbench, nbvapr, nbtyas, + > carsup, nbcomp, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adobch) = obcham +c + smem(adprpg) = blan08 + smem(adprpg+1) = blan08 + smem(adprpg+2) = blan08 +c + caraen( 1,nutvch) = typgeo + caraen( 2,nutvch) = ednodt + caraen( 3,nutvch) = ednoit + caraen( 4,nutvch) = ngauss + caraen( 5,nutvch) = nbench + caraen( 6,nutvch) = nbvapr + caraen( 7,nutvch) = 1 + caraen( 8,nutvch) = 0 + caraen( 9,nutvch) = 1 + caraen(10,nutvch) = 0 + caraen(11,nutvch) = 0 + caraen(12,nutvch) = 0 +c + carare(nutvch) = edundt +c + caraca(1,nutvch) = nofonc + caraca(2,nutvch) = blan08 + caraca(3,nutvch) = blan08 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90015) 'OBJET fonction' + call gmprsx ( nompro, nofonc ) + call gmprsx ( nompro, nofonc//'.InfoCham' ) +cgn call gmprsx ( nompro, nofonc//'.InfoPrPG' ) + endif +#endif +c +c==== +c 4. Creation du paquet de fonctions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Creation paquet ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPF', nompro +#endif + call utalpf ( nopafo, + > iaux, typgeo, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adobfo) = nofonc + smem(adobfo+1) = blan08 +c + infopf(nupafo) = nopafo +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90015) 'OBJET paquet de fonctions' + call gmprsx ( nompro, nopafo ) + call gmprsx ( nompro, nopafo//'.Fonction' ) + endif +#endif +c +c==== +c 5. Les valeurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. valeurs ; codret', codret +#endif +c +c 5.1. ==> Tableaux temporaires +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', rseutc, adprof, codre1 ) + iaux = nbcomp*rseutc + if ( numcas.le.3 ) then + call gmalot ( ntrav2, 'reel ', iaux, advatt, codre2 ) + else + call gmalot ( ntrav2, 'entier ', iaux, advatt, codre2 ) + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 5.2. ==> Tableau de travail +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03', nompro +#endif + iaux = 7 + call utre03 ( typenh, iaux, norenu, + > jaux, jaux, jaux, adencn, + > ulsort, langue, codret) +c + endif +c +c 5.3. ==> Calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC03', nompro +#endif + call infc03 ( numcas, typenh, nbcomp, nbenti, nbentf, nbenta, + > imem(adcode), imem(adinsu), imem(adcoar), + > imem(admere), imem(adins2), imem(adencn), + > rmem(pcoono), imem(psomar), imem(pmerar), + > imem(paretr), imem(ppertr), imem(pnivtr), + > imem(parequ), imem(pperqu), imem(pnivqu), + > imem(pquahe), imem(pfacpe), + > npenrc, entrec, + > rseutc, imem(adprof), imem(advatt), rmem(advatt), + > ulsort, langue, codret ) +c + endif +c +c 5.4. ==> Mise a jour des numerotations +c + if ( numcas.le.3 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSRC1', nompro +#endif + call utsrc1 ( nbcomp, rseutc, + > imem(adprof), rmem(advatt), rmem(advalr) ) +c + endif +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSRC3', nompro +#endif + call utsrc3 ( nbcomp, rseutc, + > imem(adprof), imem(advatt), imem(advale) ) +c + endif +c + endif +c +c 5.5. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90015) 'OBJET fonction' + call gmprsx ( nompro, nofonc//'.ValeursE' ) + call gmprsx ( nompro, nofonc//'.ValeursR' ) + endif +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc03.F b/src/tool/Information/infc03.F new file mode 100644 index 00000000..eadd75fa --- /dev/null +++ b/src/tool/Information/infc03.F @@ -0,0 +1,352 @@ + subroutine infc03 ( numcas, + > typenh, nbcomp, nbenti, nbentf, nbenta, + > codent, insuen, coaent, + > perent, pehepe, nentca, + > coonoe, somare, merare, + > aretri, pertri, nivtri, + > arequa, perqua, nivqua, + > quahex, facpen, + > npenrc, entrec, + > nbentc, profil, vafoti, vafotr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 03 +c -- - - -- +c Calcul des valeurs +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . typenh . e . 1 . type d'entites concernees . +c . . . . 0 : noeuds . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbcomp . e . 1 . nombre de composantes . +c . nbenti . e . 1 . nombre total d'entites concernees . +c . nbentf . e . 1 . nombre d'entites concernees - par faces . +c . nbenta . e . 1 . nombre d'entites concernees - par aretes . +c . codent . e . * . connectivite descendante des entites . +c . insuen . e . * . informations supplementaires des entites . +c . coaent . e . * . connectivite par aretes des entites . +c . perent . e . nbenti . pere des entites . +c . . . . pour un tetraedre ou une pyramide . +c . . . . si perent(i) > 0 : numero du pere meme type. +c . . . . si perent(i) < 0 : -numero dans pehepe . +c . pehepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . nentca . e . * . numero des entites dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . merare . e . nbarto . mere de chaque arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . npenrc . e . 1 . nombre de paires d'entites recollees . +c . entrec . e .3*npenrc. paires des entites voisines faces a recol. . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer numcas + integer typenh, nbcomp, nbenti, nbentf, nbenta + integer codent(nbentf,*), insuen(nbentf,*), coaent(nbenta,*) + integer perent(nbenti), pehepe(*), nentca(*) + integer somare(2,nbarto), merare(nbarto) + integer aretri(nbtrto,3), pertri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), perqua(nbquto), nivqua(nbquto) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) + integer npenrc, entrec(3,npenrc) +c + integer nbentc + integer profil(nbentc) + integer vafoti(nbentc) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Examen des '',a)' +c + texte(2,4) = '(''.. Examination of the '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'nbentc', nbentc +#endif +c + codret = 0 +c +c==== +c 2. Les triangles +c==== +c + if ( typenh.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC32', nompro +#endif + call infc32 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > aretri, pertri, nivtri, + > nentca, + > coonoe, somare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Les tetraedres +c==== +c + elseif ( typenh.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC33', nompro +#endif + call infc33 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > codent, insuen, coaent, + > perent, pehepe, nentca, + > coonoe, somare, + > aretri, nivtri, + > nivqua, + > quahex, facpen, + > npenrc, entrec, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Les quadrangles +c==== +c + elseif ( typenh.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC34', nompro +#endif + call infc34 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > arequa, perqua, nivqua, + > nentca, + > coonoe, somare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Les pyramides +c==== +c + elseif ( typenh.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC35', nompro +#endif + call infc35 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > codent, insuen, coaent, + > perent, pehepe, nentca, + > coonoe, somare, + > aretri, nivtri, + > nivqua, + > quahex, facpen, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Les hexaedres +c==== +c + elseif ( typenh.eq.6 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC36', nompro +#endif + call infc36 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > codent, insuen, coaent, + > perent, nentca, + > coonoe, somare, + > arequa, nivqua, + > npenrc, entrec, + > ulsort, langue, codret ) +c + endif +c +c==== +c 7. Les pentaedres +c==== +c + elseif ( typenh.eq.7 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC37', nompro +#endif + call infc37 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > codent, insuen, coaent, + > perent, nentca, + > coonoe, somare, + > nivtri, + > arequa, nivqua, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc32.F b/src/tool/Information/infc32.F new file mode 100644 index 00000000..aa92c07e --- /dev/null +++ b/src/tool/Information/infc32.F @@ -0,0 +1,256 @@ + subroutine infc32 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > aretri, pertri, nivtri, + > ntrica, + > coonoe, somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 32 +c -- - - -- +c Valeurs sur les triangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . ntrica . e . * . nro des triangles dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC32' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer aretri(nbtrto,3), pertri(nbtrto) + integer nivtri(nbtrto) + integer ntrica(*) + integer somare(2,nbarto) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + double precision qualit, surf, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2) + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'nbtrpe', nbtrpe + write (ulsort,90002) 'nbentc', nbentc +#endif +c + codret = 0 +cgn do 555 , iaux = 1 , nbtrto +cgn write (ulsort,90015) 'ntrica(',iaux,') =', ntrica(iaux) +cgn write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(iaux) +cgn 555 continue +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les triangles de depart ou issus d'un decoupage en 4 +c + do 31 , iaux = 1 , nbtrpe +c +cgn write (ulsort,90015) 'ntrica(',iaux,') =', ntrica(iaux) +cgn write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(iaux) +c + jaux = ntrica(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivtri(iaux)) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les triangles issus d'un decoupage de conformite +c + do 32 , iaux = nbtrpe+1 , nbtrto +c +cgn write (ulsort,90015) 'ntrica(',iaux,') =', ntrica(iaux) +cgn write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(iaux) + jaux = ntrica(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivtri(iaux)) - 0.5d0 + profil(jaux) = 1 + endif +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbtrto +c + jaux = ntrica(iaux) + if ( jaux.ne.0 ) then + call utqtri ( iaux, qualit, surf, + > coonoe, somare, aretri ) + vafotr(jaux) = qualit + profil(jaux) = 1 + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbtrto +c + jaux = ntrica(iaux) + if ( jaux.ne.0 ) then + call utdtri ( iaux, diamet, + > coonoe, somare, aretri ) + vafotr(jaux) = diamet + profil(jaux) = 1 + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbtrto +c + jaux = ntrica(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = pertri(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc33.F b/src/tool/Information/infc33.F new file mode 100644 index 00000000..2358964a --- /dev/null +++ b/src/tool/Information/infc33.F @@ -0,0 +1,353 @@ + subroutine infc33 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > tritet, cotrte, aretet, + > pertet, pthepe, ntetca, + > coonoe, somare, + > aretri, nivtri, + > nivqua, + > quahex, facpen, + > npterc, tetrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 33 +c -- - - -- +c Valeurs sur les tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . ntetca . e . * . nro des tetraedres dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . npterc . e . 1 . nombre de paires de tetraedres recolles . +c . tetrec . e .3*npterc. paires des tetra. voisins faces a recoller . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC33' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer pertet(nbteto), pthepe(*), ntetca(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3), nivtri(nbtrto) + integer nivqua(nbquto) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) + integer npterc, tetrec(3,npterc) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer indice +c + double precision niveau, qualit, qualij, volume, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3) + write (ulsort,90002) 'numcas', numcas + write (ulsort,90002) 'nbteto', nbteto + write (ulsort,90002) 'nbtepe', nbtepe + write (ulsort,90002) 'nbtecf', nbtecf + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,90002) 'nbentc', nbentc + write (ulsort,90002) 'npterc', npterc +#endif +c + codret = 0 +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les tetraedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 31 , iaux = 1 , nbtepe +c +cgn write (ulsort,90015) 'ntetca(',iaux,') =', ntetca(iaux) +c + jaux = ntetca(iaux) + if ( jaux.ne.0 ) then +cgn write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(tritet(iaux,1)) + vafotr(jaux) = dble(nivtri(tritet(iaux,1))) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les tetraedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 32 , iaux = nbtepe+1 , nbteto +c + call utntet ( iaux, niveau, + > tritet, pertet, pthepe, + > nivtri, nivqua, + > quahex, facpen ) +c + jaux = ntetca(iaux) + vafotr(jaux) = niveau + profil(jaux) = 1 +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbteto +c + jaux = ntetca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utqtet ( kaux, qualit, qualij, volume, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + vafotr(jaux) = qualit + profil(jaux) = 1 + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbteto +c + jaux = ntetca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utdtet ( kaux, diamet, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + vafotr(jaux) = diamet + profil(jaux) = 1 +c + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbteto +c + jaux = ntetca(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = pertet(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c +c==== +c 7. Voisins par recollement +c==== +c + elseif ( numcas.eq.5 ) then +c +c 7.1. ==> On met des valeurs nulles par defaut +c + do 71 , iaux = 1 , nbteto +c + jaux = ntetca(iaux) + if ( jaux.ne.0 ) then + indice = nbcomp*(jaux-1) + 1 + do 711 , kaux = 1 , nbcomp + vafoti(indice) = 0 + indice = indice + 1 + 711 continue + profil(jaux) = 1 + endif +c + 71 continue +c +c 7.2. ==> Percours des paires enregistrees +c + do 72 , iaux = 1 , npterc +c + jaux = tetrec(1,iaux) + kaux = tetrec(2,iaux) +cgn write (ulsort,90002) 'iaux, jaux, kaux, face', +cgn > iaux, jaux, kaux, tetrec(3,iaux) +c + if ( jaux.ne.0 ) then + indice = nbcomp*(jaux-1) + 1 + if ( vafoti(indice).eq.0 ) then + vafoti(indice) = kaux + vafoti(indice+1) = tetrec(3,iaux) + profil(jaux) = 1 + endif + endif +c + if ( kaux.ne.0 ) then + indice = nbcomp*(kaux-1) + 1 + do 723 , laux = 1, 3 + if ( vafoti(indice).eq.0 ) then + vafoti(indice) = jaux + vafoti(indice+1) = tetrec(3,iaux) + profil(kaux) = 1 + goto 724 + endif + indice = indice + 2 + 723 continue + 724 continue + endif +c + 72 continue +c +cgn do 73 , iaux = 1,nbentc +cgn write(ulsort,90112)'profil',iaux,profil(iaux) +cgn write (ulsort,90002) 'indices', nbcomp*(iaux-1)+1,nbcomp*iaux +cgn write(ulsort,90112)'vafoti',iaux, +cgn >(vafoti(jaux),jaux=nbcomp*(iaux-1)+1,nbcomp*iaux) +cgn 73 continue +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc34.F b/src/tool/Information/infc34.F new file mode 100644 index 00000000..dcec361f --- /dev/null +++ b/src/tool/Information/infc34.F @@ -0,0 +1,249 @@ + subroutine infc34 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > arequa, perqua, nivqua, + > nquaca, + > coonoe, somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 34 +c -- - - -- +c Valeurs sur les quadrangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . nquaca . e . * . nro des quadrangles dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC34' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer arequa(nbquto,4), perqua(nbquto) + integer nivqua(nbquto) + integer nquaca(*) + integer somare(2,nbarto) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + double precision qualit, surf, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) + write (ulsort,90002) 'cas ', numcas + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'nbqupe', nbqupe + write (ulsort,90002) 'nbentc', nbentc +#endif +c + codret = 0 +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les quadrangles de depart ou issus d'un decoupage en 4 +c + do 31 , iaux = 1 , nbqupe +c + jaux = nquaca(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivqua(iaux)) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les quadrangles issus d'un decoupage de conformite +c + do 32 , iaux = nbqupe+1 , nbquto +c + jaux = nquaca(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivqua(iaux)) - 0.5d0 + profil(jaux) = 1 + endif +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbquto +c + jaux = nquaca(iaux) + if ( jaux.ne.0 ) then + call utqqua ( iaux, qualit, surf, + > coonoe, somare, arequa ) + vafotr(jaux) = qualit + profil(jaux) = 1 + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbquto +c + jaux = nquaca(iaux) + if ( jaux.ne.0 ) then + call utdqua ( iaux, diamet, + > coonoe, somare, arequa ) + vafotr(jaux) = diamet + profil(jaux) = 1 +c + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbquto +c + jaux = nquaca(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = perqua(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc35.F b/src/tool/Information/infc35.F new file mode 100644 index 00000000..c3007c9b --- /dev/null +++ b/src/tool/Information/infc35.F @@ -0,0 +1,284 @@ + subroutine infc35 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > facpyr, cofapy, arepyr, + > perpyr, pphepe, npyrca, + > coonoe, somare, + > aretri, nivtri, + > nivqua, + > quahex, facpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 35 +c -- - - -- +c Valeurs sur les pyramides +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . perpyr . e . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . pphepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . npyrca . e . * . nro des pyramides dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC35' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer perpyr(nbpyto), pphepe(*), npyrca(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3), nivtri(nbtrto) + integer nivqua(nbquto) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + double precision niveau, qualit, qualij, volume, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,5) + write (ulsort,90002) 'numcas', numcas + write (ulsort,90002) 'nbpyto', nbpyto + write (ulsort,90002) 'nbpype', nbpype + write (ulsort,90002) 'nbpycf', nbpycf + write (ulsort,90002) 'nbentc', nbentc +#endif +c + codret = 0 +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les pyramides de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : elles sont toujours decrites par faces +c + do 31 , iaux = 1 , nbpype +c +cgn write (ulsort,90015) 'npyrca(',iaux,') =', npyrca(iaux) +cgn write (ulsort,90015) 'nivtri(',iaux,') =', nivtri(iaux) +c + jaux = npyrca(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivtri(facpyr(iaux,1))) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les pyramides issues d'un decoupage de conformite +c Remarque : elles sont toujours actives +c + do 32 , iaux = nbpype+1 , nbpyto +c + call utnpyr ( iaux, niveau, + > facpyr, perpyr, pphepe, + > nivtri, nivqua, + > quahex, facpen ) +c + jaux = npyrca(iaux) + vafotr(jaux) = niveau + profil(jaux) = 1 +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbpyto +c + jaux = npyrca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utqpyr ( kaux, qualit, qualij, volume, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) + vafotr(jaux) = qualit + profil(jaux) = 1 +c + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbpyto +c + jaux = npyrca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utdpyr ( kaux, diamet, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) + vafotr(jaux) = diamet + profil(jaux) = 1 +c + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbpyto +c + jaux = npyrca(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = perpyr(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc36.F b/src/tool/Information/infc36.F new file mode 100644 index 00000000..9de3ccdc --- /dev/null +++ b/src/tool/Information/infc36.F @@ -0,0 +1,409 @@ + subroutine infc36 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > quahex, coquhe, arehex, + > perhex, nhexca, + > coonoe, somare, + > arequa, nivqua, + > npherc, hexrec, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 36 +c -- - - -- +c Valeurs sur les hexaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . nhexca . e . * . nro des hexaedres dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . npherc . e . 1 . nombre de paires d'hexaedres recolles . +c . hexrec . e .3*npherc. paires des hexa. voisins faces a recoller . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC36' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer perhex(nbheto), nhexca(*) + integer somare(2,nbarto) + integer arequa(nbquto,4), nivqua(nbquto) + integer npherc, hexrec(3,npherc) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer indice, lmax + integer levolu, laface +c + double precision niveau, qualit, qualij, diamet + double precision volume +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,6) + write (ulsort,90002) 'numcas', numcas + write (ulsort,90002) 'nbheto', nbheto + write (ulsort,90002) 'nbhepe', nbhepe + write (ulsort,90002) 'nbcomp', nbcomp + write (ulsort,90002) 'nbentc', nbentc + write (ulsort,90002) 'npherc', npherc +#endif +c + codret = 0 +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les hexaedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 31 , iaux = 1 , nbhepe +c +cgn write (ulsort,90015) 'nhexca(',iaux,') =', nhexca(iaux) +c + jaux = nhexca(iaux) + if ( jaux.ne.0 ) then +cgn write (ulsort,90015) 'nivqua(',iaux,') =', nivqua(quahex(iaux,1)) + vafotr(jaux) = dble(nivqua(quahex(iaux,1))) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les hexaedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 32 , iaux = nbhepe+1 , nbheto +c + call utnhex ( iaux, niveau, + > quahex, perhex, + > nivqua ) +c + jaux = nhexca(iaux) + vafotr(jaux) = niveau + profil(jaux) = 1 +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbheto +c + jaux = nhexca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utqhex ( kaux, qualit, qualij, volume, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) + vafotr(jaux) = qualit + profil(jaux) = 1 + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbheto +c + jaux = nhexca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utdhex ( kaux, diamet, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) + vafotr(jaux) = diamet + profil(jaux) = 1 +c + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbheto +c + jaux = nhexca(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = perhex(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c +c==== +c 7. Voisins par recollement +c==== +c + elseif ( numcas.eq.5 ) then +c +c 7.1. ==> On met des valeurs nulles par defaut +c + do 71 , iaux = 1 , nbheto +c + jaux = nhexca(iaux) + if ( jaux.ne.0 ) then + indice = nbcomp*(jaux-1) + 1 + do 711 , kaux = 1 , nbcomp + vafoti(indice) = 0 + indice = indice + 1 + 711 continue + profil(jaux) = 1 + endif +c + 71 continue +c +c 7.2. ==> Parcours des paires enregistrees +c + lmax = nbcomp / 2 +c +cgn write (ulsort,*) 'boucle 720' +cgn write (ulsort,90002) 'npherc', npherc +cgn do 720 , iaux = 1 , npherc +cgn if ( ( hexrec(3,iaux).eq.291 ) .or. +cgn > ( hexrec(3,iaux).eq.296 ) ) then +cgn write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux), +cgn > hexrec(2,iaux), hexrec(3,iaux) +cgn endif +cgn 720 continue + do 72 , iaux = 1 , npherc +c + jaux = hexrec(1,iaux) + kaux = hexrec(2,iaux) +cgn write (ulsort,90002) 'iaux, jaux, kaux, face', +cgn > iaux, jaux, kaux, hexrec(3,iaux) +c + if ( jaux.ne.0 ) then +c +cgn write (ulsort,*) 'boucle 721' + levolu = kaux + laface = hexrec(3,iaux) + indice = nbcomp*(jaux-1) + 1 + do 721 , laux = 1, lmax + if ( vafoti(indice).eq.0 ) then + vafoti(indice) = levolu + vafoti(indice+1) = laface +cgn if ( ( hexrec(3,iaux).eq.291 ) .or. +cgn > ( hexrec(3,iaux).eq.296 ) ) then +cgn write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux), +cgn > hexrec(2,iaux), hexrec(3,iaux) +cgn write (ulsort,90002) ' ==> indice A', indice, laux +cgn write (ulsort,90002) ' ==> ecriture de', kaux, hexrec(3,iaux) +cgn endif + goto 722 + elseif ( vafoti(indice+1).eq.laface ) then +cgn if ( ( hexrec(3,iaux).eq.291 ) .or. +cgn > ( hexrec(3,iaux).eq.296 ) ) then +cgn write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux), +cgn > hexrec(2,iaux), hexrec(3,iaux) +cgn write (ulsort,90002) ' ==> indice A', indice +cgn write (ulsort,90002) ' ==> non ecriture de', kaux, hexrec(3,iaux) +cgn endif + goto 723 +#ifdef _DEBUG_HOMARD_ + else + if ( ( hexrec(3,iaux).eq.-291 ) .or. + > ( hexrec(3,iaux).eq.-296 ) ) then + write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux), + > hexrec(2,iaux), hexrec(3,iaux) + write (ulsort,*) ' indice A deja connu',indice,vafoti(indice) + write (ulsort,*) ' recherche d''un autre indice' + endif +#endif + endif + indice = indice + 2 + 721 continue + codret = 721 + write (ulsort,*) 'Ecriture impossible' + write (ulsort,90002) 'iaux', iaux + write (ulsort,90002) '1', hexrec(1,iaux) + write (ulsort,90002) '2', hexrec(2,iaux) + write (ulsort,90002) '3', hexrec(3,iaux) + goto 7999 + 722 continue + 723 continue +c + endif +c + if ( kaux.ne.0 ) then +c +cgn write (ulsort,*) 'boucle 724' + levolu = jaux + laface = hexrec(3,iaux) + indice = nbcomp*(kaux-1) + 1 + do 724 , laux = 1, lmax + if ( vafoti(indice).eq.0 ) then + vafoti(indice) = levolu + vafoti(indice+1) = laface +cgn write (ulsort,90002) ' ==> indice B', indice, laux + goto 725 +cgn else +cgn write (ulsort,90112) ' vafoti',indice,vafoti(indice) +cgn write (ulsort,*) ' indice B deja connu' + endif + indice = indice + 2 + 724 continue + codret = 724 + write (ulsort,*) 'Ecriture impossible' + write (ulsort,90002) 'iaux', iaux + write (ulsort,90002) '1', hexrec(1,iaux) + write (ulsort,90002) '2', hexrec(2,iaux) + write (ulsort,90002) '3', hexrec(3,iaux) + goto 7999 + 725 continue +c + endif +c + 72 continue +c +cgn do 73 , iaux = 1,nbentc +cgn write(ulsort,90112)'profil',iaux,profil(iaux) +cgn write (ulsort,90002) 'indices', nbcomp*(iaux-1)+1,nbcomp*iaux +cgn write(ulsort,90112)'vafoti',iaux, +cgn >(vafoti(jaux),jaux=nbcomp*(iaux-1)+1,nbcomp*iaux) +cgn 73 continue +c + 7999 continue +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infc37.F b/src/tool/Information/infc37.F new file mode 100644 index 00000000..4b0cbe04 --- /dev/null +++ b/src/tool/Information/infc37.F @@ -0,0 +1,271 @@ + subroutine infc37 ( numcas, nbcomp, nbentc, + > profil, vafoti, vafotr, + > facpen, cofape, arepen, + > perpen, npenca, + > coonoe, somare, + > nivtri, + > arequa, nivqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormations Complementaires - phase 37 +c -- - - -- +c Valeurs sur les pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numcas . e . 1 . numero du cas en cours de traitement . +c . . . . 1 : niveau . +c . . . . 2 : qualite . +c . . . . 3 : diametre . +c . . . . 4 : parente . +c . . . . 5 : voisins des recollements . +c . nbcomp . e . 1 . nombre de composantes . +c . nbentc . e . 1 . nombre total d'entites du calcul . +c . profil . s . nbentc . pour chaque entite du calcul : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafoti . s . nbentc . tableau temporaire de la fonction . +c . vafotr . s . nbentc . tableau temporaire de la fonction . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . perpen . e . nbpeto . pere des pentaedres . +c . npenca . e . * . nro des pentaedres dans le calcul . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFC37' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer numcas + integer nbcomp, nbentc + integer profil(nbentc) + integer vafoti(nbentc) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer perpen(nbpeto) + integer npenca(*) + integer somare(2,nbarto) + integer nivtri(nbtrto) + integer arequa(nbquto,4), nivqua(nbquto) +c + double precision coonoe(nbnoto,sdim) + double precision vafotr(nbentc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + double precision niveau, qualit, qualij, volume, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''.. Valeurs sur les '',a)' +c + texte(2,4) = '(''.. Values over the '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,7) + write (ulsort,90002) 'nbpeto', nbpeto + write (ulsort,90002) 'nbpepe', nbpepe + write (ulsort,90002) 'nbentc', nbentc +#endif +c + codret = 0 +c +c==== +c 2. Rien par defaut +c==== +c + do 21 , iaux = 1 , nbentc + profil(iaux) = 0 + 21 continue +c +c==== +c 3. Niveau +c==== +c + if ( numcas.eq.1 ) then +c +c 3.1. ==> Les pentaedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 31 , iaux = 1 , nbpepe +c +cgn write (ulsort,90015) 'npenca(',iaux,') =', npenca(iaux) +cgn write (ulsort,90015) 'nivqua(',iaux,') =', nivqua(iaux) +c + jaux = npenca(iaux) + if ( jaux.ne.0 ) then + vafotr(jaux) = dble(nivqua(facpen(iaux,5))) + profil(jaux) = 1 + endif +c + 31 continue +c +c 3.2. ==> Les pentaedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 32 , iaux = nbpepe+1 , nbpeto +c + call utnpen ( iaux, niveau, + > facpen, perpen, + > nivtri, nivqua ) +c + jaux = npenca(iaux) + vafotr(jaux) = niveau + profil(jaux) = 1 +c + 32 continue +c +c==== +c 4. Qualite +c==== +c + elseif ( numcas.eq.2 ) then +c + do 41 , iaux = 1 , nbpeto +c + jaux = npenca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utqpen ( kaux, qualit, qualij, volume, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) + vafotr(jaux) = qualit + profil(jaux) = 1 +c + endif +c + 41 continue +c +c==== +c 5. Diametre +c==== +c + elseif ( numcas.eq.3 ) then +c + do 51 , iaux = 1 , nbpeto +c + jaux = npenca(iaux) + if ( jaux.ne.0 ) then + kaux = iaux + call utdpen ( kaux, diamet, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) + vafotr(jaux) = diamet + profil(jaux) = 1 +c + endif +c + 51 continue +c +c==== +c 6. Parente +c==== +c + elseif ( numcas.eq.4 ) then +c + do 61 , iaux = 1 , nbpeto +c + jaux = npenca(iaux) + if ( jaux.ne.0 ) then + vafoti(jaux) = perpen(iaux) + profil(jaux) = 1 + endif +c + 61 continue +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infca1.F b/src/tool/Information/infca1.F new file mode 100644 index 00000000..90e42ea3 --- /dev/null +++ b/src/tool/Information/infca1.F @@ -0,0 +1,436 @@ + subroutine infca1 ( numfic, option, + > nbcham, nocham, + > nrocha, nrocmp, nrotab, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers Champs ASCII - 1ere partie +c -- - - - - +c ______________________________________________________________________ +c +c but : determination des choix pour les fichiers +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfic . e . 1 . numero du fichier a ecrire . +c . option . s . 1 . 0 : on ne sort aucun fichier . +c . . . . 1 : un champ et toutes ses composantes . +c . . . . 2 : un champ et 1 seule composante . +c . . . . negatif : la valeur absolue du champ . +c . . . . positif : la valeur du champ . +c . nbcham . e . 1 . nombre de champs definis . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nrocha . s . 1 . numero du champ retenu pour le coloriage . +c . . . . -1 si coloriage selon la qualite . +c . nrocmp . s . 1 . numero de la composante retenue . +c . nrotab . s . 1 . numero du tableau associe au pas de temps . +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFCA1' ) +c +#include "nblang.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer numfic, option + integer ulfido, ulenst, ulsost + integer nbcham + integer nrocha, nrocmp, nrotab +c + character*8 nocham(nbcham) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsign + integer typsig(3), valent(3) +c + character*2 valcha(3) + character*80 chaine +c + integer iaux + integer iaux1, iaux2, iaux3 +c + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca +c + integer adtrav, lgtrav +c + character*2 saux02 + character*8 saux08 + character*16 nomcmp + character*16 saux16 + character*64 saux64 + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c_______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''0 : aucun fichier'')' + texte(1,5) = + > '(''1 : fichier ascii avec un champ et toutes ses composantes'')' + texte(1,6) = + > '(''2 : fichier ascii avec un champ et 1 seule composante'')' + texte(1,14) = '(''Option non disponible'',/)' + texte(1,40) = '(''Quel choix de champ ?'')' + texte(1,41) = '(''Quelle composante ?'')' + texte(1,42) = '(''Quel numero de pas de temps ?'')' + texte(1,48) = '(''Le champ ou sa valeur absolue ? (ch/va)'')' + texte(1,49) = + > '(''Repondre ch pour le champ, va pour sa valeur absolue.'')' + texte(1,100) = '(/,''Creation du fichier ascii numero'',i4)' +c + texte(2,4) = '(''0 : no file'')' + texte(2,5) = + > '(''1 : ascii file with a field and all its components'')' + texte(2,6) = + > '(''2 : ascii file with a field and a single component'')' + texte(2,14) = '(''Option still not available'',/)' + texte(2,40) = '(''What is your choice for the field ?'')' + texte(2,41) = '(''What is your choice for the component ?'')' + texte(2,42) = '(''What is your choice for the time step ?'')' + texte(2,48) = '(''Field or absolute value ? (ch/va)'')' + texte(2,49) = + > '(''Answer ch for the field, va for its abslute value.'')' + texte(2,100) = '(/,''Creation of ascii file #'',i4)' +c +10000 format(a) +10080 format(a80) +11000 format(i10) +c + write (ulsort,texte(langue,100)) numfic+1 + write (ulsost,texte(langue,100)) numfic+1 +c +c==== +c 2. questions - reponses pour l'option +c==== +c + 20 continue +c +c 2.1. ==> interactivite +c + write (ulsost,texte(langue,4)) +cgn write (ulsost,texte(langue,5)) + write (ulsost,texte(langue,6)) +c + call dmflsh ( iaux ) + read (ulenst,10080,err=20,end=20) chaine +c +c 2.2. ==> decoupage de la chaine +c + call utqure ( chaine, + > nbsign, typsig, valcha, valent, + > ulsort, langue, codret ) +cgn write(ulsort,*) typsig +cgn write(ulsort,*) valcha +cgn write(ulsort,*) valent +c + if ( nbsign.eq.0 ) then + goto 20 + elseif ( typsig(1).ne.0 ) then + goto 20 + endif +c +c 2.4. ==> decodage et validation du choix +c + option = valent(1) +c + if ( option.le.-1 .or. option.ge.3 .or. option.eq.1 ) then + write (ulsost,texte(langue,14)) + goto 20 + endif +c + write(ulfido,1000) chaine +c +c==== +c 7. questions - reponses pour le champ +c==== +c + if ( option.ne.0 ) then +c +c 7.1. ==> choix du champ a representer +c + 71 continue +c + write (ulsost,texte(langue,40)) +c + do 711 , iaux1 = 1 , nbcham +c + if ( codret.eq.0 ) then +c + saux08 = nocham(iaux1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( saux08, + > saux64, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + write (ulsost,10000) saux64 +c + endif +c + 711 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=71,end=71) nomcha +c + call utlgut ( iaux2, nomcha, + > ulsort, langue, codret ) +c + do 712 , iaux1 = 1 , nbcham +c + if ( codret.eq.0 ) then +c + saux08 = nocham(iaux1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( saux08, + > saux64, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( iaux3, saux64, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( iaux2.eq.iaux3 ) then + if ( nomcha(1:iaux2).eq.saux64(1:iaux2) ) then + nrocha = iaux1 + write(ulfido,1000) nomcha + goto 72 + endif + endif +c + endif +c + 712 continue +c + goto 71 +c +c 7.2. ==> choix de la composante a representer +c + 72 continue +c + if ( option.eq.2 ) then +c + if ( nbcomp.eq.1 ) then +c + nrocmp = 1 + nomcmp = smem(adnocp+4)//smem(adnocp+5) +c + else +c + 721 continue +c + write (ulsost,texte(langue,41)) +c +cgn write (ulsost,10000) 'norme' + do 722 , iaux1 = 1 , nbcomp + write (ulsost,10000) smem(adnocp+3+2*iaux1-1)// + > smem(adnocp+3+2*iaux1) + 722 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=72,end=72) nomcmp + call utlgut ( iaux2, nomcmp, + > ulsort, langue, codret ) +c + do 723 , iaux1 = 1 , nbcomp +c + if ( iaux1.eq.0 ) then + iaux3 = 5 + saux16(1:iaux3) = 'norme' + else + call utlgut ( iaux3, smem(adnocp+3+2*iaux1-1), + > ulsort, langue, codret ) + saux16(1:iaux3) = smem(adnocp+3+2*iaux1-1)(1:iaux3) + if ( iaux3.eq.8 ) then + call utlgut ( iaux3, smem(adnocp+3+2*iaux1), + > ulsort, langue, codret ) + if ( iaux3.gt.0 ) then + saux16(9:8+iaux3) = smem(adnocp+3+2*iaux1)(1:iaux3) + iaux3 = iaux3 + 8 + endif + endif + endif +c + if ( iaux2.eq.iaux3 ) then + if ( nomcmp(1:iaux2).eq.saux16(1:iaux2) ) then + nrocmp = iaux1 + write(ulfido,1000) nomcmp + goto 73 + endif + endif + 723 continue +c + goto 721 +c + endif +c + endif +c +c 7.3. ==> choix du pas de temps a representer +c + 73 continue +c + if ( nbtvch.eq.1 ) then +c + nrotab = 1 +c + else +c + call gmalot ( saux08, 'entier ', 2*nbtvch, adtrav, codret ) +c + 731 continue +c + lgtrav = 0 + do 732 , iaux1 = 1 , nbtvch + iaux3 = imem(adcaen+nbinec*(iaux1-1)+2) + do 733 , iaux2 = 1 , lgtrav + if ( imem(adtrav+iaux2-1).eq.iaux3 ) then + goto 732 + endif + 733 continue + imem(adtrav+lgtrav) = iaux3 + imem(adtrav+nbtvch+lgtrav) = iaux1 + lgtrav = lgtrav + 1 + 732 continue + if ( lgtrav.eq.1 ) then + nrotab = 1 + goto 736 + endif +c + write (ulsost,texte(langue,42)) +c + do 724 , iaux1 = 1 , lgtrav + write (ulsost,11000) imem(adtrav+iaux1-1) + 724 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=731,end=731) iaux2 +c + do 735 , iaux1 = 1 , lgtrav +c + if ( iaux2.eq.imem(adtrav+iaux1-1) ) then + nrotab = imem(adtrav+nbtvch+iaux1-1) + write(ulfido,1115) iaux2 + goto 736 + endif + 735 continue +c + goto 731 +c + 736 continue +c + call gmlboj ( saux08, codret ) +c + endif +c +c 7.4. ==> le champ ou sa valeur absolue +c + 74 continue +c + write (ulsost,texte(langue,48)) + call dmflsh ( iaux ) + read (ulenst,*,err=74,end=74) saux02 + if ( saux02.eq.'ch' ) then + goto 741 + elseif ( saux02.eq.'va' ) then + option = - option + else + write (ulsost,texte(langue,49)) + goto 74 + endif + write(ulfido,1000) saux02 +c + 741 continue +c + endif +c + 1000 format(a) + 1115 format(i15) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infca2.F b/src/tool/Information/infca2.F new file mode 100644 index 00000000..d8abe4ca --- /dev/null +++ b/src/tool/Information/infca2.F @@ -0,0 +1,302 @@ + subroutine infca2 ( numfic, + > nbcham, nocham, + > nrocha, nrocmp, nrotab, + > coonoe, + > nnoeca, ntreca, nqueca, + > nnoeho, ntreho, nqueho, + > lgnoin, lgtrin, lgquin, + > nnoein, ntrein, nquein, + > decanu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers Champs ASCII - 2eme partie +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfic . es . 1 . numero du fichier a ecrire . +c . nbcham . e . 1 . nombre de champs definis . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nrocha . e . 1 . nunero du champ retenu pour le coloriage . +c . . . . -1 si coloriage selon la qualite . +c . nrocmp . e . 1 . numero de la composante retenue . +c . nrotab . e . 1 . numero du tableau associe au pas de temps . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . nnoeca . e . renoto . noeuds en entree dans le calcul . +c . ntreca . e . retrto . nro des triangles dans le calcul en entree . +c . nqueca . e . requto . nro des quads dans le calcul en entree . +c . nnoeho . e . * . nro des noeuds dans HOMARD en entree . +c . ntreho . e . * . nro des triangles dans HOMARD en entree . +c . nqueho . e . * . nro des quads dans HOMARD en entree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . decanu . e . -1:7 . decalage des numerotations selon le type . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFCA2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "envca1.h" +#include "envada.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer numfic + integer nbcham + integer nrocha, nrocmp, nrotab + integer nnoeca(renoto), ntreca(retrto), nqueca(requto) + integer nnoeho(*), ntreho(*), nqueho(*) + integer lgnoin, lgtrin, lgquin + integer nnoein(*), ntrein(*), nquein(*) + integer decanu(-1:7) +c + character*8 nocham(nbcham) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nuroul, lnomfl + integer nbquvi, nbtrvi + integer adquvi, adtrvi + integer adquva, adtrva + integer nbenti +c + character*8 saux08 + character*8 notrva + character*20 titre0 + character*200 nomflo +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,9) = '(''Caracterisation de la fonction'')' +c + texte(2,9) = '(''Characteristics of function'')' +c +c==== +c 2. les valeurs +c==== +c +c 2.1. ==> determination de la fonction +c + if ( codret.eq.0 ) then +c +c tableau notrva + call gmalot ( notrva, 'reel ', nbnoto, adtrva, codret ) +c + endif +c + adquva = 1 + adquvi = 1 + adtrvi = 1 +c +c 2.2. ==> recherche des valeurs du champ +c Remarque : on met une valeur bidon a nbtrvi et nbquvi pour +c ne pas avoir de message avec ftnchek +c + if ( nrotab.gt.0 ) then +c + if ( codret.eq.0 ) then +c + nbtrvi = 1 + nbquvi = 1 + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFFRE', nompro +#endif + call inffre ( iaux, rmem(adtrva), rmem(adquva), titre0, + > nocham(nrocha), nrocmp, nrotab, + > nbtrvi, nbquvi, + > imem(adtrvi), imem(adquvi), + > nnoeca, ntreca, nqueca, + > nnoeho, ntreho, nqueho, + > lgnoin, lgtrin, lgquin, + > nnoein, ntrein, nquein, + > decanu, + > ulsort, langue, codret ) +c + endif +c + else +c + codret = 12 +c + endif +c +c==== +c 3. ecriture des valeurs +c==== +c + if ( codret.eq.0 ) then +c +c 3.1 ==> ouverture du fichier +c + if ( codret.eq.0 ) then +c + numfic = numfic + 1 +c + saux08 = ' ' + iaux = -5 + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux08, nbiter, numfic, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> ecriture +c + if ( codret.eq.0 ) then +c + nbenti = renoto +c + if ( sdim.eq.1 ) then +c + do 321 , iaux = 1 , nbenti +c + write (nuroul,32000) coonoe(nnoeca(iaux),1), + > rmem(adtrva+iaux-1) +c + 321 continue +c + elseif ( sdim.eq.2 ) then +c + do 322 , iaux = 1 , nbenti +c + write (nuroul,32000) coonoe(nnoeca(iaux),1), + > coonoe(nnoeca(iaux),2), + > rmem(adtrva+iaux-1) +c + 322 continue +c + elseif ( sdim.eq.3 ) then +c + do 333 , iaux = 1 , nbenti +c + write (nuroul,32000) coonoe(nnoeca(iaux),1), + > coonoe(nnoeca(iaux),2), + > coonoe(nnoeca(iaux),3), + > rmem(adtrva+iaux-1) +c + 333 continue +c + else +c + codret = 15 +c + endif +c +32000 format(10g17.9) +c + endif +c +c 3.3. ==> fermeture du fichier +c + if ( codret.eq.0 ) then +c + call gufeul ( nuroul , codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, notrvi ) +#endif +c +c==== +c 4. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( notrva, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infcas.F b/src/tool/Information/infcas.F new file mode 100644 index 00000000..a300f81f --- /dev/null +++ b/src/tool/Information/infcas.F @@ -0,0 +1,565 @@ + subroutine infcas ( nomail, nosolu, + > ulfido, ulenst, ulsost, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers Champs ASCII +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iteration n . +c . nosolu . e . char8 . nom de l'objet solution . +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFCAS' ) +c +cfonc integer nbtych +cfonc parameter ( nbtych = 5 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "envca1.h" +#include "nomber.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nosolu +c + integer ulfido, ulenst, ulsost + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux +c + integer pcoono, psomar + integer pnp2ar, phetar, pmerar, pposif, pfacar + integer phettr, paretr, pnivtr + integer advotr + integer phetqu, parequ, pnivqu + integer ptrite, phette + integer adnbrn + integer adnohn, adnocn, adnoin, lgnoin + integer adtrhn, adtrcn, adtrin, lgtrin + integer adquhn, adqucn, adquin, lgquin + integer option + integer numfic +c + integer nbcham, nbfonc, nbprof, nblopg + integer aninch, aninfo, aninpr, adinlg + integer nrocha, nrocmp, nrotab +c + integer decanu(-1:7) +c + character*6 saux06 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a6,'' FICHIER ASCII POUR GRAPHIQUE'')' + texte(1,5) = '(35(''=''),/)' + texte(1,10) = '(''Lancement du trace numero'',i3)' +c + texte(2,4) = '(a6,'' ASCII FILE FOR GRAPHIC'')' + texte(2,5) = '(29(''=''),/)' + texte(2,10) = '(''Beginning of writings #'',i3)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux06, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux06 + write (ulsort,texte(langue,5)) +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2. Tableaux ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 3 + call utad01 ( iaux, nhnoeu, + > jaux, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 10 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, pmerar, + > jaux, jaux, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 22 + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 22 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> les voisinages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + if ( nbteto.ne.0 ) then + iaux = iaux*5 + endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ===> tableaux lies a la renumerotation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > renoac, renoto, adnohn, adnocn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_no', nompro +#endif + iaux = -1 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgnoin, adnoin, + > ulsort, langue, codret) +c + endif +c + if ( retrac.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > retrac, retrto, adtrhn, adtrcn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_tr', nompro +#endif + iaux = 2 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgtrin, adtrin, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( requac.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > requac, requto, adquhn, adqucn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_qu', nompro +#endif + iaux = 4 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgquin, adquin, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ( nompro, norenu//'.Nombres' ) + call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > iaux, iaux, + > iaux, iaux, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmapo', nbmapo + write(ulsort,90002) 'nbsegm', nbsegm + write(ulsort,90002) 'nbtria', nbtria + write(ulsort,90002) 'nbtetr', nbtetr + write(ulsort,90002) 'nbquad', nbquad + write(ulsort,90002) 'nbhexa', nbhexa + write(ulsort,90002) 'nbpent', nbpent + write(ulsort,90002) 'nbpyra', nbpyra +#endif +c + decanu(-1) = 0 + decanu(3) = 0 + decanu(2) = nbtetr + decanu(1) = nbtetr + nbtria + decanu(0) = nbtetr + nbtria + nbsegm + decanu(4) = nbtetr + nbtria + nbsegm + nbmapo + decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +c + endif +c +c 2.5. ===> tableaux lies a la solution eventuelle +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nosolu) + call gmprsx (nompro,nosolu//'.InfoCham') + call gmprsx (nompro,nosolu//'.InfoPaFo') + call gmprsx (nompro,nosolu//'.InfoProf') + call gmprsx (nompro,nosolu//'.InfoLoPG') +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro +#endif + call utcaso ( nosolu, + > nbcham, nbfonc, nbprof, nblopg, + > aninch, aninfo, aninpr, adinlg, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbcham.eq.0 ) then + codret = 0 + goto 60 + endif +c + endif +c +c==== +c 3. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. initialisations ; codret = ', codret +#endif +c + numfic = 0 +c +c==== +c 4. questions - reponses pour les sorties +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. questions - reponses ; codret = ', codret +#endif +c + 40 continue +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFCA1', nompro +#endif + call infca1 ( numfic, option, + > nbcham, smem(aninch), + > nrocha, nrocmp, nrotab, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( option.eq.0 ) then + codret = 0 + goto 60 + endif +c + endif +c +c==== +c 5. ecriture des valeurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. ecriture des valeurs ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFCA2', nompro +#endif + call infca2 ( numfic, + > nbcham, smem(aninch), + > nrocha, nrocmp, nrotab, + > rmem(pcoono), + > imem(adnocn), imem(adtrcn), imem(adqucn), + > imem(adnohn), imem(adtrhn), imem(adquhn), + > lgnoin, lgtrin, lgquin, + > imem(adnoin), imem(adtrin), imem(adquin), + > decanu, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + goto 40 +c + endif +c +c==== +c 6. la fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. La fin ; codret = ', codret +#endif +c + 60 continue +c + write (ulsort,*) ' ' +c +c 6.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Information/infcom.F b/src/tool/Information/infcom.F new file mode 100644 index 00000000..d7b9faa2 --- /dev/null +++ b/src/tool/Information/infcom.F @@ -0,0 +1,628 @@ + subroutine infcom ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c INformation - inFormation COMplementaires +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFCOM' ) +c +#include "nblang.h" +#include "motcle.h" +#include "consts.h" +c + integer nbrcas + parameter ( nbrcas = 5 ) +c +c 0.2. ==> communs +c +#include "indefs.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "envex1.h" +#include "impr02.h" +#include "meddc0.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombqu.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nrsect + integer nbrca0 + integer tab(-2:7,nbrcas) + integer numcas + integer nbcham, nucham, nbpafo, nupafo, nbtvch, nutvch, nbtafo + integer adinch + integer adinpf + integer adcaen, adcare, adcaca + integer typenh + integer nbento, nbencf, nbenca + integer typgeo + integer lnocmd +c + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet +c + integer caopti(nbrcas), nbcomp(nbrcas), coderf(nbrcas) +c + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc + integer npenrc, adenrc +c + character*2 saux02 + character*8 typobs + character*8 nocsol + character*8 nhenti + character*8 canotr(nblang,nbrcas) + character*16 nomcom(12), unicom(12) + character*64 nochmd +c + character*8 obcham + character*8 nohmai + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + data coderf / 2, 3, 5, 7, 11 / + data nbcomp / 1, 1, 1, 1, 12 / + data caopti / 0, 0, 0, 0, 0 / + data canotr / 'Niveau ', 'Level ', + > 'Qualite ', 'Quality ', + > 'Diametre', 'Diameter', + > 'Parent ', 'Parent ', + > 'VoisinHo', 'NeighbHo' / +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(''Creation de l''''objet '', a8)' + texte(1,5) = '(''Type de traitement : '', a)' + texte(1,6) = '(''.. Examen des'',i10,1x,a)' +c + texte(2,4) = '(''Creation of the object '', a8)' + texte(2,5) = '(''Type of treatment: '', a)' + texte(2,6) = '(''.. Examination of the'',i10,1x,a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'taopti(12)', taopti(12) +#endif +c +c==== +c 2. le maillage homard +c==== +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmai, iaux, ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nohmai, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Tri des options +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Tri des options ; codret', codret +#endif +c +c 3.1. ==> En l'absence de recollement, on supprime ce choix +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'nospec', taopts(20) +#endif + if ( taopts(20).eq.sindef ) then + nbrca0 = nbrcas - 1 + else + call gmobal ( taopts(20), codret ) + if ( codret.eq.1 ) then + nbrca0 = nbrcas + codret = 0 + else + nbrca0 = nbrcas - 1 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbrcas', nbrcas + write (ulsort,90002) 'nbrca0', nbrca0 +#endif +c +c 3.2. ==> Decodage de l'option +c + nbcham = 0 +c + do 32 , iaux = 1, nbrca0 +c + if ( mod(taopti(12),coderf(iaux)).eq.0 ) then + caopti(iaux) = 1 + nbcham = nbcham + 1 + write (ulsort,texte(langue,5)) canotr(langue,iaux) + else + caopti(iaux) = 0 + endif +c + 32 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'caopti', caopti +#endif +c +c==== +c 4. Allocation de la structure de tete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Allocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC00', nompro +#endif + call infc00 ( nbrca0, caopti, nbcham, + > tab, + > nocsol, nbpafo, + > adinch, adinpf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + do 4444 , iaux = 1, nbrca0 + write (ulsort,90015) 'tab de', iaux,' :', + > (tab(jaux,iaux),jaux=-2,7) + 4444 continue + write (ulsort,90002) 'nbcham', nbcham + write (ulsort,texte(langue,4)) nocsol +#endif +c + if ( nbcham.eq.0 ) then + taopti(12) = 1 + else + taopts(31) = nocsol + endif +c + endif +c +c==== +c 5. Remplissage champs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Remplissage ; codret', codret +#endif +c + nucham = 0 + nupafo = 0 +c + do 51 , kaux = 1 , nbrca0 +c + if ( codret.eq.0 ) then +c + numcas = kaux + nbtvch = tab(-2,numcas) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numcas', numcas + write (ulsort,90002) 'nbtvch', nbtvch +#endif +c + if ( nbtvch.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) "Cas de "//canotr(langue,numcas) +#endif +c + nrsect = 90 + kaux + call gtdems (nrsect) +c + nutvch = 0 +c +c 5.1. ==> Nom du champ +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1. Nom du champ ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nochmd = blan64 + if ( numcas.eq.1 ) then + typobs = mcicni + elseif ( numcas.eq.2 ) then + typobs = mcicqu + elseif ( numcas.eq.3 ) then + typobs = mcicdi + elseif ( numcas.eq.4 ) then + typobs = mcicpa + elseif ( numcas.eq.5 ) then + typobs = mcicvr + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'typobs', typobs +#endif + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nochmd, lnocmd, + > jaux, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) nochmd(1:lnocmd), lnocmd +#endif +c + endif +c +c 5.2. ==> Adresses pour le recollement +c + if ( numcas.eq.5 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, taopts(20) ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD41', nompro +#endif + call utad41 ( taopts(20), + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > ulsort, langue, codret) +c + endif +c + endif +c +c 5.2. ==> Structures d'information sur les champs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. InfoCham ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nucham = nucham + 1 + nbtafo = nbcomp(numcas) + do 52 , iaux = 1 , nbtafo + nomcom(iaux) = blan16 + nomcom(iaux)(1:1) = 'V' + if ( iaux.gt.1 ) then + call utench ( iaux, '0', jaux, saux02, + > ulsort, langue, codret ) + nomcom(iaux)(2:3) = saux02 + endif + unicom(iaux) = blan16 + 52 continue + if ( numcas.le.3 ) then + iaux = edfl64 + else + iaux = edint + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFC01', nompro +#endif + call infc01 ( nbtvch, + > adinch, + > nucham, nochmd, iaux, + > nbtafo, nomcom, unicom, + > obcham, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> Remplissage +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.3. Remplissage ; codret', codret +#endif +c + do 53 , typenh = -1 , 7 +c + jaux = tab(typenh,numcas) + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) jaux, mess14(langue,3,typenh) +#endif +c + if ( codret.eq.0 ) then +c + nupafo = nupafo + 1 + nutvch = nutvch + 1 + nbencf = 0 + nbenca = 0 +c + if ( typenh.eq.-1 ) then + nhenti = nhnoeu + nbento = nbnoto + typgeo = 0 + elseif ( typenh.eq.0 ) then + nhenti = nhmapo + nbento = nbmpto + typgeo = edpoi1 + elseif ( typenh.eq.1 ) then + nhenti = nharet + nbento = nbarto + if ( degre.eq.1 ) then + typgeo = edseg2 + else + typgeo = edseg3 + endif + elseif ( typenh.eq.2 ) then + nhenti = nhtria + nbento = nbtrto + if ( degre.eq.1 ) then + typgeo = edtri3 + else + typgeo = edtri6 + endif + elseif ( typenh.eq.3 ) then + nhenti = nhtetr + nbento = nbteto + nbencf = nbtecf + nbenca = nbteca + if ( degre.eq.1 ) then + typgeo = edtet4 + else + typgeo = edte10 + endif + elseif ( typenh.eq.4 ) then + nhenti = nhquad + nbento = nbquto + if ( degre.eq.1 ) then + typgeo = edqua4 + else + typgeo = edqua8 + endif + elseif ( typenh.eq.5 ) then + nhenti = nhpyra + nbento = nbpyto + nbencf = nbpycf + nbenca = nbpyca + if ( degre.eq.1 ) then + typgeo = edpyr5 + else + typgeo = edpy13 + endif + elseif ( typenh.eq.6 ) then + nhenti = nhhexa + nbento = nbheto + nbencf = nbhecf + nbenca = nbheca + if ( degre.eq.1 ) then + typgeo = edhex8 + else + typgeo = edhe20 + endif + npenrc = npqurc + adenrc = adherc +#ifdef _DEBUG_HOMARD_ + if ( numcas.eq.5 ) then + call gmprsx ( nompro, taopts(20)//'.Tab5' ) + endif +#endif + elseif ( typenh.eq.7 ) then + nhenti = nhpent + nbento = nbpeto + nbencf = nbpecf + nbenca = nbpeca + if ( degre.eq.1 ) then + typgeo = edpen6 + else + typgeo = edpe15 + endif + endif +c + iaux = typenh +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) + > 'INFC02 - '//mess14(langue,3,typenh), nompro +#endif + call infc02 ( numcas, + > iaux, nhenti, nbento, nbencf, nbenca, + > nbtvch, nutvch, + > nbtafo, jaux, typgeo, + > obcham, nupafo, smem(adinpf), + > nhnoeu, nharet, nhtria, nhquad, + > nhhexa, nhpent, norenu, + > imem(adcaen), rmem(adcare), smem(adcaca), + > npenrc, imem(adenrc), + > ulsort, langue, codret ) +c + endif +c + endif +c + 53 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90015) 'OBJET InfoCham' + call gmprsx ( nompro, obcham ) + call gmprsx ( nompro, obcham//'.Nom_Comp' ) + call gmprsx ( nompro, obcham//'.Cham_Ent' ) + call gmprsx ( nompro, obcham//'.Cham_Ree' ) + call gmprsx ( nompro, obcham//'.Cham_Car' ) + endif +#endif +c + call gtfims (nrsect) +c + endif +c + endif +c + 51 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90015) 'OBJET Solution' + call gmprsx ( nompro, nocsol//'.InfoCham' ) + call gmprsx ( nompro, nocsol//'.InfoPaFo' ) +cgn call gmprsx ( nompro, '%%%%%%10' ) +cgn call gmprsx ( nompro, '%%%%%%%9' ) +cgn call gmprsx ( nompro, '%%%%%%%9.ValeursE' ) +cgn call gmprsx ( nompro, '%%%%%%19' ) +cgn call gmprsx ( nompro, '%%%%%%18' ) +cgn call gmprsx ( nompro, '%%%%%%18.ValeursE' ) + endif +#endif +c + if ( codret.eq.0 ) then +c + if ( nbrca0.eq.5 ) then + call gmlboj ( taopts(20), codret ) + taopts(20) = sindef + endif +c + endif +c +c==== +c 6. pour le cas extrude, passage du 2D au 3D +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Cas extrude ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( taopti(39).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 2 + call utsext ( nocsol, iaux, taopti(11), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/inffre.F b/src/tool/Information/inffre.F new file mode 100644 index 00000000..9230149c --- /dev/null +++ b/src/tool/Information/inffre.F @@ -0,0 +1,698 @@ + subroutine inffre ( option, fotrva, foquva, titre0, + > nocham, nrocmp, nrotab, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > nnoeca, ntreca, nqueca, + > nnoeho, ntreho, nqueho, + > lgnoin, lgtrin, lgquin, + > nnoein, ntrein, nquein, + > decanu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier - Fonction - REcuperation +c -- - - -- +c ______________________________________________________________________ +c +c prise en compte de la fonction +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : la sortie est exprimee sur des elements. +c . . . . Si le champ est aux noeuds, on prend . +c . . . . la moyenne des valeurs sur tous ses . +c . . . . noeuds . +c . . . . Si le champ est aux noeuds par element . +c . . . . ou aux points de Gauss, on prend la . +c . . . . moyenne des valeurs sur l'element . +c . . . . 2 : la sortie est exprimee sur des noeuds . +c . . . . Si le champ est aux elements, on prend . +c . . . . la moyenne des valeurs sur tous les . +c . . . . elements voisins du noeud . +c . fotrva . s . nbtrvi . fonctions triangles : valeur . +c . . . . ou fonctions par noeud . +c . foquva . s . nbquvi . fonctions quadrangles : valeur . +c . titre0 . s . char * . titre auxiliaire . +c . nocham . e . char8 . nom de l'objet champ . +c . nrocmp . e . 1 . 0 : le module (non operationnel) . +c . . . . numero de la composante retenue . +c . nrotab . e . 1 . numero du tableau associe au pas de temps . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . nnoeca . e . renoto . noeuds en entree dans le calcul . +c . ntreca . e . retrto . nro des triangles dans le calcul en entree . +c . nqueca . e . requto . nro des quads dans le calcul en entree . +c . nnoeho . e . renoto . nro des noeuds dans HOMARD en entree . +c . ntreho . e . retrto . nro des triangles dans HOMARD en entree . +c . nqueho . e . requto . nro des quads dans HOMARD en entree . +c . decanu . e . -1:7 . decalage des numerotations selon le type . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFFRE' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "fractb.h" +#include "fractc.h" +#include "fracte.h" +#include "fractf.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nomber.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer option + integer nrocmp, nrotab + integer nbtrvi, nbquvi + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer nnoeca(renoto), ntreca(retrto), nqueca(requto) + integer nnoeho(*), ntreho(*), nqueho(*) + integer lgnoin, lgtrin, lgquin + integer nnoein(*), ntrein(*), nquein(*) + integer decanu(-1:7) +c + double precision fotrva(*), foquva(*) +c + character*8 nocham + character*(*) titre0 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca + integer nrtvch + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas + integer nbenti, adpcan, adlipr + integer numdt +c + integer iaux1, iaux2, iaux3 + integer iaux, jaux, kaux + integer adtra1 +c + logical prem +c + double precision daux1, daux2 +c + character*8 ntrav1 + character*8 obpcan + character*8 saux08 + character*64 noprof + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Objet champ a examiner : '',a)' + texte(1,5) = '(''Nom du champ : '',a)' + texte(1,6) = '(a,'' :'',i5)' + texte(1,7) = '(''Impossible de projeter sur les noeuds'')' +c + texte(2,4) = '(''Field object : '',a)' + texte(2,5) = '(''Field name : '',a)' + texte(2,6) = '(a,'' :'',i5)' + texte(2,7) = '(''Node projection cannot be done'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nocham + call gmprsx (nompro,nocham) + call gmprsx (nompro,nocham//'.Nom_Comp') + call gmprsx (nompro,nocham//'.Cham_Car') +#endif +c +c==== +c 2. Decodage du champ retenu +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( nocham, + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nomcha + write (ulsort,texte(langue,6)) 'nbcomp', nbcomp + write (ulsort,texte(langue,6)) 'nbtvch', nbtvch +#endif +c +c==== +c 3. parcours des differents tableaux stockant les valeurs de ce champ +c==== +c + prem = .true. +c + if ( codret.eq.0 ) then +c + do 30 , nrtvch = 1 , nbtvch +c +c 3.1. ==> reperage du bon pas de temps +c . on retient le premier tableau correspondant a celui cherche +c . ensuite on retient tous ceux qui correspondent au meme +c numero de pas de temps. cela correspond au cas ou le champ +c est present sur plusieurs supports differents (tria+quad +c par exemple) +c + if ( codret.eq.0 ) then +c +c 3.1.1. ==> pour le premier tableau du bon pas de temps +c + if ( nrtvch.eq.nrotab) then +c + numdt = imem(adcaen+nbinec*(nrtvch-1)+1) + prem = .false. + jaux = len(titre0) + if ( numdt.ne.ednodt ) then +c 123456 + titre0(1:6) = '( t = ' + daux1 = rmem(adcare+nrtvch-1) + call utrech ( daux1, 'G', iaux, titre0(7:jaux), + > ulsort, langue, codret ) + if ( codret.eq.0 ) then + titre0(iaux+1:iaux+2) = ' )' + endif + endif + if ( codret.ne.0 .or. numdt.eq.ednodt ) then + codret = 0 + do 31 , iaux = 1 , jaux + titre0(iaux:iaux) = ' ' + 31 continue + endif +c + else +c +c 3.1.2. ==> pour un autre tableau +c + if ( prem ) then + goto 30 + else + if ( imem(adcaen+nbinec*(nrtvch-1)+1).ne.numdt ) then + goto 30 + endif + endif +c + endif + iaux1 = imem(adcaen+nbinec*(nrtvch-1)+8) +c +c + endif +c +c 3.2. ==> reperage de la fonction +c + saux08 = smem(adcaca+nbincc*(nrtvch-1)) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, saux08 ) +cgn call gmprsx (nompro, saux08//'.ValeursR' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( saux08, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c + kaux = nbtafo*ngauss +c +cgn 1789 format(i4,12f15.7) +cgn print *, 'ngauss = ',ngauss +cgn print *, 'nbenmx = ',nbenmx +cgn print *, 'nrocmp = ',nrocmp +cgn print *, 'nbtafo = ',nbtafo +cgn print *, 'nbvapr = ',nbvapr +cgn if ( typgeo.eq.0 ) then +cgn do 310,jaux=1,nbenmx +cgn print 1789, jaux, +cgn > (rmem(advalr+kaux*(jaux-1)+iaux-1), +cgn > iaux=iaux1,iaux1+nbcomp-1) +cgn 310 continue +cgn do 311,jaux=1,nbenmx*kaux +cgn print 1789, jaux, +cgn > rmem(advalr+1*(jaux-1)) +cgn 311 continue +cgn endif +c +c 3.3. ==> changements de numerotation +c +c 3.3.1. ==> profil eventuel +c + if ( nbvapr.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( smem(adprpg), + > iaux, noprof, adlipr, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.3.2. ==> allocation du tableau de renumerotation +c + if ( codret.eq.0 ) then +c + if ( typgeo.eq.0 ) then + nbenti = renoac + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then + nbenti = retrac + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then + nbenti = requac + else + nbenti = 0 + endif +c + call gmalot ( obpcan, 'entier ', nbenti, adpcan, codret ) +c + endif +c +c 3.3.3. ==> renumerotation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 'typgeo', typgeo + write (ulsort,texte(langue,6)) 'nbenti', nbenti + write (ulsort,texte(langue,6)) 'nbvapr', nbvapr +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbenti, adtra1, codret ) +c + endif +c + if ( typgeo.eq.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTBRC-no', nompro +#endif + call uttbrc ( iaux, + > lgnoin, nnoein, nbenti, imem(adtra1), + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = decanu(-1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR02-no', nompro +#endif + call utpr02 ( iaux, + > nbenti, nbvapr, imem(adlipr), + > nnoeho, nnoeca, jaux, + > lgnoin, nnoein, imem(adtra1), + > imem(adpcan), + > ulsort, langue, codret ) +c + endif +c + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTBRC-tr', nompro +#endif + call uttbrc ( iaux, + > lgtrin, ntrein, nbenti, imem(adtra1), + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = decanu(2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR02-tr', nompro +#endif + call utpr02 ( iaux, + > nbenti, nbvapr, imem(adlipr), + > ntreho, ntreca, jaux, + > lgtrin, ntrein, imem(adtra1), + > imem(adpcan), + > ulsort, langue, codret ) +c + endif +c + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then +c + if ( codret.eq.0 ) then +cgn write (ulsort,*) 'nquein' +cgn write (ulsort,91020) (nquein(iaux), iaux = 1 , lgquin) +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTBRC-qu', nompro +#endif + call uttbrc ( iaux, + > lgquin, nquein, nbenti, imem(adtra1), + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = decanu(4) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR02-qu', nompro +#endif + call utpr02 ( iaux, + > nbenti, nbvapr, imem(adlipr), + > nqueho, nqueca, jaux, + > lgquin, nquein, imem(adtra1), + > imem(adpcan), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codret ) +c + endif +c +c 3.4. ==> transfert en fonction du support +c + if ( codret.eq.0 ) then +c + jaux = advalr - 2 + iaux1 + nrocmp - kaux +c +c 3.4.1. ==> sur les noeuds +c +cgn 1792 format(3i10,g15.7) + if ( typgeo.eq.0 ) then +c + if ( option.eq.1 .and. degre.eq.1 ) then +c + do 3411 , iaux = 1 , nbtrvi +cgn print *,' ',iaux +cgn print 1792,nntrvi(3,iaux),nnoeca(nntrvi(3,iaux)), +cgn > imem( adpcan + nnoeca(nntrvi(3,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1)) +cgn print *,kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1) +cgn print 1792,nntrvi(4,iaux),nnoeca(nntrvi(4,iaux)), +cgn > imem( adpcan + nnoeca(nntrvi(4,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) +cgn print 1792,nntrvi(5,iaux),nnoeca(nntrvi(5,iaux)), +cgn > imem( adpcan + nnoeca(nntrvi(5,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1)) + fotrva(iaux) = unstr * ( + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(3,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1)) ) +cgn print 1789,iaux,fotrva(iaux) + 3411 continue +c + do 3412 , iaux = 1 , nbquvi +cgn if ( ( nnquvi(2,iaux).ge.27713 .and. +cgn > nnquvi(2,iaux).le.27716 ) .or. +cgn > ( nnquvi(2,iaux).ge.27725 .and. +cgn > nnquvi(2,iaux).le.27728 ) .or. +cgn > nnquvi(2,iaux).eq.17127 .or. +cgn > nnquvi(2,iaux).eq.17198) ) then +cgn print *,' ',iaux,' (',nnquvi(2,iaux),')' +cgn print 1792,nnquvi(3,iaux),nnoeca(nnquvi(3,iaux)), +cgn > imem(adpcan+nnoeca(nnquvi(3,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1)) +cgn print 1792,nnquvi(4,iaux),nnoeca(nnquvi(4,iaux)), +cgn > imem(adpcan+nnoeca(nnquvi(4,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1)) +cgn print 1792,nnquvi(5,iaux),nnoeca(nnquvi(5,iaux)), +cgn > imem(adpcan+nnoeca(nnquvi(5,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1)) +cgn print 1792,nnquvi(6,iaux),nnoeca(nnquvi(6,iaux)), +cgn > imem(adpcan+nnoeca(nnquvi(6,iaux))-1), +cgn > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1)) +cgn endif + foquva(iaux) = unsqu * ( + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1)) ) +cgn if ( ( nnquvi(2,iaux).ge.27713 .and. +cgn > nnquvi(2,iaux).le.27716 ) .or. +cgn > ( nnquvi(2,iaux).ge.27725 .and. +cgn > nnquvi(2,iaux).le.27728 ) .or. +cgn > nnquvi(2,iaux).eq.17127 .or. +cgn > nnquvi(2,iaux).eq.17198) ) then +cgn print 1789,iaux,foquva(iaux) +cgn endif +3412 continue +c + elseif ( option.eq.1 .and. degre.eq.2 ) then +c + do 3413 , iaux = 1 , nbtrvi + fotrva(iaux) = unssix * ( + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(4,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(5,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(7,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(8,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nntrvi(9,iaux))-1)) ) + 3413 continue +c + do 3414 , iaux = 1 , nbquvi + foquva(iaux) = unshu * ( + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(3,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(4,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(5,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(6,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(8,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(9,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(10,iaux))-1)) + + > rmem(jaux+kaux*imem(adpcan+nnoeca(nnquvi(11,iaux))-1)) ) + 3414 continue +c + else +c + do 3415 , iaux = 1 , nbenti + fotrva(iaux) = rmem(jaux+kaux*imem(adpcan+nnoeca(iaux)-1)) + 3415 continue +c + endif +c +c 3.4.2. ==> fonction exprimee sur les triangles +c + elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then +c + if ( option.eq.1 ) then +c +c 3.4.2.1. ==> une valeur constante par element +c + if ( ngauss.eq.1 ) then +c + do 3421 , iaux = 1 , nbtrvi +cgn print *,iaux,nntrvi(2,iaux),ntreca(nntrvi(2,iaux)), +cgn > imem(adpcan+ntreca(nntrvi(2,iaux))-1) + fotrva(iaux) = rmem( jaux + + > kaux*imem(adpcan+ntreca(nntrvi(2,iaux))-1) ) +cgn print 1789,iaux,fotrva(iaux) + 3421 continue +c + else +c +c 3.4.2.2. ==> plusieurs valeurs par element (points de Gauss) +c + daux1 = 1.d0/dble(ngauss) +c + iaux2 = jaux - nbtafo + do 3422 , iaux = 1 , nbtrvi + daux2 = 0.d0 + iaux3 = iaux2 + > + kaux*imem(adpcan+ntreca(nntrvi(2,iaux))-1) + do 34221 , iaux1 = 1 , ngauss + daux2 = daux2 + rmem(iaux3+iaux1*nbtafo ) +34221 continue + fotrva(iaux) = daux1*daux2 + 3422 continue +c + endif +c + else +c + write (ulsort,texte(langue,7)) +c + endif +c +c 3.4.3. ==> fonction exprimee sur les quadrangles +c + elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then +c + if ( option.eq.1 ) then +c +c 3.4.3.1. ==> une valeur constante par element +c + if ( ngauss.eq.1 ) then +c + do 3431 , iaux = 1 , nbquvi +cgn write (ulsort,90015) 'foquva(', iaux,')',nnquvi(2,iaux),nqueca(nnquvi(2,iaux)), +cgn > imem(adpcan+nqueca(nnquvi(2,iaux))-1) + foquva(iaux) = rmem( jaux + + > kaux*imem(adpcan+nqueca(nnquvi(2,iaux))-1) ) +cgn print 1789,iaux,foquva(iaux) + 3431 continue +c + else +c +c 3.4.3.2. ==> plusieurs valeurs par element (points de Gauss) +c + daux1 = 1.d0/dble(ngauss) +c + iaux2 = jaux - nbtafo + do 3432 , iaux = 1 , nbquvi + daux2 = 0.d0 + iaux3 = iaux2 + > + kaux*imem(adpcan+nqueca(nnquvi(2,iaux))-1) + do 34321 , iaux1 = 1 , ngauss + daux2 = daux2 + rmem(iaux3+iaux1*nbtafo ) +34321 continue + foquva(iaux) = daux1*daux2 + 3432 continue +c + endif +c + else +c + write (ulsort,texte(langue,7)) +c + endif +c + endif +c + endif +c +c 3.5. ==> menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( obpcan, codret ) +c + endif +c + 30 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infoar.F b/src/tool/Information/infoar.F new file mode 100644 index 00000000..d9e12aeb --- /dev/null +++ b/src/tool/Information/infoar.F @@ -0,0 +1,538 @@ + subroutine infoar ( choix, larete, + > somare, posifa, facare, + > hetare, filare, merare, np2are, + > famare, cfaare, + > nareho, nareca, narecs, + > arehom, + > coonoe, + > hettri, hetqua, + > hettet, hetpyr, hethex, hetpen, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : ARete +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . larete . e . 1 . numero de l'arete a analyser . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . fille ainee de chaque arete . +c . merare . e . nbarto . mere de chaque arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . nareho . e . rearac . numero des aretes dans HOMARD . +c . nareca . e . * . nro des aretes du code de calcul . +c . narecs . e . * . nro des aretes du calcul pour la solution . +c . arehom . e . nbarto . liste etendue des correspondances . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . nbtear . e . 1 . nombre de tetraedres voisins d'aretes . +c . pttear . e .0:nbarto. nombre de tetraedres voisins par aretes . +c . tatear . e . nbtear . tetraedres voisins par aretes . +c . nbhear . e . 1 . nombre d'hexaedres voisins d'aretes . +c . pthear . e .0:nbarto. nombre d'hexaedres voisins par aretes . +c . tahear . e . nbhear . hexaedres voisins par aretes . +c . nbpyar . e . 1 . nombre de pyramides voisines d'aretes . +c . ptpyar . e .0:nbarto. nombre de pyramides voisines par aretes . +c . tapyar . e . nbpyar . pyramides voisines par aretes . +c . nbpear . e . 1 . nombre de pentaedres voisins d'aretes . +c . ptpear . e .0:nbarto. nombre de pentaedres voisins par aretes . +c . tapear . e . nbpear . pentaedres voisins par aretes . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . textar . e . ch40 . commentaires sur l'etat des aretes . +c . texttr . e . ch40 . commentaires sur l'etat des triangles . +c . textte . e . ch40 . commentaires sur l'etat des tetraedres . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOAR' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nomber.h" +#include "envca1.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer larete +c + integer somare(2,nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetare(nbarto), filare(nbarto), merare(nbarto) + integer np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer nareho(rearac), nareca(*), narecs(*) + integer arehom(nbarto) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) +c + integer nbtear, pttear(0:nbarto), tatear(nbtear) + integer nbhear, pthear(0:nbarto), tahear(nbhear) + integer nbpyar, ptpyar(0:nbarto), tapyar(nbpyar) + integer nbpear, ptpear(0:nbarto), tapear(nbpear) +c + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer numcal + integer ndeb, nfin, nbface + integer etat00, etat01, orient + integer sommde, sommfi, milieu + integer laface, soeain + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim) +c + double precision daux, vn(3) +c + character*40 taux40 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fracta.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero de l'arete dans HOMARD +c==== +c + if ( choix.eq.'AR' ) then + iaux = larete + if ( larete.gt.0 .and. larete.le.rearac ) then + larete = nareho(iaux) + else + larete = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero d'arete impossible +c + if ( larete.le.0 .or. larete.gt.nbarto ) then +c + if ( choix.eq.'AR' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) larete + endif + write (ulecr,40031) +c +c 3.2. ==> numero d'arete correct +c + else +c + if ( rearac.ne.0 ) then + numcal = nareca(larete) + if ( numcal.ne.0 ) then + write (ulecr,40020) larete + write (ulecr,40010) numcal + else + write (ulecr,40020) larete + write (ulecr,40041) + endif + else + write (ulecr,40020) larete + write (ulecr,40041) + endif +c +c 3.2.1. ==> maillage initial ? +c + if ( larete.le.nbarma) then + write (ulecr,41000) + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) famare(larete) +c + if ( numcal.ne.0 ) then +c + orient = cfaare(coorfa,famare(larete)) + if ( orient.gt.0 ) then + write (ulecr,42020) + elseif ( orient.lt.0 ) then + write (ulecr,42030) + endif +c + iaux = cfaare(cosfli,famare(larete)) + if ( iaux.gt.0 ) then + write (ulecr,42040) iaux + endif +c + endif +c +c 3.2.3. ==> les extremites +c + sommde = somare(1,larete) + sommfi = somare(2,larete) + write (ulecr,43110) sommde, sommfi + if ( degre.eq.2 ) then + milieu = np2are(larete) + write (ulecr,43120) milieu + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hetare(larete),10) + etat00 = (hetare(larete)-etat01) / 10 +c + taux40 = textar(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textar(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c + if ( etat01.ne.0 ) then + write (ulecr,45019) + iaux = 1 + soeain = filare(larete) + do 3251 , jaux = 0 , iaux + kaux = soeain+jaux + if ( rearac.ne.0 ) then + if ( nareca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, nareca(kaux) + endif + else + write (ulecr,45070) kaux + endif + 3251 continue + endif +c + if ( merare(larete).ne.0 ) then + write (ulecr,45049) merare(larete) + iaux = filare(merare(larete)) + if ( iaux.eq.larete ) then + jaux = larete + 1 + else + jaux = iaux + endif + write (ulecr,45059) jaux + endif +c +c 3.2.6. ==> les faces +c + nbface = 0 +c + ndeb = posifa(larete-1)+1 + nfin = posifa(larete) + if ( nfin.lt.ndeb ) then + write (ulecr,46010) + else + if ( nfin.eq.ndeb ) then + write (ulecr,46020) + else + write (ulecr,46021) + endif + do 3261 , jaux = ndeb , nfin + laface = facare(jaux) + if ( laface.gt.0 ) then + taux40 = texttr(mod(hettri(laface),10)) + else + taux40 = textqu(mod(hetqua(-laface),100)) + endif + write (ulecr,46040) laface, taux40 + nbface = nbface + 1 + iaux = nbface +#include "tbdim2.h" + trav1a(iaux) = laface + 3261 continue + endif +c +c 3.2.7. ==> les voisins volumiques +c + if ( nbteto.ne.0 .or. nbheto.ne.0 .or. + > nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c + iaux = 10 + jaux = 1 + trav1a(1) = larete + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVA', nompro +#endif + call infova ( iaux, jaux, trav1a, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > hettet, hetpyr, hethex, hetpen, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.8. ==> les homologues +c + if ( homolo.ne.0 ) then +c + if ( arehom(larete).ne.0 ) then + if ( arehom(larete).eq.larete ) then + write (ulecr,48011) + else + if ( arehom(larete).ge.0 ) then + iaux = 2 + else + iaux = 1 + endif + write (ulecr,48021) iaux, abs(arehom(larete)) + endif + endif +c + endif +c +c 3.2.9. ==> le centre de gravite +c + do 329 , iaux = 1 , sdim + vn(iaux) = unsde * ( coonoe(sommde,iaux) + + > coonoe(sommfi,iaux) ) + 329 continue +c + if ( sdim.eq.1 ) then + write (ulecr,49001) vn(1) + elseif ( sdim.eq.2 ) then + write (ulecr,49002) (vn(iaux), iaux = 1 , sdim) + else + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) + endif +c +c 3.2.10. ==> la longueur +c + if ( sdim.eq.1 ) then +c + vn(1) = coonoe(sommfi,1) - coonoe(sommde,1) + daux = abs ( vn(1) ) +c + elseif ( sdim.eq.2 ) then +c + vn(1) = coonoe(sommfi,1) - coonoe(sommde,1) + vn(2) = coonoe(sommfi,2) - coonoe(sommde,2) + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) ) +c + else +c + vn(1) = coonoe(sommfi,1) - coonoe(sommde,1) + vn(2) = coonoe(sommfi,2) - coonoe(sommde,2) + vn(3) = coonoe(sommfi,3) - coonoe(sommde,3) + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + endif +c + write (ulecr,49010) daux +c +c 3.2.11. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edseg2 + else + iaux = edseg3 + endif + jaux = narecs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Arete numero :',i10, ' dans HOMARD *') +c +41000 format( + > '* . C''est une arete du maillage initial. ', + > '*') +c +42020 format( + > '* Meme orientation que dans le maillage de calcul *') +42030 format( + > '* Orientation differente du maillage de calcul *') +42040 format( + > '* Elle appartient a la ligne-frontiere numero :',i7, ' *') +c +43110 format( + > '* . Elle va du noeud ',i10, ' au noeud ',i10, ' *') +43120 format( + > '* Le noeud au milieu est ',i10, ' *') +c +46010 format( + > '* . Elle est isolee. *') +46020 format( + > '* . Elle borde la face : *') +46021 format( + > '* . Elle borde des faces : *') +46040 format( + > '* ',i10, ' : ',a40, ' *') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infoen.h b/src/tool/Information/infoen.h new file mode 100644 index 00000000..74c8fd71 --- /dev/null +++ b/src/tool/Information/infoen.h @@ -0,0 +1,182 @@ +40000 format(61('*')) +40001 format( + > '* ',a40, ' *') +40002 format( + > '* . ',a50, ' *') +c +40010 format( + > '* Maille numero :',i10, ' dans le calcul *') +40030 format( + > '* Il n''existe pas. ', + > '*') +40031 format( + > '* Elle n''existe pas. ', + > '*') +40040 format( + > '* Il n''existe pas dans le calcul ', + > '*') +40041 format( + > '* Elle n''existe pas dans le calcul ', + > '*') +c +41010 format( + > '* . Son niveau est :',i7, ' *') +c +41011 format( + > '* . Son niveau est :',i7, '.5 *') +c +42000 format( + > '* . Famille : ',i7, ' *') +c +43310 format( + > '* . Ses faces et leurs codes sont : *') +43320 format( + > '* ',i10, ' : ',i2, + > ', ',a40, ' *') +43030 format( + > '* . Ses aretes sont : *') +43031 format( + > '* ',i10, ', ',a40, ' *') +43040 format( + > '* . Ses sommets sont : *') +43050 format( + > '* . Les noeuds au milieu des aretes sont : *') +43060 format( + > '* . Le noeud central est : ',i10, ' *') +c +44010 format( + > '* . Pour l''iteration en cours : ', + > '*') +44020 format( + > '* . A l''iteration precedente : ', + > '*') +44030 format( + > '* . Coupe par les aretes',a36, '*') +44031 format( + > '* . Coupe par l''arete',a36, ' *') +c +c 12345678901234 +45010 format( + > '* . Il est le pere des ',a14 ,' : *') +45011 format( + > '* . Il est le pere du ',a14 ,' : *') +45012 format( + > '* . Il est le pere de l''',a14 ,' : *') +45013 format( + > '* . Il est le pere de la ',a14 ,' : *') +45019 format( + > '* . Elle est la mere de : *') +c +45040 format( + > '* . Il est le fils du ',a14 ,i10, ' *') +45041 format( + > '* . Il est le fils de l''',a14 ,i10, ' ', + > '*') +45042 format( + > '* . Elle est la fille de la ',a14 ,i10, + > ' *') +45043 format( + > '* . Elle est la fille de l''',a14 ,i10, ' ', + > '*') +45044 format( + > '* . Elle est la fille du ',a14 ,i10, ' *') +45049 format( + > '* . Elle est la fille de ',i10, ' *') +c +45050 format( + > '* . Il est le frere des ',a14 ,' : *') +45051 format( + > '* . Il est le frere du ',a14 ,' : *') +45052 format( + > '* . Il est le frere de l''',a14 ,' : *') +45053 format( + > '* . Il est le frere de la ',a14 ,' : *') +45054 format( + > '* . Elle est la soeur des ',a14 ,' : *') +45059 format( + > '* . Elle est la soeur de ',i10, ' *') +45070 format( + > '* ',i10, ' ( inconnu dans le calcul ) *') +45080 format( + > '* ',i10, ' ( dans le calcul : ',i10, ' ) *') +#ifdef _DEBUG_HOMARD_ +45092 format( + > '* . Il est le fils adoptif de ',i10, ' *') +#endif +c +46000 format( + > '* ',i10, ' : ',a40, ' *') +46030 format( + > '* ',i10, ' : par les aretes',a27, ' *') +46031 format( + > '* ',i10, ' : Coupe par l''arete',a3, + > ' *') +c +48010 format( + > '* . Il est homologue de lui-meme : axe de symetrie. *') +48011 format( + > '* . Elle est homologue d''elle-meme : axe de symetrie. ', + > '*') +48020 format( + > '* . Il est sur la face homologue ',i7, ' *') +48021 format( + > '* . Elle est sur la face homologue ',i7, ' *', + >/,'* . Elle est homologue de l''arete :',i10, ' ', + > '*') +48022 format( + > '* Il est homologue du noeud : ',i10, ' *') +48023 format( + > '* Il est homologue du triangle :',i10, ' *') +48024 format( + > '* Il est homologue du quadrangle :',i10, ' *') +c +49001 format( + > '* . Centre : ', g15.5 ,' *') +49002 format( + > '* . Centre : ', g15.5 , g15.5 ,' *') +49003 format( + > '* . Centre : ', g15.5 , g15.5 , g15.5 ,' *') +49004 format( + > '* . Normale : ', g15.5 , g15.5 , g15.5 ,' *') +c +49010 format( + > '* . Longueur : ', g15.5 ,' *') +49020 format( + > '* . Surface : ', g15.5 ,' *') +49030 format( + > '* . Volume : ', g15.5 ,' *') +49040 format( + > '* . Qualite : ', f15.5 ,' *') +49041 format( + > '* . Qualite selon le Jacobien normalise : ', f15.5 ,' *') +49143 format( + > '* . Qualite selon la sphere inscrite : ', f15.5 ,' *') +49146 format( + > '* . Qualite par les tetraedres internes : ', f15.5 ,' *') +49050 format( + > '* . Diametre : ', g15.5 ,' *') +49060 format( + > '* . Torsion : ', f15.5 ,' *') +c +50003 format( + > '* ',i10, ', ',i10, ' et ',i10, ' *') +50004 format( + > '* ',i10, ', ',i10, ', ',i10, ' et ',i10, ' *') +50005 format( + > '* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* et ',i10, ' *') +50006 format( + > '* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* ',i10, ' et ',i10, ' *') +50008 format( + > '* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* ',i10, ', ',i10, ', ',i10, ' et ',i10, ' *') +50009 format( + > '* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* et ',i10, ' *') +50012 format( + > '* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* ',i10, ', ',i10, ', ',i10, ' , ',i10, ' *' + >/,'* ',i10, ', ',i10, ', ',i10, ' et ',i10, ' *') +c diff --git a/src/tool/Information/infofo.F b/src/tool/Information/infofo.F new file mode 100644 index 00000000..adeff900 --- /dev/null +++ b/src/tool/Information/infofo.F @@ -0,0 +1,490 @@ + subroutine infofo ( nbfonc, nofonc, + > typg, numcal, + > ulecr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : FOnction +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions . +c . nofonc . e . nbfonc . nom des objets qui contiennent la . +c . . . . description de chaque fonction . +c . typg . e . 1 . type de l'entite a examiner . +c . numcal . e . 1 . numero du calcul de l'entite a examiner . +c . ulecr . e . 1 . unite logique pour l'ecriture . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOFO' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +#include "gmreel.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer typg, numcal +c + integer ulecr + integer ulsort, langue, codret +c + character*8 nofonc(*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer adaux1, adaux2, adaux3 + integer nrfonc, nrtafo + integer nbpg + integer advale, advalr, adobch, adprpg, adtyas + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint +c + integer nbcomp, nbtvch, typcha + integer nrocmp, nrotch + integer nument + integer adnocp, adcaen, adcare, adcaca + integer adlipr +c + character*8 nnfonc + character*8 saux08 + character*16 nomcmp + character*16 saux16 + character*18 unicmp + character*64 nomcha, saux64, noprof +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "infoen.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Type de l''''entite a examiner :'',i5)' + texte(1,5) = '(''Numero de l''''entite a examiner :'',i5)' + texte(1,6) = '(/,''Fonction numero '',i5)' + texte(1,7) = '(''. Nom du profil : '',a)' + texte(1,8) = '(''Incoherence dans la longueur du profil.'')' +c + texte(2,4) = '(''Type of entity :'',i5)' + texte(2,5) = '(''Number of entity :'',i5)' + texte(2,6) = '(/,''Functions # '',i5)' + texte(2,7) = '(''. Profil name : '',a)' + texte(2,8) = '(''Profile lengths are not coherent.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) typg + write (ulsort,texte(langue,5)) numcal +#endif +c + codret = 0 +c +c Pour eviter un message de ftnchek : + nomcha = blan64 +c +c==== +c 2. on parcourt toutes les fonctions +c==== +c + do 20 , nrfonc = 1 , nbfonc +c +c 2.1. ==> caracterisation de la fonction courante +c + if ( codret.eq.0 ) then +c + nnfonc = nofonc(nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nrfonc +cgn call gmprsx (nompro, nnfonc ) +cgn call gmprsx (nompro, nnfonc//'.ValeursR' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nnfonc, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbenmx', nbenmx + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo +#endif +c +c 2.2. ==> En l'absence de profil, le numero d'entite a rechercher est +c le numero dans le calcul qui est fourni en argument +c Avec un profil, on cherche si ce numero est present dans la +c liste. Si oui, on memorise sa position avec numcal ; si non, +c on mentionne qu'aucune valeur n'est disponible. +c + if ( codret.eq.0 ) then +c + if ( nbvapr.le.0 ) then +c + nument = numcal +c + else +c + saux08 = smem(adprpg) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( saux08, + > iaux, noprof, adlipr, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) noprof + call gmprot (nompro,saux08//'.ListEnti',1,50) +#endif + if ( iaux.ne.nbvapr ) then + write (ulsort,texte(langue,8)) + write (ulsort,90002) 'Pour la fonction', nbvapr + write (ulsort,90002) 'Pour le profil ', iaux + codret = 3 + endif +c + endif +c + if ( codret.eq.0 ) then +c + nument = 0 + do 220 , iaux = 0 , nbvapr-1 + if ( imem(adlipr+iaux).eq.numcal ) then + nument = iaux+1 + goto 221 + endif + 220 continue + 221 continue +c + endif +c + endif +c + endif +c +c 2.3. ==> les valeurs +c + if ( codret.eq.0 ) then +c + if ( typgeo.eq.typg ) then +c +cgn call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo ) + if ( ngauss.eq.ednopg ) then + nbpg = 1 + else + nbpg = ngauss + endif +c + do 231 , nrtafo = 1 , nbtafo +c +c 2.3.1. ==> le nom du champ et de la composante +c 2.3.1.1. ==> recuperation +c + if ( codret.eq.0 ) then +c + saux08 = smem(adobch+nrtafo-1) +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,saux08) +cgn call gmprsx (nompro,saux08//'.Nom_Comp') +cgn call gmprsx (nompro,saux08//'.Cham_Ent') +cgn call gmprsx (nompro,saux08//'.Cham_Ree') + call gmprsx (nompro,saux08//'.Cham_Car') + call gmprsx (nompro,'%%%%%%19') + call gmprsx (nompro,'%%%%%%19.ValeursR') +cgn call gmprsx (nompro,'%%%%%%19.ValeursE') +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( saux08, + > saux64, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c +cgn write(ulsort,*) 'nbcomp = ',nbcomp , ', nbtvch = ',nbtvch + if ( codret.eq.0 ) then +cgn write(ulsort,*) 'nrtafo = ',nrtafo , ', saux64 = ',saux64 +c +c 2.3.1.2. ==> le nom du champ +c + if ( nrtafo.eq.1 .or. saux64.ne.nomcha ) then + nomcha = saux64 + write (ulecr,30001) nomcha(1:48) + call utlgut ( iaux, nomcha, ulsort, langue, codret ) + if ( iaux.gt.48 ) then + write (ulecr,30002) nomcha(49:64) + endif + nrocmp = nbcomp + nrotch = 0 + endif +c +c 2.3.1.3. ==> le pas de temps +c + if ( nrocmp.eq.nbcomp ) then + nrocmp = 0 + nrotch = nrotch + 1 + if ( imem(adcaen+nbinec*(nrotch-1)+1).eq.ednodt .and. + > imem(adcaen+nbinec*(nrotch-1)+2).eq.ednonr ) then + write(ulecr,30004) + else + write(ulecr,30003) imem(adcaen+nbinec*(nrotch-1)+1), + > imem(adcaen+nbinec*(nrotch-1)+2) + saux16 = smem(adnocp+8+4*nbcomp)// + > smem(adnocp+9+4*nbcomp) + if ( saux16(1:8).eq.'INCONNUE' ) then + saux16 = blan16 + endif + write(ulecr,30005) rmem(adcare+nrotch-1), saux16 + endif + endif +c +c 2.3.1.4. ==> le nom et l'unite de la composante +c + nrocmp = nrocmp + 1 + nomcmp = smem(adnocp+6+2*nrocmp)//smem(adnocp+7+2*nrocmp) + saux16 = smem(adnocp+6+2*nbcomp+2*nrocmp)// + > smem(adnocp+7+2*nbcomp+2*nrocmp) +c + if ( saux16.eq.blan16 ) then + unicmp = blan16//' ' + else + unicmp = '('//saux16//')' + endif +c + endif +c +c 2.3.2. ==> la/les valeurs +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nument', nument +#endif +c + if ( nument.eq.0 ) then +c + if ( nrocmp.eq.nbcomp ) then + write (ulecr,30300) + endif +c + else +c + if ( typcha.eq.edfl64 ) then + adaux1 = advalr + else + adaux1 = advale + endif + adaux1 = adaux1 + nbtafo*nbpg*(nument-1)-1 +c + if ( nomcmp.ne.blan16 ) then + write (ulecr,30006) nomcmp, unicmp + else + if ( nbcomp.gt.1 ) then + write (ulecr,30016) nrocmp + endif + endif + adaux2 = adaux1 + nrtafo +c + if ( nbpg.eq.1 ) then +c + if ( typcha.eq.edfl64 ) then + write (ulecr,30105) rmem(adaux2) + else + write (ulecr,30205) imem(adaux2) + endif +c + else +cgn call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo*nbpg ) + kaux = nbpg - mod(nbpg,2) + do 232 , jaux = 1 , kaux, 2 + adaux3 = adaux2 + nbtafo*jaux + if ( carsup.eq.1 ) then + if ( typcha.eq.edfl64 ) then + write (ulecr,30106) jaux, rmem(adaux3-nbtafo), + > jaux+1, rmem(adaux3) + else + write (ulecr,30206) jaux, imem(adaux3-nbtafo), + > jaux+1, imem(adaux3) + endif + else + if ( typcha.eq.edfl64 ) then + write (ulecr,30108) jaux, rmem(adaux3-nbtafo), + > jaux+1, rmem(adaux3) + else + write (ulecr,30208) jaux, imem(adaux3-nbtafo), + > jaux+1, imem(adaux3) + endif + endif + 232 continue +c + if ( mod(nbpg,2).ne.0 ) then + adaux3 = adaux2 + nbtafo*(nbpg-1) + if ( typcha.eq.edfl64 ) then + if ( carsup.eq.1 ) then + write (ulecr,30107) nbpg, rmem(adaux3) + else + write (ulecr,30109) nbpg, rmem(adaux3) + endif + else + if ( carsup.eq.1 ) then + write (ulecr,30207) nbpg, imem(adaux3) + else + write (ulecr,30209) nbpg, imem(adaux3) + endif + endif + endif +c + endif +c + endif +c + 231 continue +c + endif +c + endif +c + 20 continue +c +c=== +c 3. formats +c=== +c +30001 format( + > '* Champ : ',a48, ' *') +30002 format( + > '* ',a16, ' *') +30003 format( + > '* Pas de temps :',i10, ', Numero d''ordre :',i10, ' ', + > '*') +30004 format( + > '* Sans pas de temps, ni numero d''ordre ', + > '*') +30005 format( + > '* Instant :', d14.7, ' ',a16, ' *') +30006 format( + > '* . Composante : ',a16, ' ',a18, ' *') +30016 format( + > '* . Composante numero',i3, + > ' : *') +30105 format( + > '* ', d14.7, 42x, '*') +c 12345678901234123456789012345678901234567890123456789012 +30106 format( + > '* ',2('no ',i2,' : ', d15.8,4x), ' *') +30107 format( + > '* ','no ',i2,' : ', d15.8,33x,'*') +30108 format( + > '* ',2('pg ',i2,' : ', d15.8,4x), ' *') +30109 format( + > '* ','pg ',i2,' : ', d15.8,33x,'*') +30205 format( + > '* ', i14, 42x, '*') +30206 format( + > '* ',2('no ',i2,' : ', i15,4x), ' *') +30207 format( + > '* ','no ',i2,' : ', i15,33x,'*') +30208 format( + > '* ',2('pg ',i2,' : ', i15,4x), ' *') +30209 format( + > '* ','pg ',i2,' : ', i15,33x,'*') +30300 format( + > '* Aucune valeur n''est presente. ', + > '*') +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infohe.F b/src/tool/Information/infohe.F new file mode 100644 index 00000000..2036b34b --- /dev/null +++ b/src/tool/Information/infohe.F @@ -0,0 +1,647 @@ + subroutine infohe ( choix, lehexa, + > quahex, coquhe, arehex, + > hethex, filhex, perhex, fhpyte, + > famhex, + > nhexho, nhexca, nhexcs, + > hetare, somare, np2are, coonoe, + > hetqua, arequa, nivqua, + > hettet, ntetca, + > hetpyr, npyrca, + > hetpen, + > voltri, pypetr, + > volqua, pypequ, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : HExaedre +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lehexa . e . 1 . numero du hexaedre a analyser . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . . . . si perhex(i) > 0 : numero de l'hexaedre . +c . . . . si perhex(i) < 0 : -numero dans pthepe . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . famhex . e . nbheto . famille des hexaedres . +c . nhexho . e . reheac . numero des hexaedres dans HOMARD . +c . nhexca . e . * . numero des hexaedres dans le calcul . +c . nhexcs . e . * . nro des hexa. du calcul pour la solution . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . ntetca . e . * . numero des tetraedres dans le calcul . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . npyrca . e . * . numero des pyramides dans le calcul . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOHE' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "hexcf0.h" +#include "hexcf1.h" +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lehexa +c + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer filhex(nbheto), perhex(nbheto) + integer fhpyte(2,nbheco) + integer famhex(nbheto) + integer nhexho(reheac), nhexca(*), nhexcs(*) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer hettet(nbteto), ntetca(*) + integer hetpyr(nbpyto), npyrca(*) + integer hetpen(nbpeto) + integer volqua(2,nbquto), pypequ(2,*) + integer voltri(2,nbtrto), pypetr(2,*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbfa, nbar, nbso + parameter ( nbfa = 6, nbar = 12, nbso = 8 ) +c + integer iaux, jaux, kaux + integer numcal + integer etat00, etat01, bindec + integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer laface, lecode + integer nbface + integer larete, lepere + integer nbfihe, filshe + integer nbfipy, filspy + integer nbfite, filste + integer listar(nbar), listso(nbso), volint(4,0:21) + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision qualit, qualij, volume, diamet, torsio + double precision vn(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fractf.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero de l'hexaedre dans HOMARD +c==== +c + if ( choix.eq.'HE' ) then + iaux = lehexa + if ( lehexa.gt.0 .and. lehexa.le.reheac ) then + lehexa = nhexho(iaux) + else + lehexa = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero d'hexaedre impossible +c + if ( lehexa.le.0 .or. lehexa.gt.nbheto ) then +c + if ( choix.eq.'HE' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) lehexa + endif + write (ulecr,40030) +c +c 3.2. ==> numero d'hexaedre correct +c + else +c + if ( reheac.gt.0 ) then + numcal = nhexca(lehexa) + else + numcal = 0 + endif + if ( numcal.ne.0 ) then + write (ulecr,40020) lehexa + write (ulecr,40010) numcal + else + write (ulecr,40020) lehexa + write (ulecr,40040) + endif +c +c 3.2.1. ==> Niveau +c + if ( lehexa.le.nbhema ) then + write (ulecr,41000) + else +c + if ( lehexa.le.nbhecf ) then + lafac1 = quahex(lehexa,1) + lafac2 = quahex(lehexa,2) + lafac3 = quahex(lehexa,3) + lafac4 = quahex(lehexa,4) + lafac5 = quahex(lehexa,5) + lafac6 = quahex(lehexa,6) + niveau = max(nivqua(lafac1),nivqua(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5),nivqua(lafac6)) + else + lepere = perhex(lehexa) + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + niveau = max(nivqua(lafac1),nivqua(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5),nivqua(lafac6)) + 1 + endif + if ( lehexa.le.nbhepe ) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif +c + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) famhex(lehexa) +c +c 3.2.3. ==> les faces, les aretes et les noeuds +c 3.2.3.1. ==> les faces +c + if ( lehexa.le.nbhecf ) then +c + write (ulecr,43310) + do 3231 , iaux = 1 , nbfa + laface = quahex(lehexa,iaux) + lecode = coquhe(lehexa,iaux) + taux40 = textqu(mod(hetqua(laface),100)) + write (ulecr,43320) laface, lecode, taux40 + 3231 continue +c + endif +c +c 3.2.3.2. ==> les aretes et les sommets +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + write (ulecr,43030) + do 3232 , iaux = 1 , nbar + larete = listar(iaux) + taux40 = textar(mod(hetare(larete),10)) + write (ulecr,43031) larete, taux40 + 3232 continue +c + write (ulecr,43040) + write (ulecr,50008) (listso(iaux),iaux=1,nbso) +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then +c + write (ulecr,43050) + write (ulecr,50012) (np2are(listar(iaux)),iaux=1,nbar) +c + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hethex(lehexa),1000) + etat00 = (hethex(lehexa)-etat01) / 1000 + bindec = chbiet(etat01) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etat01, ' ==> code binaire', bindec +#endif +c + write (ulecr,44010) + if ( etat01.le.10 ) then + taux40 = texthe(etat01) + write (ulecr,40001) taux40 + else + if ( etat01.le.22 ) then + write (ulecr,44031) charde(bindec) + elseif ( ( etat01.ge.285 ) .and. ( etat01.le.290 ) ) then + taux40 = texthe(etat01-244) + write (ulecr,40001) taux40 + else + write (ulecr,44030) charde(bindec) + endif + endif + if ( nbiter.ge.1 ) then + taux40 = texthe(etat00) + write (ulecr,44020) + jaux = chbiet(etat00) + if ( etat00.le.10 ) then + write (ulecr,40001) taux40 + else + if ( etat00.le.22 ) then + write (ulecr,44031) charde(jaux) + elseif ( ( etat00.ge.285 ) .and. ( etat00.le.290 ) ) then + taux40 = texthe(etat00-244) + write (ulecr,40001) taux40 + else + write (ulecr,44030) charde(jaux) + endif + endif + endif +c +c 3.2.5. ==> la parente +c + call utfihe ( lehexa, + > hethex, filhex, fhpyte, + > nbfite, filste, + > nbfihe, filshe, + > nbfipy, filspy ) +c + if ( etat01.ne.0 ) then +c +c 3.2.5.1. ==> les fils +c 3.2.5.1.1. ==> fils pour le decoupage de conformite +c + if ( etat01.ge.11 ) then +c + if ( nbfipy.ge.1 ) then + write (ulecr,45010) mess14(langst,3,5) + do 3251 , jaux = 0 , nbfipy-1 + kaux = filspy+jaux + write (ulecr,45080) kaux, npyrca(kaux) + 3251 continue + endif + if ( nbfite.ge.1 ) then + write (ulecr,45010) mess14(langst,3,3) + do 3252 , jaux = 0 , nbfite-1 + kaux = filste+jaux + write (ulecr,45080) kaux, ntetca(kaux) + 3252 continue + endif + if ( nbfihe.ge.1 ) then + write (ulecr,45010) mess14(langst,3,6) + do 3253 , jaux = 0 , nbfihe-1 + kaux = filshe+jaux + write (ulecr,45080) kaux, nhexca(kaux) + 3253 continue + endif +c +c 3.2.5.1.2. ==> fils pour le decoupage standard +c + else +c + write (ulecr,45010) mess14(langst,3,6) + do 3254 , jaux = 0 , nbfihe-1 + kaux = filshe+jaux + if ( reheac.eq.0 .or. nhexca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, nhexca(kaux) + endif + 3254 continue + endif +c + endif +c +c 3.2.5.2 ==> pere +c + if ( perhex(lehexa).ne.0 ) then +c + write (ulecr,45041) mess14(langst,1,6), perhex(lehexa) + call utfihe ( perhex(lehexa), + > hethex, filhex, fhpyte, + > nbfite, filste, + > nbfihe, filshe, + > nbfipy, filspy ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfihe', nbfihe + write (ulsort,90002) 'nbfipy', nbfipy + write (ulsort,90002) 'nbfite', nbfite +#endif + write (ulecr,45050) mess14(langst,3,6) + if ( nbfipy.ge.1 ) then + write (ulecr,45010) mess14(langst,3,5) + do 32521 , jaux = 0 , nbfipy-1 + kaux = filspy+jaux + write (ulecr,45080) kaux, npyrca(kaux) +32521 continue + endif + if ( nbfite.ge.1 ) then + write (ulecr,45010) mess14(langst,3,3) + do 32522 , jaux = 0 , nbfite-1 + kaux = filste+jaux + write (ulecr,45080) kaux, ntetca(kaux) +32522 continue + endif + if ( nbfihe.ge.1 ) then + do 32523 , jaux = 0 , nbfihe-1 + kaux = filshe+jaux + if ( kaux.ne.lehexa ) then + if ( reheac.eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, nhexca(kaux) + endif + endif +32523 continue + endif +c + endif +c +c 3.2.6. ==> les volumes voisins +c 3.2.6.1. ==> on commence par dresser la liste de tous les hexaedres +c qui bordent les faces de l'hexaedre courant mais qui ne +c peuvent pas etre consideres comme des volumes voisins : +c lui-meme et ses fils dans les cas de conformite. +c il suffit d'eliminer les pyramides dont la base est une +c des faces quadrangulaires de l'hexaedre. Dans les autres +c cas, le volume ne peut pas etre voisin de l'hexaedre. +c + volint(1,0) = 0 + iaux = 1 + volint(2,iaux) = lehexa + volint(2,0) = iaux + iaux = 0 + if ( etat01.ge.11 ) then + do 3261 , jaux = 1 , nbfipy + iaux = iaux + 1 + volint(3,iaux) = fhpyte(1,-filhex(lehexa)) + jaux - 1 + 3261 continue + endif + volint(3,0) = iaux + volint(4,0) = 0 +c +c 3.2.6.2. ==> liste des faces a examiner +c + nbface = 0 + if ( lehexa.le.nbhecf ) then +c + do 3262 , iaux = 1 , 6 + if ( volqua(2,quahex(lehexa,iaux)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = -quahex(lehexa,iaux) + endif + 3262 continue +c + endif +c +c 3.2.6.3. ==> impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + iaux = 40 + kaux = ulecr + call infovo ( iaux, 1, nbface, volint, + > voltri, pypetr, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c +c 3.2.7. ==> le centre de gravite +c + do 327 , iaux = 1 , sdim + vn(iaux) = unshu * ( coonoe(listso(1),iaux) + + > coonoe(listso(2),iaux) + + > coonoe(listso(3),iaux) + + > coonoe(listso(4),iaux) + + > coonoe(listso(5),iaux) + + > coonoe(listso(6),iaux) + + > coonoe(listso(7),iaux) + + > coonoe(listso(8),iaux) ) + 327 continue +c + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) +c +c 3.2.8. ==> volume, qualite, diametre et torsion +c + call utqhex ( lehexa, qualit, qualij, volume, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c + write (ulecr,49030) volume +c + write (ulecr,49146) qualit +c + write (ulecr,49041) qualij +c + call utdhex ( lehexa, diamet, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c + write (ulecr,49050) diamet +c + call utthex ( lehexa, torsio, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c + write (ulecr,49060) torsio +c +c 3.2.9. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edhex8 + else + iaux = edhe20 + endif + jaux = nhexcs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Hexaedre numero :',i10, ' dans HOMARD *') +c +41000 format( + > '* . C''est un hexaedre du maillage initial. ', + > '*') +c +46110 format( + > '* . Il a un hexaedre voisin : *') +46120 format( + > '* . Il est le voisin de ',i10, ' hexaedres : *') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infomp.F b/src/tool/Information/infomp.F new file mode 100644 index 00000000..ea93fd9d --- /dev/null +++ b/src/tool/Information/infomp.F @@ -0,0 +1,266 @@ + subroutine infomp ( choix, lamapo, + > noempo, hetmpo, + > fammpo, + > nmpoho, nmpoca, nmpocs, + > coonoe, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : Maille-Point +c ---- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lamapo . e . 1 . numero de la maille-point a analyser . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . hetmpo . e . nbmpto . historique de l'etat des maille-points . +c . fammpo . e . nbmpto . famille des mailles-points . +c . nmpoho . e . rearac . numero des maille-points dans HOMARD . +c . nmpoca . e . rearto . numero des maille-points du code de calcul . +c . nmpocs . e . rearto . numero des m-pts du calcul pour la solution. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOMP' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nomber.h" +#include "envca1.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lamapo +c + integer noempo(nbmpto), hetmpo(nbmpto) + integer fammpo(nbmpto) + integer nmpoho(rempac), nmpoca(*), nmpocs(*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer numcal + integer etat00, etat01 + integer somsup + integer uldeb, ulfin, ulpas, ulecr +c + character*40 taux40 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero de la maille-point dans HOMARD +c==== +c + if ( choix.eq.'MP' ) then + iaux = lamapo + if ( lamapo.gt.0 .and. lamapo.le.rearac ) then + lamapo = nmpoho(iaux) + else + lamapo = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de maille-point impossible +c + if ( lamapo.le.0 .or. lamapo.gt.nbmpto ) then +c + if ( choix.eq.'MP' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) lamapo + endif + write (ulecr,40031) +c +c 3.2. ==> numero de maille-point correct +c + else +c + numcal = nmpoca(lamapo) + write (ulecr,40020) lamapo + write (ulecr,40010) numcal +c +c 3.2.1. ==> caracteristiques +c + write (ulecr,42000) fammpo(lamapo) +c +c 3.2.2. ==> etat +c + etat01 = mod(hetmpo(lamapo),10) + etat00 = (hetmpo(lamapo)-etat01) / 10 +c + taux40 = textmp(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textmp(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.3. ==> le noeud support +c + somsup = noempo(lamapo) + write (ulecr,43000) somsup +c +c 3.2.4. ==> la position +c + if ( sdim.eq.1 ) then + write (ulecr,44001) coonoe(somsup,1) + elseif ( sdim.eq.2 ) then + write (ulecr,44002) (coonoe(somsup,iaux), iaux = 1 , sdim) + else + write (ulecr,44003) (coonoe(somsup,iaux), iaux = 1 , sdim) + endif +c +c 3.2.5. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + iaux = edpoi1 + jaux = nmpocs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Maille-point numero :',i10, ' dans HOMARD *') +c +43000 format( + > '* Le noeud support est ',i10, ' *') +c +44001 format( + > '* . Position : ', g15.5 ,' *') +44002 format( + > '* . Position : ', g15.5 , g15.5 ,' *') +44003 format( + > '* . Position : ', g14.4 , g14.4 , g14.4 ,' *') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infono.F b/src/tool/Information/infono.F new file mode 100644 index 00000000..9d3e55b0 --- /dev/null +++ b/src/tool/Information/infono.F @@ -0,0 +1,618 @@ + subroutine infono ( choix, lenoeu, + > coonoe, hetnoe, arenoe, famnoe, + > nnoeho, nnoeca, + > noehom, + > noempo, + > somare, hetare, posifa, facare, + > hettri, hetqua, + > hettet, hetpyr, hethex, hetpen, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : NOeud +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lenoeu . e . 1 . numero du noeud a analyser . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . . . . 0 pour les noeuds isoles . +c . . . . 1 pour les sommets . +c . . . . 2 pour les noeuds milieux . +c . . . . 3 pour les noeuds support de maille-point . +c . . . . 4 pour les noeuds internes aux mailles . +c . . . . 7 pour les noeuds n'appartenant qu'a des . +c . . . . elements ignores . +c . arenoe . e . nbnoto . arete liee a un nouveau noeud . +c . famnoe . e . nbnoto . famille des noeuds . +c . nnoeho . e . renoac . numero des noeuds dans HOMARD . +c . nnoeca . e . * . numero des noeuds du code de calcul . +c . nnoecs . e . * . nro des noeuds du calcul pour la solution . +c . noehom . e . nbnoto . liste etendue des correspondances . +c . noempo . e . nbmpto . numeros des noeuds associes aux mailles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . nbtear . e . 1 . nombre de tetraedres voisins d'aretes . +c . pttear . e .0:nbarto. nombre de tetraedres voisins par aretes . +c . tatear . e . nbtear . tetraedres voisins par aretes . +c . nbhear . e . 1 . nombre d'hexaedres voisins d'aretes . +c . pthear . e .0:nbarto. nombre d'hexaedres voisins par aretes . +c . tahear . e . nbhear . hexaedres voisins par aretes . +c . nbpyar . e . 1 . nombre de pyramides voisines d'aretes . +c . ptpyar . e .0:nbarto. nombre de pyramides voisines par aretes . +c . tapyar . e . nbpyar . pyramides voisines par aretes . +c . nbpear . e . 1 . nombre de pentaedres voisins d'aretes . +c . ptpear . e .0:nbarto. nombre de pentaedres voisins par aretes . +c . tapear . e . nbpear . pentaedres voisins par aretes . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFONO' ) +c +#include "nblang.h" +#include "tbdim0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envca1.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lenoeu +c + integer hetnoe(nbnoto), arenoe(nbnoto), famnoe(nbnoto) + integer nnoeho(renoac), nnoeca(renoto) + integer noehom(nbnoto) + integer noempo(nbmpto) + integer somare(2,nbarto), hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) +c + integer nbtear, pttear(0:nbarto), tatear(nbtear) + integer nbhear, pthear(0:nbarto), tahear(nbhear) + integer nbpyar, ptpyar(0:nbarto), tapyar(nbpyar) + integer nbpear, ptpear(0:nbarto), tapear(nbpear) +c + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer iaux1 + integer kdeb, kfin + integer numcal + integer nbares, nbfacm, nbfam1, nbface + integer etat00, etat01 + integer larete, laretm, sommde, sommfi + integer laface + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + logical logaux +c + character*20 taux20 + character*40 taux40 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 1. initialisation +c==== +c + if ( choix.eq.'NO' ) then + iaux = lenoeu + if ( lenoeu.gt.0 .and. lenoeu.le.renoto ) then + lenoeu = nnoeho(iaux) + else + lenoeu = 0 + endif + endif +c +c==== +c 2. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 2.1. ==> numero de noeud impossible +c + if ( lenoeu.le.0 .or. lenoeu.gt.nbnoto ) then +c + if ( choix.eq.'NO' ) then + write (ulecr,40012) iaux + else + write (ulecr,40022) lenoeu + endif + write (ulecr,40030) +c +c 2.2. ==> numero de noeud correct +c + else +c + numcal = nnoeca(lenoeu) + write (ulecr,40022) lenoeu + write (ulecr,40012) numcal +c +c 2.2.1. ==> maillage initial ? +c Dans le maillage initial on a dans cet ordre (cf. vcmnoe) : +c . les eventuels isoles +c . les supports de maille-points +c . les p1 +c . les p2 +c +c En degre 1 : son numero est inferieur au nombre de noeuds +c du macro-maillage +c En degre 2 : +c Si le noeud etait sommet dans le macro-maillage, son +c numero est inferieur au nombre de noeuds du +c macro-maillage moins l enombre d' +c + logaux = .false. + if ( degre.eq.1 ) then + if ( lenoeu.le.nbnoma ) then + logaux = .true. + endif + else + if ( lenoeu.le.nbnoma ) then + logaux = .true. + endif + endif + if ( logaux ) then + write (ulecr,41000) + endif +c +c 2.2.2. ==> famille +c + write (ulecr,42000) famnoe(lenoeu) +c +c 2.2.3. ==> coordonnees +c + write (ulecr,43000) coonoe(lenoeu,1) + if ( sdim.ge.2 ) then + write (ulecr,43010) 'y', coonoe(lenoeu,2) + if ( sdim.eq.3 ) then + write (ulecr,43010) 'z', coonoe(lenoeu,3) + endif + endif +c +c 2.2.4. ==> etat : isole, element ignore, maille-point, +c sommet ou milieu d'arete +c + etat01 = mod(hetnoe(lenoeu),10) + etat00 = (hetnoe(lenoeu)-etat01) / 10 +c + taux40 = textno(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textno(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 2.2.5. ==> mailles-points +c remarque : si le noeud est un support pour une maille-point +c on n'a pas d'autre solution pour le savoir que d'explorer +c la liste de ces mailles, car le tableau reciproque n'existe +c pas. Mais comme generalement le nombre de telles mailles +c est tres faible, voire nul, ce n'est pas une operation +c couteuse. +c + if ( nbmpto.gt.0 ) then +c + do 251 , iaux = 1 , nbmpto + if ( noempo(iaux).eq.lenoeu ) then + write (ulecr,45000) iaux + endif + 251 continue +c + endif +c +c 2.2.6. ==> aretes +c 2.2.6.1 ==> dont le noeud est milieu +c + if ( ( etat01.eq.1 .and. lenoeu.gt.nbnoma ) .or. + > etat01.eq.2 ) then + laretm = arenoe(lenoeu) + if ( laretm.gt.0 ) then + sommde = somare(1,laretm) + sommfi = somare(2,laretm) + taux20 = textar(mod(hetare(laretm),10))(1:20) + write (ulecr,46010) + write (ulecr,46021) laretm, sommde, sommfi, taux20 + endif + else + laretm = 0 + endif +c +c 2.2.6.2 ==> dont le noeud est extremite +c + iaux = 0 + jaux = 0 +c on range dans trav2a les aretes qui demarrent sur ce noeud +c on range dans trav1a les aretes qui finissent a ce noeud + do 2261 , kaux = 1 , nbarto + if ( somare(1,kaux).eq.lenoeu ) then + jaux = jaux + 1 +#include "tbdim3.h" + trav2a(jaux) = kaux + elseif ( somare(2,kaux).eq.lenoeu ) then + iaux = iaux + 1 +#include "tbdim2.h" + trav1a(iaux) = kaux + endif + 2261 continue +c +c on imprime d'abord les aretes qui finissent a ce noeud (trav1a) +c puis celles qui finissent a ce noeud (trav2a) que l'on inclut +c dans trav1a + if ( iaux+jaux.ne.0 ) then + write (ulecr,46020) + do 2262 , kaux = 1 , iaux + larete = trav1a(kaux) + sommde = somare(1,larete) + taux20 = textar(mod(hetare(larete),10))(1:20) + write (ulecr,46021) larete, sommde, lenoeu, taux20 + 2262 continue + do 2263 , kaux = 1 , jaux + larete = trav2a(kaux) + sommfi = somare(2,larete) + taux20 = textar(mod(hetare(larete),10))(1:20) + write (ulecr,46021) larete, lenoeu, sommfi, taux20 + iaux = iaux + 1 +#include "tbdim2.h" + trav1a(iaux) = larete + 2263 continue + endif +c +c nbares est le nombre total d'aretes ayant ce noeud pour sommet + nbares = iaux +c +c 2.2.7. ==> les faces +c 2.2.7.1. ==> dont le noeud est le milieu d'un cote +c + iaux = 0 +c + if ( laretm.ne.0 ) then +c + kdeb = posifa(laretm-1)+1 + kfin = posifa(laretm) + if ( kfin.ge.kdeb ) then + write (ulecr,47010) + do 2271 , kaux = kdeb , kfin + laface = facare(kaux) + if ( laface.gt.0 ) then + taux40 = texttr(mod(hettri(laface),10)) + else + taux40 = textqu(mod(hetqua(-laface),100)) + endif + write (ulecr,47030) laface, taux40 + iaux = iaux + 1 +#include "tbdim2.h" + trav2a(iaux) = laface + 2271 continue + endif +c + endif +c + nbfacm = iaux + nbface = nbfacm + nbfam1 = nbfacm + 1 +c +c 2.2.7.2. ==> dont le noeud est l'un des sommets +c trav1a de 1 a nbares = liste des nbares aretes dont le noeud +c est sommet +c trav2a de nbfacm+1 a nbface = liste des nbface-nbfacm faces +c dont le noeud est sommet, en evitant les doublons +c remarque : on repere d'abord s'il existe au moins une face +c dont le noeud est sommet, pour ne pas imprimer +c des en-tetes pour rien. +c + if ( nbares.ne.0 ) then +c + jaux = 0 + do 2272 , iaux1 = 1 , nbares + larete = trav1a(iaux1) + kdeb = posifa(larete-1)+1 + kfin = posifa(larete) + if ( kfin.ge.kdeb ) then + jaux = 1 + goto 2273 + endif + 2272 continue + 2273 continue +c + if ( jaux.ne.0 ) then +c + do 2274 , iaux1 = 1 , nbares + larete = trav1a(iaux1) + kdeb = posifa(larete-1)+1 + kfin = posifa(larete) + do 2275 , kaux = kdeb , kfin + laface = facare(kaux) + do 2276 , jaux = nbfam1 , nbface + if ( laface.eq.trav2a(jaux) ) then + goto 2277 + endif + 2276 continue + nbface = nbface + 1 + iaux = nbface +#include "tbdim2.h" + trav2a(iaux) = laface + 2277 continue + 2275 continue + 2274 continue +c + write (ulecr,47020) + do 2278 , iaux1 = nbfam1 , nbface + laface = trav2a(iaux1) + if ( laface.gt.0 ) then + taux40 = texttr(mod(hettri(laface),10)) + else + taux40 = textqu(mod(hetqua(-laface),100)) + endif + write (ulecr,47030) laface, taux40 + 2278 continue +c + endif +c + endif +c +c 2.2.8. ==> les voisins volumiques +c + if ( nbteto.ne.0 .or. nbheto.ne.0 .or. + > nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c +c 2.2.8.1. ==> dont le noeud est le milieu d'un cote +c + if ( laretm.ne.0 ) then +c + iaux = 30 + kaux = ulecr + trav2a(1) = laretm +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVA - milieu', nompro +#endif + call infova ( iaux, 1, trav2a, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > hettet, hetpyr, hethex, hetpen, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2.8.2. ==> dont le noeud est l'un des sommets +c + iaux = 20 + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVA - sommets', nompro +#endif + call infova ( iaux, nbares, trav1a, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > hettet, hetpyr, hethex, hetpen, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2.9. les homologues +c + if ( homolo.ne.0 ) then +c + if ( noehom(lenoeu).ne.0 ) then + if ( noehom(lenoeu).eq.lenoeu ) then + write (ulecr,48010) + else + if ( noehom(lenoeu).ge.0 ) then + iaux = 2 + else + iaux = 1 + endif + write (ulecr,48020) iaux + write (ulecr,48022) abs(noehom(lenoeu)) + endif + endif +c + endif +c +c 2.2.10. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 ) then +c + iaux = 0 + jaux = numcal + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF-sommet', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 3. formats +c=== +c +40012 format( + > '* Noeud numero :',i10, ' dans le calcul *') +40022 format( + > '* Noeud numero :',i10, ' dans HOMARD *') +40032 format( + > '* Noeud numero :',i10, ' dans HOMARD *', + >/,'* Noeud numero :',i10, ' dans le calcul *') +c +41000 format( + > '* . C''est un noeud du maillage initial. ', + > '*') +c +43000 format( + > '* . Coordonnees : *', + >/,'* x = ', d24.15, ' *') +43010 format( + >'* ',a1,' = ', d24.15, ' *') +c +45000 format( + > '* . Il est le support de la maille-point ',i10, ' *') +c +46010 format( + > '* . Il est le milieu d''une arete : ', + > '*') +46020 format( + > '* . Il est une extremite pour des aretes : *') +46021 format( + > '*',i10, ' de',i10, ' a ',i10, ' : ',a20, '*') +c +47010 format( + > '* . Il est le milieu d''un cote de faces : ', + > '*') +47020 format( + > '* . Il est un sommet pour des faces : *') +47030 format( + > '* ',i10, ' : ',a40, ' *') +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infope.F b/src/tool/Information/infope.F new file mode 100644 index 00000000..d920a05c --- /dev/null +++ b/src/tool/Information/infope.F @@ -0,0 +1,639 @@ + subroutine infope ( choix, lepent, + > facpen, cofape, arepen, + > hetpen, filpen, perpen, fppyte, + > fampen, + > npenho, npenca, npencs, + > hetare, somare, np2are, coonoe, + > hettri, nivtri, + > hetqua, arequa, nivqua, + > hettet, ntetca, + > hethex, + > hetpyr, npyrca, + > voltri, pypetr, + > volqua, pypequ, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : PEntaedre +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lepent . e . 1 . numero du pentaedre a analyser . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . perpen . e . nbpeto . pere des pentaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) = -j. +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . fampen . e . nbpeto . famille des pentaedres . +c . npenho . e . repeac . numero des pentaedres dans HOMARD . +c . npenca . e . * . numero des pentaedres dans le calcul . +c . npencs . e . * . nro des pent. du calcul pour la solution . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . ntetca . e . * . numero des tetraedres dans le calcul . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . npyrca . e . * . numero des pyramides dans le calcul . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOPE' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lepent +c + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer filpen(nbpeto), perpen(nbpeto), fppyte(2,nbpeco) + integer fampen(nbpeto) + integer npenho(repeac), npenca(*), npencs(*) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer hettri(nbtrto), nivtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto) + integer hettet(nbteto), ntetca(*) + integer hethex(nbheto) + integer hetpyr(nbpyto), npyrca(*) + integer volqua(2,nbquto), pypequ(2,*) + integer voltri(2,nbtrto), pypetr(2,*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbfa, nbar, nbso + parameter ( nbfa = 5, nbar = 9, nbso = 6 ) +c + integer iaux, jaux, kaux + integer numcal + integer etat00, etat01, etatpe + integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5 + integer laface, lecode + integer nbface + integer freain, larete + integer nbfipy, filspy + integer nbfite, filste + integer nbfipe + integer listar(nbar), listso(nbso), volint(4,0:5) + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision qualit, qualij, volume, diamet, torsio + double precision vn(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fracte.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero du pentaedre dans HOMARD +c==== +c + if ( choix.eq.'PE' ) then + iaux = lepent + if ( lepent.gt.0 .and. lepent.le.repeac ) then + lepent = npenho(iaux) + else + lepent = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de pentaedre impossible +c + if ( lepent.le.0 .or. lepent.gt.nbpeto ) then +c + if ( choix.eq.'PE' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) lepent + endif + write (ulecr,40030) +c +c 3.2. ==> numero de pentaedre correct +c + else +c + if ( repeac.gt.0 ) then + numcal = npenca(lepent) + else + numcal = 0 + endif + if ( numcal.ne.0 ) then + write (ulecr,40020) lepent + write (ulecr,40010) numcal + else + write (ulecr,40020) lepent + write (ulecr,40040) + endif +c +c 3.2.1. ==> Niveau +c + if ( lepent.le.nbpema ) then + write (ulecr,41000) + else + if ( lepent.le.nbpecf ) then + lafac1 = facpen(lepent,1) + lafac2 = facpen(lepent,2) + lafac3 = facpen(lepent,3) + lafac4 = facpen(lepent,4) + lafac5 = facpen(lepent,5) + niveau = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5)) + endif + if ( lepent.le.nbpepe ) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif +c + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) fampen(lepent) +c +c 3.2.3. ==> les faces, les aretes et les noeuds +c 3.2.3.1. ==> les faces +c + if ( lepent.le.nbpecf ) then +c + write (ulecr,43310) + do 3231 , iaux = 1 , nbfa + laface = facpen(lepent,iaux) + lecode = cofape(lepent,iaux) + if ( iaux.le.2 ) then + taux40 = texttr(mod(hettri(laface),10)) + else + taux40 = textqu(mod(hetqua(laface),100)) + laface = -laface + endif + write (ulecr,43320) laface, lecode, taux40 + 3231 continue +c + endif +c +c 3.2.3.2. ==> les aretes et les sommets +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c + write (ulecr,43030) + do 3232 , iaux = 1 , nbar + larete = listar(iaux) + taux40 = textar(mod(hetare(larete),10)) + write (ulecr,43031) larete, taux40 + 3232 continue +c + write (ulecr,43040) + write (ulecr,50006) (listso(iaux),iaux=1,nbso) +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then +c + write (ulecr,43050) + write (ulecr,50009) (np2are(listar(iaux)),iaux=1,nbar) +c + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hetpen(lepent),100) + etat00 = (hetpen(lepent)-etat01) / 100 +c + taux40 = textpe(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textpe(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c 3.2.5.1. ==> les fils +c + if ( etat01.ne.0 ) then +c + freain = filpen(lepent) +c +c 3.2.5.1. ==> les fils +c 3.2.5.1.1. ==> fils pour le decoupage de conformite +c + if ( ( etat01.ge. 1 .and. etat01.le. 6 ) .or. + > ( etat01.ge.17 .and. etat01.le.19 ) .or. + > ( etat01.ge.21 .and. etat01.le.26 ) .or. + > ( etat01.ge.31 .and. etat01.le.36 ) .or. + > ( etat01.ge.43 .and. etat01.le.45 ) .or. + > ( etat01.ge.51 .and. etat01.le.52 ) ) then +c + freain = -freain + filspy = fppyte(1,freain) + filste = fppyte(2,freain) + if ( etat01.ge.1 .and. etat01.le.6 ) then + nbfipy = 1 + nbfite = 0 + elseif ( etat01.ge.17 .and. etat01.le.19 ) then + nbfipy = 0 + nbfite = 1 + elseif ( etat01.ge.21 .and. etat01.le.26 ) then + nbfipy = -1 + nbfite = 5 + elseif ( etat01.ge.31 .and. etat01.le.36 ) then + nbfipy = 0 + nbfite = 9 + elseif ( etat01.ge.43 .and. etat01.le.45 ) then + nbfipy = 3 + nbfite = 1 + elseif ( etat01.ge.51 .and. etat01.le.52 ) then + nbfipy = -1 + nbfite = 10 + else + nbfipy = -1 + nbfite = -1 + endif + if ( nbfipy.ge.0 ) then + write (ulecr,45010) mess14(langst,3,5) + do 3251 , jaux = 0 , nbfipy + kaux = filspy+jaux + write (ulecr,45080) kaux, npyrca(kaux) + 3251 continue + endif + if ( nbfite.ge.0 ) then + write (ulecr,45010) mess14(langst,3,3) + do 3252 , jaux = 0 , nbfite + kaux = filste+jaux + write (ulecr,45080) kaux, ntetca(kaux) + 3252 continue + endif +c +c 3.2.5.1.2. ==> fils pour le decoupage standard +c + else +c + write (ulecr,45010) mess14(langst,3,7) + nbfipe = 7 + do 3253 , jaux = 0 , nbfipe + kaux = freain+jaux + if ( repeac.eq.0 .or. npenca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, npenca(kaux) + endif + 3253 continue + endif +c + endif +c +c 3.2.5.2 ==> pere +c + if ( perpen(lepent).ne.0 ) then +c + write (ulecr,45040) mess14(langst,1,7), perpen(lepent) + etatpe = mod(hetpen(perpen(lepent)),100) + if ( etatpe.eq.80 .or. etatpe.eq.99 ) then + iaux = 7 + else + codret = 3252 + goto 30 + endif + freain = filpen(perpen(lepent)) + write (ulecr,45050) mess14(langst,3,7) + do 3254 , jaux = 0 , iaux + kaux = freain+jaux + if ( kaux.ne.lepent ) then + if ( repeac.eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, npenca(kaux) + endif + endif + 3254 continue +c + endif +c +c 3.2.6. ==> les volumes voisins +c 3.2.6.1. ==> on commence par dresser la liste de tous les pentaedres +c qui bordent les faces du pentaedre courant mais qui ne +c peuvent pas etre consideres comme des volumes voisins : +c lui-meme et ses fils dans les cas de conformite. +c il suffit d'eliminer les pyramides dont la base est une +c des faces quadrangulaires de l'hexaedre et les tetraedres +c s'appuyant sur une face triangulaire non decoupee. +c Dans les autres cas, le volume ne peut pas etre voisin +c du pentaedre. +c voir cmcdpe pour les conventions sur les fils +c + iaux = 0 + if ( etat01.ge.1 .and. etat01.le.9 ) then + iaux = iaux + 1 + volint(1,iaux) = fppyte(2,-filpen(lepent)) + elseif ( etat01.ge.7 .and. etat01.le.9 ) then + iaux = iaux + 1 + volint(1,iaux) = fppyte(2,-filpen(lepent)) + iaux = iaux + 1 + volint(1,iaux) = fppyte(2,-filpen(lepent)) + 1 + elseif ( etat01.ge.11 .and. etat01.le.16 ) then + iaux = iaux + 1 + volint(1,iaux) = fppyte(2,-filpen(lepent)) + elseif ( etat01.ge.31 .and. etat01.le.32 ) then + iaux = iaux + 1 + volint(1,iaux) = fppyte(2,-filpen(lepent)) + 10 + endif + volint(1,0) = iaux + volint(2,0) = 0 + iaux = 1 + if ( etat01.ge.1 .and. etat01.le.9 ) then + iaux = iaux + 1 + volint(3,iaux) = fppyte(1,-filpen(lepent)) + iaux = iaux + 1 + volint(3,iaux) = fppyte(1,-filpen(lepent)) + 1 + elseif ( etat01.ge.7 .and. etat01.le.9 ) then + iaux = iaux + 1 + volint(3,iaux) = fppyte(1,-filpen(lepent)) + elseif ( etat01.ge.21 .and. etat01.le.23 ) then + iaux = iaux + 1 + volint(3,iaux) = fppyte(2,-filpen(lepent)) + endif + volint(3,0) = iaux + volint(4,iaux) = lepent + volint(4,0) = iaux +c +c 3.2.6.2. ==> liste des faces a examiner +c + nbface = 0 +c +c 3.2.6.2.1. ==> voisinage par les triangles +c + do 32621 , iaux = 1, 2 + if ( voltri(2,facpen(lepent,iaux)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = facpen(lepent,iaux) + endif +32621 continue +c +c 3.2.6.2.2. ==> voisinage par les quadrangles +c + do 32622 , iaux = 3, 5 + if ( volqua(2,facpen(lepent,iaux)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = -facpen(lepent,iaux) + endif +32622 continue +c +c 3.2.6.3. ==> impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + iaux = 40 + kaux = ulecr + call infovo ( iaux, 1, nbface, volint, + > voltri, pypetr, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c +c 3.2.7. ==> le centre de gravite +c + do 327 , iaux = 1 , sdim + vn(iaux) = unssix * ( coonoe(listso(1),iaux) + + > coonoe(listso(2),iaux) + + > coonoe(listso(3),iaux) + + > coonoe(listso(4),iaux) + + > coonoe(listso(5),iaux) + + > coonoe(listso(6),iaux) ) + 327 continue +c + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) +c +c 3.2.8. ==> volume, qualite, diametre et torsion +c + call utqpen ( lepent, qualit, qualij, volume, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c + write (ulecr,49030) volume +c + write (ulecr,49041) qualij +c + call utdpen ( lepent, diamet, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c + write (ulecr,49050) diamet +c + call uttpen ( lepent, torsio, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c + write (ulecr,49060) torsio +c +c 3.2.9. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edpen6 + else + iaux = edpe15 + endif + jaux = npencs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Pentaedre numero :',i10, ' dans HOMARD *') +c +41000 format( + > '* . C''est un pentaedre du maillage initial. ', + > '*') +c +46110 format( + > '* . Il a un pentaedre voisin : *') +46120 format( + > '* . Il est le voisin de ',i10, ' pentaedres : *') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infopf.F b/src/tool/Information/infopf.F new file mode 100644 index 00000000..f6e28146 --- /dev/null +++ b/src/tool/Information/infopf.F @@ -0,0 +1,223 @@ + subroutine infopf ( nbpafo, nopafo, + > typg, numcal, + > ulecr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : Paquet de Fonctions +c ---- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . typg . e . 1 . type de l'entite a examiner . +c . numcal . e . 1 . numero du calcul de l'entite a examiner . +c . ulecr . e . 1 . unite logique pour l'ecriture . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOPF' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbpafo + integer typg, numcal +c + integer ulecr + integer ulsort, langue, codret +c + character*8 nopafo(*) +c +c 0.4. ==> variables locales +c + integer iaux + integer nrpafo + integer nbfopa, nbtyas, ngauss, carsup, typint + integer adobfo, adtyge +c + character*8 obpafo +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Type de l''''entite a examiner :'',i5)' + texte(1,5) = '(''Numero de l''''entite a examiner :'',i5)' + texte(1,6) = '(/,''Paquet de fonction numero '',i5)' +c + texte(2,4) = '(''Type of entity :'',i5)' + texte(2,5) = '(''Number of entity :'',i5)' + texte(2,6) = '(/,''Pack of functions # '',i5)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) typg + write (ulsort,texte(langue,5)) numcal +#endif +c + codret = 0 +c +c==== +c 2. on parcourt tous les paquets de fonctions +c==== +c + codret = 0 +c + do 20 , nrpafo = 1 , nbpafo +c +c 2.1. ==> caracterisation du paquet courant +c + if ( codret.eq.0 ) then +c + obpafo = nopafo(nrpafo) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nrpafo + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) + call gmprsx (nompro, obpafo//'.TypeSuAs' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, nbtyas, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfopa', nbfopa + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint +#endif +c +c 2.2. ==> si le type de support est inclus dans ceux du paquet, on +c examine toutes ses fonctions +c + if ( codret.eq.0 ) then +c + afaire = .false. +c +c cas du support unique +c + if ( nbtyas.ge.0 ) then + if ( nbtyas.eq.typg ) then + afaire = .true. + endif +c +c cas de support multiple +c + else +c + do 22 , iaux = 0, abs(nbtyas)-1 + if ( imem(adtyge+iaux).eq.typg ) then + afaire = .true. + endif + 22 continue +c + endif +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOFO', nompro +#endif + call infofo ( nbfopa, smem(adobfo), + > typg, numcal, + > ulecr, + > ulsort, langue, codret ) +c + endif +c + endif +c + 20 continue +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infopy.F b/src/tool/Information/infopy.F new file mode 100644 index 00000000..0942103e --- /dev/null +++ b/src/tool/Information/infopy.F @@ -0,0 +1,658 @@ + subroutine infopy ( choix, lapyra, + > facpyr, cofapy, arepyr, + > hetpyr, filpyr, perpyr, pphepe, + > fampyr, + > npyrho, npyrca, npyrcs, + > hetare, somare, np2are, coonoe, + > hettri, aretri, nivtri, + > hetqua, nivqua, + > hettet, ntetca, + > hethex, quahex, filhex, fhpyte, + > hetpen, facpen, filpen, fppyte, + > voltri, pypetr, + > volqua, pypequ, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : PYramide +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lapyra . e . 1 . numero du pyramide a analyser . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . filpyr . e . nbpyto . premier fils des pyramides . +c . perpyr . e . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . pphepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . fampyr . e . nbpyto . famille des pyramides . +c . npyrho . e . repyac . numero des pyramides dans HOMARD . +c . npyrca . e . * . numero des pyramides dans le calcul . +c . npyrcs . e . * . nro des pyra. du calcul pour la solution . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . ntetca . e . * . numero des tetraedres dans le calcul . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . filpen . e . nbpeto . premier fils des hexaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) = -j. +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOPY' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "hexcf0.h" +c +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lapyra +c + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer filpyr(nbpyto), perpyr(nbpyto), pphepe(*) + integer fampyr(nbpyto) + integer npyrho(repyac), npyrca(*), npyrcs(*) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer hetqua(nbquto), nivqua(nbquto) + integer hettet(nbteto), ntetca(*) + integer hethex(nbheto), quahex(nbhecf,6) + integer filhex(nbheto), fhpyte(2,nbheco) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer filpen(nbheto), fppyte(2,nbpeco) + integer volqua(2,nbquto), pypequ(2,*) + integer voltri(2,nbtrto), pypetr(2,*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbfa, nbar, nbso + parameter ( nbfa = 5, nbar = 8, nbso = 5 ) +c + integer iaux, jaux, kaux + integer numcal + integer etat00, etat01, etatpe + integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer laface, lecode + integer nbface + integer larete, lepere + integer nbfipy, filspy + integer nbfite, filste + integer nbfihe + integer listar(nbar), listso(nbso), volint(4,0:5) + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision qualit, qualij, volume, diamet, torsio + double precision vn(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fractd.h" +c +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero de la pyramide dans HOMARD +c==== +c + if ( choix.eq.'PY' ) then + iaux = lapyra + if ( lapyra.gt.0 .and. lapyra.le.repyac ) then + lapyra = npyrho(iaux) + else + lapyra = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de pyramide impossible +c + if ( lapyra.le.0 .or. lapyra.gt.nbpyto ) then +c + if ( choix.eq.'PY' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) lapyra + endif + write (ulecr,40031) +c +c 3.2. ==> numero de pyramide correct +c + else +c + numcal = npyrca(lapyra) + if ( numcal.ne.0 ) then + write (ulecr,40020) lapyra + write (ulecr,40010) numcal + else + write (ulecr,40020) lapyra + write (ulecr,40041) + endif +c +c 3.2.1. ==> Niveau +c + if ( lapyra.le.nbpyma ) then + write (ulecr,41000) + else +c + if ( lapyra.le.nbpycf ) then + lafac1 = facpyr(lapyra,1) + lafac2 = facpyr(lapyra,2) + lafac3 = facpyr(lapyra,3) + lafac4 = facpyr(lapyra,4) + lafac5 = facpyr(lapyra,5) + niveau = max(nivtri(lafac1),nivtri(lafac2), + > nivtri(lafac3),nivtri(lafac4), + > nivqua(lafac5)) + else + iaux = perpyr(lapyra) + lepere = pphepe(-iaux) + if ( -iaux.le.nbheco ) then + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + niveau = max(nivqua(lafac1),nivqua(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5),nivqua(lafac6)) + 1 + else + lafac1 = facpen(lepere,1) + lafac2 = facpen(lepere,2) + lafac3 = facpen(lepere,3) + lafac4 = facpen(lepere,4) + lafac5 = facpen(lepere,5) + niveau = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5)) + 1 + endif + endif + if ( lapyra.le.nbpype ) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) fampyr(lapyra) +c +c 3.2.3. ==> les faces, les aretes et les noeuds +c 3.2.3.1. ==> les faces +c + if ( lapyra.le.nbpycf ) then +c + write (ulecr,43310) + do 3231 , iaux = 1 , nbfa + laface = facpyr(lapyra,iaux) + lecode = cofapy(lapyra,iaux) + if ( iaux.le.4 ) then + taux40 = texttr(mod(hettri(laface),10)) + else + taux40 = textqu(mod(hetqua(laface),100)) + endif + write (ulecr,43320) laface, lecode, taux40 + 3231 continue +c + endif +c +c 3.2.3.2. ==> les aretes et les sommets +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c + write (ulecr,43030) + do 3232 , iaux = 1 , nbar + larete = listar(iaux) + taux40 = textar(mod(hetare(larete),10)) + write (ulecr,43031) larete, taux40 + 3232 continue +c + write (ulecr,43040) + write (ulecr,50005) (listso(iaux),iaux=1,nbso) +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then +c + write (ulecr,43050) + write (ulecr,50008) (np2are(listar(iaux)),iaux=1,nbar) +c + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hetpyr(lapyra),100) + etat00 = (hetpyr(lapyra)-etat01) / 100 +c + taux40 = textpy(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textpy(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c 3.2.5.1. ==> les fils +c + if ( etat01.ne.0 ) then + codret = 1 + endif +c +c 3.2.5.2 ==> pere +c + iaux = perpyr(lapyra) +cgn write (ulsort,90002) 'iaux', iaux + if ( iaux.ne.0 ) then +c +c 3.2.5.2.1. ==> issu d'un decoupage standard d'une pyramide : non ! +c + if ( iaux.gt.0 ) then + codret = 1 +c +c 3.2.5.2.2. ==> issu d'un decoupage de conformite d'un hexaedre +c + elseif ( -iaux.le.nbheco ) then +c + lepere = pphepe(-iaux) + write (ulecr,45043) mess14(langst,1,6), lepere + etatpe = mod(hethex(lepere),1000) + jaux = chbiet(etatpe) + nbfihe = chnhe(jaux)-1 + nbfipy = chnpy(jaux)-1 + nbfite = chnte(jaux)-1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat', etatpe, ' ==> code binaire', jaux + write (ulsort,90002) 'nbfihe', nbfihe+1 + write (ulsort,90002) 'nbfipy', nbfipy+1 + write (ulsort,90002) 'nbfite', nbfite+1 +#endif + kaux = filhex(lepere) + filspy = fhpyte(1,-kaux) + filste = fhpyte(2,-kaux) +cgn print *,'etatpe = ', etatpe +cgn print *,'nbfipy, nbfite = ',nbfipy, nbfite + if ( nbfipy.gt.0 ) then + write (ulecr,45054) mess14(langst,3,5) + do 3253 , jaux = 0 , nbfipy + kaux = filspy+jaux + if ( kaux.ne.lapyra ) then + write (ulecr,45080) kaux, npyrca(kaux) + endif + 3253 continue + endif + if ( nbfite.gt.0 ) then + write (ulecr,45054) mess14(langst,3,3) + do 3254 , jaux = 0 , nbfite + kaux = filste+jaux + write (ulecr,45080) kaux, ntetca(kaux) + 3254 continue + endif +c +c 3.2.5.2.3. ==> issu d'un decoupage de conformite d'un pentaedre +c + else +c + lepere = pphepe(-iaux) + write (ulecr,45044) mess14(langst,1,7), lepere + etatpe = mod(hetpen(lepere),100) + kaux = filpen(lepere) + filspy = fppyte(1,-kaux) + filste = fppyte(2,-kaux) + if ( etatpe.ge.1 .and. etatpe.le.6 ) then + nbfipy = 1 + nbfite = 0 + elseif ( etatpe.ge.17 .and. etatpe.le.19 ) then + nbfipy = 0 + nbfite = 1 + elseif ( etatpe.ge.21 .and. etatpe.le.26 ) then + nbfipy = 0 + nbfite = 5 + elseif ( etatpe.ge.31 .and. etatpe.le.36 ) then + nbfipy = 0 + nbfite = 9 + elseif ( etatpe.ge.43 .and. etatpe.le.45 ) then + nbfipy = 3 + nbfite = 1 + elseif ( etatpe.ge.51 .and. etatpe.le.52 ) then + nbfipy = -1 + nbfite = 10 + else + nbfipy = -1 + nbfite = -1 + endif + if ( nbfipy.gt.0 ) then + write (ulecr,45054) mess14(langst,3,5) + do 3255 , jaux = 0 , nbfipy + kaux = filspy+jaux + if ( kaux.ne.lapyra ) then + write (ulecr,45080) kaux, npyrca(kaux) + endif + 3255 continue + endif + if ( nbfite.gt.0 ) then + write (ulecr,45054) mess14(langst,3,3) + do 3256 , jaux = 0 , nbfite + kaux = filste+jaux + write (ulecr,45080) kaux, ntetca(kaux) + 3256 continue + endif + endif +c + endif +c +c 3.2.6. ==> les volumes voisins +c + if ( lapyra.le.nbpycf ) then +c +c 3.2.6.1. ==> on commence par dresser la liste de toutes les pyramides +c qui bordent les faces de la pyramide courante mais qui ne +c peuvent pas etre consideres comme des volumes voisins : +c elle-meme. +c + iaux = 1 + volint(3,iaux) = lapyra + if ( etat01.ne.0 ) then + codret = 2 + endif + volint(1,0) = 0 + volint(2,0) = 0 + volint(3,0) = iaux + volint(4,0) = 0 +c +c 3.2.6.2. ==> liste des faces a examiner +c + nbface = 0 +c + if ( lapyra.le.nbpycf ) then +c +c 3.2.6.2.1. ==> voisinage par les triangles +c + do 32621 , iaux = 1, 4 + if ( voltri(2,facpyr(lapyra,iaux)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = facpyr(lapyra,iaux) + endif +32621 continue +c +c 3.2.6.2.2. ==> voisinage par les quadrangles +c + if ( volqua(2,facpyr(lapyra,5)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = -facpyr(lapyra,5) + endif +c + endif +c +c 3.2.6.3. ==> impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + iaux = 50 + kaux = ulecr + call infovo ( iaux, 1, nbface, volint, + > voltri, pypetr, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.7. ==> le centre de gravite +c + do 327 , iaux = 1 , sdim + vn(iaux) = unscq * ( coonoe(listso(1),iaux) + + > coonoe(listso(2),iaux) + + > coonoe(listso(3),iaux) + + > coonoe(listso(4),iaux) + + > coonoe(listso(5),iaux) ) + 327 continue +c + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) +c +c 3.2.8. ==> volume, qualite, diametre et torsion +c + call utqpyr ( lapyra, qualit, qualij, volume, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c + write (ulecr,49030) volume +c + write (ulecr,49041) qualij +c + call utdpyr ( lapyra, diamet, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c + write (ulecr,49050) diamet +c + call uttpyr ( lapyra, torsio, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c + write (ulecr,49060) torsio +c +c 3.2.9. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edpyr5 + else + iaux = edpy13 + endif + jaux = npyrcs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Pyramide numero :',i10, ' dans HOMARD *') +c +41000 format( + > '* . C''est une pyramide du maillage initial. ', + > '*') +c +46110 format( + > '* . Il a un pyramide voisin : *') +46120 format( + > '* . Il est le voisin de ',i10, ' pyramides : *') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infoqu.F b/src/tool/Information/infoqu.F new file mode 100644 index 00000000..389a480c --- /dev/null +++ b/src/tool/Information/infoqu.F @@ -0,0 +1,716 @@ + subroutine infoqu ( choix, lequad, + > arequa, hetqua, volqua, pypequ, + > nivqua, filqua, perqua, ninqua, + > famqua, + > nquaho, nquaca, nquacs, + > quahom, + > somare, np2are, hetare, posifa, facare, + > coonoe, + > hettri, nivtri, ntrica, + > hetpyr, hethex, hetpen, + > extrus, hexqua, nhenca, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : QUadrangle +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . lequad . e . 1 . numero du quadrangle a analyser . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . volqua . e .nbquto*2. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(k,1/2) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(k,1/2) = -j . +c . nivqua . e . nbquto . niveau des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . famqua . e . nbquto . famille des quadrangles . +c . nquaho . e . requac . numero des quadrangles dans HOMARD . +c . nquaca . e . * . nro des quad. dans le calcul . +c . nquacs . e . * . nro des quad. du calcul pour la solution . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . ntrica . e . * . nro des triangles dans le calcul . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . extrus . e . 1 . prise en compte d'extrusion . +c . hexqua . e . nbquto . hexaedre sur un quadrangle de la face avant. +c . nhenca . e . * . numero des hexaedres dans le calcul . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOQU' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +#include "indefi.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer lequad +c + integer hetqua(nbquto), arequa(nbquto,4) + integer volqua(2,nbquto), pypequ(2,*) + integer nivqua(nbquto), filqua(nbquto), perqua(nbquto) + integer ninqua(nbquto) + integer famqua(nbquto) + integer nquaho(requac), nquaca(*), nquacs(*) + integer quahom(nbquto) + integer somare(2,nbarto), np2are(nbarto), hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), nivtri(nbtrto), ntrica(*) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) + integer hexqua(nbquto), nhenca(*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + logical extrus +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbar, nbso + parameter ( nbar = 4, nbso = 4 ) +c + integer iaux, jaux, kaux, laux + integer tbaux1(1), tbaux2(1) + integer kdeb, kfin + integer numcal + integer etat00, etat01, etatpe + integer lafac1 + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer nquniv, nquaut, ntrniv, ntraut + integer niveau, freain + integer nbfiqu, lifiqu(4) + integer nbfitr, lifitr(4) + integer hettet(1) + integer volint(4,0:1) + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision vn(4) + double precision surf, qualit, diamet, torsio +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fractc.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero du quadrangle dans HOMARD +c==== +c + if ( choix.eq.'QU' ) then + iaux = lequad + if ( lequad.gt.0 .and. lequad.le.requac ) then + lequad = nquaho(iaux) + else + lequad = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de quadrangle impossible +c + if ( lequad.le.0 .or. lequad.gt.nbquto ) then +c + if ( choix.eq.'QU' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) lequad + endif + write (ulecr,40030) +c +c 3.2. ==> numero de quadrangle correct +c + else +c + if ( extrus ) then + numcal = nhenca(hexqua(lequad)) + write (ulecr,40020) lequad + write (ulecr,40050) numcal + else + if ( requac.ne.0 ) then + numcal = nquaca(lequad) + if ( numcal.ne.0 ) then + write (ulecr,40020) lequad + write (ulecr,40010) numcal + else + write (ulecr,40020) lequad + write (ulecr,40040) + endif + else + write (ulecr,40020) lequad + write (ulecr,40040) + endif + endif +c +c 3.2.1. ==> Niveau +c + if ( lequad.le.nbquma) then + niveau = 0 + write (ulecr,41000) + else + niveau = nivqua(lequad) + if ( lequad.le.nbqupe) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) famqua(lequad) +c +c 3.2.3. ==> ses aretes et ses noeuds +c +c 3.2.3.1. ==> ses aretes +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + write (ulecr,43030) + taux40 = textar(mod(hetare(a1),10)) + write (ulecr,43031) a1, taux40 + taux40 = textar(mod(hetare(a2),10)) + write (ulecr,43031) a2, taux40 + taux40 = textar(mod(hetare(a3),10)) + write (ulecr,43031) a3, taux40 + taux40 = textar(mod(hetare(a4),10)) + write (ulecr,43031) a4, taux40 +c +c 3.2.3.2. ==> ses noeuds +c + write (ulecr,43040) + write (ulecr,50004) sa4a1, sa1a2, sa2a3, sa3a4 +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then + write (ulecr,43050) + write (ulecr,50004) np2are(a1), np2are(a2), + > np2are(a3), np2are(a4) + endif +c +c 3.2.3.4. ==> le noeud central +c + if ( mod(mailet,3).eq.0 ) then + write (ulecr,43060) ninqua(lequad) + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hetqua(lequad),100) + etat00 = (hetqua(lequad)-etat01) / 100 +c + taux40 = textqu(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textqu(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c 3.2.5.1. ==> les fils +c + nbfiqu = 0 + nbfitr = 0 +c + if ( etat01.ne.0 ) then +c + if ( etat01.eq.4 .or. etat01.eq.99 .or. + > etat01.eq.21 .or. etat01.eq.22 .or. + > ( etat01.ge.41 .and. etat01.le.44 ) ) then + write (ulecr,45010) mess14(langst,3,4) + if ( etat01.eq.21 .or. etat01.eq.22 ) then + iaux = 1 + elseif ( etat01.ge.41 .and. etat01.le.44 ) then + iaux = 2 + else + iaux = 3 + endif + freain = filqua(lequad) + do 3251 , jaux = 0 , iaux + kaux = freain+jaux + if ( requac.ne.0 ) then + if ( nquaca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, nquaca(kaux) + endif + else + write (ulecr,45070) kaux + endif + nbfiqu = nbfiqu + 1 + lifiqu(nbfiqu) = kaux + 3251 continue +c + elseif ( etat01.ge.31 .and. etat01.le.34 ) then +c + write (ulecr,45010) mess14(langst,3,2) + iaux = 2 + freain = -filqua(lequad) + do 3252 , jaux = 0 , iaux + kaux = freain+jaux + if ( retrac.ne.0 ) then + if ( ntrica(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntrica(kaux) + endif + else + write (ulecr,45070) kaux + endif + nbfitr = nbfitr + 1 + lifitr(nbfitr) = kaux + 3252 continue + endif +c + endif +c +c 3.2.5.2 ==> pere +c + if ( perqua(lequad).gt.0 ) then + write (ulecr,45040) mess14(langst,1,4), perqua(lequad) + etatpe = mod(hetqua(perqua(lequad)),100) + if ( etatpe.eq.21 .or. etatpe.eq.22 ) then + iaux = 1 + elseif ( etatpe.ge.41 .and. etatpe.le.44 ) then + iaux = 2 + else + iaux = 3 + endif + freain = filqua(perqua(lequad)) + if ( iaux.eq.1 ) then + write (ulecr,45051) mess14(langst,1,4) + else + write (ulecr,45050) mess14(langst,3,4) + endif + do 3253 , jaux = 0 , iaux + kaux = freain+jaux + if ( kaux.ne.lequad) then + if ( requac.ne.0 ) then + if ( nquaca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, nquaca(kaux) + endif + else + write (ulecr,45070) kaux + endif + endif + 3253 continue + elseif ( perqua(lequad).lt.0 ) then + write (ulecr,45091) +#ifdef _DEBUG_HOMARD_ + write (ulecr,45092) perqua(lequad) +#endif + endif +c +c 3.2.6. ==> les faces voisines +c + trav1a(1) = a1 + trav1a(2) = a2 + trav1a(3) = a3 + trav1a(4) = a4 +c +c 3.2.6.1. ==> reperage ; attention a ne pas compter les fils ! +c + nquniv = 0 + ntrniv = 0 + nquaut = 0 + ntraut = 0 + do 3261 , iaux = 1 , nbar + kdeb = posifa(trav1a(iaux)-1)+1 + kfin = posifa(trav1a(iaux)) + do 3262 , kaux = kdeb , kfin + jaux = facare(kaux) + if ( jaux.ne.perqua(lequad) ) then + if ( jaux.gt.0 ) then + if ( nivtri(jaux).eq.niveau ) then + ntrniv = ntrniv + 1 +#include "tbdim4.h" + trav2a(ntrniv+nquniv) = jaux + else + do 32621 , laux = 1 , nbfitr + if ( jaux.eq.lifitr(laux) ) then + goto 3262 + endif +32621 continue + ntraut = ntraut + 1 +#include "tbdim5.h" + trav1a(nbar+ntraut+nquaut) = jaux + endif + else + if ( -jaux.ne.lequad ) then + if ( nivqua(-jaux).eq.niveau ) then + nquniv = nquniv + 1 +#include "tbdim4.h" + trav2a(ntrniv+nquniv) = jaux + else + do 32622 , laux = 1 , nbfiqu + if ( jaux.eq.lifiqu(laux) ) then + goto 3262 + endif +32622 continue + nquaut = nquaut + 1 +#include "tbdim5.h" + trav1a(nbar+ntraut+nquaut) = jaux + endif + endif + endif + endif + 3262 continue + 3261 continue +c +c 3.2.6.2. ==> quadrangles de meme niveau +c + if ( nquniv.ne.0 ) then + write (ulecr,46110) + do 3263 , iaux = 1 , ntrniv+nquniv + lafac1 = trav2a(iaux) + if ( lafac1.lt.0 ) then + taux40 = textqu(mod(hetqua(-lafac1),100)) + write (ulecr,46000) -lafac1, taux40 + endif + 3263 continue + endif +c +c 3.2.6.3. ==> triangles de meme niveau +c + if ( ntrniv.ne.0 ) then + write (ulecr,46120) + do 3264 , iaux = 1 , ntrniv+nquniv + lafac1 = trav2a(iaux) + if ( lafac1.gt.0 ) then + taux40 = texttr(mod(hettri(lafac1),10)) + write (ulecr,46000) lafac1, taux40 + endif + 3264 continue + endif +c +c 3.2.6.4. ==> quadrangles des autres niveaux +c + if ( nquaut.ne.0 ) then + write (ulecr,46130) + do 3265 , iaux = 1 , ntraut+nquaut + lafac1 = trav1a(nbar+iaux) + if ( lafac1.lt.0 ) then + taux40 = textqu(mod(hetqua(-lafac1),100)) + write (ulecr,46000) -lafac1, taux40 + endif + 3265 continue + endif +c +c 3.2.6.5. ==> triangles des autres niveaux +c + if ( ntraut.ne.0 ) then + write (ulecr,46140) + do 3266 , iaux = 1 , ntraut+nquaut + lafac1 = trav1a(nbar+iaux) + if ( lafac1.gt.0 ) then + taux40 = textqu(mod(hettri(lafac1),10)) + write (ulecr,46000) lafac1, taux40 + endif + 3266 continue + endif +c +c 3.2.7. ==> les voisins volumiques +c Remarque : on met une valeur bidon au tableau hettet pour +c ne pas avoir de message avec ftnchek +c + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + volint(1,0) = 0 + volint(2,0) = 0 + volint(3,0) = 0 + volint(4,0) = 0 + trav2a(1) = -lequad + iaux = 0 + hettet(1) = iindef + kaux = ulecr + call infovo ( iaux, 1, 1, volint, + > tbaux1, tbaux2, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.8. ==> les homologues +c + if ( homolo.ne.0 .and. sdim.eq.3 ) then +c + if ( quahom(lequad).ne.0 ) then + if ( quahom(lequad).ge.0 ) then + iaux = 2 + else + iaux = 1 + endif + write (ulecr,48020) iaux + write (ulecr,48024) abs(quahom(lequad)) + endif +c + endif +c +c 3.2.9. ==> le centre de gravite +c + do 329 , iaux = 1 , sdim + vn(iaux) = unsqu * ( coonoe(sa1a2,iaux) + + > coonoe(sa2a3,iaux) + + > coonoe(sa3a4,iaux) + + > coonoe(sa4a1,iaux) ) + 329 continue +c + if ( sdim.eq.2 ) then + write (ulecr,49002) (vn(iaux), iaux = 1 , sdim) + else + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) + endif +c +c 3.2.10. ==> normale +c + if ( sdim.eq.3 ) then +c + call utnqua ( lequad, vn, + > nbnoto, nbquto, + > coonoe, somare, arequa ) +c + write (ulecr,49004) (vn(iaux), iaux = 1 , sdim) +c + endif +c +c 3.2.11. ==> surface, qualite, diametre et torsion +c + call utqqua ( lequad, qualit, surf, + > coonoe, somare, arequa ) +c + write (ulecr,49020) surf +c + write (ulecr,49040) qualit +c + call utdqua ( lequad, diamet, + > coonoe, somare, arequa ) +c + write (ulecr,49050) diamet +c + if ( sdim.eq.3 ) then +c + call uttoqu ( sa1a2, sa2a3, sa3a4, sa4a1, coonoe, torsio ) +c + write (ulecr,49060) torsio +c + endif +c +c 3.2.12. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edqua4 + else + iaux = edqua8 + endif + jaux = nquacs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Quadrangle numero :',i10, ' dans HOMARD *') +40050 format( + > '* Face de l''hexaedre extrude numero',i10, ' dans le calcul*') +c +41000 format( + > '* . C''est un quadrangle du maillage initial. ', + > '*') +c +45091 format( + > '* . C''est un quadrangle bordant une non-conformite initiale ', + > '*') +c +46110 format( + > '* . Il a des quadrangles voisins de meme niveau : *') +46120 format( + > '* . Il a des triangles voisins de meme niveau : *') +46130 format( + > '* . Il a des quadrangles voisins d''autre niveau : ', + > '*') +46140 format( + > '* . Il a des triangles voisins d''autre niveau : ', + > '*') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infote.F b/src/tool/Information/infote.F new file mode 100644 index 00000000..e0ab286f --- /dev/null +++ b/src/tool/Information/infote.F @@ -0,0 +1,673 @@ + subroutine infote ( choix, letetr, + > tritet, cotrte, aretet, + > hettet, filtet, pertet, pthepe, + > famtet, + > ntetho, ntetca, ntetcs, + > hetare, somare, np2are, coonoe, + > hettri, aretri, nivtri, + > nivqua, + > hethex, quahex, filhex, fhpyte, + > hetpyr, npyrca, + > hetpen, facpen, filpen, fppyte, + > voltri, pypetr, + > volqua, pypequ, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : TEtraedre +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . letetr . e . 1 . numero du tetraedre a analyser . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . famtet . e . nbteto . famille des tetraedres . +c . ntetho . e . reteac . numero des tetraedres dans HOMARD . +c . ntetca . e . * . numero des tetraedres dans le calcul . +c . ntetcs . e . * . nro des tetra. du calcul pour la solution . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . filpen . e . nbpeto . premier fils des hexaedres . +c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) = -j. +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . npyrca . e . * . numero des pyramides dans le calcul . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . 2 .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOTE' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "hexcf0.h" +c +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer letetr +c + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer filtet(nbteto), pertet(nbteto), pthepe(*) + integer famtet(nbteto) + integer ntetho(reteac), ntetca(*), ntetcs(*) + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto) + integer nivqua(nbquto) + integer hethex(nbheto), quahex(nbhecf,6) + integer filhex(nbheto), fhpyte(2,nbheco) + integer hetpyr(nbpyto), npyrca(*) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer filpen(nbheto), fppyte(2,nbpeco) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbfa, nbar, nbso + parameter ( nbfa = 4, nbar = 6, nbso = 4 ) +c + integer iaux, jaux, kaux + integer numcal + integer etat00, etat01, etatpe + integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer laface, lecode + integer nbface + integer freain, larete, lepere + integer nbfipy, filspy + integer nbfite, filste + integer nbfihe + integer listar(nbar), listso(nbso), volint(4,0:5) + integer uldeb, ulfin, ulpas, ulecr +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision qualit, qualij, volume, diamet + double precision vn(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fractc.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero du tetraedre dans HOMARD +c==== +c + if ( choix.eq.'TE' ) then + iaux = letetr + if ( letetr.gt.0 .and. letetr.le.reteac ) then + letetr = ntetho(iaux) + else + letetr = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de tetraedre impossible +c + if ( letetr.le.0 .or. letetr.gt.nbteto ) then +c + if ( choix.eq.'TE' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) letetr + endif + write (ulecr,40030) +c +c 3.2. ==> numero de tetraedre correct +c + else +c + numcal = ntetca(letetr) + if ( numcal.ne.0 ) then + write (ulecr,40020) letetr + write (ulecr,40010) numcal + else + write (ulecr,40020) letetr + write (ulecr,40040) + endif +c +c 3.2.1. ==> Niveau +c + if ( letetr.le.nbtema ) then + write (ulecr,41000) + else +c + if ( letetr.le.nbtecf ) then + lafac1 = tritet(letetr,1) + lafac2 = tritet(letetr,2) + lafac3 = tritet(letetr,3) + lafac4 = tritet(letetr,4) + niveau = max(nivtri(lafac1),nivtri(lafac2), + > nivtri(lafac3),nivtri(lafac4)) + else + iaux = pertet(letetr) + lepere = pthepe(-iaux) + if ( -iaux.le.nbheco ) then + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + niveau = max(nivqua(lafac1),nivqua(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5),nivqua(lafac6)) + 1 + else + lafac1 = facpen(lepere,1) + lafac2 = facpen(lepere,2) + lafac3 = facpen(lepere,3) + lafac4 = facpen(lepere,4) + lafac5 = facpen(lepere,5) + niveau = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4), + > nivqua(lafac5)) + 1 + endif + endif + if ( letetr.le.nbtepe ) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif +c + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) famtet(letetr) +c +c 3.2.3. ==> les faces, les aretes et les noeuds +c 3.2.3.1. ==> les faces +c + if ( letetr.le.nbtecf ) then +c + write (ulecr,43310) + do 3231 , iaux = 1 , nbfa + laface = tritet(letetr,iaux) + lecode = cotrte(letetr,iaux) + taux40 = texttr(mod(hettri(laface),10)) + write (ulecr,43320) laface, lecode, taux40 + 3231 continue +c + endif +c +c 3.2.3.2. ==> les aretes et les sommets +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + write (ulecr,43030) + do 3232 , iaux = 1 , nbar + larete = listar(iaux) + taux40 = textar(mod(hetare(larete),10)) + write (ulecr,43031) larete, taux40 + 3232 continue +c + write (ulecr,43040) + write (ulecr,50004) (listso(iaux),iaux=1,nbso) +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then +c + write (ulecr,43050) + write (ulecr,50006) (np2are(listar(iaux)),iaux=1,nbar) +c + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hettet(letetr),100) + etat00 = (hettet(letetr)-etat01) / 100 +c + taux40 = textte(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = textte(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c 3.2.5.1. ==> les fils +c + if ( etat01.ne.0 ) then + if ( etat01.le.26 ) then + iaux = 1 + elseif ( etat01.le.47 ) then + iaux = 3 + else + iaux = 7 + endif + write (ulecr,45010) mess14(langst,3,3) + freain = filtet(letetr) + do 3251 , jaux = 0 , iaux + kaux = freain+jaux + if ( ntetca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntetca(kaux) + endif + 3251 continue + endif +c +c 3.2.5.2. ==> pere +c + iaux = pertet(letetr) + if ( iaux.ne.0 ) then +c +c 3.2.5.2.1. ==> issu d'un decoupage standard d'un tetraedre +c + if ( iaux.gt.0 ) then +c + write (ulecr,45040) mess14(langst,1,3), iaux + etatpe = mod(hettet(iaux),100) + if ( etatpe.le.26 ) then + nbfite = 1 + elseif ( etatpe.le.47 ) then + nbfite = 3 + else + nbfite = 7 + endif + if ( nbfite.eq.1 ) then + write (ulecr,45051) mess14(langst,1,3) + else + write (ulecr,45050) mess14(langst,3,3) + endif + freain = filtet(iaux) + do 3252 , jaux = 0 , nbfite + kaux = freain+jaux + if ( kaux.ne.letetr ) then + if ( ntetca(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntetca(kaux) + endif + endif + 3252 continue +c +c 3.2.5.2.2. ==> issu d'un decoupage de conformite d'un hexaedre +c + elseif ( -iaux.le.nbheco ) then +c + lepere = pthepe(-iaux) + write (ulecr,45041) mess14(langst,1,6), lepere + etatpe = mod(hethex(lepere),1000) + jaux = chbiet(etatpe) + nbfihe = chnhe(jaux)-1 + nbfipy = chnpy(jaux)-1 + nbfite = chnte(jaux)-1 + kaux = filhex(lepere) + filspy = fhpyte(1,-kaux) + filste = fhpyte(2,-kaux) + if ( nbfipy.ge.0 ) then + write (ulecr,45050) mess14(langst,3,5) + do 3253 , jaux = 0 , nbfipy + kaux = filspy+jaux + write (ulecr,45080) kaux, npyrca(kaux) + 3253 continue + endif + if ( nbfite.ge.0 ) then + write (ulecr,45050) mess14(langst,3,3) + do 3254 , jaux = 0 , nbfite + kaux = filste+jaux + if ( kaux.ne.letetr ) then + write (ulecr,45080) kaux, ntetca(kaux) + endif + 3254 continue + endif +c +c 3.2.5.2.3. ==> issu d'un decoupage de conformite d'un pentaedre +c + else +c + lepere = pthepe(-iaux) + write (ulecr,45040) mess14(langst,1,7), lepere + etatpe = mod(hetpen(lepere),100) + kaux = filpen(lepere) + filspy = fppyte(1,-kaux) + filste = fppyte(2,-kaux) + if ( etatpe.ge.1 .and. etatpe.le.6 ) then + nbfipy = 1 + nbfite = 0 + elseif ( etatpe.ge.17 .and. etatpe.le.19 ) then + nbfipy = 0 + nbfite = 1 + elseif ( etatpe.ge.21 .and. etatpe.le.26 ) then + nbfipy = 0 + nbfite = 5 + elseif ( etatpe.ge.31 .and. etatpe.le.36 ) then + nbfipy = 0 + nbfite = 9 + elseif ( etatpe.ge.43 .and. etatpe.le.45 ) then + nbfipy = 3 + nbfite = 1 + elseif ( etatpe.ge.51 .and. etatpe.le.52 ) then + nbfipy = -1 + nbfite = 10 + else + nbfipy = -1 + nbfite = -1 + endif + if ( nbfipy.ge.0 ) then + write (ulecr,45050) mess14(langst,3,5) + do 3255 , jaux = 0 , nbfipy + kaux = filspy+jaux + write (ulecr,45080) kaux, npyrca(kaux) + 3255 continue + endif + if ( nbfite.gt.0 ) then + write (ulecr,45050) mess14(langst,3,3) + do 3256 , jaux = 0 , nbfite + kaux = filste+jaux + if ( kaux.ne.letetr ) then + write (ulecr,45080) kaux, ntetca(kaux) + endif + 3256 continue + endif + endif +c + endif +c +c 3.2.6. ==> les volumes voisins +c + if ( letetr.le.nbtecf ) then +c +c 3.2.6.1. ==> on commence par dresser la liste de tous les tetraedres +c qui bordent les faces du tetraedre courant mais qui ne +c peuvent pas etre consideres comme des volumes voisins : +c lui-meme et ses fils dans les cas de conformite en 2 et +c 2 fois 2. +c + iaux = 1 + volint(1,iaux) = letetr + if ( etat01.ge.21 .and. etat01.le.26 ) then + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + 1 + elseif ( etat01.ge.45 .and. etat01.le.47 ) then + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + 1 + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + 2 + iaux = iaux + 1 + volint(1,iaux) = filtet(letetr) + 3 + endif + volint(1,0) = iaux + volint(2,0) = 0 + volint(3,0) = 0 + volint(4,0) = 0 +c +c 3.2.6.2. ==> liste des faces a examiner +c + nbface = 0 +c + do 3262 , iaux = 1 , 4 + if ( voltri(2,tritet(letetr,iaux)).ne.0 ) then + nbface = nbface + 1 + trav2a(nbface) = tritet(letetr,iaux) + endif + 3262 continue +c +c 3.2.6.3. ==> impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + iaux = 40 + kaux = ulecr + call infovo ( iaux, 1, nbface, volint, + > voltri, pypetr, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.7. ==> le centre de gravite +c + do 327 , iaux = 1 , sdim + vn(iaux) = unsqu * ( coonoe(listso(1),iaux) + + > coonoe(listso(2),iaux) + + > coonoe(listso(3),iaux) + + > coonoe(listso(4),iaux) ) + 327 continue +c + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) +c +c 3.2.8. ==> volume, qualite et diametre +c + call utqtet ( letetr, qualit, qualij, volume, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c + write (ulecr,49030) volume +c + write (ulecr,49143) qualit +c + write (ulecr,49041) qualij +c + call utdtet ( letetr, diamet, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c + write (ulecr,49050) diamet +c +c 3.2.9. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edtet4 + else + iaux = edte10 + endif + jaux = ntetcs(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Tetraedre numero :',i10, ' dans HOMARD *') +c +41000 format( + > '* . C''est un tetraedre du maillage initial. ', + > '*') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infotr.F b/src/tool/Information/infotr.F new file mode 100644 index 00000000..ea8fdf4f --- /dev/null +++ b/src/tool/Information/infotr.F @@ -0,0 +1,701 @@ + subroutine infotr ( choix, letria, + > aretri, hettri, voltri, pypetr, + > nivtri, filtri, pertri, nintri, + > famtri, + > ntriho, ntrica, ntrics, + > homtri, + > somare, np2are, hetare, posifa, facare, + > coonoe, + > hetqua, nivqua, filqua, + > hettet, hetpyr, hetpen, + > extrus, pentri, npenca, + > nbpafo, nopafo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : TRiangle +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . ch2 . choix . +c . letria . e . 1 . numero du triangle a analyser . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . a .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . famtri . e . nbtrto . famille des triangles . +c . ntriho . e . retrac . numero des triangles dans HOMARD . +c . ntrica . e . * . nro des triangles dans le calcul . +c . ntrics . e . * . nro des triangles du calcul pour la solutio. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . homtri . s . nbtrto . ensemble des triangles homologues . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . extrus . e . 1 . prise en compte d'extrusion . +c . pentri . e . nbtrto . pentaedre sur un triangle de la face avant . +c . npenca . e . * . numero des pentaedres dans le calcul . +c . nbpafo . e . 1 . nombre de paquets de fonctions . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquet de fonctions . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOTR' ) +c + integer langst + parameter ( langst = 1 ) +c +#include "nblang.h" +#include "consts.h" +#include "tbdim0.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +#include "indefi.h" +c +#include "nomber.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer letria +c + integer hettri(nbtrto), aretri(nbtrto,3) + integer voltri(2,nbtrto), pypetr(2,*) + integer nivtri(nbtrto), filtri(nbtrto), pertri(nbtrto) + integer nintri(nbtrto) + integer famtri(nbtrto) + integer ntriho(retrac), ntrica(*), ntrics(*) + integer homtri(nbtrto) + integer somare(2,nbarto), np2are(nbarto), hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hetqua(nbquto), nivqua(nbquto), filqua(nbquto) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hetpen(nbpeto) + integer pentri(nbtrto), npenca(*) + integer nbpafo +c + double precision coonoe(nbnoto,sdim) +c + character*8 nopafo(*) +c + logical extrus +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbar, nbso + parameter ( nbar = 3, nbso = 3 ) +c + integer iaux, jaux, kaux, laux + integer tbaux1(1), tbaux2(1) + integer kdeb, kfin + integer numcal + integer etat00, etat01, etatpe + integer a1, a2, a3 + integer sa1a2, sa2a3, sa3a1 + integer lafac1 + integer nquniv, nquaut, ntrniv, ntraut + integer niveau, freain + integer nbfitr, lifitr(4) + integer volint(4,0:1) + integer uldeb, ulfin, ulpas, ulecr + integer hethex(1) +c + integer trav1a(tbdim), trav2a(tbdim) +c + character*40 taux40 +c + double precision vn(3) + double precision surf, qualit, diamet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "fractb.h" +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +#include "infoen.h" +#include "tbdim1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. numero du triangle dans HOMARD +c==== +c + if ( choix.eq.'TR' ) then + iaux = letria + if ( letria.gt.0 .and. letria.le.retrac ) then + letria = ntriho(iaux) + else + letria = 0 + endif + endif +c +c==== +c 3. reponses +c==== +c + do 30 , ulecr = uldeb , ulfin, ulpas +c + write (ulecr,40000) +c +c 3.1. ==> numero de triangle impossible +c + if ( letria.le.0 .or. letria.gt.nbtrto ) then +c + if ( choix.eq.'TR' ) then + write (ulecr,40010) iaux + else + write (ulecr,40020) letria + endif + write (ulecr,40030) +c +c 3.2. ==> numero de triangle correct +c + else +c + if ( extrus ) then + numcal = npenca(pentri(letria)) + write (ulecr,40020) letria + write (ulecr,40050) numcal + else + if ( retrac.ne.0 ) then + numcal = ntrica(letria) + if ( numcal.ne.0 ) then + write (ulecr,40020) letria + write (ulecr,40010) numcal + else + write (ulecr,40020) letria + write (ulecr,40040) + endif + else + write (ulecr,40020) letria + write (ulecr,40040) + endif + endif +c +c 3.2.1. ==> Niveau +c + if ( letria.le.nbtrma) then + niveau = 0 + write (ulecr,41000) + else + niveau = nivtri(letria) + if ( letria.le.nbtrpe) then + write (ulecr,41010) niveau + else + write (ulecr,41011) niveau-1 + endif + endif +c +c 3.2.2. ==> caracteristiques +c + write (ulecr,42000) famtri(letria) +c +c 3.2.3. ==> ses aretes et ses noeuds +c +c 3.2.3.1. ==> ses aretes +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + write (ulecr,43030) + taux40 = textar(mod(hetare(a1),10)) + write (ulecr,43031) a1, taux40 + taux40 = textar(mod(hetare(a2),10)) + write (ulecr,43031) a2, taux40 + taux40 = textar(mod(hetare(a3),10)) + write (ulecr,43031) a3, taux40 +c +c 3.2.3.2. ==> ses noeuds +c + write (ulecr,43040) + write (ulecr,50003) sa3a1, sa1a2, sa2a3 +c +c 3.2.3.3. ==> les noeuds au milieu des aretes +c + if ( degre.eq.2 ) then + write (ulecr,43050) + write (ulecr,50003) np2are(a1), np2are(a2), + > np2are(a3) + endif +c +c 3.2.3.4. ==> le noeud central +c + if ( mod(mailet,2).eq.0 ) then + write (ulecr,43060) nintri(letria) + endif +c +c 3.2.4. ==> etat +c + etat01 = mod(hettri(letria),10) + etat00 = (hettri(letria)-etat01) / 10 +c + taux40 = texttr(etat01) + write (ulecr,44010) + write (ulecr,40001) taux40 + if ( nbiter.ge.1 ) then + taux40 = texttr(etat00) + write (ulecr,44020) + write (ulecr,40001) taux40 + endif +c +c 3.2.5. ==> la parente +c 3.2.5.1. ==> les fils +c + nbfitr = 0 +c + if ( etat01.ne.0 ) then +c + write (ulecr,45010) mess14(langst,3,2) + if ( etat01.le.3 ) then + iaux = 1 + else + iaux = 3 + endif + freain = filtri(letria) + do 3251 , jaux = 0 , iaux + kaux = freain+jaux + if ( retrac.ne.0 ) then + if ( ntrica(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntrica(kaux) + endif + else + write (ulecr,45070) kaux + endif + nbfitr = nbfitr + 1 + lifitr(nbfitr) = kaux + 3251 continue +c + endif +c +c 3.2.5.2 ==> pere et freres +c + if ( pertri(letria).gt.0 ) then +c + write (ulecr,45040) mess14(langst,1,2), pertri(letria) + etatpe = mod(hettri(pertri(letria)),10) + if ( etatpe.le.3 ) then + iaux = 1 + else + iaux = 3 + endif + if ( iaux.eq.1 ) then + write (ulecr,45051) mess14(langst,1,2) + else + write (ulecr,45050) mess14(langst,3,2) + endif + freain = filtri(pertri(letria)) + do 3252 , jaux = 0 , iaux + kaux = freain+jaux + if ( kaux.ne.letria) then + if ( retrac.ne.0 ) then + if ( ntrica(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntrica(kaux) + endif + else + write (ulecr,45070) kaux + endif + endif + 3252 continue +c + elseif ( pertri(letria).lt.0 .and. + > pertri(letria).ge.-nbquto) then +c + write (ulecr,45040) mess14(langst,1,4), -pertri(letria) + freain = filqua(-pertri(letria)) + write (ulecr,45050) mess14(langst,3,2) + do 3253 , jaux = 0 , 2 + kaux = -freain+jaux + if ( kaux.ne.letria) then + if ( retrac.ne.0 ) then + if ( ntrica(kaux).eq.0 ) then + write (ulecr,45070) kaux + else + write (ulecr,45080) kaux, ntrica(kaux) + endif + else + write (ulecr,45070) kaux + endif + endif + 3253 continue +c + elseif ( pertri(letria).lt.-nbquto) then +c + write (ulecr,45091) +#ifdef _DEBUG_HOMARD_ + write (ulecr,45092) pertri(letria) +#endif + endif +c +c 3.2.6. ==> les faces voisines +c + trav1a(1) = a1 + trav1a(2) = a2 + trav1a(3) = a3 +c +c 3.2.6.1. ==> reperage ; attention a ne pas compter les fils ! +c + nquniv = 0 + ntrniv = 0 + nquaut = 0 + ntraut = 0 + do 3261 , iaux = 1 , nbar + kdeb = posifa(trav1a(iaux)-1)+1 + kfin = posifa(trav1a(iaux)) + do 3262 , kaux = kdeb , kfin + jaux = facare(kaux) + if ( jaux.ne.pertri(letria) ) then + if ( jaux.gt.0 ) then + if ( jaux.ne.letria ) then + if ( nivtri(jaux).eq.niveau ) then + ntrniv = ntrniv + 1 +#include "tbdim4.h" + trav2a(ntrniv+nquniv) = jaux + else + do 32621 , laux = 1 , nbfitr + if ( jaux.eq.lifitr(laux) ) then + goto 3262 + endif +32621 continue + ntraut = ntraut + 1 +#include "tbdim5.h" + trav1a(nbar+ntraut+nquaut) = jaux + endif + endif + else + if ( nivqua(-jaux).eq.niveau ) then + nquniv = nquniv + 1 +#include "tbdim4.h" + trav2a(ntrniv+nquniv) = jaux + else + nquaut = nquaut + 1 +#include "tbdim5.h" + trav1a(nbar+ntraut+nquaut) = jaux + endif + endif + endif + 3262 continue + 3261 continue +c +c 3.2.6.2. ==> quadrangles de meme niveau +c + if ( nquniv.ne.0 ) then + write (ulecr,46110) + do 3263 , iaux = 1 , ntrniv+nquniv + lafac1 = trav2a(iaux) + if ( lafac1.lt.0 ) then + taux40 = textqu(mod(hetqua(-lafac1),100)) + write (ulecr,46000) -lafac1, taux40 + endif + 3263 continue + endif +c +c 3.2.6.3. ==> triangles de meme niveau +c + if ( ntrniv.ne.0 ) then + write (ulecr,46120) + do 3264 , iaux = 1 , ntrniv+nquniv + lafac1 = trav2a(iaux) + if ( lafac1.gt.0 ) then + taux40 = texttr(mod(hettri(lafac1),10)) + write (ulecr,46000) lafac1, taux40 + endif + 3264 continue + endif +c +c 3.2.6.4. ==> quadrangles des autres niveaux +c + if ( nquaut.ne.0 ) then + write (ulecr,46130) + do 3265 , iaux = 1 , ntraut+nquaut + lafac1 = trav1a(nbar+iaux) + if ( lafac1.lt.0 ) then + taux40 = textqu(mod(hetqua(-lafac1),100)) + write (ulecr,46000) -lafac1, taux40 + endif + 3265 continue + endif +c +c 3.2.6.5. ==> triangles des autres niveaux +c + if ( ntraut.ne.0 ) then + write (ulecr,46140) + do 3266 , iaux = 1 , ntraut+nquaut + lafac1 = trav1a(nbar+iaux) + if ( lafac1.gt.0 ) then + taux40 = texttr(mod(hettri(lafac1),10)) + write (ulecr,46000) lafac1, taux40 + endif + 3266 continue + endif +c +c 3.2.7. ==> les voisins volumiques +c Remarque : on met une valeur bidon au tableau hethex pour +c ne pas avoir de message avec ftnchek +c + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVO', nompro +#endif + volint(1,0) = 0 + volint(2,0) = 0 + volint(3,0) = 0 + volint(4,0) = 0 + trav2a(1) = letria + iaux = 0 + hethex(1) = iindef + kaux = ulecr + call infovo ( iaux, 1, 1, volint, + > voltri, pypetr, + > tbaux1, tbaux2, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > kaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.8. ==> les homologues +c + if ( homolo.ne.0 .and. sdim.eq.3 ) then +c + if ( homtri(letria).ne.0 ) then + if ( homtri(letria).ge.0 ) then + iaux = 2 + else + iaux = 1 + endif + write (ulecr,48020) iaux + write (ulecr,48023) abs(homtri(letria)) + endif +c + endif +c +c 3.2.9. ==> le centre de gravite +c + do 329 , iaux = 1 , sdim + vn(iaux) = unstr * ( coonoe(sa1a2,iaux) + + > coonoe(sa2a3,iaux) + + > coonoe(sa3a1,iaux) ) + 329 continue +c + if ( sdim.eq.2 ) then + write (ulecr,49002) (vn(iaux), iaux = 1 , sdim) + else + write (ulecr,49003) (vn(iaux), iaux = 1 , sdim) + endif +c +c 3.2.10. ==> normale +c + if ( sdim.eq.3 ) then +c + call utntri ( letria, vn, + > coonoe, somare, aretri ) +c + write (ulecr,49004) (vn(iaux), iaux = 1 , sdim) +c + endif +c +c 3.2.11. ==> surface, qualite et diametre +c + call utqtri ( letria, qualit, surf, + > coonoe, somare, aretri ) +c + write (ulecr,49020) surf +c + write (ulecr,49040) qualit +c + call utdtri ( letria, diamet, + > coonoe, somare, aretri ) +c + write (ulecr,49050) diamet +c +c 3.2.12. ==> les valeurs des fonctions +c + if ( nbpafo.ne.0 .and. numcal.ne.0 ) then +c + if ( degre.eq.1 ) then + iaux = edtri3 + else + iaux = edtri6 + endif +cgn write (ulecr,90002) 'letria', letria +cgn write (ulecr,90002) 'numcal', numcal +cgn write (ulecr,90002) 'ntrics(numcal)', ntrics(numcal) +cgn write (ulecr,90002) 'ntrica(letria)', ntrica(letria) +cgn write (ulecr,90002) 'ntrics(ntrica(letria))', +cgn > ntrics(ntrica(letria)) +cgn jaux = ntrics(ntrica(letria)) + jaux = ntrics(numcal) + kaux = ulecr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPF', nompro +#endif + call infopf ( nbpafo, nopafo, + > iaux, jaux, + > kaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + write (ulecr,40000) +c + 30 continue +c +c=== +c 4. formats +c=== +c +40020 format( + > '* Triangle numero :',i10, ' dans HOMARD *') +40050 format( + > '* Face du pentaedre extrude numero ',i10, ' dans le calcul*') +c +41000 format( + > '* . C''est un triangle du maillage initial. ', + > '*') +c +43210 format( + > '* . Ses aretes et les numeros locaux de reference sont : *') +c +45091 format( + > '* . C''est un triangle bordant une non-conformite initiale ', + > '*') +c +46110 format( + > '* . Il a des quadrangles voisins de meme niveau : *') +46120 format( + > '* . Il a des triangles voisins de meme niveau : *') +46130 format( + > '* . Il a des quadrangles voisins d''autre niveau : ', + > '*') +46140 format( + > '* . Il a des triangles voisins d''autre niveau : ', + > '*') +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infova.F b/src/tool/Information/infova.F new file mode 100644 index 00000000..356fb3f0 --- /dev/null +++ b/src/tool/Information/infova.F @@ -0,0 +1,335 @@ + subroutine infova ( typmes, nbaret, tbaret, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > hettet, hetpyr, hethex, hetpen, + > ulecr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : Volumes voisins des Aretes +c ---- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typmes . e . 1 . 10 : message pour les aretes . +c . . . . 20 : message pour les noeuds sommets . +c . . . . 30 : message pour les noeuds milieux . +c . nbaret . e . 1 . nombre d'aretes concernees . +c . tbaret . e . nbaret . les aretes concernees . +c . nbtear . e . 1 . nombre de tetraedres voisins d'aretes . +c . pttear . e .0:nbarto. nombre de tetraedres voisins par aretes . +c . tatear . e . nbtear . tetraedres voisins par aretes . +c . nbhear . e . 1 . nombre d'hexaedres voisins d'aretes . +c . pthear . e .0:nbarto. nombre d'hexaedres voisins par aretes . +c . tahear . e . nbhear . hexaedres voisins par aretes . +c . nbpyar . e . 1 . nombre de pyramides voisines d'aretes . +c . ptpyar . e .0:nbarto. nombre de pyramides voisines par aretes . +c . tapyar . e . nbpyar . pyramides voisines par aretes . +c . nbpear . e . 1 . nombre de pentaedres voisins d'aretes . +c . ptpear . e .0:nbarto. nombre de pentaedres voisins par aretes . +c . tapear . e . nbpear . pentaedres voisins par aretes . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . ulecr . e . 1 . unite logique pour l'ecriture . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOVA' ) +c +#include "nblang.h" +#include "tbdim0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombar.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer typmes + integer nbaret, tbaret(nbaret) + integer nbtear, pttear(0:nbarto), tatear(nbtear) + integer nbhear, pthear(0:nbarto), tahear(nbhear) + integer nbpyar, ptpyar(0:nbarto), tapyar(nbpyar) + integer nbpear, ptpear(0:nbarto), tapear(nbpear) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) +c + integer ulecr + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer larete + integer letetr, lehexa, lapyra, lepent + integer nbtevr, tatevr(tbdim) + integer nbhevr, tahevr(tbdim) + integer nbpyvr, tapyvr(tbdim) + integer nbpevr, tapevr(tbdim) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +#include "infoen.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de segments :'',i10)' +c + texte(2,4) = '(''Number of edgs'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbaret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto +#endif +c +c==== +c 2. tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbteto, nbtecf', nbteto, nbtecf +#endif +c + nbtevr = 0 +c + if ( nbteto.ne.0 ) then +c + do 21 , iaux = 1 , nbaret + larete = tbaret(iaux) +cgn write (ulecr,90002) 'larete', larete + jdeb = pttear(larete-1)+1 + jfin = pttear(larete) + do 211 , jaux = jdeb , jfin + letetr = tatear(jaux) + if ( nbtevr.eq.0 ) then + nbtevr = 1 + tatevr(nbtevr) = letetr + else + do 2111 , kaux = 1 , nbtevr + if ( tatevr(kaux).eq.letetr ) then + goto 211 + endif + 2111 continue + nbtevr = nbtevr + 1 + tatevr(nbtevr) = letetr + endif + 211 continue + 21 continue +c + endif +c +c==== +c 3. hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheto, nbhecf', nbheto, nbhecf +#endif +c + nbhevr = 0 +c + if ( nbheto.ne.0 ) then +c + do 31 , iaux = 1 , nbaret + larete = tbaret(iaux) +cgn write (ulecr,90002) 'larete', larete + jdeb = pthear(larete-1)+1 + jfin = pthear(larete) + do 311 , jaux = jdeb , jfin + lehexa = tahear(jaux) + if ( nbhevr.eq.0 ) then + nbhevr = 1 + tahevr(nbhevr) = lehexa + else + do 3111 , kaux = 1 , nbhevr + if ( tahevr(kaux).eq.lehexa ) then + goto 311 + endif + 3111 continue + nbhevr = nbhevr + 1 + tahevr(nbhevr) = lehexa + endif + 311 continue + 31 continue +c + endif +c +c==== +c 4. pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpyto, nbpycf', nbpyto, nbpycf +#endif +c + nbpyvr = 0 +c + if ( nbpyto.ne.0 ) then +c + do 41 , iaux = 1 , nbaret + larete = tbaret(iaux) +cgn write (ulecr,90002) 'larete', larete + jdeb = ptpyar(larete-1)+1 + jfin = ptpyar(larete) + do 411 , jaux = jdeb , jfin + lapyra = tapyar(jaux) + if ( nbpyvr.eq.0 ) then + nbpyvr = 1 + tapyvr(nbpyvr) = lapyra + else + do 4111 , kaux = 1 , nbpyvr + if ( tapyvr(kaux).eq.lapyra ) then + goto 411 + endif + 4111 continue + nbpyvr = nbpyvr + 1 + tapyvr(nbpyvr) = lapyra + endif + 411 continue + 41 continue +c + endif +c +c==== +c 5. pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpeto, nbpecf', nbpeto, nbpecf +#endif +c + nbpevr = 0 +c + if ( nbpeto.ne.0 ) then +c + do 51 , iaux = 1 , nbaret + larete = tbaret(iaux) +cgn write (ulecr,90002) 'larete', larete + jdeb = ptpear(larete-1)+1 + jfin = ptpear(larete) + do 511 , jaux = jdeb , jfin + lepent = tapear(jaux) + if ( nbpevr.eq.0 ) then + nbpevr = 1 + tapevr(nbpevr) = lepent + else + do 5111 , kaux = 1 , nbpevr + if ( tapevr(kaux).eq.lepent ) then + goto 511 + endif + 5111 continue + nbpevr = nbpevr + 1 + tapevr(nbpevr) = lepent + endif + 511 continue + 51 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulecr,90002) 'nbtevr', nbtevr + write (ulecr,90002) 'nbhevr', nbhevr + write (ulecr,90002) 'nbpyvr', nbpyvr + write (ulecr,90002) 'nbpevr', nbpevr +#endif +c +c==== +c 6. Impressions +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOVI', nompro +#endif + call infovi ( typmes, + > nbtevr, tatevr, + > nbhevr, tahevr, + > nbpyvr, tapyvr, + > nbpevr, tapevr, + > hettet, hetpyr, hethex, hetpen, + > ulecr, + > ulsort, langue, codret ) +c +c==== +c 7. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infovi.F b/src/tool/Information/infovi.F new file mode 100644 index 00000000..9af2f4de --- /dev/null +++ b/src/tool/Information/infovi.F @@ -0,0 +1,259 @@ + subroutine infovi ( typmes, + > nbtevr, tatevr, + > nbhevr, tahevr, + > nbpyvr, tapyvr, + > nbpevr, tapevr, + > hettet, hetpyr, hethex, hetpen, + > ulecr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : Volumes voisins - Impression +c ---- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typmes . e . 1 . 10 : message pour les aretes . +c . . . . 20 : message pour les noeuds sommets . +c . . . . 30 : message pour les noeuds milieux . +c . nbtevr . e . 1 . nombre de tetraedres voisins d'aretes . +c . tatevr . e . nbtevr . tetraedres voisins par aretes . +c . nbhevr . e . 1 . nombre d'hexaedres voisins d'aretes . +c . tahevr . e . nbhevr . hexaedres voisins par aretes . +c . nbpyvr . e . 1 . nombre de pyramides voisines d'aretes . +c . tapyvr . e . nbpyvr . pyramides voisines par aretes . +c . nbpevr . e . 1 . nombre de pentaedres voisins d'aretes . +c . tapevr . e . nbpevr . pentaedres voisins par aretes . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . ulecr . e . 1 . unite logique pour l'ecriture . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOVI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "hexcf0.h" +#include "hexcf1.h" +c +c 0.3. ==> arguments +c + integer typmes + integer nbtevr, tatevr(nbtevr) + integer nbhevr, tahevr(nbhevr) + integer nbpyvr, tapyvr(nbpyvr) + integer nbpevr, tapevr(nbpevr) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) +c + integer ulecr + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer etat, bindec + integer letetr, lehexa, lapyra, lepent + integer inditv (0:2,0:2,0:2,0:2) +c + character*40 taux40 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +#include "infoen.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c 1.2. ==> indirections dans les messages +c + inditv(1,0,0,0) = 1 + typmes + inditv(2,0,0,0) = 2 + typmes + inditv(0,1,0,0) = 3 + typmes + inditv(0,2,0,0) = 4 + typmes + inditv(0,0,1,0) = 5 + typmes + inditv(0,0,2,0) = 6 + typmes + inditv(0,0,0,1) = 7 + typmes + inditv(0,0,0,2) = 8 + typmes +c +c==== +c 2. tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulecr,90002) 'nbtevr', nbtevr +#endif +c + if ( nbtevr.gt.0 ) then +c + iaux = min(2,nbtevr) + write (ulecr,40002) textvo(inditv(iaux,0,0,0)) +c + do 21 , iaux = 1 , nbtevr + letetr = tatevr(iaux) + etat = mod(hettet(letetr),100) + taux40 = textte(etat) + write (ulecr,46000) letetr, taux40 + 21 continue +c + endif +c +c==== +c 3. hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulecr,90002) 'nbhevr', nbhevr +#endif +c + if ( nbhevr.gt.0 ) then +c + iaux = min(2,nbhevr) + write (ulecr,40002) textvo(inditv(0,iaux,0,0)) +c + do 31 , iaux = 1 , nbhevr + lehexa = tahevr(iaux) + etat = mod(hethex(lehexa),1000) + if ( etat.le.10 ) then + taux40 = texthe(etat) + write (ulecr,46000) lehexa, taux40 + else + bindec = chbiet(etat) + if ( etat.le.22 ) then + write (ulecr,46031) lehexa, charde(bindec)(1:3) + elseif ( ( etat.ge.285 ) .and. ( etat.le.290 ) ) then + taux40 = texthe(etat-244) + write (ulecr,46000) lehexa, taux40 + else + write (ulecr,46030) lehexa, charde(bindec)(1:27) + endif + endif + 31 continue +c + endif +c +c==== +c 4. pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulecr,90002) 'nbpyvr', nbpyvr +#endif +c + if ( nbpyvr.gt.0 ) then +c + iaux = min(2,nbpyvr) + write (ulecr,40002) textvo(inditv(0,0,iaux,0)) +c + do 41 , iaux = 1 , nbpyvr + lapyra = tapyvr(iaux) + etat = mod(hetpyr(lapyra),100) + taux40 = textpy(etat) + write (ulecr,46000) lapyra, taux40 + 41 continue +c + endif +c +c==== +c 5. pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulecr,90002) 'nbpevr', nbpevr +#endif +c + if ( nbpevr.gt.0 ) then +c + iaux = min(2,nbpevr) + write (ulecr,40002) textvo(inditv(0,0,0,iaux)) +c + do 51 , iaux = 1 , nbpevr + lepent = tapevr(iaux) + etat = mod(hetpen(lepent),100) + taux40 = textpe(etat) + write (ulecr,46000) lepent, taux40 + 51 continue +c + endif +c +c==== +c 6. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infovo.F b/src/tool/Information/infovo.F new file mode 100644 index 00000000..083ce9d3 --- /dev/null +++ b/src/tool/Information/infovo.F @@ -0,0 +1,454 @@ + subroutine infovo ( typmes, nufade, nufafi, volint, + > voltri, pypetr, + > volqua, pypequ, + > hettet, hetpyr, hethex, hetpen, + > trav1a, trav2a, + > ulecr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INFOrmation : VOisins +c ---- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typmes . e . 1 . 0 : message pour les faces . +c . . . . 40 : message pour les tetra-penta-hexaedres. +c . . . . 50 : message pour les pyramides . +c . nufade . e . 1 . numero initial de la liste des faces . +c . nufafi . e . 1 . numero final de la liste des faces . +c . volint . e . 4** . i,0 : nombre de volumes interdits . +c . . . . i,j>0 : numeros des volumes interdits . +c . . . . i=1 : tetr, i=2 : hexa, i=3 : pyra, . +c . . . . i=4 : pent . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . trav1a . a . * . tableau de travail numero 1 . +c . trav2a . a . * . liste des faces a examiner . +c . . . . . numero positif si triangle . +c . . . . . numero negatif si quadrangle . +c . ulecr . e . 1 . unite logique pour l'ecriture . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFOVO' ) +c +#include "nblang.h" +#include "tbdim0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +#include "impr02.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +#include "hexcf0.h" +#include "hexcf1.h" +c +c 0.3. ==> arguments +c + integer typmes + integer nufade, nufafi + integer volint(4,0:*) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer hettet(nbteto) + integer hetpyr(nbpyto) + integer hethex(nbheto) + integer hetpen(nbpeto) +c + integer trav1a(tbdim), trav2a(tbdim) +c + integer ulecr + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nument, decafv + integer etat, bindec + integer letetr, lehexa, lapyra, lepent + integer nbtetr, nbhexa, nbpyra, nbpent + integer nbtevr, nbhevr, nbpyvr, nbpevr + integer inditv (0:2,0:2,0:2,0:2) +c + character*40 taux40 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. ==> messages +c +#include "impr01.h" +#include "infoen.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de'',i10,'' face(s).'')' + texte(1,5) = '(''Nombre de '',a,'' interdits :'',i10)' + texte(1,6) = '(''.. '',a,''numero'',i10)' + texte(1,7) = '(''Nombre de '',a,'' :'',i10)' +c + texte(2,4) = '(''Examination of'',i10,'' face(s).'')' + texte(2,5) = '(''Number of '',,a,'' which are forbiden :'',i10)' + texte(2,6) = '(''.. '',a,''#'',i10)' + texte(2,7) = '(''Number of '',,a,'':'',i10)' +c +#include "impr03.h" +c +#include "tbdim1.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nufafi-nufade+1 + write (ulsort,90002) 'Numeros',(trav2a(jaux),jaux=nufade,nufafi) +#endif +c +c 1.2. ==> indirections dans les messages +c + inditv(1,0,0,0) = 1 + typmes + inditv(2,0,0,0) = 2 + typmes + inditv(0,1,0,0) = 3 + typmes + inditv(0,2,0,0) = 4 + typmes + inditv(0,0,1,0) = 5 + typmes + inditv(0,0,2,0) = 6 + typmes + inditv(0,0,0,1) = 7 + typmes + inditv(0,0,0,2) = 8 + typmes +c +cgn print *,(volint(1,iaux), iaux = 0 , volint(1,0) ) +cgn print *,(volint(2,iaux), iaux = 0 , volint(2,0) ) +cgn print *,(volint(3,iaux), iaux = 0 , volint(3,0) ) +cgn print *,(volint(4,iaux), iaux = 0 , volint(4,0) ) +c +c==== +c 2. decompte des elements de volumes voisins +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVA', nompro +#endif + call utvgv1 ( nufade, nufafi, + > voltri, pypetr, + > volqua, pypequ, + > nbtetr, nbhexa, nbpyra, nbpent, + > trav1a, trav2a, + > ulsort, langue, codret ) +c +c==== +c 3. filtrage des elements interdits +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. filtrage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.0. ==> decalage dans le tableau face/volumes (trav1a) +c + decafv = 2 * ( nufafi - nufade + 1 ) +c +c 3.1. ==> tetraedres +c + if ( volint(1,0).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,3), volint(1,0) + write (ulsort,90002) 'Numeros',(volint(1,jaux),jaux=1,volint(1,0)) +#endif +c + kaux = 0 + do 31 , nument = 1 , nbtetr + letetr = trav1a(nument) + do 311 , jaux = 1 , volint(1,0) + if ( volint(1,jaux).eq.letetr ) then + iaux = nument +#include "tbdim2.h" + trav1a(iaux) = 0 + goto 31 + endif + 311 continue + kaux = kaux + 1 + 31 continue + nbtevr = min(2,kaux) +c + else +c + nbtevr = nbtetr +c + endif +c +c 3.2. ==> hexaedres +c + if ( volint(2,0).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,6), volint(2,0) + write (ulsort,90002) 'Numeros',(volint(2,jaux),jaux=1,volint(2,0)) +#endif +c + kaux = 0 + do 32 , nument = 1 , nbhexa + lehexa = trav1a(decafv+nument) + do 321 , jaux = 1 , volint(2,0) + if ( volint(2,jaux).eq.lehexa ) then + iaux = decafv+nument +#include "tbdim2.h" + trav1a(iaux) = 0 + goto 32 + endif + 321 continue + kaux = kaux + 1 + 32 continue + nbhevr = kaux +c + else +c + nbhevr = nbhexa +c + endif +c +c 3.3. ==> pyramides +c + if ( volint(3,0).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,5), volint(3,0) + write (ulsort,90002) 'Numeros',(volint(3,jaux),jaux=1,volint(3,0)) +#endif +c + kaux = 0 + do 33 , nument = 1 , nbpyra + lapyra = trav1a(2*decafv+nument) + do 331 , jaux = 1 , volint(3,0) + if ( volint(3,jaux).eq.lapyra ) then + iaux = 2*decafv+nument +#include "tbdim2.h" + trav1a(iaux) = 0 + goto 33 + endif + 331 continue + kaux = kaux + 1 + 33 continue + nbpyvr = min(2,kaux) +c + else +c + nbpyvr = nbpyra +c + endif +c +c 3.4. ==> pentaedres +c + if ( volint(4,0).gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,7), volint(4,0) + write (ulsort,90002) 'Numeros',(volint(4,jaux),jaux=1,volint(4,0)) +#endif +c + kaux = 0 + do 34 , nument = 1 , nbpent + lepent = trav1a(3*decafv+nument) + do 341 , jaux = 1 , volint(4,0) + if ( volint(4,jaux).eq.lepent ) then + iaux = 3*decafv+nument +#include "tbdim2.h" + trav1a(iaux) = 0 + goto 34 + endif + 341 continue + kaux = kaux + 1 + 34 continue + nbpevr = min(2,kaux) +c + else +c + nbpevr = nbpent +c + endif +c +c==== +c 4. impression +c==== +c +c 4.1. ==> tetraedres +c + if ( nbtevr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,3), nbtevr +#endif + iaux = min(2,nbtevr) + write (ulecr,40002) textvo(inditv(iaux,0,0,0)) + do 41 , nument = 1 , nbtetr + iaux = nument + letetr = trav1a(iaux) + if ( letetr.gt.0 ) then + etat = mod(hettet(letetr),100) + taux40 = textte(etat) + write (ulecr,46000) letetr, taux40 + endif + 41 continue + endif +c +c 4.2. ==> hexaedres +c + if ( nbhevr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhevr + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhexa +#endif + iaux = min(2,nbhevr) + write (ulecr,40002) textvo(inditv(0,iaux,0,0)) + do 42 , nument = 1 , nbhexa + iaux = decafv+nument + lehexa = trav1a(iaux) + if ( lehexa.gt.0 ) then + etat = mod(hethex(lehexa),1000) + if ( etat.le.10 ) then + taux40 = texthe(etat) + write (ulecr,46000) lehexa, taux40 + else + bindec = chbiet(etat) + if ( etat.le.22 ) then + write (ulecr,46031) lehexa, charde(bindec)(1:3) + elseif ( ( etat.ge.285 ) .and. ( etat.le.290 ) ) then + taux40 = texthe(etat-244) + write (ulecr,46000) lehexa, taux40 + else + write (ulecr,46030) lehexa, charde(bindec)(1:27) + endif + endif + endif + 42 continue + endif +c +c 4.3. ==> pyramides +c + if ( nbpyvr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,5), nbpyvr +#endif + iaux = min(2,nbpyvr) + write (ulecr,40002) textvo(inditv(0,0,iaux,0)) + do 43 , nument = 1 , nbpyra + iaux = 2*decafv+nument + lapyra = trav1a(iaux) + if ( lapyra.gt.0 ) then + etat = mod(hetpyr(lapyra),100) + taux40 = textpy(etat) + write (ulecr,46000) lapyra, taux40 + endif + 43 continue + endif +c +c 4.4. ==> pentaedres +c + if ( nbpevr.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpevr +#endif + iaux = min(2,nbpevr) + write (ulecr,40002) textvo(inditv(0,0,0,iaux)) + do 44 , nument = 1 , nbpent + iaux = 3*decafv+nument + lepent = trav1a(iaux) + if ( lepent.gt.0 ) then + etat = mod(hetpen(lepent),100) + taux40 = textpe(etat) + write (ulecr,46000) lepent, taux40 + endif + 44 continue + endif +c + endif +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infqen.F b/src/tool/Information/infqen.F new file mode 100644 index 00000000..fa3780d9 --- /dev/null +++ b/src/tool/Information/infqen.F @@ -0,0 +1,397 @@ + subroutine infqen ( choix, nbenti, + > coonoe, somare, + > hettri, aretri, + > famtri, cfatri, + > hetqua, arequa, + > famqua, cfaqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > ntreca, nqueca, nteeca, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Qualite des ENtites +c --- - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbenti . e . 1 . nombre d'entites a imprimer . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . ntreca . e . * . nro des triangles dans le calcul en entree . +c . nqueca . e . * . nro des quadrangles dans le calcul en ent. . +c . nteeca . e . reteto . numero des tetraedres du code de calcul . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFQEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmreel.h" +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + double precision coonoe(nbnoto,sdim) +c + integer nbenti + integer somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer ntreca(*), nqueca(*), nteeca(*) +c + integer ulsost + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer codre1, codre2, codre3, codre4 + integer ptrav1, ptrav2, ptrav3, ptrav4 + integer ltrav1 + integer iaux, jaux + integer ideb, ifin, ipas + integer nbeexa + integer typenh, nbenac + integer uldeb, ulfin, ulpas, ulecr +c + double precision vmin, vmax +c + character*8 ntrav1, ntrav2, ntrav3, ntrav4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Quel choix : '',a,'' ?'')' + texte(1,5) = '(/,''Les pires '',a14,'' :'',/,25(''=''),/)' + texte(1,6) = '(/,''Les meilleurs '',a14,'' :'',/,30(''=''),/)' + texte(1,8) = '(''* Numeros | Qualite *'')' + texte(1,9) = '(''* HOMARD | calcul | *'')' + texte(1,10) = + > '(''Aucune face non liee a un tetraedre dans ce maillage.'')' +c + texte(2,4) = '(''What choice : '',a,'' ?'')' + texte(2,5) = '(/,''Worst '',a14,'' :'',/,21(''=''),/)' + texte(2,6) = '(/,''Best '',a14,'' :'',/,20(''=''),/)' + texte(2,8) = '(''* Numbers | Quality *'')' + texte(2,9) = '(''* HOMARD |calculation| *'')' + texte(2,10) = + > '(''In this mesh, all the faces are connected to tetraedra.'')' +c +#include "impr03.h" +c +10000 format (40('*')) +10001 format ('*',i10 ,' |',i10 ,' | ',g12.5,' *') +c + codret = 0 +c +c 1.2. ==> type d'entites +c + if ( choix.eq.'tr' .or. + > choix.eq.'TR' ) then + typenh = 2 + nbenac = nbtrac +c + elseif ( choix.eq.'qu' .or. + > choix.eq.'QU' ) then + typenh = 4 + nbenac = nbquac +c + elseif ( choix.eq.'te' .or. + > choix.eq.'TE' ) then + typenh = 3 + nbenac = nbteac +c + else + write (ulsort,texte(langue,4)) choix + codret = 1 + endif +c +c 1.2. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c + ltrav1 = nbenac + call gmalot ( ntrav1, 'entier ', 2*ltrav1, ptrav1, codre1 ) + call gmalot ( ntrav2, 'reel ', nbenac, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', nbenac, ptrav3, codre3 ) + call gmalot ( ntrav4, 'reel ', nbenac, ptrav4, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 1.3. ==> Preparation de l'affichage +c + uldeb = min(ulsost,ulsort) + ulfin = max(ulsost,ulsort) + ulpas = max ( 1 , ulfin-uldeb ) +c +c==== +c 2. recherche des qualites globales +c==== +c + if ( codret.eq.0 ) then +c +cgn write (ulsost,90002) 'typenh',typenh +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05A', nompro +#endif + call utb05a ( typenh, + > coonoe, somare, + > hettri, aretri, + > famtri, cfatri, + > hetqua, arequa, + > famqua, cfaqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > jaux, + > nbeexa, + > imem(ptrav1), imem(ptrav1+ltrav1), + > rmem(ptrav2), rmem(ptrav4), + > ulsost, + > ulsort, langue, codret ) +c +cgn write (ulsost,90002) 'nbeexa',nbeexa +cgn do 31 , iaux = 1 , nbeexa +cgn write (ulsost,*) imem(ptrav1+iaux-1), rmem(ptrav2+iaux-1) +cgn 31 continue +c + endif +c +c==== +c 3. tri +c==== +c + if ( codret.eq.0 ) then +c + if ( nbeexa.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTRIR', nompro +#endif + call uttrir ( imem(ptrav3), vmin, vmax, + > nbeexa, rmem(ptrav2), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. affichage +c==== +c + if ( codret.eq.0 ) then +c + do 40 , ulecr = uldeb , ulfin, ulpas +c + if ( nbeexa.ne.0 ) then +c + if ( nbenti.lt.0 ) then + ideb = nbeexa + ifin = max(1,nbeexa+nbenti+1) + ipas = -1 + write (ulecr,texte(langue,5)) mess14(langue,3,typenh) + else + ideb = 1 + ifin = min(nbeexa,nbenti) + ipas = 1 + write (ulecr,texte(langue,6)) mess14(langue,3,typenh) + endif +c + write (ulecr,10000) + write (ulecr,texte(langue,8)) + write (ulecr,texte(langue,9)) + write (ulecr,10000) + if ( typenh.eq.2 ) then + do 41 , iaux = ideb, ifin, ipas + jaux = imem(ptrav3+iaux-1) + write (ulecr,10001) imem(ptrav1+jaux-1), + > ntreca(imem(ptrav1+jaux-1)), rmem(ptrav2+jaux-1) + 41 continue + elseif ( typenh.eq.3 ) then + do 42 , iaux = ideb, ifin, ipas + jaux = imem(ptrav3+iaux-1) + write (ulecr,10001) imem(ptrav1+jaux-1), + > nteeca(imem(ptrav1+jaux-1)), rmem(ptrav2+jaux-1) + 42 continue + elseif ( typenh.eq.4 ) then + do 43 , iaux = ideb, ifin, ipas + jaux = imem(ptrav3+iaux-1) + write (ulecr,10001) imem(ptrav1+jaux-1), + > nqueca(imem(ptrav1+jaux-1)), rmem(ptrav2+jaux-1) + 43 continue + endif + write (ulecr,10000) +c + else +c + write (ulecr,texte(langue,10)) +c + endif +c + 40 continue +c + endif +c +c==== +c 5. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) + call gmlboj ( ntrav4, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve0.F b/src/tool/Information/infve0.F new file mode 100644 index 00000000..f36ef6bd --- /dev/null +++ b/src/tool/Information/infve0.F @@ -0,0 +1,653 @@ + subroutine infve0 ( action, numblo, numniv, numfic, + > infsup, typcof, typcop, typbor, optnoe, + > porpay, zoom, triedr, + > nbcham, nocham, + > nomcha, nomcmp, nrocha, nrocmp, nrotab, + > coonoe, + > somare, np2are, hetare, merare, + > posifa, facare, + > aretri, hettri, nivtri, nintri, + > voltri, pypetr, + > famtri, + > arequa, hetqua, nivqua, ninqua, + > volqua, pypequ, + > famqua, + > nnoeca, nareca, ntreca, nqueca, + > nnoeho, ntreho, nqueho, + > lgnoin, lgtrin, lgquin, + > nnoein, ntrein, nquein, + > decanu, + > anglex, angley, anglez, + > xyzmiz, xyzmaz, vafomi, vafoma, + > tbaux1, tbaux2, + > nublfa, nubnvo, + > ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier VEctoriel - Trace +c -- - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . action . e . char8 . action en cours . +c . numblo . e . 1 . numero du bloc a tracer . +c . . . . 0 : trace du domaine global . +c . numniv . e . 1 . numero du niveau a tracer . +c . . . . -1 : tous les niveaux . +c . numfic . es . 1 . numero du fichier a ecrire . +c . infsup . e . 1 . information supplementaire a afficher . +c . . . . 0 : aucune . +c . . . . 1 : numero homard des noeuds . +c . . . . 2 : numero du calcul des noeuds . +c . . . . 3 : numero homard des faces . +c . . . . 4 : numero du calcul des faces . +c . . . . 5 : numero homard des aretes . +c . . . . 6 : numero du calcul des aretes . +c . . . . np : choix n et choix p simultanement . +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 4 : idem 2, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . typcop . e . 1 . type de coloriage du perimetre des faces . +c . . . . 0 : pas de trace . +c . . . . 2 : noir . +c . . . . 4 : niveau de la face . +c . typbor . e . 1 . type d'affichage du bord . +c . . . . 0 : pas de trace . +c . . . . 1 : trace en rouge . +c . . . . 2 : trace en noir . +c . optnoe . e . 1 . 0 : rien de special . +c . . . . 1 : trace d'un rond vide sur chaque noeud . +c . . . . 2 : trace d'un rond plein sur chaque noeud . +c . porpay . e . 1 . 0 : portrait/paysage selon la taille . +c . . . . 1 : portrait . +c . . . . 2 : paysage . +c . zoom . e . 1 . vrai ou faux selon zoom ou non . +c . triedr . e . 1 . 0 : pas de trace du triedre . +c . . . . 1 : trace du triedre . +c . nbcham . e . 1 . nombre de champs definis . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nomcha . e . char64 . nom du champ retenu pour le coloriage . +c . nomcmp . e . 1 . nom de la composante retenue . +c . nrocha . e . 1 . nunero du champ retenu pour le coloriage . +c . . . . -1 si coloriage selon la qualite . +c . nrocmp . e . 1 . numero de la composante retenue . +c . nrotab . e . 1 . numero du tableau associe au pas de temps . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . merare . e . nbarto . mere de chaque arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . s .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . famtri . e . nbtrto . famille des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . s .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . famqua . e . nbquto . famille des quadrangles . +c . nnoeca . e . renoto . noeuds en entree dans le calcul . +c . nareca . e . rearto . nro des aretes dans le calcul en entree . +c . ntreca . e . retrto . nro des triangles dans le calcul en entree . +c . nqueca . e . requto . nro des quads dans le calcul en entree . +c . nnoeho . e . renoto . nro des noeuds dans HOMARD en entree . +c . ntreho . e . retrto . nro des triangles dans HOMARD en entree . +c . nqueho . e . requto . nro des quads dans HOMARD en entree . +c . decanu . e . -1:7 . decalage des numerotations selon le type . +c . anglex . e . 1 . angle de rotation autour de x . +c . angley . e . 1 . angle de rotation autour de y . +c . anglez . e . 1 . angle de rotation autour de z . +c . xyzmiz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales de la fenetre de zoom . +c . xyzmaz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales de la fenetre de zoom . +c . vafomi . e . 1 . minimum de l'echelle de la fonction . +c . vafoma . e . 1 . maximum de l'echelle de la fonction . +c . tbaux1 . e . nbftri/. donne un numero equivalent a une famille . +c . . . nbfqua . selon que l'orientation est gardee ou non . +c . nublfa . e .-nbquto:. numero de blocs des faces . +c . . . nbtrto . . +c . nubnvo . e . * . . si numblo>0 : numero de blocs des volumes. +c . . . . . si numniv >=0 : niveau des volumes . +c . . . . Rangement : . +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +#include "envada.h" +#include "nomber.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer ulsost + integer numblo, numniv,numfic + integer infsup, typcof, typcop, typbor, optnoe, porpay, triedr + integer nbcham + integer nrocha, nrocmp, nrotab + integer somare(2,nbarto) + integer np2are(nbarto), merare(nbarto), hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer nintri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer famtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer ninqua(nbquto) + integer volqua(2,nbquto), pypequ(2,*) + integer famqua(nbquto) + integer nnoeca(renoto) + integer nareca(rearto), ntreca(retrto), nqueca(requto) + integer nnoeho(*), ntreho(*), nqueho(*) + integer lgnoin, lgtrin, lgquin + integer nnoein(*), ntrein(*), nquein(*) + integer decanu(-1:7) + integer tbaux1(*), tbaux2(-nbquto:*) + integer nublfa(-nbquto:nbtrto), nubnvo(*) +c + double precision anglex, angley, anglez + double precision xyzmiz(sdim), xyzmaz(sdim) + double precision vafomi, vafoma +c + logical zoom +c + character*8 action + character*8 nocham(nbcham) + character*16 nomcmp + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nuroul, lnomfl + integer ptrav1, ptrav2 + integer nbquvi, nbtrvi, nbarvi + integer adquvi, adtrvi, adarvi + integer adquva, adtrva + integer lgtit1, lgtit2 +c + integer codre1, codre2, codre3 + integer codre0 +c + character*8 saux08 + character*8 noquvi, notrvi, noarvi + character*8 noquva, notrva + character*8 ntrav1, ntrav2 + character*20 titre0 + character*100 titre1, titre2 + character*200 nomflo +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Trace du domaine global'')' + texte(1,5) = '(/,''Trace du bloc numero'',i6)' + texte(1,6) = '(''Trace de tous les niveaux'')' + texte(1,7) = '(''Trace du niveau numero'',i6)' + texte(1,9) = '(''Nombre de '',a,'' a visualiser :'',i10)' + texte(1,10) = '(''titre'',i1,'' : '',a)' + texte(1,11) = '(''Projection'')' + texte(1,12) = '(''Caracterisation de la fonction'')' + texte(1,18) = '(''Action en cours : '',a)' + texte(1,20) = '(/,''Creation du fichier Xfig numero'',i4)' +c + texte(2,4) = '(/,''Writings of the whole domain)' + texte(2,5) = '(/,''Writings for the block #'',i6)' + texte(2,6) = '(''Writings of all the levels'')' + texte(2,7) = '(''Writings for the level #'',i6)' + texte(2,9) = '(''Number of '',a,'' to be drawn :'',i10)' + texte(2,10) = '(''titre'',i1,'' : '',a)' + texte(2,11) = '(''Projection'')' + texte(2,12) = '(''Characteristics of function'')' + texte(2,18) = '(''Current action : '',a)' + texte(2,20) = '(/,''Creation of Xfig file #'',i4)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( numblo.eq.0 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) numblo + endif + if ( numniv.eq.-1 ) then + write (ulsort,texte(langue,6)) + else + write (ulsort,texte(langue,7)) numniv + endif + write (ulsort,texte(langue,18)) action +#endif +c +c==== +c 2. recherche des elements et transformations des coordonnees +c ce travail est a faire pour tous les types de sorties +c==== +c +c 2.1. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c +c tableau nnarvi + iaux = 6*nbarto + call gmalot ( noarvi, 'entier ', iaux, adarvi, codre1 ) +c +c tableau nntrvi + iaux = 10*nbtrac + call gmalot ( notrvi, 'entier ', iaux, adtrvi, codre2 ) +c +c tableau nnquvi + iaux = 12*nbquac + call gmalot ( noquvi, 'entier ', iaux, adquvi, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 2.2. ==> creation de la liste des elements visualisables +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE2', nompro +#endif + call infve2 ( coonoe, + > somare, np2are, + > hetare, merare, + > posifa, facare, + > aretri, hettri, nivtri, nintri, + > voltri, pypetr, + > famtri, + > arequa, hetqua, nivqua, ninqua, + > volqua, pypequ, + > famqua, + > infsup, typbor, tbaux1, + > zoom, xyzmiz, xyzmaz, + > tbaux2, + > numniv, numblo, nublfa, nubnvo, + > imem(adquvi), nbquvi, + > imem(adtrvi), nbtrvi, + > imem(adarvi), nbarvi, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,1), nbarvi + write (ulsort,texte(langue,9)) mess14(langue,3,2), nbtrvi + write (ulsort,texte(langue,9)) mess14(langue,3,4), nbquvi +#endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( noarvi, adarvi, 6, 6, nbarto, nbarvi, codre1 ) + call gmmod ( notrvi, adtrvi, 10, 10, nbtrac, nbtrvi, codre2 ) + call gmmod ( noquvi, adquvi, 12, 12, nbquac, nbquvi, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 2.3. ==> projection selon l'angle de vue desire +c ("trav1" contient la liste "coopro" des coordonnees +c projetees des noeuds) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) +#endif +c +c tableau coopro + iaux = 3*(nbnoto+12) + call gmalot ( ntrav1, 'reel ', iaux, ptrav1, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE3', nompro +#endif + call infve3 ( coonoe, + > anglex, angley, anglez, + > zoom, triedr, xyzmiz, xyzmaz, + > rmem(ptrav1), + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> determination de la fonction +c + if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) +#endif +c +c tableau notrva + call gmalot ( notrva, 'reel ', nbtrvi, adtrva, codre1 ) +c +c tableau noquva + call gmalot ( noquva, 'reel ', nbquvi, adquva, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3.1. ==> recherche des valeurs du champ +c + if ( nrotab.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFFRE', nompro +#endif + call inffre ( iaux, rmem(adtrva), rmem(adquva), titre0, + > nocham(nrocha), nrocmp, nrotab, + > nbtrvi, nbquvi, + > imem(adtrvi), imem(adquvi), + > nnoeca, ntreca, nqueca, + > nnoeho, ntreho, nqueho, + > lgnoin, lgtrin, lgquin, + > nnoein, ntrein, nquein, + > decanu, + > ulsort, langue, codret ) +c + endif +c + else +c +c 2.3.2. ==> recherche des qualites +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE4', nompro +#endif + call infve4 ( rmem(adtrva), rmem(adquva), + > coonoe, somare, aretri, arequa, + > nbtrvi, nbquvi, + > imem(adtrvi), imem(adquvi), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. ecriture du maillage sous forme xfig +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. ecriture du maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + numfic = numfic + 1 +c + write (ulsort,texte(langue,20)) numfic + if ( ulsost.ne.ulsort ) then + write (ulsost,texte(langue,20)) numfic + endif +c +c 6.1 ==> ouverture du fichier +c + if ( codret.eq.0 ) then +c +c 12345678 + saux08 = ' ' + if ( action(1:7).eq.'info_av' ) then + saux08(1:4) = 'avad' + elseif ( action(1:7).eq.'info_ap' ) then + saux08(1:4) = 'apad' + endif + iaux = -6 + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux08, nbiter, numfic, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> titres +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE6', nompro +#endif + call infve6 ( action, numblo, numniv, + > infsup, typcof, + > nomcha, nomcmp, nrocha, + > titre0, + > titre1, lgtit1, titre2, lgtit2, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 1, titre1 + write (ulsort,texte(langue,10)) 2, titre2 +#endif +c +c 6.3. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c +c tableau liste pour pppmai + iaux = nbtrvi + nbquvi + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 6.4. ==> trace +c + if ( codret.eq.0 ) then +c + jaux = porpay +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'PPPXMA', nompro +#endif +c + call pppxma ( + > infsup, typcof, typcop, typbor, optnoe, + > jaux, zoom, triedr, + > degre, sdim, mailet, nivsup, + > titre1(1:lgtit1), titre2(1:lgtit2), + > nbarvi, nbtrvi, nbquvi, + > imem(adarvi), imem(adtrvi), imem(adquvi), + > rmem(ptrav1), imem(ptrav2), + > nnoeca, nareca, ntreca, nqueca, + > rmem(adtrva), rmem(adquva), vafomi, vafoma, + > nuroul, nomflo, lnomfl, ulsost, + > ulsort, langue, codret ) +c + endif +c +c 6.5. ==> fermeture du fichier +c + if ( codret.eq.0 ) then +c + call gufeul ( nuroul , codret) +c + endif +c + endif +c +c==== +c 7. menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( noarvi, codre1 ) + call gmlboj ( notrvi, codre2 ) + call gmlboj ( noquvi, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) then +c + call gmlboj ( notrva, codre1 ) + call gmlboj ( noquva, codre2 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +cgn stop +c + end diff --git a/src/tool/Information/infve1.F b/src/tool/Information/infve1.F new file mode 100644 index 00000000..96609c9f --- /dev/null +++ b/src/tool/Information/infve1.F @@ -0,0 +1,1114 @@ + subroutine infve1 ( option, + > typcof, typcop, typbor, optnoe, + > porpay, triedr, + > anglex, angley, anglez, + > zoom, xyzmiz, xyzmaz, + > vafomi, vafoma, + > xyzmin, xyzmax, xyzeps, + > nbcham, nocham, + > nomcha, nomcmp, nrocha, nrocmp, nrotab, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers VEctoriel - 1ere partie +c -- - -- - +c ______________________________________________________________________ +c +c but : determination des choix pour les fichiers +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . s . 1 . 0 : on ne sort aucun fichier . +c . . . . 1 : sortie graphique sans numero . +c . . . . 2 : graphique et numero homard des noeuds . +c . . . . 3 : graphique et numero du calcul des noeud. +c . . . . 4 : graphique et numero homard des faces . +c . . . . 5 : graphique et numero du calcul des faces. +c . . . . 6 : graphique et numero homard des aretes . +c . . . . 7 : graphique et numero du calcul des aret . +c . . . . np : choix n et choix p simultanement . +c . . . . negatif : par blocs connexes . +c . . . . positif : tout le maillage . +c . . . . 100+positif : tout le maillage par niveau . +c . typcof . s . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 4 : idem 2, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . typcop . s . 1 . type de coloriage du perimetre des faces . +c . . . . 0 : pas de trace . +c . . . . 1 : pas de trace et bord rouge . +c . . . . 2 : noir . +c . . . . 3 : noir et bord rouge . +c . . . . 4 : niveau de la face . +c . typbor . s . 1 . type d'affichage du bord . +c . . . . 0 : pas de trace . +c . . . . 1 : trace en rouge . +c . . . . 2 : trace en noir . +c . optnoe . s . 1 . 0 : rien de special . +c . . . . 1 : trace d'un rond vide sur chaque noeud . +c . . . . 2 : trace d'un rond plein sur chaque noeud . +c . porpay . s . 1 . 0 : portrait/paysage selon la taille . +c . . . . 1 : portrait . +c . . . . 2 : paysage . +c . triedr . s . 1 . 0 : pas de trace du triedre . +c . . . . 1 : trace du triedre . +c . anglex . s . 1 . angle de rotation autour de x . +c . angley . s . 1 . angle de rotation autour de y . +c . anglez . s . 1 . angle de rotation autour de z . +c . zoom . s . 1 . vrai ou faux selon zoom ou non . +c . xyzmiz . s . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales de la fenetre de zoom . +c . xyzmaz . s . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales de la fenetre de zoom . +c . vafomi . s . 1 . minimum de l'echelle de la fonction . +c . vafoma . s . 1 . maximum de l'echelle de la fonction . +c . xyzmin . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales du domaine total . +c . xyzmax . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales du domaine total . +c . xyzeps . e . sdim . -1 si min = max dans la direction, . +c . . . . ecart sinon. . +c . nbcham . e . 1 . nombre de champs definis . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . nomcha . s . char64 . nom du champ retenu pour le coloriage . +c . nomcmp . s . 1 . nom de la composante retenue . +c . nrocha . s . 1 . nunero du champ retenu pour le coloriage . +c . . . . -1 si coloriage selon la qualite . +c . nrocmp . s . 1 . numero de la composante retenue . +c . nrotab . s . 1 . numero du tableau associe au pas de temps . +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE1' ) +c +#include "nblang.h" +#include "esutil.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "gmenti.h" +#include "gmstri.h" +#include "infini.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + integer option + integer typcof, typcop, typbor, optnoe, porpay, triedr + integer ulfido, ulenst, ulsost + integer nbcham + integer nrocha, nrocmp, nrotab +c + double precision anglex, angley, anglez + double precision xyzmin(sdim), xyzmax(sdim), xyzeps(sdim) + double precision xyzmiz(sdim), xyzmaz(sdim) + double precision vafomi, vafoma +c + logical zoom + logical abssol +c + character*8 nocham(nbcham) + character*16 nomcmp + character*64 nomcha +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbsign + integer typsig(3), valent(3) +c + character*1 xyz(3) + character*1 rep01 + character*2 valcha(3) + character*80 chaine +c + integer iaux + integer iaux1, iaux2, iaux3 +c + double precision daux1, daux2, daux3 + double precision angle1, angle2, angle3 +c + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca +c + integer adtrav, lgtrav +c + character*2 saux02 + character*8 saux08 + character*16 saux16 + character*64 saux64 +c + integer nbmess + parameter ( nbmess = 110 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisation +c + data xyz / 'x' , 'y' , 'z' / +c_______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''0 : aucun fichier'')' + texte(1,5) = '(''1 : maillage seul'')' + texte(1,6) = '(''2 : avec numero HOMARD des noeuds'')' + texte(1,7) = '(''3 : avec numero du calcul des noeuds'')' + texte(1,8) = '(''4 : avec numero HOMARD des faces'')' + texte(1,9) = '(''5 : avec numero du calcul faces'')' + texte(1,10) = '(''6 : avec numero HOMARD des aretes'')' + texte(1,11) = '(''7 : avec numero du calcul aretes'')' + texte(1,12) = '(''8 : avec numero HOMARD pour tout'')' + texte(1,13) = '(''9 : avec numero du calcul pour tout'')' + texte(1,17) = '(''si >0, tout le domaine de calcul'')' + texte(1,18) = '(''si <0, par bloc connexe'')' + texte(1,19) = + > '(''si 100+>0, tout le domaine de calcul, par niveau'')' + texte(1,20) = '(''Option non disponible'',/)' + texte(1,25) = '(/,''Taille et orientation de l''''image :'')' + texte(1,26) = '(''0 : A4 portrait ou paysage selon la taille'')' + texte(1,27) = '(''1 : A4 portrait'')' + texte(1,28) = '(''2 : A4 paysage'')' + texte(1,29) = '(''Format non disponible'',/)' + texte(1,30) = '(/,''Couleur des faces :'')' + texte(1,31) = '(''0 : incolore transparent'')' + texte(1,32) = '(''1 : incolore opaque'')' + texte(1,33) = '(''2 : selon famille HOMARD'')' + texte(1,35) = '(''4 : idem 2, en N&B'')' + texte(1,37) = '(''6 : selon la qualite'')' + texte(1,38) = '(''7 : selon un champ solution'')' + texte(1,39) = '(''10 : selon niveau'')' + texte(1,40) = '(/,''Couleur des perimetres des faces :'')' + texte(1,41) = '(''0 : incolore'')' + texte(1,43) = '(''2 : noir'')' + texte(1,45) = '(''4 : selon niveau'')' + texte(1,50) = '(''Quel choix de champ ?'')' + texte(1,51) = '(''La norme ou une composante ?'')' + texte(1,51) = '(''Quelle composante ?'')' + texte(1,52) = '(''Quel numero de pas de temps ?'')' + texte(1,58) = '(''Le champ ou sa valeur absolue ? (ch/va)'')' + texte(1,59) = + > '(''Repondre ch pour le champ, va pour sa valeur absolue.'')' + texte(1,60) = '(''Quel type de coloriage ?'')' + texte(1,61) = '(''1 ! avec une echelle automatique'')' + texte(1,62) = '(''2 ! avec une echelle fixe'')' + texte(1,63) = '(''3 ! idem 1 en N&B'')' + texte(1,64) = '(''4 ! idem 2 en N&B'')' + texte(1,65) = '(''Donner le min et le max pour l''''echelle'')' + texte(1,66) = '(''Le min est plus grand que le max ?'')' + texte(1,67) = '(''min = '',g15.7,'' max = '',g15.7)' + texte(1,71) = + > '(''Donner les trois angles de rotation pour la vision.'')' + texte(1,72) = '(''Suggestion : x y z'')' + texte(1,73) = '('' '',3g11.3)' + texte(1,74) = + > '(''ATTENTION : les limites pour les angles de vue sont :'')' + texte(1,75) = + > '(''[-180:180] pour la rotation autour de chaque axe.'')' + texte(1,81) = '(/,''Avec zoom ? (o/n) '')' + texte(1,82) = '(''Donner le min et le max pour '',a1,'' :'')' + texte(1,83) = '(''Domaine : min/max = '',2g15.7)' + texte(1,84) = '(''Le zoom est hors du domaine.'')' + texte(1,85) = + > '(''min domaine = '',g15.7,'' max zoom = '',g15.7)' + texte(1,86) = + > '(''max domaine = '',g15.7,'' min zoom = '',g15.7)' + texte(1,90) = '(/,''Affichage des bords du domaine :'')' + texte(1,91) = '(''0 : non'')' + texte(1,92) = '(''1 : noir'')' + texte(1,93) = '(''2 : rouge'')' + texte(1,100) = '(/,''Des cercles pour les noeuds :'')' + texte(1,101) = '(''0 : non'')' + texte(1,102) = '(''1 : cercles incolores'')' + texte(1,103) = '(''2 : cercles pleins'')' + texte(1,110) = '(/,''On trace le triedre ? (o/n) '')' +c + texte(2,4) = '(''0 : no file'')' + texte(2,5) = '(''1 : mesh only'')' + texte(2,6) = '(''2 : with node HOMARD numbers'')' + texte(2,7) = '(''3 : with node extern numbers'')' + texte(2,8) = '(''4 : with face HOMARD numbers'')' + texte(2,9) = '(''5 : with face extern numbers'')' + texte(2,10) = '(''6 : with edge HOMARD numbers'')' + texte(2,11) = '(''7 : with edge extern numbers'')' + texte(2,12) = '(''8 : with HOMARD numbers for all'')' + texte(2,13) = '(''9 : with extern numbers for all'')' + texte(2,17) = '(''if >0, the whole calculation domain'')' + texte(2,18) = '(''if <0, by connex part'')' + texte(2,19) = + > '(''if 100+>0, the whole calculation domain, by level'')' + texte(2,20) = '(''Option still not available'',/)' + texte(2,25) = '(/,''Image size and orientation :'')' + texte(2,26) = + > '(''0 : A4 portrait or landscape, according to size'')' + texte(2,27) = '(''1 : A4 portrait'')' + texte(2,28) = '(''2 : A4 landscape'')' + texte(2,29) = '(''Size still not available'',/)' + texte(2,30) = '(/,''Face coloring :'')' + texte(2,31) = '(''0 : no color with transparency'')' + texte(2,32) = '(''1 : no color with opacity'')' + texte(2,33) = '(''2 : by HOMARD family'')' + texte(2,35) = '(''4 : as #2, B&W'')' + texte(2,37) = '(''6 : by quality'')' + texte(2,38) = '(''7 : by value of solution'')' + texte(2,39) = '(''1 : by level'')' + texte(2,40) = '(/,''Color of boundaries of the faces :'')' + texte(2,41) = '(''0 : no color'')' + texte(2,43) = '(''2 : black'')' + texte(2,45) = '(''4 : by level'')' + texte(2,50) = '(''What is your choice for the field ?'')' + texte(2,51) = '(''Norm or a component ?'')' + texte(2,51) = '(''What is your choice for the component ?'')' + texte(2,52) = '(''What is your choice for the time step ?'')' + texte(2,58) = '(''Field or absolute value ? (ch/va)'')' + texte(2,59) = + > '(''Answer ch for the field, va for its abslute value.'')' + texte(2,60) = '(''Which coloring ?'')' + texte(2,61) = '(''1 ! automatic scaling'')' + texte(2,62) = '(''2 ! fixed scaling'')' + texte(2,63) = '(''3 ! as #1,but B&W'')' + texte(2,64) = '(''4 ! as #2,but B&W'')' + texte(2,65) = '(''Give min and max for scaling'')' + texte(2,66) = '(''Min is higher than max ?'')' + texte(2,67) = '(''min = '',g15.7,'' max = '',g15.7)' + texte(2,71) = '(''Give the three angles of rotation :'')' + texte(2,72) = '(''Suggestion : x y z'')' + texte(2,73) = '('' '',3g11.3)' + texte(2,74) = '(''CAUTION : limits for the angles are :'')' + texte(2,75) = '(''[-180:180] for rotation around each axis.'')' + texte(2,81) = '(/,''Zoom ? (y/n) '')' + texte(2,82) = '(''Give min and max for '',a1,'' :'')' + texte(2,83) = '(''Domain : min/max = '',2g15.7)' + texte(2,84) = '(''Zoom is out of the domain.'')' + texte(2,85) = + > '(''min domain = '',g15.7,'' max zoom = '',g15.7)' + texte(2,86) = + > '(''max domain = '',g15.7,'' min zoom = '',g15.7)' + texte(2,90) = '(/,''Boundaries of the domain :'')' + texte(2,91) = '(''0 : no'')' + texte(2,92) = '(''1 : black'')' + texte(2,93) = '(''2 : red'')' + texte(2,100) = '(/,''Circles around the nodes :'')' + texte(2,101) = '(''0 : no'')' + texte(2,102) = '(''1 : empty circles'')' + texte(2,103) = '(''2 : fll circles'')' + texte(2,110) = '(/,''Are axes plotted ? (y/n) '')' +c +10000 format(a) +10080 format(a80) +11000 format(i10) +c +c 1.2. ==> initialisation d'une fenetre de zoom infinie +c + do 11 , iaux1 = 1 , sdim +c + xyzmiz(iaux1) = -vinfpo + xyzmaz(iaux1) = vinfpo +c + 11 continue +c +c==== +c 2. questions - reponses pour l'option +c==== +c + 20 continue +c +c 2.1. ==> interactivite +c + write (ulsost,texte(langue,4)) + write (ulsost,texte(langue,5)) + write (ulsost,texte(langue,6)) + write (ulsost,texte(langue,7)) + write (ulsost,texte(langue,8)) + write (ulsost,texte(langue,9)) + write (ulsost,texte(langue,10)) + write (ulsost,texte(langue,11)) + write (ulsost,texte(langue,12)) + write (ulsost,texte(langue,13)) + write (ulsost,texte(langue,17)) + write (ulsost,texte(langue,18)) + write (ulsost,texte(langue,19)) +c + call dmflsh ( iaux ) + read (ulenst,10080,err=20,end=20) chaine +c +c 2.2. ==> decoupage de la chaine +c + call utqure ( chaine, + > nbsign, typsig, valcha, valent, + > ulsort, langue, codret ) +cgn write(ulsort,*) typsig +cgn write(ulsort,*) valcha +cgn write(ulsort,*) valent +c + if ( nbsign.eq.0 ) then + goto 20 + elseif ( typsig(1).ne.0 ) then + goto 20 + endif +c +c 2.4. ==> decodage et validation du choix +c + option = valent(1) +c + if ( option.lt.-9 .or. + > ( option.gt.9 .and. option.lt.101 ) .or. + > option.gt.109 ) then + write (ulsost,texte(langue,20)) + goto 20 + endif +c + call utlgut ( iaux, chaine, + > ulsort, langue, codret ) + write(ulfido,1000) chaine(1:iaux) +c +c==== +c 3. questions - reponses pour la mise en page +c==== +c +cgn if ( option .ne. 0 ) then +c +cgn 30 continue +c +c 3.1. ==> interactivite +c +cgn write (ulsost,texte(langue,25)) +cgn write (ulsost,texte(langue,26)) +cgn write (ulsost,texte(langue,27)) +cgn write (ulsost,texte(langue,28)) +c +cgn call dmflsh ( iaux ) +cgn read (ulenst,10080,err=30,end=30) chaine +c +c 3.2. ==> iaux1 = place du premier caractere non-blanc +c +cgn iaux1 = 0 +cgn do 321 , i = 1 , 80 +cgn if ( chaine(i:i).ne.' ' ) then +cgn iaux1 = i +cgn goto 322 +cgn endif +cgn 321 continue +c +cgn 322 continue +cgn if ( iaux1.eq.0 ) then +cgn goto 30 +cgn endif +c +c 3.3. ==> iaux2 = place du dernier caractere non-blanc du choix +c +cgn iaux3 = iaux1 + 1 +cgn iaux2 = 0 +cgn do 331 , i = iaux3 , 80 +cgn if ( chaine(i:i).eq.' ' ) then +cgn iaux2 = i-1 +cgn goto 34 +cgn endif +cgn 331 continue +c +cgn goto 30 +c +c 3.4. ==> decodage du choix +c +cgn 34 continue +c +cgn fmtent = '(I )' +cgn if ( iaux2-iaux1+1.lt.10 ) then +cgn write(fmtent(3:3),'(i1)') iaux2-iaux1+1 +cgn else +cgn write(fmtent(3:4),'(i2)') iaux2-iaux1+1 +cgn endif +cgn call dmflsh ( iaux ) +cgn read (chaine(iaux1:iaux2),fmtent) porpay +c +cgn if ( porpay.lt.0 .or. +cgn > porpay.gt.3 ) then +cgn write (ulsost,texte(langue,29)) +cgn goto 30 +cgn endif +c +cgn endif +c + porpay = 0 +c==== +c 4. questions - reponses pour les angles +c==== +c + if ( option.ne.0 ) then +c +c 4.1. ==> si le probleme est plan, on se place a la perpendiculaire +c + if ( sdim.le.2 .or. xyzeps(3).lt.0.d0 ) then + anglex = 0.d0 + angley = 0.d0 + anglez = 0.d0 +c + elseif ( xyzeps(1).lt.0.d0 ) then + anglex = 0.d0 + angley = 90.d0 + anglez = 0.d0 +c + elseif ( xyzeps(2).lt.0.d0 ) then + anglex = -90.d0 + angley = 0.d0 + anglez = 0.d0 +c + else +c +c 4.2. ==> cas 3D +c + anglex = -60.d0 + angley = 30.d0 + anglez = 0.d0 +c + 42 continue +c + write (ulsost,texte(langue,71)) + write (ulsost,texte(langue,72)) + write (ulsost,texte(langue,73)) anglex, angley, anglez +c + call dmflsh ( iaux ) + read (ulenst,*,err=42,end=42) angle1, angle2, angle3 +c + if ( (angle1.lt.-180.d0) .or. (angle1.gt.180.d0) + > .or. (angle2.lt.-180.d0) .or. (angle2.gt.180.d0) + > .or. (angle3.lt.-180.d0) .or. (angle3.gt.180.d0) ) then + write(ulsost,texte(langue,74)) + write(ulsost,texte(langue,75)) + goto 42 + else + anglex = angle1 + angley = angle2 + anglez = angle3 + write(ulfido,1200) angle1, angle2, angle3 + endif +c + endif +c + endif +c +c==== +c 5. questions - reponses pour le zoom +c si on ne veut pas de zoom, on ne fait rien sur les dimensions +c de la fenetre car elles sont initialisees a des valeurs extremes +c==== +c + if ( option.ne.0 ) then +c +c 5.1. ==> veut-on un zoom ? +c + 51 continue +c + write (ulsost,texte(langue,81)) +c + call dmflsh ( iaux ) + read (ulenst,*,err=51,end=51) rep01 +c + if ( rep01.eq.'o' .or. rep01.eq.'O' .or. + > rep01.eq.'y' .or. rep01.eq.'Y' ) then + zoom = .true. + elseif ( rep01.eq.'n' .or. rep01.eq.'N' ) then + zoom = .false. + else + goto 51 + endif +c + write(ulfido,1000) rep01 +c +c 5.2. ==> Si on veut le zoom, on demande les dimensions de la fenetre +c Il faut etendre legerement cette fenetre, sinon on risque de +c perdre des valeurs du fait des erreurs d'arrondi sur les +c coordonnees +c Quand une coordonnee est constante, on prend une fenetre de +c zoom egale a cette constante dans cette direction. Cela +c permet de passer sans envombre les projections. +c + if ( zoom ) then +c + do 52 , iaux1 = 1 , sdim +c + daux1 = xyzmax(iaux1)-xyzmin(iaux1) +c + if ( daux1.gt.zeroma ) then +c + 520 continue +c + write (ulsost,texte(langue,82)) xyz(iaux1) + write (ulsost,texte(langue,83)) xyzmin(iaux1),xyzmax(iaux1) +c + call dmflsh ( iaux ) + read (ulenst,*,err=520,end=520) xyzmiz(iaux1), xyzmaz(iaux1) +c + if ( xyzmaz(iaux1).le.xyzmin(iaux1) ) then + write(ulsost,texte(langue,84)) + write(ulsost,texte(langue,85)) xyzmin(iaux1),xyzmaz(iaux1) + goto 520 + endif +c + if ( xyzmiz(iaux1).ge.xyzmax(iaux1) ) then + write(ulsost,texte(langue,84)) + write(ulsost,texte(langue,86)) xyzmax(iaux1),xyzmiz(iaux1) + goto 520 + endif +c + if ( xyzmaz(iaux1).lt.xyzmiz(iaux1) ) then + write(ulsost,texte(langue,87)) + write(ulsost,texte(langue,88)) xyzmiz(iaux1),xyzmaz(iaux1) + goto 520 + endif +c + write(ulfido,1200) xyzmiz(iaux1), xyzmaz(iaux1) +c + if ( xyzeps(iaux1).lt.0.d0 ) then + xyzmiz(iaux1) = xyzmiz(iaux1) - 1.d0 + xyzmaz(iaux1) = xyzmaz(iaux1) + 1.d0 + else + if ( xyzmiz(iaux1).gt.0.d0 ) then + xyzmiz(iaux1) = xyzmiz(iaux1)*0.999d0 + elseif ( xyzmiz(iaux1).lt.0 ) then + xyzmiz(iaux1) = xyzmiz(iaux1)*1.001d0 + else + xyzmiz(iaux1) = -xyzeps(iaux1)*0.001d0 + endif + if ( xyzmaz(iaux1).gt.0.d0 ) then + xyzmaz(iaux1) = xyzmaz(iaux1)*1.001d0 + elseif ( xyzmaz(iaux1).lt.0.d0 ) then + xyzmaz(iaux1) = xyzmaz(iaux1)*0.999d0 + else + xyzmaz(iaux1) = xyzeps(iaux1) + endif + endif +c + else +c + xyzmiz(iaux1) = xyzmin(iaux1) + xyzmaz(iaux1) = xyzmax(iaux1) +c + endif +c + 52 continue +c + endif +c + endif +c +c==== +c 6. questions - reponses pour le triedre +c==== +c + if ( option.ne.0 ) then +c +c 6.1. ==> on repere si le triedre est grosso modo dans l'enveloppe +c du maillage a traiter +c + iaux2 = 1 +c + do 61 , iaux1 = 1 , sdim +c + if ( zoom ) then + daux1 = xyzmiz(iaux1) + daux2 = xyzmaz(iaux1) + else + daux1 = xyzmin(iaux1) + daux2 = xyzmax(iaux1) + endif + daux3 = daux2 - daux1 +c + if ( daux3.gt.epsima ) then +c + daux3 = 0.1d0 * daux3 +c + if ( daux1-daux3 .gt. 0.d0 ) then + iaux2 = 0 + endif +c + if ( daux2+daux3 .lt. 0.d0 ) then + iaux2 = 0 + endif +c + endif +c + 61 continue +c +c 6.2. ==> veut-on tracer le triedre ? +c + if ( iaux2.eq.0 ) then +c + triedr = 0 +c + else +c + 62 continue +c + write (ulsost,texte(langue,110)) +c + call dmflsh ( iaux ) + read (ulenst,*,err=62,end=62) rep01 +c + if ( rep01.eq.'o' .or. rep01.eq.'O' .or. + > rep01.eq.'y' .or. rep01.eq.'Y' ) then + triedr = 1 + elseif ( rep01.eq.'n' .or. rep01.eq.'N' ) then + triedr = 0 + else + goto 62 + endif +c + write(ulfido,1000) rep01 +c + endif +c + endif +c +c==== +c 7. questions - reponses pour les couleurs +c==== +c + if ( option.ne.0 ) then +c +c 7.1. ==> interieur des faces +c + 71 continue +c +c 7.1.1. ==> choix general pour l'interieur des faces +c + if ( codret.eq.0 ) then +c + write (ulsost,texte(langue,30)) + write (ulsost,texte(langue,31)) + write (ulsost,texte(langue,32)) + write (ulsost,texte(langue,33)) + write (ulsost,texte(langue,35)) + write (ulsost,texte(langue,37)) + if ( nbcham.eq.0 ) then + iaux1 = 6 + else + iaux1 = 7 + write (ulsost,texte(langue,38)) + endif + if ( rafdef.ne.0 ) then + write (ulsost,texte(langue,39)) + endif +c + endif +c + call dmflsh ( iaux ) + read (ulenst,*,err=71,end=71) typcof +c +c 7.1.2. ==> controle +c + if ( typcof.eq.10 ) then + if ( rafdef.eq.0 ) then + goto 71 + endif + else + if ( typcof.lt.0 .or. typcof.gt.iaux1 .or. + > typcof.eq.3 .or. typcof.eq.5 ) then + goto 71 + endif + endif + write(ulfido,1102) typcof +c +c 7.1.3. ==> precision quand on colorie selon la qualite ou une fonction +c + if ( typcof.eq.6 .or. typcof.eq.7 ) then +c +c 7.1.3.1. ==> le champ +c 7.1.3.1.1. ==> la qualite +c + if ( typcof.eq.6 ) then +c + abssol = .false. + nrocha = -1 +c + else +c +c 7.1.3.1.2. ==> un vrai champ +c + typcof = 6 +c +c 7.1.3.1.2.1. ==> choix du champ a representer +c + 7131 continue +c + write (ulsost,texte(langue,50)) +c + do 71311 , iaux1 = 1 , nbcham +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + saux08 = nocham(iaux1) + call utcach ( saux08, + > saux64, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + write (ulsost,10000) saux64 +c + endif +c +71311 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=7131,end=7131) nomcha +c + call utlgut ( iaux2, nomcha, + > ulsort, langue, codret ) +c + do 71312 , iaux1 = 1 , nbcham +c + if ( codret.eq.0 ) then +c + saux08 = nocham(iaux1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( saux08, + > saux64, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( iaux3, saux64, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( iaux2.eq.iaux3 ) then + if ( nomcha(1:iaux2).eq.saux64(1:iaux2) ) then + nrocha = iaux1 + write(ulfido,1000) nomcha(1:iaux2) + goto 7132 + endif + endif +c + endif +c +71312 continue +c + goto 7131 +c +c 7.1.3.1.2.2. ==> choix de la composante a representer +c + 7132 continue +c + if ( nbcomp.eq.1 ) then +c + nrocmp = 1 + nomcmp = smem(adnocp+8)//smem(adnocp+9) +c + else +c +71321 continue +c + write (ulsost,texte(langue,51)) +c +cgn write (ulsost,10000) 'norme' + do 71322 , iaux1 = 1 , nbcomp + write (ulsost,10000) smem(adnocp+7+2*iaux1-1)// + > smem(adnocp+7+2*iaux1) +71322 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=7132,end=7132) nomcmp + call utlgut ( iaux2, nomcmp, + > ulsort, langue, codret ) +c +cgn do 71323 , iaux1 = 0 , nbcomp + do 71323 , iaux1 = 1 , nbcomp +c + saux16 = blan16 + if ( iaux1.eq.0 ) then + iaux3 = 5 + saux16(1:iaux3) = 'norme' + else + call utlgut ( iaux3, smem(adnocp+7+2*iaux1-1), + > ulsort, langue, codret ) + saux16(1:iaux3) = smem(adnocp+7+2*iaux1-1)(1:iaux3) + if ( iaux3.eq.8 ) then + call utlgut ( iaux3, smem(adnocp+7+2*iaux1), + > ulsort, langue, codret ) + if ( iaux3.gt.0 ) then + saux16(9:8+iaux3) = smem(adnocp+7+2*iaux1)(1:iaux3) + iaux3 = iaux3 + 8 + endif + endif + endif +c + if ( iaux2.eq.iaux3 ) then + if ( nomcmp(1:iaux2).eq.saux16(1:iaux2) ) then + nrocmp = iaux1 + write(ulfido,1000) nomcmp + goto 7133 + endif + endif +71323 continue +c + goto 71321 +c + endif +c +c 7.1.3.1.2.3. ==> choix du pas de temps a representer +c + 7133 continue +c + if ( nbtvch.eq.1 ) then +c + nrotab = 1 +c + else +c + call gmalot ( saux08, 'entier ', 2*nbtvch, adtrav, codret ) +c +71331 continue +c + lgtrav = 0 + do 71332 , iaux1 = 1 , nbtvch + iaux3 = imem(adcaen+nbinec*(iaux1-1)+1) + do 71333 , iaux2 = 1 , lgtrav + if ( imem(adtrav+iaux2-1).eq.iaux3 ) then + goto 71332 + endif +71333 continue + imem(adtrav+lgtrav) = iaux3 + imem(adtrav+nbtvch+lgtrav) = iaux1 + lgtrav = lgtrav + 1 +71332 continue + if ( lgtrav.eq.1 ) then + nrotab = 1 + goto 71336 + endif +c + write (ulsost,texte(langue,52)) +c + do 71324 , iaux1 = 1 , lgtrav + write (ulsost,11000) imem(adtrav+iaux1-1) +71324 continue +c + call dmflsh ( iaux ) + read (ulenst,*,err=71331,end=71331) iaux2 +c + do 71335 , iaux1 = 1 , lgtrav +c + if ( iaux2.eq.imem(adtrav+iaux1-1) ) then + nrotab = imem(adtrav+nbtvch+iaux1-1) + write(ulfido,1115) iaux2 + goto 71336 + endif +71335 continue +c + goto 71331 +c +71336 continue +c + call gmlboj ( saux08, codret ) +c + endif +c +c 7.1.3.1.2.4. ==> le champ ou sa valeur absolue +c + 7134 continue +c + write (ulsost,texte(langue,58)) + call dmflsh ( iaux ) + read (ulenst,*,err=7134,end=7134) saux02 + if ( saux02.eq.'ch' ) then + abssol = .false. + elseif ( saux02.eq.'va' ) then + abssol = .true. + else + write (ulsost,texte(langue,59)) + goto 7134 + endif + write(ulfido,1000) saux02 +c + endif +c +c 7.1.3.2. ==> type de coloriage +c + 7135 continue +c + write (ulsost,texte(langue,60)) + write (ulsost,texte(langue,61)) + write (ulsost,texte(langue,62)) + write (ulsost,texte(langue,63)) + write (ulsost,texte(langue,64)) + call dmflsh ( iaux ) + read (ulenst,*,err=7135,end=7135) iaux1 + if ( iaux1.le.0 .or. iaux1.ge.5 ) then + goto 7135 + endif + write(ulfido,1101) iaux1 +c + typcof = typcof + iaux1 - 1 + if ( abssol ) then + typcof = - typcof + endif +c +c 7.1.3.6. ==> valeurs extremes si echelle fixe +c + if ( abs(typcof).eq.7 .or. abs(typcof).eq.9 ) then +c + 7136 continue +c + write (ulsost,texte(langue,65)) + call dmflsh ( iaux ) + read (ulenst,*,err=7136,end=7136) vafomi, vafoma + if ( vafoma.le.vafomi ) then + write(ulsost,texte(langue,66)) + write(ulsost,texte(langue,67)) vafomi, vafoma + goto 7136 + endif + write(ulfido,1200) vafomi, vafoma +c + endif +c + endif +c +c 7.2. ==> perimetre des faces +c + 72 continue +c + write (ulsost,texte(langue,40)) + if ( typcof.ne.0 ) then + iaux1 = 0 + write (ulsost,texte(langue,41)) + else + iaux1 = 2 + endif + write (ulsost,texte(langue,43)) + if ( rafdef.eq.0 ) then + iaux2 = 3 + else + write (ulsost,texte(langue,45)) + iaux2 = 4 + endif +c + call dmflsh ( iaux ) + read (ulenst,*,err=72,end=72) typcop +c + if ( typcop.lt.iaux1 .or. typcop.gt.iaux2 .or. + > typcop.eq.1 .or. typcop.eq.3 ) then + goto 72 + endif + write(ulfido,1101) typcop +c +c 7.3. ==> Trace du bord externe +c + 73 continue +c + write (ulsost,texte(langue,90)) + write (ulsost,texte(langue,91)) + write (ulsost,texte(langue,92)) + write (ulsost,texte(langue,93)) +c + call dmflsh ( iaux ) + read (ulenst,*,err=73,end=73) typbor +c + if ( typbor.lt.0 .or. typbor.gt.2 ) then + goto 73 + endif + write(ulfido,1101) typbor +c +c 7.4. ==> ronds autour des noeuds +c + 74 continue +c + write (ulsost,texte(langue,100)) + write (ulsost,texte(langue,101)) + write (ulsost,texte(langue,102)) + write (ulsost,texte(langue,103)) +c + call dmflsh ( iaux ) + read (ulenst,*,err=74,end=74) optnoe +c + if ( optnoe.lt.0 .or. optnoe.gt.2 ) then + goto 74 + endif + write(ulfido,1101) optnoe +c + endif +c + write(ulfido,1000) ' ' +c + 1000 format(a) + 1101 format(i1) + 1102 format(i2) + 1115 format(i15) + 1200 format(5g15.6) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve2.F b/src/tool/Information/infve2.F new file mode 100644 index 00000000..fd8af50c --- /dev/null +++ b/src/tool/Information/infve2.F @@ -0,0 +1,862 @@ + subroutine infve2 ( coonoe, + > somare, np2are, hetare, merare, + > posifa, facare, + > aretri, hettri, nivtri, nintri, + > voltri, pypetr, + > famtri, + > arequa, hetqua, nivqua, ninqua, + > volqua, pypequ, + > famqua, + > infsup, typbor, tbaux1, + > zoom, xyzmiz, xyzmaz, + > tbaux2, + > numniv, numblo, nublfa, nubnvo, + > nnquvi, nbquvi, + > nntrvi, nbtrvi, + > nnarvi, nbarvi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier VEctoriel - 2eme partie +c -- - -- - +c ______________________________________________________________________ +c +c determination de la liste des noeuds des faces et aretes a visualiser +c +c remarque : en sortie, on dispose de la liste des noeuds +c decrivant une face a visualiser par ses noeuds. +c la numerotation precedente des faces correspondantes est +c oubliee, et une nouvelle numerotation est disponible +c par defaut grace a l'ordre de sortie des triplets/quadruplets. +c idem pour les aretes isolees +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . merare . e . nbarto . mere de chaque arete . +c . np2are . e . nbarto . numero du noeud p2 milieu de l'arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . nintri . e . nbtrto . noeud interne au triangle . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . famtri . e . nbtrto . famille des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . ninqua . e . nbquto . noeud interne au quadrangle . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . famqua . e . nbquto . famille des quadrangles . +c . infsup . e . 1 . information supplementaire a afficher . +c . . . . 0 : aucune . +c . . . . 1 : numero homard des noeuds . +c . . . . 2 : numero du calcul des noeuds . +c . . . . 3 : numero homard des faces . +c . . . . 4 : numero du calcul des faces . +c . . . . 5 : numero homard des aretes . +c . . . . 6 : numero du calcul des aretes . +c . . . . np : choix n et choix p simultanement . +c . typbor . e . 1 . type d'affichage du bord . +c . . . . 0 : pas de trace . +c . . . . 1 : trace en rouge . +c . . . . 2 : trace en noir . +c . tbaux1 . e . nbftri/. donne un numero equivalent a une famille . +c . . . nbfqua . selon que l'orientation est gardee ou non . +c . zoom . e . 1 . vrai ou faux selon zoom ou non . +c . xyzmiz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales de la fenetre de zoom . +c . xyzmaz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales de la fenetre de zoom . +c . tbaux2 . es .-nbquto:. tableau de travail . +c . . .nbt/arto. . +c . numniv . e . 1 . numero du niveau a tracer . +c . . . . -1 : tous les niveaux . +c . numblo . e . 1 . numero du bloc a tracer . +c . . . . 0 : trace du domaine global . +c . nublfa . e .-nbquto:. numero de blocs des faces . +c . . . nbtrto . . +c . nubnvo . e . * . . si numblo>0 : numero de blocs des volumes. +c . . . . . si numniv >=0 : niveau des volumes . +c . . . . Rangement : . +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . nnquvi . s .12nbquac. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . nbquvi . s . 1 . nombre de quadrangles a visualiser . +c . nntrvi . s .10nbtrac. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nbtrvi . s . 1 . nombre de triangles a visualiser . +c . nnarvi . s .6*nbarto. niveau et numero des aretes a visualiser . +c . . . . liste des noeuds des aretes a visualiser . +c . nbarvi . s . 1 . nombre d'aretes visualisables . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "envada.h" +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto) + integer np2are(nbarto), merare(nbarto), hetare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto) + integer nintri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer famtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto) + integer ninqua(nbquto) + integer volqua(2,nbquto), pypequ(2,*) + integer famqua(nbquto) + integer tbaux2(-nbquto:*) + integer nnquvi(12,nbquac), nbquvi + integer nntrvi(10,nbtrac), nbtrvi + integer numniv + integer numblo, nublfa(-nbquto:nbtrto), nubnvo(*) + integer nnarvi(6,nbarto), nbarvi + integer infsup, typbor, tbaux1(*) +c + double precision xyzmiz(sdim), xyzmaz(sdim) +c + logical zoom +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1 + integer larete, letria, lequad, noeudf(4) + integer iaux, jaux, kaux, laux + integer infsu1, infsu2, infsu3 + logical avoir +c +#ifdef _DEBUG_HOMARD_ + double precision daux(sdim) +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' a tracer :'',i10)' +c + texte(2,4) = '(''Number of '',a,'' for plotting:'',i10)' +c +#include "impr03.h" +c +c a priori, on ne trace rien +c + nbarvi = 0 + nbtrvi = 0 + nbquvi = 0 +c +c==== +c 2. Recherche des faces a tracer : +c On trace une face seulement si elle est active et +c . si elle appartient a une region bidimensionnelle du maillage, et +c si elle appartient au bloc ou au niveau retenu +c . si elle est une face ayant un et un seul element volumique +c voisin, et si ce volume appartient au bloc ou au niveau retenu +c . si elle est une face ayant deux elements volumiques voisins, +c et si un et un seul des volumes appartient au bloc ou au niveau +c retenu +c +c La convention est la suivante : +c * tbaux2(iaux) vaut 0 si la face est d'une region 2D, du bloc ou +c du niveau retenu +c * tbaux2(iaux) vaut 1 si la face borde un domaine volumique, du +c bloc ou du niveau retenu +c * tbaux2(iaux) vaut 2 si la face est interne a un domaine +c volumique, un et un seul des voisins appartenant au bloc ou au +c niveau retenu +c * tbaux2(iaux) vaut -1 sinon +c On tracera donc pour tbaux2(iaux) >= 0 +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. recherche des faces a tracer' +#endif +c +c 2.1. ==> A priori, on ne retient rien +c + do 21 , iaux = -nbquto, nbtrto + tbaux2(iaux) = -1 + 21 continue +c +c 2.2. ==> En l'absence de mailles 3D +c + if ( nbteto.eq.0 .and. nbheto.eq.0 .and. + > nbpyto.eq.0 .and. nbpeto.eq.0 ) then +c +c 2.2.1. ==> Pour tout le domaine et sans tenir compte des niveaux, on +c se contente de filtrer sur les actives / inactives +c + if ( numblo.eq.0 .and. numniv.eq.-1 ) then +c + do 221 , iaux = -nbquto, -1 + if ( mod(hetqua(-iaux),100).eq.0 ) then + tbaux2(iaux) = 0 + endif + 221 continue +c + do 212 , iaux = 1, nbtrto + if ( mod(hettri(iaux),10).eq.0 ) then + tbaux2(iaux) = 0 + endif + 212 continue +c +c 2.1.2. ==> Avec un bloc, on filtre aussi sur ce bloc +c + elseif ( numblo.gt.0 ) then +c + do 213 , iaux = -nbquto, -1 + if ( mod(hetqua(-iaux),100).eq.0 ) then + if ( nublfa(iaux).eq.numblo ) then + tbaux2(iaux) = 0 + endif + endif + 213 continue +c + do 214 , iaux = 1, nbtrto + if ( mod(hettri(iaux),10).eq.0 ) then + if ( nublfa(iaux).eq.numblo ) then + tbaux2(iaux) = 0 + endif + endif + 214 continue +c +c 2.1.2. ==> Avec un niveau, on filtre aussi sur ce niveau +c + else +c + do 215 , iaux = -nbquto, -1 + if ( mod(hetqua(-iaux),100).eq.0 ) then + if ( nivqua(iaux).eq.numniv ) then + tbaux2(iaux) = 0 + endif + endif + 215 continue +c + do 216 , iaux = 1, nbtrto + if ( mod(hettri(iaux),10).eq.0 ) then + if ( nivtri(iaux).eq.numniv ) then + tbaux2(iaux) = 0 + endif + endif + 216 continue +c + endif +c + endif +c +c 2.2 ==> En presence d'elements volumiques +c 2.2.1. ==> Les triangles +c + if ( codret.eq.0 ) then +c + if ( nbteto.gt.0 .or. nbpyto.gt.0 .or. nbpeto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE5_tr', nompro +#endif + iaux = 2 + call infve5 ( iaux, nbtrto, voltri, pypetr, + > hettri, + > numniv, numblo, nubnvo, + > tbaux2, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.2. ==> Les quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbheto.gt.0 .or. nbpyto.gt.0 .or. nbpeto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE5_qu', nompro +#endif + iaux = 4 + call infve5 ( iaux, nbquto, volqua, pypequ, + > hetqua, + > numniv, numblo, nubnvo, + > tbaux2, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. caracteristiques associees aux triangles a tracer +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. caracteristiques des tria a tracer' +#endif +c +c 3.1. ==> prealable : on etablit le tableau de correspondance des +c familles. +c on indique simplement le numero de la famille. +c +c iaux : numero de la famille en cours d'examen +c jaux : nombre de familles equivalentes etablies +c kaux : numero des familles a comparer +c laux : numero des codes a comparer +c famille courante iaux +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbftri + tbaux1(iaux) = iaux + 31 continue +c + do 30 , letria = 1 , nbtrto +c + if ( tbaux2(letria).ge.0 ) then +c + avoir = .true. +c +c 3.2. ==> on cherche les sommets +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + noeudf(1) = sa1a2 + noeudf(2) = sa2a3 + noeudf(3) = sa3a1 +c +c 3.3. ==> on cherche si au moins un des noeuds est a l'interieur +c de la fenetre de zoom +c + if ( zoom ) then +c + avoir = .false. +c + do 33 , iaux = 1 , 3 + kaux = 0 + do 331 , jaux = 1 , sdim + if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and. + > coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then + kaux = kaux + 1 + endif + 331 continue + if ( kaux.eq.sdim ) then + avoir = .true. + goto 332 + endif + 33 continue +c + 332 continue +c + endif +c +c 3.4. ==> Si le triangle est retenu, filtrage eventuel pour deboggage +c +#ifdef _DEBUG_HOMARD_ + if ( avoir ) then +c + do 34 , jaux = 1 , sdim + daux(jaux) = 0.d0 + do 341 , iaux = 1 , 3 + daux(jaux) = daux(jaux) + coonoe(noeudf(iaux),jaux) + 341 continue + daux(jaux) = daux(jaux)/3.d0 + 34 continue +cgn print *,daux +c + if ( abs(daux(1)-6.d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(1)-4.d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(2)-1.5d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(3)-0.0d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(3)-1.5d-2).lt.1.d-5 ) then + avoir = .false. + endif +c + endif +#endif +c +c 3.5. ==> Si le triangle est retenu, on le memorise ainsi que +c son niveau, sa famille, et on stocke ses trois sommets. +c En degre 2, on stocke les 3 noeuds milieux. Attention a +c les placer en coherence avec l'ordre des sommets ... +c + if ( avoir ) then +c + nbtrvi = nbtrvi + 1 +c + nntrvi(1,nbtrvi) = nivtri(letria) + nntrvi(2,nbtrvi) = letria + nntrvi(3,nbtrvi) = noeudf(1) + nntrvi(4,nbtrvi) = noeudf(2) + nntrvi(5,nbtrvi) = noeudf(3) + nntrvi(6,nbtrvi) = tbaux1(famtri(letria)) + if ( degre.eq.2 ) then + nntrvi(7,nbtrvi) = np2are(aretri(letria,2)) + nntrvi(8,nbtrvi) = np2are(aretri(letria,3)) + nntrvi(9,nbtrvi) = np2are(aretri(letria,1)) + endif + if ( mod(mailet,2).eq.0 ) then + nntrvi(10,nbtrvi) = nintri(letria) + endif +c + endif +c + endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrvi +#endif +c + endif +c +c==== +c 4. caracteristiques associees aux quadrangles a tracer +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. caracteristiques des quad a tracer' +#endif +c + if ( codret.eq.0 ) then +c +c 4.1. ==> prealable : on etablit le tableau de correspondance des +c familles. +c on indique simplement le numero de la famille. +c +c iaux : numero de la famille en cours d'examen +c jaux : nombre de familles equivalentes etablies +c kaux : numero des familles a comparer +c laux : numero des codes a comparer +c famille courante iaux +c + do 41 , iaux = 1 , nbfqua + tbaux1(iaux) = iaux + 41 continue +c + do 40 , lequad = 1 , nbquto +c + if ( tbaux2(-lequad).ge.0 ) then +c + avoir = .true. +c +c 4.2. ==> on cherche les sommets +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + noeudf(1) = sa1a2 + noeudf(2) = sa2a3 + noeudf(3) = sa3a4 + noeudf(4) = sa4a1 +c +c 4.3. ==> on cherche si au moins un des noeuds est a l'interieur +c de la fenetre de zoom +c + if ( zoom ) then +c + avoir = .false. +c + do 43 , iaux = 1 , 4 + kaux = 0 + do 431 , jaux = 1 , sdim + if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and. + > coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then + kaux = kaux + 1 + endif + 431 continue + if ( kaux.eq.sdim ) then + avoir = .true. + goto 432 + endif + 43 continue +c + 432 continue +c + endif +c +c 4.4. ==> Si le quadrangle est retenu, filtrage eventuel pour deboggage +c +#ifdef _DEBUG_HOMARD_ + if ( avoir ) then +c + do 44 , jaux = 1 , sdim + daux(jaux) = 0.d0 + do 441 , iaux = 1 , 4 + daux(jaux) = daux(jaux) + coonoe(noeudf(iaux),jaux) + 441 continue + daux(jaux) = daux(jaux)/4.d0 + 44 continue +c + if ( abs(daux(1)-6.d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(1)-4.d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(2)-1.5d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(3)-0.0d-2).lt.1.d-5 ) then + avoir = .false. + elseif ( abs(daux(3)-1.5d-2).lt.1.d-5 ) then + avoir = .false. + endif +c + endif +#endif +c +c 4.5. ==> Si le quadrangle est retenu, on le memorise ainsi que +c son niveau, sa famille, et on stocke ses quatre sommets. +c En degre 2, on stocke les 4 noeuds milieux. Attention a +c les placer en coherence avec l'ordre des sommets ... +c + if ( avoir ) then +c + nbquvi = nbquvi + 1 +cgn write (ulsort,*) 'quadrangle ',lequad,' de niveau ',nivqua(lequad) +c + nnquvi(1,nbquvi) = nivqua(lequad) + nnquvi(2,nbquvi) = lequad + nnquvi(3,nbquvi) = noeudf(1) + nnquvi(4,nbquvi) = noeudf(2) + nnquvi(5,nbquvi) = noeudf(3) + nnquvi(6,nbquvi) = noeudf(4) + nnquvi(7,nbquvi) = tbaux1(famqua(lequad)) + if ( degre.eq.2 ) then + nnquvi( 8,nbquvi) = np2are(arequa(lequad,2)) + nnquvi( 9,nbquvi) = np2are(arequa(lequad,3)) + nnquvi(10,nbquvi) = np2are(arequa(lequad,4)) + nnquvi(11,nbquvi) = np2are(arequa(lequad,1)) + endif + if ( mod(mailet,3).eq.0 ) then + nnquvi(12,nbquvi) = ninqua(lequad) + endif +c + endif +c + endif +c + 40 continue + +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquvi +#endif +c + endif +c +c==== +c 5. recherche des aretes a tracer si on a demande le trace des bords +c +c Une arete a tracer a au plus une face voisine +c +c la convention est la suivante : +c * tbaux2(iaux) vaut 0 si l'arete est isolee et est active ; +c * tbaux2(iaux) vaut 1 si l'arete est un bord de face active ; +c * tbaux2(iaux) vaut 2 sinon. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. recherche des aretes a tracer' +#endif +c + if ( numblo.eq.0 .and. numniv.eq.-1 ) then +c + if ( codret.eq.0 ) then +c +c 5.1. ==> on repere les aretes isolees actives ; pour les autres, on +c les oublie +c + do 51 , larete = 1 , nbarto +cgn print *,hetare(larete),posifa(larete-1),posifa(larete) + if ( mod(hetare(larete),10).eq.0 .and. + > posifa(larete).eq.posifa(larete-1) ) then + tbaux2(larete) = 0 + else + tbaux2(larete) = 2 + endif +cgn print *,'===> tbaux2(,',larete,') = ',tbaux2(larete) + 51 continue +c +c 5.2. ==> recherche des bords eventuels de faces actives +c attention aux voisinages multiples dus aux conformites +c + if ( typbor.gt.0 ) then +c + do 521 , larete = 1 , nbarto + jaux = 0 + do 522 , iaux = posifa(larete-1)+1, posifa(larete) + kaux = facare(iaux) + if ( kaux.gt.0 ) then + if ( mod(hettri(kaux),10).eq.0 ) then + jaux = jaux + 1 + endif + else + if ( mod(hetqua(-kaux),100).eq.0 ) then + jaux = jaux + 1 + endif + endif + 522 continue + if ( jaux.eq.1 ) then + tbaux2(larete) = 1 + endif + 521 continue +c + endif +c + endif +c + endif +c +c==== +c 6. recherche des noeuds associes aux aretes retenues +c methode : on boucle sur toutes les aretes retenues en ne +c considerant que les actives. +c pour celles-la, on recupere les 2 sommets +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. recherche des noeuds associes aux aretes' +#endif +c + if ( ( numblo.eq.0 .and. numniv.eq.-1 ) .or. + > ( typbor.gt.0 ) ) then +c + if ( codret.eq.0 ) then +c + infsu1 = mod(infsup,10) + if ( infsup.ge.10 ) then + iaux = ( infsup-infsu1 ) / 10 + infsu2 = mod(iaux,10) + if ( iaux.ge.10 ) then + infsu3 = ( iaux-infsu2 ) / 10 + else + infsu3 = 0 + endif + else + infsu2 = 0 + infsu3 = 0 + endif +c + if ( ( infsu1.ge.5 .and. infsu1.le.6 ) .or. + > ( infsu2.ge.5 .and. infsu2.le.6 ) .or. + > ( infsu3.ge.5 .and. infsu3.le.6 ) ) then + laux = 1 + else + laux = 0 + endif +c + avoir = .true. + do 60 , larete = 1 , nbarto +c +c dans le cas ou l'arete "est active" et "est a tracer" +c + if ( tbaux2(larete).le.1 .or. + > ( laux.eq.1 .and. mod(hetare(larete),10).eq.0 ) ) then +c +c 6.1. ==> on memorise les deux noeuds +c + noeudf(1) = somare ( 1, larete ) + noeudf(2) = somare ( 2, larete ) +c +c 6.3. ==> on cherche si au moins un des noeuds est a l'interieur +c de la fenetre de zoom +c + if ( zoom ) then +c + avoir = .false. +c + do 62 , iaux = 1 , 2 + kaux = 0 + do 621 , jaux = 1 , sdim + if ( coonoe(noeudf(iaux),jaux).ge.xyzmiz(jaux) .and. + > coonoe(noeudf(iaux),jaux).le.xyzmaz(jaux) ) then + kaux = kaux + 1 + endif + 621 continue + if ( kaux.eq.sdim ) then + avoir = .true. + goto 622 + endif + 62 continue +c + 622 continue +c + endif +c +c 6.4. ==> Si l'arete est retenue, on la memorise, ainsi que son niveau +c et ses noeuds extremes. +c En degre 2, on stocke le noeud milieu +c + if ( avoir ) then +c + nbarvi = nbarvi + 1 +c + jaux = larete + do 64 , iaux = 0 , nivsup + if ( merare(jaux).eq.0 ) then + nnarvi(1,nbarvi) = iaux + goto 641 + endif + jaux = merare(jaux) + 64 continue + 641 continue + nnarvi(2,nbarvi) = larete + nnarvi(3,nbarvi) = noeudf(1) + nnarvi(4,nbarvi) = noeudf(2) + nnarvi(5,nbarvi) = tbaux2(larete) +c if ( tbaux2(larete).eq.1 ) then +c nnarvi(5,nbarvi) = 1 +c else +c nnarvi(5,nbarvi) = 0 +c endif + if ( degre.eq.2 ) then + nnarvi(6,nbarvi) = np2are(larete) + endif +c + endif +c + endif +c + 60 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarvi + endif +#endif +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve3.F b/src/tool/Information/infve3.F new file mode 100644 index 00000000..94a439c2 --- /dev/null +++ b/src/tool/Information/infve3.F @@ -0,0 +1,427 @@ + subroutine infve3 ( coonoe, + > anglex, angley, anglez, + > zoom, triedr, xyzmiz, xyzmaz, + > coopro, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers VEctoriel - 3eme partie +c -- - -- - +c ______________________________________________________________________ +c +c but : calcul des coordonnees projetees selon les angles demandes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . anglex . e . 1 . angle de rotation autour de x . +c . angley . e . 1 . angle de rotation autour de y . +c . anglez . e . 1 . angle de rotation autour de z . +c . zoom . e . 1 . vrai ou faux selon zoom ou non . +c . triedr . e . 1 . 0 : pas de trace du triedre . +c . . . . 1 : trace du triedre . +c . xyzmiz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales de la fenetre de zoom . +c . xyzmaz . e . 1 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales de la fenetre de zoom . +c . coopro . s . 3* . coordonnees projetees de : . +c . . .nbnot+12. le triedre : -8:O ; -9:I ; -10:J ; -11:K . +c . . . . la fenetre de zoom : de -7 a 0 en 3D ou . +c . . . . de -3 a 0 en 2D . +c . . . . les noeuds de 1 a nbnoto . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE3' ) +c +#include "nblang.h" +c +#include "consta.h" +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +#include "precis.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer triedr +c + double precision anglex, angley, anglez + double precision coonoe(nbnoto,sdim) + double precision coopro(3,-11:nbnoto) + double precision xyzmiz(sdim), xyzmaz(sdim) +c + logical zoom +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer noeud +c + double precision anglrx, anglry, anglrz + double precision daux1, daux2 + double precision rotate(3,3), centre(3), taille(3) + double precision pidegr, valmin, valmax +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Angles en degres'')' + texte(1,5) = '(''Matrice de rotation'')' + texte(1,6) = '(''Centre = '',3g12.5)' + texte(1,7) = '(''Taille = '',3g12.5)' +c + texte(2,4) = '(''Angles (degrees)'')' + texte(2,5) = '(''Matrix of the rotation'')' + texte(2,6) = '(''Centre = '',3g12.5)' + texte(2,7) = '(''Size = '',3g12.5)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. En 3D ou si le triedre est demande, calcul des dimensions +c de l'objet +c==== +c + if ( sdim.eq.3 .or. triedr.eq.1 ) then +c + do 21 , iaux = 1 , sdim +c + valmin = coonoe(1,iaux) + valmax = valmin + do 211 , noeud = 2 , nbnoto + valmin = min( coonoe(noeud,iaux), valmin ) + valmax = max( coonoe(noeud,iaux), valmax ) + 211 continue +c + centre(iaux) = ( valmax + valmin ) * unsde + taille(iaux) = valmax - valmin +c + 21 continue + +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) (centre(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,7)) (taille(iaux), iaux = 1 , sdim) +#endif +c + endif +c +c==== +c 3. En 3D, calcul de la tranformation de coordonnees associee a +c une rotation autour de x, puis de y, puis de z +c Attention : l'ordre d'enchainement des rotations est important ! +c Il n'y a pas commutativite ! +c==== +c + if ( sdim.eq.3 ) then +c +c 3.1. ==> transformation des angles de degres en radians +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,92010) anglex, angley, anglez +#endif + pidegr = pi / 180.d0 + anglrx = anglex * pidegr + anglry = angley * pidegr + anglrz = anglez * pidegr +c +c 3.2. ==> calcul prealable de la matrice de rotation +c + rotate(1,1) = cos(anglry) * cos(anglrz) + rotate(2,1) = cos(anglry) * sin(anglrz) + rotate(3,1) = - sin(anglry) +c + rotate(1,2) = sin(anglrx) * sin(anglry) * cos(anglrz) + > - cos(anglrx) * sin(anglrz) + rotate(2,2) = sin(anglrx) * sin(anglry) * sin(anglrz) + > + cos(anglrx) * cos(anglrz) + rotate(3,2) = sin(anglrx) * cos(anglry) +c + rotate(1,3) = cos(anglrx) * sin(anglry) * cos(anglrz) + > + sin(anglrx) * sin(anglrz) + rotate(2,3) = cos(anglrx) * sin(anglry) * sin(anglrz) + > - sin(anglrx) * cos(anglrz) + rotate(3,3) = cos(anglrx) * cos(anglry) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) + do 3333 , iaux = 1 , 3 + write (ulsort,92010) (rotate(iaux,noeud),noeud=1,3) + 3333 continue +#endif +c + endif +c +c==== +c 4. transformation des coordonnees des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. transformation ; codret', codret +#endif +c 4.1. ==> En 1D, transfert du tableau +c + if ( sdim.eq.1 ) then +c + do 41 , noeud = 1 , nbnoto + coopro(1,noeud) = coonoe(noeud,1) + coopro(2,noeud) = 0.d0 + coopro(3,noeud) = 0.d0 + 41 continue +c +c 4.2. ==> En 2D, transfert du tableau +c + elseif ( sdim.eq.2 ) then +c + do 42 , noeud = 1 , nbnoto + coopro(1,noeud) = coonoe(noeud,1) + coopro(2,noeud) = coonoe(noeud,2) + coopro(3,noeud) = 0.d0 + 42 continue +c + elseif ( sdim.eq.3 ) then +c +c 4.3. ==> En 3D, centrage de l'objet puis rotation +c + do 43 , iaux = 1 , sdim + do 431 , noeud = 1 , nbnoto + coopro(iaux,noeud) = + > rotate(iaux,1) * ( coonoe(noeud,1) - centre(1) ) + > + rotate(iaux,2) * ( coonoe(noeud,2) - centre(2) ) + > + rotate(iaux,3) * ( coonoe(noeud,3) - centre(3) ) + 431 continue + 43 continue +c + endif +cgn do 34 , noeud = 1 , nbnoto +cgn print 1797,noeud,(coopro(iaux,noeud),iaux=1,sdim) +cgn 34 continue +cgn 1797 format(i5,' *',6f12.5) +c +c==== +c 5. transformation des coordonnees de la fenetre de zoom +c==== +c + if ( zoom ) then +c + if ( sdim.eq.1 ) then +c + coopro(1,-3) = xyzmiz(1) + coopro(2,-3) = 0.d0 + coopro(3,-3) = 0.d0 + coopro(1,-2) = xyzmaz(1) + coopro(2,-2) = 0.d0 + coopro(3,-2) = 0.d0 + coopro(1,-1) = xyzmaz(1) + coopro(2,-1) = 0.d0 + coopro(3,-1) = 0.d0 + coopro(1, 0) = xyzmiz(1) + coopro(2, 0) = 0.d0 + coopro(3, 0) = 0.d0 +c + elseif ( sdim.eq.2 ) then +c + coopro(1,-3) = xyzmiz(1) + coopro(2,-3) = xyzmiz(2) + coopro(3,-3) = 0.d0 + coopro(1,-2) = xyzmaz(1) + coopro(2,-2) = xyzmiz(2) + coopro(3,-2) = 0.d0 + coopro(1,-1) = xyzmaz(1) + coopro(2,-1) = xyzmaz(2) + coopro(3,-1) = 0.d0 + coopro(1, 0) = xyzmiz(1) + coopro(2, 0) = xyzmaz(2) + coopro(3, 0) = 0.d0 +c + elseif ( sdim.eq.3 ) then +c + do 52 , iaux = 1 , sdim + coopro(iaux,-7) = + > rotate(iaux,1) * ( xyzmiz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmiz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmiz(3) - centre(3) ) + coopro(iaux,-6) = + > rotate(iaux,1) * ( xyzmaz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmiz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmiz(3) - centre(3) ) + coopro(iaux,-5) = + > rotate(iaux,1) * ( xyzmaz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmaz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmiz(3) - centre(3) ) + coopro(iaux,-4) = + > rotate(iaux,1) * ( xyzmiz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmaz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmiz(3) - centre(3) ) + coopro(iaux,-3) = + > rotate(iaux,1) * ( xyzmiz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmiz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmaz(3) - centre(3) ) + coopro(iaux,-2) = + > rotate(iaux,1) * ( xyzmaz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmiz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmaz(3) - centre(3) ) + coopro(iaux,-1) = + > rotate(iaux,1) * ( xyzmaz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmaz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmaz(3) - centre(3) ) + coopro(iaux,0) = + > rotate(iaux,1) * ( xyzmiz(1) - centre(1) ) + > + rotate(iaux,2) * ( xyzmaz(2) - centre(2) ) + > + rotate(iaux,3) * ( xyzmaz(3) - centre(3) ) + 52 continue +c + endif +c + endif +c +c==== +c 6. transformation des coordonnees du triedre +c On a les points classiques : -8:O ; -9:I ; -10:J ; -11:K +c Quand une coordonnee est constante, on prend un point identifie a +c l'origine. Cela evite des traces bizarres apres projection. +c==== +c + if ( triedr.ne.0 ) then +c + if ( sdim.le.2 ) then +c + if ( zoom ) then + daux1 = max(xyzmaz(1)-xyzmiz(1),xyzmaz(2)-xyzmiz(2)) + else + daux1 = max(taille(1),taille(2)) + endif + daux1 = 0.20d0 * daux1 +cgn print *,'=====> daux1 =',daux1 +c + coopro(1, -8) = 0.d0 + coopro(2, -8) = 0.d0 + coopro(1, -9) = daux1 + coopro(2, -9) = 0.d0 + coopro(1,-10) = 0.d0 + coopro(2,-10) = daux1 +c + elseif ( sdim.eq.3 ) then +c + if ( zoom ) then + daux1 = max(xyzmaz(1)-xyzmiz(1), + > xyzmaz(2)-xyzmiz(2), + > xyzmaz(3)-xyzmiz(3)) + else + daux1 = max(taille(1),taille(2),taille(3)) + endif + daux1 = 0.20d0 * daux1 +cgn print *,'=====> daux1 =',daux1 +c + do 61 , iaux = 1 , sdim + coopro(iaux,-8) = + > rotate(iaux,1) * ( 0.d0 - centre(1) ) + > + rotate(iaux,2) * ( 0.d0 - centre(2) ) + > + rotate(iaux,3) * ( 0.d0 - centre(3) ) + if ( taille(1).le.epsima ) then + daux2 = 0.d0 + else + daux2 = daux1 + endif + coopro(iaux,-9) = + > rotate(iaux,1) * ( daux2 - centre(1) ) + > + rotate(iaux,2) * ( 0.d0 - centre(2) ) + > + rotate(iaux,3) * ( 0.d0 - centre(3) ) + if ( taille(2).le.epsima ) then + daux2 = 0.d0 + else + daux2 = daux1 + endif + coopro(iaux,-10) = + > rotate(iaux,1) * ( 0.d0 - centre(1) ) + > + rotate(iaux,2) * ( daux2 - centre(2) ) + > + rotate(iaux,3) * ( 0.d0 - centre(3) ) + if ( taille(3).le.epsima ) then + daux2 = 0.d0 + else + daux2 = daux1 + endif + coopro(iaux,-11) = + > rotate(iaux,1) * ( 0.d0 - centre(1) ) + > + rotate(iaux,2) * ( 0.d0 - centre(2) ) + > + rotate(iaux,3) * ( daux2 - centre(3) ) + 61 continue +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve4.F b/src/tool/Information/infve4.F new file mode 100644 index 00000000..32710047 --- /dev/null +++ b/src/tool/Information/infve4.F @@ -0,0 +1,185 @@ + subroutine infve4 ( fotrva, foquva, + > coonoe, somare, aretri, arequa, + > nbtrvi, nbquvi, + > nntrvi, nnquvi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers VEctoriel - 4eme partie +c -- - -- - +c ______________________________________________________________________ +c +c recherche des qualites +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . fotrva . s . nbtrvi . fonctions triangles : valeur . +c . foquva . s . nbquvi . fonctions quadrangles : valeur . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nbtrvi . e . 1 . nombre triangles visualisables . +c . nbquvi . e . 1 . nombre de quadrangles visualisables . +c . nntrvi . e .10nbtrvi. 1 : niveau du triangle a afficher . +c . . . . 2 : numero HOMARD du triangle . +c . . . . 3, 4, 5 : numeros des noeuds p1 . +c . . . . 6 : famille du triangle . +c . . . . 7, 8, 9 : numeros des noeuds p2 . +c . . . . 10 : numero du noeud interne . +c . nnquvi . e .12nbquvi. 1 : niveau du quadrangle a afficher . +c . . . . 2 : numero HOMARD du quadrangle . +c . . . . 3, 4, 5, 6 : numeros des noeuds p1 . +c . . . . 7 : famille du quadrangle . +c . . . . 8, 9, 10, 11 : numeros des noeuds p2 . +c . . . . 12 : numero du noeud interne . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE4' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer nbtrvi, nbquvi + integer nntrvi(10,nbtrvi) + integer nnquvi(12,nbquvi) + integer somare(2,nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) +c + double precision fotrva(*), foquva(*) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letria, lequad +c + double precision qual, daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Recherche des qualites des mailles'')' +c + texte(2,4) = '(''Research of mesh qualities'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +cgn 1789 format(i4,12f13.6) +c +c==== +c 2. Parcours des differentes mailles +c==== +c 2.1. ==> les triangles +c + do 21 , iaux = 1 , nbtrvi +c + letria = nntrvi(2,iaux) +c + call utqtri ( letria, qual, daux, + > coonoe, somare, aretri ) +c + fotrva(iaux) = qual +cgn print 1789,iaux,fotrva(iaux) +c + 21 continue +c +c 2.2. ==> les quadrangles +c + do 22 , iaux = 1 , nbquvi +c + lequad = nnquvi(2,iaux) +c + call utqqua ( lequad, qual, daux, + > coonoe, somare, arequa ) +c + foquva(iaux) = qual +cgn print 1789,iaux,fotrva(iaux) +c + 22 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve5.F b/src/tool/Information/infve5.F new file mode 100644 index 00000000..47c4e478 --- /dev/null +++ b/src/tool/Information/infve5.F @@ -0,0 +1,411 @@ + subroutine infve5 ( typenh, nbfato, volfac, pypefa, + > hetfac, + > numniv, numblo, nubnvo, + > tbaux2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier VEctoriel - 5eme partie +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . nbfato . e . 1 .nombre de faces total . +c . volfac . e .2*nbfato. numeros des 2 volumes par face . +c . . . . volfac(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre/tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypefa(1/2,j). +c . pypefa . e .2*lgpype. pypefa(1,j) = numero de la pyramide voisine. +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . . . . pypefa(2,j) = numero du pentaedre voisin . +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . hetfac . e . nbfato . historique de l'etat des faces . +c . numniv . e . 1 . numero du niveau a tracer . +c . . . . -1 : tous les niveaux . +c . numblo . e . 1 . numero du bloc a tracer . +c . . . . 0 : trace du domaine global . +c . nubnvo . e . * . . si numblo>0 : numero de blocs des volumes. +c . . . . . si numniv >=0 : niveau des volumes . +c . . . . Rangement : . +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . tbaux2 . es .-nbquto:. tableau de travail . +c . . .nbt/arto. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, nbfato + integer volfac(2,nbfato), pypefa(2,*) + integer hetfac(nbfato) + integer numniv, numblo, nubnvo(*) + integer tbaux2(-nbquto:*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer maxtet, maxhex, maxpyr + integer dectet, dechex, decpyr, decpen, decvol + integer nument, etaent, numen2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Trace du domaine global'')' + texte(1,5) = '(/,''Examen du '',a,'' numero'',i6)' + texte(1,6) = '(''Trace de tous les niveaux'')' + texte(1,7) = '(''Trace du niveau numero'',i6)' + texte(1,8) = '(''Recherche des '',a,'' a tracer'')' +c + texte(2,4) = '(/,''Writings of the whole domain)' + texte(2,5) = '(/,''Examination of '',a,'' #'',i6)' + texte(2,6) = '(''Writings of all the levels'')' + texte(2,7) = '(''Writings for the level #'',i6)' + texte(2,8) = '(''Search of the '',a,'' for plotting'')' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( numblo.eq.0 ) then + write (ulsort,texte(langue,4)) + else + write (ulsort,texte(langue,5)) numblo + endif + if ( numniv.eq.-1 ) then + write (ulsort,texte(langue,6)) + else + write (ulsort,texte(langue,7)) numniv + endif + write (ulsort,texte(langue,8)) mess14(langue,3,typenh) +#endif +c +c 1.2. ==> decalages +c + dectet = 0 + maxtet = dectet + nbteto + dechex = maxtet + maxhex = dechex + nbheto + decpyr = maxhex + maxpyr = decpyr + nbpyto + decpen = maxpyr +c +c 1.3. ==> Particularites selon le type de mailles tria/quad : +c . Diviseur pour trouver l'etat actif +c . Decalage dans la numerotation des volumes +c + if ( typenh.eq.2 ) then + etaent = 10 + decvol = dectet + else + etaent = 100 + decvol = dechex + endif +c +c==== +c 2. Recherche des faces a tracer : +c On trace une face seulement si elle est active et +c . si elle appartient a une region bidimensionnelle du maillage, et +c si elle appartient au bloc ou au niveau retenu +c . si elle est une face ayant un et un seul element volumique +c voisin, et si ce volume appartient au bloc ou au niveau retenu +c . si elle est une face ayant deux elements volumiques voisins, +c et si un et un seul des volumes appartient au bloc ou au niveau +c retenu +c +c La convention est la suivante : +c * tbaux2(iaux) vaut 0 si la face est d'une region 2D, du bloc ou +c du niveau retenu +c * tbaux2(iaux) vaut 1 si la face borde un domaine volumique, du +c bloc ou du niveau retenu +c * tbaux2(iaux) vaut 2 si la face est interne a un domaine +c volumique, un et un seul des voisins appartenant au bloc ou au +c niveau retenu +c * tbaux2(iaux) vaut -1 sinon +c On tracera donc pour tbaux2(iaux) >= 0 +c==== +c +c 2.1. ==> Cas du domaine global avec tous les niveaux +c On examine les faces actives et on retient celles avec au +c plus un voisin +c + if ( numblo.eq.0 .and. numniv.eq.-1 ) then +c + do 21 , iaux = 1, nbfato +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,typenh), iaux + write (ulsort,90002) 'voisins', volfac(1,iaux),volfac(2,iaux) +#endif +c +c . La face est active + if ( mod(hetfac(iaux),etaent).eq.0 ) then +c +c . La face n'a pas deux voisins + if ( volfac(2,iaux).eq.0 ) then +c + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif +c . La face est 2D + if ( volfac(1,iaux).eq.0 ) then + tbaux2(jaux) = 0 +c . La face a un seul voisin + else + tbaux2(jaux) = 1 + endif +c + endif +c + endif +c + 21 continue +c +c 2.2. ==> Cas d'un filtrage par bloc volumique +c On examine les faces actives et on retient celles avec au +c plus un voisin, ce voisin etant du bon bloc +c Remarque : avec deux voisins, le bloc est forcement le meme +c + elseif ( numblo.gt.0 ) then +c + do 22 , iaux = 1, nbfato +c +c . La face est active + if ( mod(hetfac(iaux),etaent).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif + write (ulsort,90002) mess14(langue,2,typenh), iaux, tbaux2(jaux) +#endif +c +c . La face n'a pas deux voisins + if ( volfac(2,iaux).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. voisins',volfac(1,iaux),volfac(2,iaux) +#endif +c +c . La face a un seul voisin + kaux = volfac(1,iaux) + if ( kaux.ne.0 ) then +c +c 2.2.1. ==> reperage du numero d'entite de ce voisin, avec le decalage +c pour le reperage des blocs +c + if ( kaux.gt.0 ) then + nument = decvol + kaux + else + if ( pypefa(1,-kaux).ne.0 ) then + nument = decpyr + pypefa(1,-kaux) + else + nument = decpen + pypefa(2,-kaux) + endif + endif +cgn write (ulsort,90002) +cgn > '. '//mess14(langue,1,3),nument,nubnvo(nument) +c +c 2.2.2. ==> Choix en fonction du bloc du voisin +c + if ( nubnvo(nument).eq.numblo ) then + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif + tbaux2(jaux) = 1 + endif +c + endif +c + endif +c + endif +#ifdef _DEBUG_HOMARD_ + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif + if ( tbaux2(jaux).ne.-1 ) then + write (ulsort,90002) '==> On la trace', tbaux2(jaux) + endif +#endif +c + 22 continue +c +c 2.3. ==> Cas d'un filtrage par niveau +c On examine les faces actives et on retient celles : +c . avec un seul voisin, ce voisin etant du bon niveau +c . avec deux voisins, un et un seul des voisins etant +c du bon niveau +c + else +c + do 23 , iaux = 1, nbfato +c +c . La face est active + if ( mod(hetfac(iaux),etaent).eq.0 ) then +c +c . La face a au moins un voisin + kaux = volfac(1,iaux) + if ( kaux.ne.0 ) then +c +c 2.3.1. ==> reperage du numero d'entite de ce voisin, avec le decalage +c pour le reperage des blocs +c + if ( kaux.gt.0 ) then + nument = decvol + kaux + else + if ( pypefa(1,-kaux).ne.0 ) then + nument = decpyr + pypefa(1,-kaux) + else + nument = decpen + pypefa(2,-kaux) + endif + endif +c +c 2.3.2. ==> . La face a un seul voisin : choix en fonction du niveau +c + laux = volfac(2,iaux) + if ( laux.eq.0 ) then +c + if ( nubnvo(nument).eq.numniv ) then + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif + tbaux2(jaux) = 1 + endif +c +c 2.3.3. ==> . La face a 2 voisins : choix en fonction de leurs niveaux +c + else +c + if ( laux.gt.0 ) then + numen2 = decvol + laux + else + if ( kaux.eq.laux ) then + numen2 = decpen + pypefa(2,-laux) + else + if ( pypefa(1,-laux).ne.0 ) then + numen2 = decpyr + pypefa(1,-laux) + else + numen2 = decpen + pypefa(2,-laux) + endif + endif + endif + if ( nubnvo(nument).eq.numniv .or. + > nubnvo(numen2).eq.numniv ) then + if ( nubnvo(nument).ne.nubnvo(numen2) ) then + if ( typenh.eq.2 ) then + jaux = iaux + else + jaux = -iaux + endif + tbaux2(jaux) = 2 + endif + endif +c + endif +c + endif +c + endif +c + 23 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve6.F b/src/tool/Information/infve6.F new file mode 100644 index 00000000..034226cf --- /dev/null +++ b/src/tool/Information/infve6.F @@ -0,0 +1,416 @@ + subroutine infve6 ( action, numblo, numniv, + > infsup, typcof, + > nomcha, nomcmp, nrocha, + > titre0, + > titre1, lgtit1, titre2, lgtit2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier VEctoriel - 6eme partie +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . action . e . char8 . action en cours . +c . numblo . e . 1 . numero du bloc a tracer . +c . . . . 0 : trace du domaine global . +c . numniv . e . 1 . numero du niveau a tracer . +c . . . . -1 : tous les niveaux . +c . infsup . e . 1 . information supplementaire a afficher . +c . . . . 0 : aucune . +c . . . . 1 : numero homard des noeuds . +c . . . . 2 : numero du calcul des noeuds . +c . . . . 3 : numero homard des faces . +c . . . . 4 : numero du calcul des faces . +c . . . . 5 : numero homard des aretes . +c . . . . 6 : numero du calcul des aretes . +c . . . . np : choix n et choix p simultanement . +c . typcof . e . 1 . type de coloriage des faces . +c . . . . 0 : incolore transparent . +c . . . . 1 : incolore opaque . +c . . . . 2 : famille HOMARD . +c . . . . 4 : idem 2, en niveau de gris . +c . . . . +-6 : couleur selon un champ, echelle auto.. +c . . . . +-7 : idem avec echelle fixe . +c . . . . +-8/+-9 : idem +-6/+-7, en niveau de gris . +c . . . . 10 : niveau . +c . nomcha . e . char64 . nom du champ retenu pour le coloriage . +c . nomcmp . e . 1 . nom de la composante retenue . +c . nrocha . e . 1 . nunero du champ retenu pour le coloriage . +c . . . . -1 si coloriage selon la qualite . +c . titre0 . e . 20 . titre initial . +c . titre1 . s . 100 . titre 1 . +c . lgtit1 . s . 1 . longueur du titre 1 . +c . titre2 . s . 100 . titre 2 . +c . lgtit2 . s . 1 . longueur du titre 2 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca2.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + integer numblo, numniv + integer infsup, typcof + integer nrocha + integer lgtit1, lgtit2 +c + character*8 action + character*16 nomcmp + character*64 nomcha + character*100 titre1, titre2 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + character*8 saux08 + character*20 titre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Action en cours : '',a)' + texte(1,10) = '(''titre'',i1,'' : '',a)' +c + texte(2,4) = '(''Current action : '',a)' + texte(2,10) = '(''titre'',i1,'' : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) action +#endif +c +c==== +c 2. Titres +c==== +c 2.1. ==> Titres vides au depart +c + do 21 , iaux = 1 , 100 + titre1(iaux:iaux) = ' ' + titre2(iaux:iaux) = ' ' + 21 continue +c +c 2.2 ==> Action et numero d'iteration +c 12345678 + saux08 = ' ' + if ( action(1:7).eq.'info_av' ) then + saux08(1:4) = 'avad' + elseif ( action(1:7).eq.'info_ap' ) then + saux08(1:4) = 'apad' + endif +c + call utench ( nbiter, '0', iaux, saux08(6:7), + > ulsort, langue, codret ) +c +c 2.3 ==> Ajout du titre du calcul +c + if ( codret.eq.0 ) then +c + call utlgut ( iaux, titre, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + titre1(1:iaux+11) = saux08//'- '//titre +c + lgtit1 = iaux + 11 +c + endif +c +c 2.4 ==> Bloc eventuel +c + if ( codret.eq.0 ) then +c + if ( numblo.gt.0 ) then +c + call utench ( numblo, 'g', jaux, saux08, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + if ( langue.eq.1 ) then + if ( lgtit1+14+jaux.le.100 ) then + titre1(lgtit1+1:lgtit1+14+jaux) = + > '- Bloc numero '//saux08(1:jaux) +c 12345678901234 + lgtit1 = lgtit1+14+jaux + endif + else + if ( lgtit1+10+jaux.le.100 ) then + titre1(lgtit1+1:lgtit1+10+jaux) = + > '- Block # '//saux08(1:jaux) +c 1234567890 + lgtit1 = lgtit1+10+jaux + endif + endif +c + endif +c + endif +c + endif +c +c 2.5 ==> Niveau eventuel +c + if ( codret.eq.0 ) then +c + if ( numniv.gt.-1 ) then +c + call utench ( numniv, 'g', jaux, saux08, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + if ( langue.eq.1 ) then + if ( iaux+10+jaux.le.100 ) then + titre1(iaux+1:iaux+10+jaux) = + > ' - Niveau '//saux08(1:jaux) +c 1234567890 + iaux = iaux+10+jaux + endif + else + if ( iaux+11+jaux.le.100 ) then + titre1(iaux+1:iaux+11+jaux) = + > ' - Level # '//saux08(1:jaux) +c 12345678901 + iaux = iaux+11+jaux + endif + endif +c + lgtit1 = iaux +c + endif +c + endif +c + endif +c +c 2.6 ==> Complements en fonction des choix retenus pour les couleurs +c + if ( codret.eq.0 ) then +cgn print *,titre1 +cgn print *,'lgtit1 =', lgtit1 +c + if ( ( typcof.ge.2 .and. typcof.le.5 ) .or. + > ( abs(typcof).ge.6 .and. abs(typcof).le.9 ) .or. + > typcof.eq.10 ) then +c + if ( typcof.eq.10 ) then + if ( langue.eq.1 ) then + if ( lgtit1+24.le.100 ) then +c 123456789012345678901234 + titre1(lgtit1+1:lgtit1+24) = ' - Niveau de raffinement' + lgtit1 = lgtit1 + 24 + endif + else + if ( iaux+19.le.100 ) then + titre1(lgtit1+1:lgtit1+19) = ' - Refinement level' + lgtit1 = lgtit1 + 19 + endif + endif + elseif ( typcof.eq.2 .or. typcof.eq.4 ) then + if ( langue.eq.1 ) then + if ( lgtit1+17.le.100 ) then +c 12345678901234567 + titre1(lgtit1+1:lgtit1+17) = ' - Famille HOMARD' + lgtit1 = lgtit1 + 17 + endif + else + if ( lgtit1+16.le.100 ) then + titre1(lgtit1+1:lgtit1+16) = ' - HOMARD family' + lgtit1 = lgtit1 + 16 + endif + endif + else + if ( nrocha.le.0 ) then + if ( langue.eq.1 ) then + if ( lgtit1+10.le.100 ) then +c 1234567890 + titre1(lgtit1+1:lgtit1+10) = ' - Qualite' + lgtit1 = lgtit1 + 10 + endif + else + if ( lgtit1+10.le.100 ) then + titre1(lgtit1+1:lgtit1+10) = ' - Quality' + lgtit1 = lgtit1 + 10 + endif + endif + else + call utlgut ( iaux, nomcha, ulsort, langue, codret ) + jaux = lgtit1 + 3 + iaux + if ( iaux.gt.0 .and. jaux.le.100 ) then + titre1(lgtit1+1:jaux) = ' - '//nomcha(1:iaux) + lgtit1 = jaux + endif + call utlgut ( iaux, nomcmp, ulsort, langue, codret ) + jaux = lgtit1 + 2 + iaux + if ( iaux.gt.0 .and. jaux.le.100 ) then + titre1(lgtit1+1:jaux) = ', '//nomcmp(1:iaux) + lgtit1 = jaux + endif + call utlgut ( iaux, titre0, ulsort, langue, codret ) + jaux = lgtit1 + 1 + iaux + if ( iaux.gt.0 .and. jaux.le.100 ) then + titre1(lgtit1+1:jaux) = ' ' // titre0(1:iaux) + lgtit1 = jaux + endif + endif + endif + endif +c + endif +c +c 2.6 ==> Complements en fonction des choix retenus pour les ecritures +c + if ( codret.eq.0 ) then +c +c 123456789012345678901234567 + if ( infsup.eq.1 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero HOMARD des noeuds' + lgtit2 = 24 + else + titre2 = 'HOMARD # of nodes' + lgtit2 = 17 + endif + elseif ( infsup.eq.2 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero du calcul des noeuds' + lgtit2 = 27 + else + titre2 = 'Extern # of nodes' + lgtit2 = 17 + endif + elseif ( infsup.eq.3 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero HOMARD des faces' + lgtit2 = 23 + else + titre2 = 'HOMARD # of faces' + lgtit2 = 17 + endif + elseif ( infsup.eq.4 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero du calcul des faces' + lgtit2 = 26 + else + titre2 = 'Extern # of faces' + lgtit2 = 17 + endif + elseif ( infsup.eq.5 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero HOMARD des aretes' + lgtit2 = 24 + else + titre2 = 'HOMARD # of edges' + lgtit2 = 17 + endif + elseif ( infsup.eq.6 ) then + if ( langue.eq.1 ) then + titre2 = 'Numero du calcul des aretes' + lgtit2 = 27 + else + titre2 = 'Extern # of edges' + lgtit2 = 17 + endif + else + lgtit2 = 0 + endif +c + if ( lgtit2.ne.0 ) then + titre2(lgtit2+1:lgtit2+3) = ' - ' + lgtit2 = lgtit2 + 3 + endif + call utlgut ( iaux, ladate, ulsort, langue, codret ) + titre2(lgtit2+1:lgtit2+iaux) = ladate + lgtit2 = lgtit2 + iaux +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 1, titre1 + write (ulsort,texte(langue,10)) 2, titre2 +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infve7.F b/src/tool/Information/infve7.F new file mode 100644 index 00000000..a852c435 --- /dev/null +++ b/src/tool/Information/infve7.F @@ -0,0 +1,199 @@ + subroutine infve7 ( nubnvo, + > nivtri, nivqua, + > tritet, quahex, + > facpyr, facpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichier VEctoriel - 7eme partie +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nubnvo . s . * . niveau des volumes . +c . . . . Rangement : . +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . nivtri . e . nbtrto . niveau des triangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVE7' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nubnvo(*) + integer nivtri(nbtrto) + integer nivqua(nbquto) + integer tritet(nbtecf,4) + integer quahex(nbhecf,6) + integer facpyr(nbpycf,5) + integer facpen(nbpecf,5) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c_______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Niveaux des '',i10,1x,a)' +c + texte(2,4) = '(''Levels for the '',i10,1x,a)' +c +c==== +c 2. Niveaux des tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbteto, mess14(langue,3,3) +#endif + jaux = 0 +c + do 21 , iaux = 1 , nbteto + nubnvo(jaux+iaux) = max( nivtri(tritet(iaux,1)), + > nivtri(tritet(iaux,2)), + > nivtri(tritet(iaux,3)), + > nivtri(tritet(iaux,4)) ) + 21 continue +c +c==== +c 3. Niveaux des hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,6) +#endif + jaux = jaux + nbteto +c + do 31 , iaux = 1 , nbheto + nubnvo(jaux+iaux) = max( nivqua(quahex(iaux,1)), + > nivqua(quahex(iaux,2)), + > nivqua(quahex(iaux,3)), + > nivqua(quahex(iaux,4)), + > nivqua(quahex(iaux,5)), + > nivqua(quahex(iaux,6)) ) + 31 continue +c +c==== +c 4. Niveaux des pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpyto, mess14(langue,3,5) +#endif + jaux = jaux + nbheto +c + do 41 , iaux = 1 , nbpyto + nubnvo(jaux+iaux) = max( nivtri(facpyr(iaux,1)), + > nivtri(facpyr(iaux,2)), + > nivtri(facpyr(iaux,3)), + > nivtri(facpyr(iaux,4)), + > nivqua(facpyr(iaux,5)) ) + 41 continue +c +c==== +c 5. Niveaux des pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbpeto, mess14(langue,3,7) +#endif + jaux = jaux + nbpyto +c + do 51 , iaux = 1 , nbpeto + nubnvo(jaux+iaux) = max( nivtri(facpen(iaux,1)), + > nivtri(facpen(iaux,2)), + > nivqua(facpen(iaux,3)), + > nivqua(facpen(iaux,4)), + > nivqua(facpen(iaux,5)) ) + 51 continue +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/infvec.F b/src/tool/Information/infvec.F new file mode 100644 index 00000000..0fe92317 --- /dev/null +++ b/src/tool/Information/infvec.F @@ -0,0 +1,1110 @@ + subroutine infvec ( nomail, nosolu, action, + > ulfido, ulenst, ulsost, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : Fichiers VECtoriels +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iteration n . +c . nosolu . e . char8 . nom de l'objet solution . +c . action . e . char8 . action en cours . +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INFVEC' ) +c +cfonc integer nbtych +cfonc parameter ( nbtych = 5 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nbfami.h" +#include "envca1.h" +#include "envada.h" +#include "nomber.h" +#include "nbutil.h" +c +c 0.3. ==> arguments +c + character*8 action + character*8 nomail, nosolu +c + integer ulfido, ulenst, ulsost + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux, jaux, kaux + integer ideb, ifin +c + integer pcoono, adcocs + integer psomar + integer pnp2ar, phetar, pmerar + integer phettr, paretr, pnivtr, adnmtr + integer advotr, adpptr + integer advoqu, adppqu + integer phetqu, parequ, pnivqu, adnmqu + integer ptrite, phette + integer pquahe, phethe + integer pfacpy, phetpy + integer pfacpe, phetpe + integer pposif, pfacar + integer ppovos, pvoiso + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte, pcfate + integer pfamhe, pcfahe + integer pfampy, pcfapy + integer pfampe, pcfape + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer ptra11, ptra12, ptra13, ptra14 + integer ptra15, ptra16 + integer ptrac1, ptrab1 + integer adnbrn + integer adarcn + integer adnohn, adnocn, adnoin, lgnoin + integer adtrhn, adtrcn, adtrin, lgtrin + integer adquhn, adqucn, adquin, lgquin + integer option, infsup, typcof, typcop, typbor, optnoe + integer porpay, triedr + integer numfic +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nbcham, nbfonc, nbprof, nblopg + integer aninch, aninfo, aninpr, adinlg + integer nrocha, nrocmp, nrotab +c + integer decanu(-1:7) +c + integer nbblfa, nbblvo +c + double precision anglex, angley, anglez + double precision xyzmiz(3), xyzmaz(3) + double precision vafomi, vafoma +c + logical zoom +c + character*6 saux06 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*8 ntra11, ntra12, ntra13, ntra14 + character*8 ntra15, ntra16 + character*8 ntrac1, ntrab1 + character*16 nomcmp + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a6,'' FICHIERS Xfig'')' + texte(1,5) = '(20(''=''),/)' + texte(1,6) = '(''Lancement du trace numero'',i3)' + texte(1,7) = '(''Action en cours : '',a)' +c + texte(2,4) = '(a6,'' Xfig FILES'')' + texte(2,5) = '(17(''=''),/)' + texte(2,6) = '(''Beginning of writings #'',i3)' + texte(2,7) = '(''Current action : '',a)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux06, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux06 + write (ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) action +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. tableaux ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 3*19 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > jaux, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, adcocs, + > ulsort, langue, codret ) +c + iaux = 2590 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, pmerar, + > pfamar, pcfaar, jaux, + > jaux , pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( nbtrto.ne.0 ) then + iaux = iaux*154 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > pfamtr, pcfatr, jaux, + > pnivtr, jaux, jaux, + > adnmtr, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 5698 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > pnivqu, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 518 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux, + > pfamte, pcfate, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 518 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux, + > pfamhe, pcfahe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 518 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , jaux, + > pfampy, pcfapy, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 518 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > pfampe, pcfape, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> les voisinages +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. voisinages ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > iaux, jaux, jaux, jaux, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*221 + endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ===> tableaux lies a la renumerotation +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. renumerotation ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,norenu) + call gmprsx (nompro,norenu//'.Nombres') + call gmprsx (nompro,norenu//'.TrHOMARD') + call gmprsx (nompro,norenu//'.TrCalcul') + call gmprsx (nompro,norenu//'.InfoSupE') +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > renoac, renoto, adnohn, adnocn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_no', nompro +#endif + iaux = -1 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgnoin, adnoin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + iaux = 1 + jaux = -21 + call utre03 ( iaux, jaux, norenu, + > kaux, rearto, kaux, adarcn, + > ulsort, langue, codret) +c + endif +c + if ( nbtrac.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > retrac, retrto, adtrhn, adtrcn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_tr', nompro +#endif + iaux = 2 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgtrin, adtrin, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( nbquac.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > requac, requto, adquhn, adqucn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_qu', nompro +#endif + iaux = 4 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgquin, adquin, + > ulsort, langue, codret) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ( nompro, norenu//'.Nombres' ) + call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > nbnois, nbnoei, nbnomp, + > nbnop1, nbnop2, nbnoim, + > iaux, iaux, iaux, + > nbelem, nbmaae, nbmafe, nbmane, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > numano, numael, + > nvoare, nvosom, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmapo', nbmapo + write(ulsort,90002) 'nbsegm', nbsegm + write(ulsort,90002) 'nbtria', nbtria + write(ulsort,90002) 'nbtetr', nbtetr + write(ulsort,90002) 'nbquad', nbquad + write(ulsort,90002) 'nbhexa', nbhexa + write(ulsort,90002) 'nbpent', nbpent + write(ulsort,90002) 'nbpyra', nbpyra +#endif +c + decanu(-1) = 0 + decanu(3) = 0 + decanu(2) = nbtetr + decanu(1) = nbtetr + nbtria + decanu(0) = nbtetr + nbtria + nbsegm + decanu(4) = nbtetr + nbtria + nbsegm + nbmapo + decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'decanu', decanu +#endif +c + endif +c +c 2.5. ===> tableaux lies a la solution eventuelle +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. Solution ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nosolu) + call gmprsx (nompro,nosolu//'.InfoCham') + call gmprsx (nompro,nosolu//'.InfoPaFo') + call gmprsx (nompro,nosolu//'.InfoProf') + call gmprsx (nompro,nosolu//'.InfoLoPG') +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCASO', nompro +#endif + call utcaso ( nosolu, + > nbcham, nbfonc, nbprof, nblopg, + > aninch, aninfo, aninpr, adinlg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. initialisations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. initialisations ; codret', codret +#endif +c + numfic = 0 +c +c==== +c 4. questions - reponses pour les sorties +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. questions - reponses ; codret', codret +#endif +c + 40 continue +c +c 4.1. ==> choix de la sortie, des angles de vue, des couleurs, etc. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE1', nompro +#endif + call infve1 ( option, + > typcof, typcop, typbor, optnoe, + > porpay, triedr, + > anglex, angley, anglez, + > zoom, xyzmiz, xyzmaz, + > vafomi, vafoma, + > rmem(adcocs+1), rmem(adcocs+4), rmem(adcocs+7), + > nbcham, smem(aninch), + > nomcha, nomcmp, nrocha, nrocmp, nrotab, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> traitement des options +c + if ( codret.eq.0 ) then +c + if ( option.eq.0 ) then + codret = 0 + goto 80 + else + if ( option.lt.0 ) then + iaux = -option + else + iaux = mod(option,100) + endif + if ( iaux.le.7 ) then + infsup = iaux - 1 + elseif ( iaux.eq.8 ) then + infsup = 531 + else + infsup = 462 + endif + endif +c + endif +c +c==== +c 5. preparatifs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. preparatifs ; codret', codret + write (ulsort,90002) 'option', option +#endif +c +c 5.1. ==> recherche des blocs connexes +c + if ( option.lt.0 ) then +c +c 5.1.1. ==> adresses +c + if ( codret.eq.0 ) then +c + iaux = nbquto + 1 + nbtrto + call gmalot ( ntrac1, 'entier ', iaux, ptrac1, codre1 ) +c + iaux = nbteto + nbheto + nbpeto + nbpyto + call gmalot ( ntrab1, 'entier ', iaux, ptrab1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = max ( nbtrac + nbquac, + > nbteac + nbheac + nbpyac + nbpeac ) + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', nbarto, ptrav3, codre3 ) + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre4 ) + iaux = nbquto + nbtrto + 1 + call gmalot ( ntrav5, 'entier ', iaux, ptrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + jaux = nbquto + nbtrto + 1 + call gmalot ( ntra11, 'entier ', jaux, ptra11, codre1 ) + call gmalot ( ntra12, 'entier ', nbnoto, ptra12, codre2 ) + call gmalot ( ntra13, 'entier ', nbarto, ptra13, codre3 ) + jaux = nbquto + nbtrto + call gmalot ( ntra14, 'entier ', jaux, ptra14, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmalot ( ntra15, 'entier ', nbarto, ptra15, codre1 ) + call gmalot ( ntra16, 'entier ', nbarto, ptra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 5.1.2. ==> traitement +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '51.2. traitement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.gt.0 .or. nbheto.gt.0 .or. + > nbpyto.gt.0 .or. nbpeto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + jaux = ulsort +#else + jaux = 0 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11B', nompro +#endif + call utb11b ( nbblvo, + > imem(phetar), imem(psomar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(phette), imem(ptrite), + > imem(phethe), imem(pquahe), + > imem(phetpy), imem(pfacpy), + > imem(phetpe), imem(pfacpe), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > imem(ptrav1), imem(ptrav2), + > imem(ptrav3), imem(ptrav5), + > imem(ptra11), imem(ptra12), + > imem(ptra13), imem(ptra14), + > imem(ptra15), imem(ptra16), + > imem(ptrab1), + > jaux, ulsort, langue, codret ) +c + endif +c + else + nbblvo = 0 + endif +c + if ( codret.eq.0 ) then +c +c on examine toutes les faces actives du calcul +c + jaux = nbquto + nbtrto + do 51 ,iaux = 0, jaux + imem(ptrav4+iaux) = 1 + 51 continue + imem(ptrav4+nbquto) = 0 + iaux = 2 +#ifdef _DEBUG_HOMARD_ + jaux = ulsort +#else + jaux = 0 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11C', nompro +#endif + call utb11c ( nbblfa, iaux, imem(ptrav4), + > imem(phetar), imem(psomar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > imem(ptra15), imem(ptra16), + > imem(ptrac1), + > jaux, ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) + call gmlboj ( ntrav4, codre4 ) + call gmlboj ( ntrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmlboj ( ntra11, codre1 ) + call gmlboj ( ntra12, codre2 ) + call gmlboj ( ntra13, codre3 ) + call gmlboj ( ntra14, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmlboj ( ntra15, codre1 ) + call gmlboj ( ntra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +cgn call gmprsx (nompro,ntrac1) +cgn call gmprsx (nompro,ntrab1) +c + endif +c +c 5.2. ==> recherche des niveaux des volumes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. niveaux des volumes ; codret', codret +#endif +c + if ( option.gt.100 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbteto + nbheto + nbpeto + nbpyto + call gmalot ( ntrab1, 'entier ', iaux, ptrab1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE7', nompro +#endif + call infve7 ( imem(ptrab1), + > imem(pnivtr), imem(pnivqu), + > imem(ptrite), imem(pquahe), + > imem(pfacpy), imem(pfacpe), + > ulsort, langue, codret ) +c + endif +cgn call gmprsx(nompro,ntrab1) +c + endif +c +c 5.3. ==> allocation des tableaux : +c +c Les aretes : +c . Les aretes isolees sont visualisables. +c . Si on a demande de tracer les bords, on les represente. +c "nbarvi" est le nombre d'aretes visualisables +c tableau nnarvi(6,nbarvi) : +c 1 : niveau de l'arete a afficher +c 2 : numero HOMARD de l'arete +c 3, 4 : numero des 2 noeuds +c 5 : 0, si isolee, 1 si bord +c 6 : numero de l'eventuel noeud P2 +c +c Les faces : +c En dimension 2, toutes les faces actives sont visualisables. +c En dimension 3, seules les faces de bord d'elements 3D actifs +c ou les faces isolees sont visualisables. +c "nbtrvi" est le nombre de triangles visualisables +c tableau nntrvi(9,nbtrvi) : +c 2 : numero HOMARD du triangle +c 3, 4, 5 : numeros des noeuds p1 +c 6 : famille du triangle +c 7, 8, 9 : numeros des noeuds p2 +c 10 : numero du noeud interne +c +c "nbquvi" est le nombre de quadrangles visualisables +c tableau nnquvi(11,nbquvi) : +c 2 : numero HOMARD du quadrangle +c 3, 4, 5, 6 : numeros des noeuds p1 +c 7 : famille du quadrangle +c 8, 9, 10, 11 : numeros des noeuds p2 +c 12 : numero du noeud interne +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.3. allocation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c tableau auxiliaire tabaux pour infve2 + iaux = max(nbfare,nbftri,nbfqua) + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) +c +c tableau auxiliaire tbaux2 pour infve2 + iaux = nbquto + 1 + max(nbarto,nbtrto) + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 6. Trace pour tous les blocs ou tous les niveaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. trace ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( option.lt.0 ) then +c + ideb = 1 + if ( nbteto.gt.0 .or. nbheto.gt.0 .or. + > nbpyto.gt.0 .or. nbpeto.gt.0 ) then + ifin = nbblvo + else + ifin = nbblfa + endif +c + elseif ( option.gt.100 ) then +c + ideb = nivinf + ifin = nivsup +c + else +c + ideb = 0 + ifin = 0 +c + endif +c + do 61 , iaux = ideb , ifin +c + if ( codret.eq.0 ) then +c + if ( option.lt.0 ) then + jaux = iaux + kaux = -1 + elseif ( option.gt.100 ) then + jaux = 0 + kaux = iaux + else + jaux = 0 + kaux = -1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) jaux +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVE0', nompro +#endif + call infve0 ( action, jaux, kaux, numfic, + > infsup, typcof, typcop, typbor, optnoe, porpay, + > zoom, triedr, + > nbcham, smem(aninch), + > nomcha, nomcmp, nrocha, nrocmp, nrotab, + > rmem(pcoono), + > imem(psomar), imem(pnp2ar), + > imem(phetar), imem(pmerar), + > imem(pposif), imem(pfacar), + > imem(paretr), imem(phettr), imem(pnivtr), + > imem(adnmtr), + > imem(advotr), imem(adpptr), + > imem(pfamtr), + > imem(parequ), imem(phetqu), imem(pnivqu), + > imem(adnmqu), + > imem(advoqu), imem(adppqu), + > imem(pfamqu), + > imem(adnocn), + > imem(adarcn), imem(adtrcn), imem(adqucn), + > imem(adnohn), imem(adtrhn), imem(adquhn), + > lgnoin, lgtrin, lgquin, + > imem(adnoin), imem(adtrin), imem(adquin), + > decanu, + > anglex, angley, anglez, + > xyzmiz, xyzmaz, vafomi, vafoma, + > imem(ptrav1), imem(ptrav2), + > imem(ptrac1), imem(ptrab1), + > ulsost, + > ulsort, langue, codret ) +c + endif +c + 61 continue +c + endif +c +c==== +c 7. menage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. menage ; codret', codret +#endif +c +c 7.1. ==> suppression des tableaux temporaires +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( option.lt.0 ) then +c + call gmlboj ( ntrac1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( option.gt.100 ) then +c + call gmlboj ( ntrab1, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 7.2. ==> nouveau trace +c + if ( codret.eq.0 ) then +c + goto 40 +c + endif +c +c==== +c 8. la fin +c==== +c + 80 continue +c + write (ulsort,*) ' ' +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Information/ininfm.F b/src/tool/Information/ininfm.F new file mode 100644 index 00000000..83196f44 --- /dev/null +++ b/src/tool/Information/ininfm.F @@ -0,0 +1,555 @@ + subroutine ininfm ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation - INFormation sur le Maillage +c -- --- - +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'ININFM' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "envada.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux, jaux + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer adnbrn + integer adinch, adinpf, adinpr, adinlg + integer lnomfi +c + integer ulfido, ulenst, ulsost +c + logical exisol +c + character*6 saux + character*8 action + character*8 nohman, norenu, nocsol, nochso + character*8 typobs + character*50 commen(nblang) + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.1. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.2. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.3. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr03.h" +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'// + >''' I N F O R M A T I O N S U R L E M A I L L A G E'')' + texte(1,5) = '(63(''=''),/)' + texte(1,7) = '(''Le maillage est a corriger.'')' +c + texte(2,4) = '(//,a6,'' M E S H I N F O R M A T I O N'')' + texte(2,5) = '(39(''=''),/)' + texte(2,7) = '(''This mesh is not correct.'')' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.8. ==> les numeros d'unite logique au terminal +c + call dmunit ( ulenst, ulsost ) +c +c 1.9. ==> le maillage d'entree +c + nohman = smem(adopts+2) + action = smem(adopts+29) +c +c 1.10. ==> le numero d'unite logique du fichier de donnees correct +c + call utulfd ( action, nbiter, ulfido, codret ) +c +c==== +c 2. reactualisation des communs de la renumerotation +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '2. reactualisation communs ; codret', codret +#endif +c +c 2.1. ==> Noms des structures +c + if ( codret.eq.0 ) then +c + call gmnomc ( nohman//'.RenuMail', norenu, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret ) +c + endif +c +c 2.2. ==> Adresses +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '2.2. Adresses ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > renois, renoei, renomp, + > renop1, renop2, renoim, + > iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, iaux, + > iaux, iaux, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> Recuperations des valeurs +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '2.3. Recuperations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + reno1i = renois + renoei + renomp + renop1 +c + call gmliat ( norenu, 1, renoac, codre1 ) + call gmliat ( norenu, 2, renoto, codre2 ) + call gmliat ( norenu, 3, rempac, codre3 ) + call gmliat ( norenu, 4, rempto, codre4 ) + call gmliat ( norenu, 5, rearac, codre5 ) + call gmliat ( norenu, 6, rearto, codre6 ) + call gmliat ( norenu, 7, retrac, codre7 ) + call gmliat ( norenu, 8, retrto, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + call gmliat ( norenu, 9, requac, codre1 ) + call gmliat ( norenu, 10, requto, codre2 ) + call gmliat ( norenu, 11, reteac, codre3 ) + call gmliat ( norenu, 12, reteto, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. Lecture de tous les champs presents dans le fichier +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. Lecture des champs ; codret', codret +#endif +c +c 3.1. ==> Recherche du type de code de calcul associe +c + if ( codret.eq.0 ) then +c + call gmliat ( nohman, 9, typcca, codret ) +c + endif +c +c 3.2. ==> Lecture de l'eventuelle solution +c +c 3.2.1. ==> La solution existe-t-elle ? +c + if ( codret.eq.0 ) then +c + if ( mod(typcca-6,10).eq.0 ) then +c + typobs = mccson + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then + exisol = .true. + else + exisol = .false. + codret = 0 + endif +c + else + exisol = .false. + endif +c + endif +c +c 3.2.2. ==> Une solution existe +c + if ( exisol ) then +c +c 3.2.2.1. ==> Lecture du format MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSMD', nompro +#endif + nochso = ' ' + iaux = 0 + call eslsmd ( nocsol, nochso, + > imem(adopti+8), iaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.2.2. ==> pour le cas extrude, passage du 3D au 2D +c + if ( imem(adopti+38).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 1 + call utsext ( nocsol, iaux, typcca, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + else +c +c 3.2.3. ==> S'il n'y a pas de solution, on en alloue une vide pour ne +c pas perturber la suite +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALSO', nompro +#endif + iaux = 0 + call utalso ( nocsol, + > iaux, iaux, iaux, iaux, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c + endif +c +cgn call gmprsx (nompro,nocsol) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fin etape 3 avec codret', codret +#endif +c +c==== +c 4. Analyse du maillage d'entree +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '4. Analyse ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c + endif +c +c 4.1. ==> numero d'iteration +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INITER', nompro +#endif + call initer ( ulsort, langue, codret ) +c + endif +c +c 4.2. ==> analyse du maillage d'entree +c + if ( codret.eq.0 ) then +c + commen(1) = 'Maillage a analyser ' + commen(2) = 'Mesh to analyze ' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBILM', nompro +#endif + call utbilm ( nohman, commen(langue), imem(adopti+2), action, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gtfims (nrssse) +c + endif +c +c==== +c 5. Familles +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5. Familles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = maextr + if ( imem(adopti+10).eq.26 .or. imem(adopti+10).eq.46 ) then + iaux = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFAMI', nompro +#endif + call infami ( nohman, iaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Fichiers +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '6. Fichiers ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 + nrssse = imem(adetco+3) +c + call gtdems (nrssse) +c + endif +c +c 6.1. ==> sorties vectorielles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFVEC', nompro +#endif + call infvec ( nohman, nocsol, action, + > ulfido, ulenst, ulsost, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> fichiers ascii pour les champs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFCAS', nompro + write(ulsort,*) imem(adetco+3) +#endif + call infcas ( nohman, nocsol, + > ulfido, ulenst, ulsost, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gtfims (nrssse) +c + endif +c +c==== +c 7. la fin +c==== +c +c 7.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 7.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Information/initer.F b/src/tool/Information/initer.F new file mode 100644 index 00000000..adf1140e --- /dev/null +++ b/src/tool/Information/initer.F @@ -0,0 +1,148 @@ + subroutine initer ( ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : ITERation +c -- ---- +c Cette ecriture sert au programme d'analyse. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INITER' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +c +c 0.3. ==> arguments +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nuroul, lnomfl +c + character*8 saux08 + character*200 nomflo +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Numero d''''iteration :'',i5)' +c + texte(2,4) = '(''Iteration number :'',i5)' +c +c==== +c 2. recherche du numero d'unite logique lie au fichier +c==== +c + saux08 = blan08 + iaux = 9 + jaux = -1 + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux08, jaux, jaux, + > ulsort, langue, codret ) +c +c==== +c 2. ecriture du numero d'iteration dans un fichier, si ce n'est +c pas le standard +c==== +c + if ( codret.eq.0 ) then +c + if ( nuroul.ne.ulsort ) then +c +c 2.1. ==> ecriture +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbiter +#endif +c + write (nuroul,*) nbiter +c +c 2.2. ==> fermeture du fichier +c + call gufeul ( nuroul, codret ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/inmes0.h b/src/tool/Information/inmes0.h new file mode 100644 index 00000000..bbb3d50b --- /dev/null +++ b/src/tool/Information/inmes0.h @@ -0,0 +1,169 @@ +c +c texte pour l'information sur les entites +c +c 1234567890123456789012345678901234567890 + textno(0) = 'C''est un noeud isole. ' + textno(1) = 'C''est un sommet d''arete. ' + textno(2) = 'C''est un milieu d''arete (noeud P2). ' + textno(3) = 'C''est un support de maille-point. ' + textno(5) = 'Il n''existe pas ' + textno(7) = 'C''est un noeud d''une maille ignoree. ' +c +c 1234567890123456789012345678901234567890 + textmp(0) = 'Active ' + textmp(5) = 'Elle n''existe pas ' +c +c 1234567890123456789012345678901234567890 + textar(0) = 'Active ' + textar(2) = 'Mere de deux actives ' + textar(5) = 'Elle n''existe pas ' + textar(9) = 'Mere d''inactive(s) ' +c + texttr(0) = 'Actif ' + texttr(1) = 'Coupe en deux par l''arete numero 1 ' + texttr(2) = 'Coupe en deux par l''arete numero 2 ' + texttr(3) = 'Coupe en deux par l''arete numero 3 ' + texttr(4) = 'Pere de quatre actifs ' + texttr(5) = 'Il n''existe pas ' + texttr(6) = 'Coupe en 2 par l''arete nro 1 basculee ' + texttr(7) = 'Coupe en 2 par l''arete nro 2 basculee ' + texttr(8) = 'Coupe en 2 par l''arete nro 3 basculee ' + texttr(9) = 'Pere d''inactif(s) ' +c +c 1234567890123456789012345678901234567890 + textqu( 0) = 'Actif ' + textqu( 4) = 'Pere de quatre actifs ' + textqu(55) = 'Il n''existe pas ' + textqu(99) = 'Pere d''inactif(s) ' + textqu(21) = 'Coupe en 2 quad. par les aretes 1 et 3 ' + textqu(22) = 'Coupe en 2 quad. par les aretes 2 et 4 ' + textqu(31) = 'Coupe en 3 triangles par l''arete 1 ' + textqu(32) = 'Coupe en 3 triangles par l''arete 2 ' + textqu(33) = 'Coupe en 3 triangles par l''arete 3 ' + textqu(34) = 'Coupe en 3 triangles par l''arete 4 ' + textqu(41) = 'Coupe en 3 quad. par les aretes 1 et 2 ' + textqu(42) = 'Coupe en 3 quad. par les aretes 2 et 3 ' + textqu(43) = 'Coupe en 3 quad. par les aretes 3 et 4 ' + textqu(44) = 'Coupe en 3 quad. par les aretes 4 et 1 ' +c +c 1234567890123456789012345678901234567890 + textte( 0) = 'Actif ' + textte(21) = 'Coupe en deux par l''arete numero 1 ' + textte(22) = 'Coupe en deux par l''arete numero 2 ' + textte(23) = 'Coupe en deux par l''arete numero 3 ' + textte(24) = 'Coupe en deux par l''arete numero 4 ' + textte(25) = 'Coupe en deux par l''arete numero 5 ' + textte(26) = 'Coupe en deux par l''arete numero 6 ' + textte(41) = 'Coupe en quatre par le triangle numero 1' + textte(42) = 'Coupe en quatre par le triangle numero 2' + textte(43) = 'Coupe en quatre par le triangle numero 3' + textte(44) = 'Coupe en quatre par le triangle numero 4' + textte(45) = 'Coupe en quatre par la diagonale 1-6 ' + textte(46) = 'Coupe en quatre par la diagonale 2-5 ' + textte(47) = 'Coupe en quatre par la diagonale 3-4 ' + textte(55) = 'Il n''existe pas ' + textte(85) = 'Coupe en huit par la diagonale 1-6 ' + textte(86) = 'Coupe en huit par la diagonale 2-5 ' + textte(87) = 'Coupe en huit par la diagonale 3-4 ' + textte(99) = 'Pere d''inactif(s) ' +c +c 1234567890123456789012345678901234567890 + textpy( 0) = 'Active ' + textpy(55) = 'Elle n''existe pas ' +c +c 1234567890123456789012345678901234567890 + texthe( 0) = 'Actif ' + texthe( 5) = 'Il n''existe pas ' + texthe( 8) = 'Coupe en huit ' + texthe( 9) = 'Pere d''inactif(s) ' + texthe(41) = 'Coupe par la face 1 ' + texthe(42) = 'Coupe par la face 2 ' + texthe(43) = 'Coupe par la face 3 ' + texthe(44) = 'Coupe par la face 4 ' + texthe(45) = 'Coupe par la face 5 ' + texthe(46) = 'Coupe par la face 6 ' +c +c 1234567890123456789012345678901234567890 + textpe( 0) = 'Actif ' + textpe( 1) = 'Coupe par l''arete 1 ' + textpe( 2) = 'Coupe par l''arete 2 ' + textpe( 3) = 'Coupe par l''arete 3 ' + textpe( 4) = 'Coupe par l''arete 4 ' + textpe( 5) = 'Coupe par l''arete 5 ' + textpe( 6) = 'Coupe par l''arete 6 ' + textpe(17) = 'Coupe par l''arete 7 ' + textpe(18) = 'Coupe par l''arete 8 ' + textpe(19) = 'Coupe par l''arete 9 ' + textpe(21) = 'Coupe par les aretes 1 et 8 ' + textpe(22) = 'Coupe par les aretes 2 et 9 ' + textpe(23) = 'Coupe par les aretes 3 et 7 ' + textpe(24) = 'Coupe par les aretes 4 et 8 ' + textpe(25) = 'Coupe par les aretes 5 et 9 ' + textpe(26) = 'Coupe par les aretes 6 et 7 ' + textpe(31) = 'Coupe par les aretes 1 et 5 ' + textpe(32) = 'Coupe par les aretes 2 et 6 ' + textpe(33) = 'Coupe par les aretes 3 et 4 ' + textpe(34) = 'Coupe par les aretes 1 et 6 ' + textpe(35) = 'Coupe par les aretes 2 et 4 ' + textpe(36) = 'Coupe par les aretes 4 et 5 ' + textpe(43) = 'Coupe par la face 3 ' + textpe(44) = 'Coupe par la face 4 ' + textpe(45) = 'Coupe par la face 5 ' + textpe(51) = 'Coupe par la face 1 ' + textpe(52) = 'Coupe par la face 2 ' + textpe(55) = 'Il n''existe pas ' + textpe(80) = 'Coupe en huit ' + textpe(99) = 'Pere d''inactif(s) ' +c +c 12345678901234567890123456789012345678901234567890 + textvo( 1) = 'Il borde le tetraedre : ' + textvo( 2) = 'Il borde les deux tetraedres : ' + textvo( 3) = 'Il borde l''hexaedre : ' + textvo( 4) = 'Il borde les deux hexaedres : ' + textvo( 5) = 'Il borde la pyramide : ' + textvo( 6) = 'Il borde les deux pyramides : ' + textvo( 7) = 'Il borde le pentaedre : ' + textvo( 8) = 'Il borde les deux pentaedres : ' + textvo(11) = 'Elle borde le tetraedre : ' + textvo(12) = 'Elle borde les tetraedres : ' + textvo(13) = 'Elle borde l''hexaedre : ' + textvo(14) = 'Elle borde les hexaedres : ' + textvo(15) = 'Elle borde la pyramide : ' + textvo(16) = 'Elle borde les pyramides : ' + textvo(17) = 'Elle borde le pentaedre : ' + textvo(18) = 'Elle borde les pentaedres : ' + textvo(21) = 'Il est un sommet pour le tetraedre : ' + textvo(22) = 'Il est un sommet pour les tetraedres : ' + textvo(23) = 'Il est un sommet pour l''hexaedre : ' + textvo(24) = 'Il est un sommet pour les hexaedres : ' + textvo(25) = 'Il est un sommet pour la pyramide : ' + textvo(26) = 'Il est un sommet pour les pyramides : ' + textvo(27) = 'Il est un sommet pour le pentaedre : ' + textvo(28) = 'Il est un sommet pour les pentaedres : ' + textvo(31) = 'Il est le milieu d''un cote du tetraedre : ' + textvo(32) = 'Il est le milieu d''un cote des tetraedres : ' + textvo(33) = + > 'Il est le milieu d''un cote de l''hexaedre : ' + textvo(34) = 'Il est le milieu d''un cote des hexaedres : ' + textvo(35) = 'Il est le milieu d''un cote de la pyramide : ' + textvo(36) = 'Il est le milieu d''un cote des pyramides : ' + textvo(37) = 'Il est le milieu d''un cote de pentaedre : ' + textvo(38) = 'Il est le milieu d''un cote des pentaedres : ' + textvo(41) = 'Il est voisin du tetraedre : ' + textvo(42) = 'Il est voisin des tetraedres : ' + textvo(43) = 'Il est voisin de l''hexaedre : ' + textvo(44) = 'Il est voisin des hexaedres : ' + textvo(45) = 'Il est voisin de la pyramide : ' + textvo(46) = 'Il est voisin des pyramides : ' + textvo(47) = 'Il est voisin du pentaedre : ' + textvo(48) = 'Il est voisin des pentaedres : ' + textvo(51) = 'Elle est voisine du tetraedre : ' + textvo(52) = 'Elle est voisine des tetraedres : ' + textvo(53) = 'Elle est voisine de l''hexaedre : ' + textvo(54) = 'Elle est voisine des hexaedres : ' + textvo(55) = 'Elle est voisine de la pyramide : ' + textvo(56) = 'Elle est voisine des pyramides : ' + textvo(57) = 'Elle est voisine du pentaedre : ' + textvo(58) = 'Elle est voisine des pentaedres : ' +c 12345678901234567890123456789012345678901234567890 +c diff --git a/src/tool/Information/inmess.h b/src/tool/Information/inmess.h new file mode 100644 index 00000000..bb4a38e0 --- /dev/null +++ b/src/tool/Information/inmess.h @@ -0,0 +1,19 @@ +c +c texte pour l'information : declaration +c + character*40 textno(0:7) + character*40 textmp(0:9) + character*40 textar(0:9) + character*40 texttr(0:9) + character*40 textqu(0:99) + character*40 textte(0:99) + character*40 textpy(0:99) + character*40 texthe(0:99) + character*40 textpe(0:99) + character*50 textvo(0:60) +c + common / inmess / textno, textmp, textar, + > texttr, textqu, + > textte, textpy, texthe, textpe, + > textvo +c diff --git a/src/tool/Information/inqur1.F b/src/tool/Information/inqur1.F new file mode 100644 index 00000000..ec4b19a1 --- /dev/null +++ b/src/tool/Information/inqur1.F @@ -0,0 +1,1389 @@ + subroutine inqur1 ( nomail, nosolu, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : QUestions / Reponses - phase 1 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iteration n . +c . nosolu . e . char8 . nom de l'objet solution . +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INQUR1' ) +c +#include "nblang.h" +#include "consts.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "inmess.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "meddc0.h" +#include "envca1.h" +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nomber.h" +#include "nbfami.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nosolu +c + integer ulfido, ulenst, ulsost +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tbiaux(1) +c + integer pcoono, phetno, pareno + integer pnoemp, phetmp + integer psomar, pposif, pfacar, phetar, pfilar + integer pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr, adpetr, adnmtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu, adhequ, adnmqu + integer ptrite, pcotrt, parete, phette, pfilte, pperte, adtes2 + integer pquahe, pcoquh, parehe, phethe, pfilhe, pperhe, adhes2 + integer adnmhe + integer pfacpy, pcofay, parepy, phetpy, pfilpy, pperpy, adpys2 + integer pfacpe, pcofap, parepe, phetpe, pfilpe, pperpe, adpes2 + integer advotr, advoqu + integer adpptr, adppqu + integer pnp2ar + integer pfamno, pcfano + integer pfammp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte + integer pfamhe + integer pfampy + integer pfampe + integer adhono, admpho, adhoar, adhotr, adhoqu +c + integer adnohn, adnocn, adnoin, lgnoin + integer admphn, admpcn, admpin, lgmpin, admpcs + integer adarhn, adarcn, adarin, lgarin, adarcs + integer adtrhn, adtrcn, adtrin, lgtrin, adtrcs + integer adquhn, adqucn, adquin, lgquin, adqucs + integer adtehn, adtecn, adtein, lgtein, adtecs + integer adhehn, adhecn, adhein, lghein, adhecs + integer adpyhn, adpycn, adpyin, lgpyin, adpycs + integer adpehn, adpecn, adpein, lgpein, adpecs +c + integer nbcham, nbpafo, nbprof, nblopg + integer aninch, aninpf, aninpr, adinlg +c + integer numero, numdeb, numfin + integer adnbrn + integer nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra + integer decanu(-1:7) + integer voarno, vofaar, vovoar, vovofa + integer lgtate, adptte, adtate + integer lgtahe, adpthe, adtahe + integer lgtapy, adptpy, adtapy + integer lgtape, adptpe, adtape +c + logical extrus +c + character*2 choix + character*8 saux08 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntramp, ntraar, ntratr, ntraqu + character*8 ntrate, ntrahe, ntrapy, ntrape +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "inmes0.h" +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( typcca.eq.26 .or .typcca.eq.46 ) then + extrus = .false. + elseif ( maextr.ne.0 .and. rafdef.eq.0 ) then + extrus = .true. + else + extrus = .false. + endif +c + endif +c +c 2.2. ==> tableaux +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - nhtria.InfoSupp', nhtria//'.InfoSupp' ) + call gmprsx ( nompro//' - nhquad.InfoSupp', nhquad//'.InfoSupp' ) +#endif +c + if ( codret.eq.0 ) then +c + iaux = 210 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, adhono, jaux, + > ulsort, langue, codret ) +c + if ( nbmpto.ne.0 ) then +c + iaux = 14 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + call utad02 ( iaux, nhmapo, + > phetmp, pnoemp, jaux, jaux, + > pfammp, jaux, jaux, + > jaux, jaux, jaux, + > jaux, admpho, jaux, + > ulsort, langue, codret ) +c + endif +c + iaux = 7770 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbftri.ne.0 ) then +c + iaux = 37 + if ( nbtrto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( extrus ) then + iaux = iaux*13 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, adpetr, jaux, + > adnmtr, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbfqua.ne.0 ) then +c + iaux = 37 + if ( nbquto.ne.0 ) then + iaux = iaux*2310 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( extrus ) then + iaux = iaux*13 + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, pcfaqu, jaux, + > pnivqu, adhequ, jaux, + > adnmqu, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 2730 + if ( nbteh1.gt.0 .or. nbteh2.gt.0 .or. nbteh3.gt.0 .or. + > nbteh4.gt.0 .or. + > nbtep0.gt.0 .or. nbtep1.gt.0 .or. nbtep2.gt.0 .or. + > nbtep3.gt.0 .or. nbtep4.gt.0 .or. nbtep5.gt.0 .or. + > nbtedh.gt.0 .or. nbtedp.gt.0 ) then + iaux = iaux*17 + endif + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, pperte, + > pfamte, jaux, jaux, + > jaux, pcotrt, adtes2, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 2730 + if ( nbheco.ne.0 ) then + iaux = iaux*17 + endif + if ( mod(mailet,5).eq.0 ) then + iaux = iaux*19 + endif + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, jaux, jaux, + > jaux, pcoquh, adhes2, + > adnmhe, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 2730 + if ( nbpyh1.gt.0 .or. nbpyh2.gt.0 .or. nbpyh3.gt.0 .or. + > nbpyh4.gt.0 .or. + > nbpyp0.gt.0 .or. nbpyp1.gt.0 .or. nbpyp2.gt.0 .or. + > nbpyp3.gt.0 .or. nbpyp4.gt.0 .or. nbpyp5.gt.0 .or. + > nbpydh.gt.0 .or. nbpydp.gt.0 ) then + iaux = iaux*17 + endif + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, pfilpy, pperpy, + > pfampy, jaux, jaux, + > jaux, pcofay, adpys2, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 2730 + if ( nbpeco.ne.0 ) then + iaux = iaux*17 + endif + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, jaux, jaux, + > jaux, pcofap, adpes2, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> les voisinages +c + if ( codret.eq.0 ) then +c + voarno = 0 + vofaar = 0 + vovoar = 2 + vovofa = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nhvois) + call gmprsx (nompro,nhvois//'.Vol/Tri') + call gmprsx (nompro,nhvois//'.PyPe/Tri') + call gmprsx (nompro,nhvois//'.Vol/Qua') + call gmprsx (nompro,nhvois//'.PyPe/Qua') +#endif +c +c Remarque : on passe en deux fois pour ne pas avoir un nombre +c trop grand en 32 bits ... + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*13*17 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04 - phase 1', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > lgtate, adptte, adtate, + > lgtahe, adpthe, adtahe, + > lgtapy, adptpy, adtapy, + > lgtape, adptpe, adtape, + > ulsort, langue, codret ) + iaux = 1 + if ( nbteto.ne.0 ) then + iaux = iaux*19 + endif + if ( nbheto.ne.0 ) then + iaux = iaux*23 + endif + if ( nbpyto.ne.0 ) then + iaux = iaux*29 + endif + if ( nbpeto.ne.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04 - phase 2', nompro +#endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > lgtate, adptte, adtate, + > lgtahe, adpthe, adtahe, + > lgtapy, adptpy, adtapy, + > lgtape, adptpe, adtape, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> renumerotation +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - PeCalcul', norenu//'.PeCalcul' ) + call gmprsx ( nompro//' - PeHOMARD', norenu//'.PeHOMARD' ) + call gmprsx ( nompro//' - HeCalcul', norenu//'.HeCalcul' ) + call gmprsx ( nompro//' - HeHOMARD', norenu//'.HeHOMARD' ) +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_no', nompro +#endif + iaux = -1 + jaux = 210 + call utre03 ( iaux, jaux, norenu, + > renoac, renoto, adnohn, adnocn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_no', nompro +#endif + iaux = -1 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgnoin, adnoin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_mp', nompro +#endif + iaux = 0 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rempac, rempto, admphn, admpcn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_mp', nompro +#endif + iaux = 0 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgmpin, admpin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro +#endif + iaux = 1 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > rearac, rearto, adarhn, adarcn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_ar', nompro +#endif + iaux = 1 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgarin, adarin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro +#endif + iaux = 2 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > retrac, retrto, adtrhn, adtrcn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_tr', nompro +#endif + iaux = 2 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgtrin, adtrin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_te', nompro +#endif + iaux = 3 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > reteac, reteto, adtehn, adtecn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_te', nompro +#endif + iaux = 3 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgtein, adtein, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro +#endif + iaux = 4 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > requac, requto, adquhn, adqucn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_qu', nompro +#endif + iaux = 4 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgquin, adquin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_py', nompro +#endif + iaux = 5 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > repyac, repyto, adpyhn, adpycn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_py', nompro +#endif + iaux = 5 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgpyin, adpyin, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_he', nompro +#endif + iaux = 6 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > reheac, reheto, adhehn, adhecn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_he', nompro +#endif + iaux = 6 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lghein, adhein, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro +#endif + iaux = 7 + jaux = -210 + call utre03 ( iaux, jaux, norenu, + > repeac, repeto, adpehn, adpecn, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_pe', nompro +#endif + iaux = 7 + jaux = -11 + call utre04 ( iaux, jaux, norenu, + > lgpein, adpein, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ( nompro, norenu//'.Nombres' ) + call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > iaux, iaux, + > iaux, iaux, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbmapo', nbmapo + write(ulsort,90002) 'nbsegm', nbsegm + write(ulsort,90002) 'nbtria', nbtria + write(ulsort,90002) 'nbtetr', nbtetr + write(ulsort,90002) 'nbquad', nbquad + write(ulsort,90002) 'nbhexa', nbhexa + write(ulsort,90002) 'nbpent', nbpent + write(ulsort,90002) 'nbpyra', nbpyra +#endif +c + decanu(-1) = 0 + decanu(3) = 0 + decanu(2) = nbtetr + decanu(1) = nbtetr + nbtria + decanu(0) = nbtetr + nbtria + nbsegm + decanu(4) = nbtetr + nbtria + nbsegm + nbmapo + decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + > + nbpyra +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'decanu', decanu +#endif +c + endif +c +c 2.5. ==> Profils +c + if ( rempac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 mapo', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > rempac, jaux, + > imem(admphn), imem(admpcn), decanu(0), + > lgmpin, imem(admpin), tbiaux, + > ntramp, saux08, + > admpcs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( rearac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 aret', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > rearac, jaux, + > imem(adarhn), imem(adarcn), decanu(1), + > lgarin, imem(adarin), tbiaux, + > ntraar, saux08, + > adarcs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( retrac.ne.0 ) then +c + if ( .not.extrus ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 tria', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > retrac, jaux, + > imem(adtrhn), imem(adtrcn), decanu(2), + > lgtrin, imem(adtrin), tbiaux, + > ntratr, saux08, + > adtrcs, jaux, + > ulsort, langue, codret ) +c + endif +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - TrCalcul', norenu//'.TrCalcul' ) + call gmprsx ( nompro//' - TrHOMARD', norenu//'.TrHOMARD' ) + call gmprsx ( nompro//' - PeCalcul', norenu//'.PeCalcul' ) + call gmprsx ( nompro//' - PeHOMARD', norenu//'.PeHOMARD' ) +#endif + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR06 tria', nompro +#endif + call utpr06 ( iaux, + > retrac, jaux, + > imem(adpetr), imem(adtrhn), + > imem(adpehn), imem(adpecn), + > ntratr, saux08, + > adtrcs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +cgn call gmprsx ( nompro//' - profil triangle', ntratr ) +cgn call gmprsx ( nompro//' - pentri', nhtria//'.InfoSupp' ) +c + if ( requac.ne.0 ) then +c + if ( .not.extrus ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 quad', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > requac, jaux, + > imem(adquhn), imem(adqucn), decanu(4), + > lgquin, imem(adquin), tbiaux, + > ntraqu, saux08, + > adqucs, jaux, + > ulsort, langue, codret ) +c + endif +c + else +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - QuCalcul', norenu//'.QuCalcul' ) + call gmprsx ( nompro//' - QuHOMARD', norenu//'.QuHOMARD' ) + call gmprsx ( nompro//' - HeCalcul', norenu//'.HeCalcul' ) + call gmprsx ( nompro//' - HeHOMARD', norenu//'.HeHOMARD' ) +#endif + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR06 quad', nompro +#endif + call utpr06 ( iaux, + > requac, jaux, + > imem(adhequ), imem(adquhn), + > imem(adhehn), imem(adhecn), + > ntraqu, saux08, + > adqucs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +cgn call gmprsx ( nompro//' - profil quadrangle', ntraqu ) +cgn call gmprsx ( nompro//' - hexqua', nhquad//'.InfoSupp' ) +c + if ( reteac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 tetr', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > reteac, jaux, + > imem(adtehn), imem(adtecn), decanu(3), + > lgtein, imem(adtein), tbiaux, + > ntrate, saux08, + > adtecs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( repyac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 pyra', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > repyac, jaux, + > imem(adpyhn), imem(adpycn), decanu(5), + > lgpyin, imem(adpyin), tbiaux, + > ntrapy, saux08, + > adpycs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( reheac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 hexa', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > reheac, jaux, + > imem(adhehn), imem(adhecn), decanu(6), + > lghein, imem(adhein), tbiaux, + > ntrahe, saux08, + > adhecs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( repeac.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR05 pent', nompro +#endif + call utpr05 ( iaux, -1, tbiaux, + > repeac, jaux, + > imem(adpehn), imem(adpecn), decanu(7), + > lgpein, imem(adpein), tbiaux, + > ntrape, saux08, + > adpecs, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.5. ===> tableaux lies a la solution eventuelle +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nosolu) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcaso ( nosolu, + > nbcham, nbpafo, nbprof, nblopg, + > aninch, aninpf, aninpr, adinlg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. questions - reponses +c==== +c + if ( codret.eq.0 ) then +c + 30 continue +c +c 3.1. ==> choix +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INQUR2', nompro +#endif +c + call inqur2 ( choix, numdeb, numfin, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + codret = 0 + goto 30 + endif +c +c 3.2. ==> sortie +c + if ( choix.eq.'q ' ) then +c + goto 40 +c + else +c +c 3.3. ==> description d'entites +c + if ( numdeb.gt.0 ) then +c + do 33 , iaux = numdeb, numfin +c + numero = iaux +c +c 3.3.1. ==> informations sur un noeud +c + if ( choix.eq.'no' .or. + > choix.eq.'NO' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFONO', nompro +#endif + call infono ( choix, numero, + > rmem(pcoono), imem(phetno), imem(pareno), imem(pfamno), + > imem(adnohn), imem(adnocn), + > imem(adhono), + > imem(pnoemp), + > imem(psomar), imem(phetar), imem(pposif), imem(pfacar), + > imem(phettr), imem(phetqu), + > imem(phette), imem(phetpy), imem(phethe), imem(phetpe), + > lgtate, imem(adptte), imem(adtate), + > lgtahe, imem(adpthe), imem(adtahe), + > lgtapy, imem(adptpy), imem(adtapy), + > lgtape, imem(adptpe), imem(adtape), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.2. ==> informations sur une maille-point +c + elseif ( choix.eq.'mp' .or. + > choix.eq.'MP' .or. + > choix.eq.'E ' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOMP', nompro +#endif + call infomp ( choix, numero, + > imem(pnoemp), imem(phetmp), + > imem(pfammp), + > imem(admphn), imem(admpcn), imem(admpcs), + > rmem(pcoono), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.4. ==> informations sur une arete +c + elseif ( choix.eq.'ar' .or. + > choix.eq.'AR' .or. + > choix.eq.'E ' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOAR', nompro +#endif + call infoar ( choix, numero, + > imem(psomar), imem(pposif), imem(pfacar), + > imem(phetar), imem(pfilar), imem(pmerar), imem(pnp2ar), + > imem(pfamar), imem(pcfaar), + > imem(adarhn), imem(adarcn), imem(adarcs), + > imem(adhoar), + > rmem(pcoono), + > imem(phettr), imem(phetqu), + > imem(phette), imem(phetpy), imem(phethe), imem(phetpe), + > lgtate, imem(adptte), imem(adtate), + > lgtahe, imem(adpthe), imem(adtahe), + > lgtapy, imem(adptpy), imem(adtapy), + > lgtape, imem(adptpe), imem(adtape), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.5. ==> informations sur un triangle +c + elseif ( choix.eq.'tr' .or. + > choix.eq.'TR' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOTR', nompro +#endif + call infotr ( choix, numero, + > imem(paretr), imem(phettr), imem(advotr), imem(adpptr), + > imem(pnivtr), imem(pfiltr), imem(ppertr), imem(adnmtr), + > imem(pfamtr), + > imem(adtrhn), imem(adtrcn), imem(adtrcs), + > imem(adhotr), + > imem(psomar), imem(pnp2ar), imem(phetar), + > imem(pposif), imem(pfacar), + > rmem(pcoono), + > imem(phetqu), imem(pnivqu), imem(pfilqu), + > imem(phette), imem(phetpy), imem(phetpe), + > extrus, imem(adpetr), imem(adpecn), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.6. ==> informations sur un quadrangle +c + elseif ( choix.eq.'qu' .or. + > choix.eq.'QU' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOQU', nompro +#endif + call infoqu ( choix, numero, + > imem(parequ), imem(phetqu), imem(advoqu), imem(adppqu), + > imem(pnivqu), imem(pfilqu), imem(pperqu), imem(adnmqu), + > imem(pfamqu), + > imem(adquhn), imem(adqucn), imem(adqucs), + > imem(adhoqu), + > imem(psomar), imem(pnp2ar), imem(phetar), + > imem(pposif), imem(pfacar), + > rmem(pcoono), + > imem(phettr), imem(pnivtr), imem(adtrcn), + > imem(phetpy), imem(phethe), imem(phetpe), + > extrus, imem(adhequ), imem(adhecn), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.7. ==> informations sur un tetraedre +c + elseif ( choix.eq.'te' .or. + > choix.eq.'TE' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOTE', nompro +#endif + call infote ( choix, numero, + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), imem(pfilte), imem(pperte), imem(adtes2), + > imem(pfamte), + > imem(adtehn), imem(adtecn), imem(adtecs), + > imem(phetar), imem(psomar), imem(pnp2ar), rmem(pcoono), + > imem(phettr), imem(paretr), imem(pnivtr), + > imem(pnivqu), + > imem(phethe), imem(pquahe), imem(pfilhe), imem(adhes2), + > imem(phetpy), imem(adpycn), + > imem(phetpe), imem(pfacpe), imem(pfilpe), imem(adpes2), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.8. ==> informations sur une pyramide +c + elseif ( choix.eq.'py' .or. + > choix.eq.'PY' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPY', nompro +#endif + call infopy ( choix, numero, + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), imem(pfilpy), imem(pperpy), imem(adpys2), + > imem(pfampy), + > imem(adpyhn), imem(adpycn), imem(adpycs), + > imem(phetar), imem(psomar), imem(pnp2ar), rmem(pcoono), + > imem(phettr), imem(paretr), imem(pnivtr), + > imem(phetqu), imem(pnivqu), + > imem(phette), imem(adtecn), + > imem(phethe), imem(pquahe), imem(pfilhe), imem(adhes2), + > imem(phetpe), imem(pfacpe), imem(pfilpe), imem(adpes2), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.9. ==> informations sur un hexaedre +c + elseif ( choix.eq.'he' .or. + > choix.eq.'HE' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOHE', nompro +#endif + call infohe ( choix, numero, + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), imem(pfilhe), imem(pperhe), imem(adhes2), + > imem(pfamhe), + > imem(adhehn), imem(adhecn), imem(adhecs), + > imem(phetar), imem(psomar), imem(pnp2ar), rmem(pcoono), + > imem(phetqu), imem(parequ), imem(pnivqu), + > imem(phette), imem(adtecn), + > imem(phetpy), imem(adpycn), + > imem(phetpe), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c +c 3.3.10. ==> informations sur un pentaedre +c + elseif ( choix.eq.'pe' .or. + > choix.eq.'PE' .or. + > choix.eq.'E' ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFOPE', nompro +#endif + call infope ( choix, numero, + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), imem(pfilpe), imem(pperpe), imem(adpes2), + > imem(pfampe), + > imem(adpehn), imem(adpecn), imem(adpecs), + > imem(phetar), imem(psomar), imem(pnp2ar), rmem(pcoono), + > imem(phettr), imem(pnivtr), + > imem(phetqu), imem(parequ), imem(pnivqu), + > imem(phette), imem(adtecn), + > imem(phethe), + > imem(phetpy), imem(adpycn), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbpafo, smem(aninpf), + > ulsost, + > ulsort, langue, codret ) +c + endif +c +c 3.3.11. ==> sortie en cas d'erreur +c + if ( codret.ne.0 ) then + goto 40 + endif +c + 33 continue +c +c 3.4. ==> qualite des entites +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INFQEN', nompro +#endif + call infqen ( choix, numfin, + > rmem(pcoono), imem(psomar), + > imem(phettr), imem(paretr), + > imem(pfamtr), imem(pcfatr), + > imem(phetqu), imem(parequ), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > imem(adtrcn), imem(adqucn), imem(adtecn), + > ulsost, + > ulsort, langue, codret ) +c + endif +c + endif +c + goto 30 +c + endif +c +c==== +c 4. fin +c==== +c + 40 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '40 continue avec codret', codret +#endif +c + if ( rempac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntramp, codret ) + endif + if ( rearac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntraar, codret ) + endif + if ( retrac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntratr, codret ) + endif + if ( requac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntraqu, codret ) + endif + if ( reteac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntrate, codret ) + endif + if ( repyac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntrapy, codret ) + endif + if ( reheac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntrahe, codret ) + endif + if ( repeac.ne.0 .and. codret.eq.0 ) then + call gmlboj ( ntrape, codret ) + endif +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/inqur2.F b/src/tool/Information/inqur2.F new file mode 100644 index 00000000..24d3f50f --- /dev/null +++ b/src/tool/Information/inqur2.F @@ -0,0 +1,465 @@ + subroutine inqur2 ( choix, numdeb, numfin, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : QUestions / Reponses - phase 2 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . s . 2 . choix . +c . numdeb . s . 1 . 1er numero ou 0 si qualite . +c . numfin . s . 1 . 2nd numero (eventuellement) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . ulfido . e . 1 . unite logique du fichier de donnees correct. +c . ulenst . e . 1 . unite logique de l'entree standard . +c . ulsost . e . 1 . unite logique de la sortie standard . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans les memoires . +c . . . . 3 : probleme dans les fichiers . +c . . . . 5 : probleme autre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'INQUR2' ) +#endif +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#ifdef _DEBUG_HOMARD_ +#include "envex1.h" +#endif +c +#include "nombmp.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*2 choix +c + integer numdeb, numfin +c + integer ulfido, ulenst, ulsost +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbsign + integer typsig(3), valent(3) +c + character*2 valcha(3) + character*80 chaine +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Quel choix : '''''',a,'''''' ?'')' + texte(1,5) = '(''Quel choix apres '''''',a,'''''' ?'')' + texte(1,6) = '(''Information '',i1,'' illisible'')' + texte(1,7) = '(''Qualite impossible avec le choix '',a)' + texte(1,8) = '(''Uniquement faces ou tetraedres.'')' + texte(1,9) = + > '(''Numero'',i10,'' impossible. Il faut un nombre >0.'')' +c + texte(2,4) = '(''What choice : '''''',a,'''''' ?'')' + texte(2,5) = '(''What choice after '''''',a,'''''' ?'')' + texte(2,6) = '(''Information '',i1,'' cannot be read.'')' + texte(2,7) = '(''Quality impossible with choice '',a)' + texte(2,8) = '(''Only faces or tetraedra.'')' + texte(2,9) = '(''#'',i10,'' impossible. A >0 # is required.'')' +c +#include "impr03.h" +c +10001 format ( + >/,'Choisir . soit ''q'' pour quitter,', + >/,' . soit une sequence de type : ''a n1 (n2)'',', + >/,' . soit une sequence de type : ''a q +-n2''.', + >/,' . soit ''h'' pour un mode d''emploi.',/) +11000 format (60('=')) +11001 format ( + >/,'a : designe le type d''entite voulue, a choisir parmi :', + >/,' no pour les noeuds', + >/,' mp pour les mailles-points', + >/,' ar pour les aretes', + >/,' tr pour les triangles', + >/,' qu pour les quadrangles', + >/,' te pour les tetraedres', + >/,' he pour les hexaedres', + >/,' py pour les pyramides', + >/,' pe pour les pentaedres',/, + >/,'n1 : vaut le numero de l''entite voulue', + >/,'n2 : vaut le numero de la derniere entite examinee ;', + >/,' on aura les infos sur les entites de n1 a n2 ; si n2 est', + >/,' absent, on les aura pour la seule entite numero n1', + >/,'Pour les codes : minuscules : numerotation dans HOMARD', + >/,' MAJUSCULES : numerotation du calcul',/, + >/,'''q'' pour des informations sur la qualite des entites a', + >/,' +n2 : on affichera les n2 meilleures,', + >/,' -n2 : on affichera les n2 pires.') +11011 format ( + >/,'Exemples :', + >/,'''NO 14'' : description du noeud 14 dans le calcul', + >/,'''te 345 350'' : description des tetraedres', + >/,' de 345 a 350 dans HOMARD', + >/,'''tr q 10'' : reperage des 10 meilleurs triangles,', + >/,'''te q -5'' : reperage des 10 tetraedres les pires.',/) +c +10002 format ( + >/,'Choose . either ''q'' to quit,', + >/,' . either sequence like : ''a n1 (n2)'',', + >/,' . either sequence like : ''a q +-n2''.', + >/,' . either ''h'' for help,') +11002 format ( + >/,'a : indicates the kind of entity, in :', + >/,' no for nodes', + >/,' mp for points-meshes', + >/,' ar for edges', + >/,' tr for triangles', + >/,' qu for quadrangles', + >/,' te for tetrahedron', + >/,' he for hexahedron', + >/,' py for pyramids', + >/,' pe for pentahedrons',/, + >/,'n1 : is the # of the choosen entity', + >/,'n2 : is the # of the last entity ;', + >/,' infos will be displayed for entities # from n1 to n2 ;', + >/,' if n2 is not given, infos will only be displayed for', + >/,' entity # n1.', + >/,' lower case : numerotation in HOMARD', + >/,' UPPER CASE : numerotation in calculation',/, + >/,'''q'' for information about quality of entity ''a''', + >/,' +n2 : n2 best will be displayed,', + >/,' -n2 : n2 worst will be displayed.') +11012 format ( + >/,'Examples :', + >/,'''NO 14'' : description of node # 14 in calculation', + >/,'''te 345 350'' : description of tetraedra', + >/,' from 345 to 350 in HOMARD', + >/,'''tr q 10'' : information about 10 best triangles,', + >/,'''te q -5'' : information about 5 worst tetraedra.',/) +c +20080 format (a80) +c + codret = 0 +c +c==== +c 2. Decodage +c==== +c + 20 continue +c +c 2.1. ==> lecture de la demande +c + if ( codret.eq.0 ) then +c + if ( langue.eq.2 ) then + write (ulsost,10002) + else + write (ulsost,10001) + endif +c + endif +c + if ( codret.eq.0 ) then + read (ulenst,20080,err=20,end=20) chaine + endif +c +c 2.2. ==> decoupage de la chaine +c nbsign : nombre de signes dans la chaine +c typsig : type des signes : +c -1 : rien +c 0 : entier +c 1 : caractere*1 +c 2 : caractere*2 +c valcha : valeur du signe s'il est caractere +c valent : valeur du signe s'il est entier +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTQURE', nompro +#endif + call utqure ( chaine, + > nbsign, typsig, valcha, valent, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbsign', nbsign + write (ulsort,90002) 'typsig', typsig + write (ulsort,90003) 'valcha', valcha + write (ulsort,90002) 'valent', valent +#endif +c + if ( nbsign.eq.0 ) then + goto 20 + endif +c +c 2.3. ==> le choix +c + if ( codret.eq.0 ) then +c + if ( typsig(1).ne.0 ) then +c + choix = valcha(1) +c + if ( choix.eq.'h ' ) then +c + write (ulsost,11000) + if ( langue.eq.2 ) then + write (ulsost,11002) + write (ulsost,11012) + else + write (ulsost,11001) + write (ulsost,11011) + endif + write (ulsost,11000) + goto 20 +c + elseif ( choix.eq.'q ' ) then +c + goto 30 +c + elseif ( choix.eq.'no' .or. + > choix.eq.'NO' .or. + > choix.eq.'ar' .or. + > choix.eq.'AR' .or. + > choix.eq.'E ' ) then +c + codret = 0 +c + elseif ( nbmpto.ne.0 .and. + > ( choix.eq.'mp' .or.choix.eq.'MP' ) ) then +c + codret = 0 +c + elseif ( nbtrto.ne.0 .and. + > ( choix.eq.'tr' .or.choix.eq.'TR' ) ) then +c + codret = 0 +c + elseif ( nbquto.ne.0 .and. + > ( choix.eq.'qu' .or.choix.eq.'QU' ) ) then +c + codret = 0 +c + elseif ( nbteto.ne.0 .and. + > ( choix.eq.'te' .or.choix.eq.'TE' ) ) then +c + codret = 0 +c + elseif ( nbheto.ne.0 .and. + > ( choix.eq.'he' .or.choix.eq.'HE' ) ) then +c + codret = 0 +c + elseif ( nbpyto.ne.0 .and. + > ( choix.eq.'py' .or.choix.eq.'PY' ) ) then +c + codret = 0 +c + elseif ( nbpeto.ne.0 .and. + > ( choix.eq.'pe' .or.choix.eq.'PE' ) ) then +c + codret = 0 +c + else +c + write (ulsost,texte(langue,4)) choix + codret = 1 + goto 30 +c + endif +c + else +c + write (ulsost,texte(langue,6)) 1 + codret = 1 + goto 30 +c + endif +c + endif +c +c 2.4. ==> le premier numero ou la qualite +c + if ( codret.eq.0 ) then +c + if ( nbsign.ge.2 ) then +c + if ( typsig(2).ne.0 ) then +c + if ( valcha(2).eq.'q ' .or. + > valcha(2).eq.'Q ' ) then + if ( choix.eq.'tr' .or. + > choix.eq.'TR' .or. + > choix.eq.'qu' .or. + > choix.eq.'QU' .or. + > choix.eq.'te' .or. + > choix.eq.'TE' .or. + > choix.eq.'he' .or. + > choix.eq.'HE' .or. + > choix.eq.'py' .or. + > choix.eq.'PY' .or. + > choix.eq.'pe' .or. + > choix.eq.'PE' ) then + numdeb = 0 + else + write (ulsost,texte(langue,7)) choix + write (ulsost,texte(langue,8)) + codret = 1 + goto 30 + endif + else + write (ulsost,texte(langue,6)) 2 + codret = 1 + goto 30 + endif +c + elseif ( typsig(2).eq.0 ) then +c + numdeb = valent(2) + if ( numdeb.le.0 ) then + write (ulsost,texte(langue,9)) numdeb + codret = 1 + goto 30 + endif +c + else +c + write (ulsost,texte(langue,6)) 2 + codret = 1 + goto 30 +c + endif +c + else +c + write (ulsost,texte(langue,5)) choix + codret = 1 + goto 30 +c + endif +c + endif +c +c 2.5. ==> l'eventuel second numero +c + if ( codret.eq.0 ) then +c + if ( nbsign.ge.3 ) then +c + if ( typsig(3).eq.0 ) then +c + numfin = valent(3) +c + else +c + write (ulsost,texte(langue,6)) 3 + codret = 1 + goto 30 +c + endif +c + else +c + if ( numdeb.ne.0 ) then + numfin = numdeb + else + write (ulsost,texte(langue,5)) choix//' q' + codret = 1 + endif + goto 30 +c + endif +c + endif +c +c==== +c 3. fin +c==== +c + 30 continue +c + if ( codret.eq.0 ) then +c + call utlgut ( iaux, chaine, + > ulsort, langue, codret ) + write(ulfido,1000) chaine(1:iaux) +c + endif +c + 1000 format(a) +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Information/inqure.F b/src/tool/Information/inqure.F new file mode 100644 index 00000000..34831e2a --- /dev/null +++ b/src/tool/Information/inqure.F @@ -0,0 +1,368 @@ + subroutine inqure ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c INformation : QUestions / REponses +c -- -- -- +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'INQURE' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envada.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adopts, lgopts + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux, jaux + integer adinch, adinpf, adinpr, adinlg + integer typcca + integer lnomfi +c + integer ulfido, ulenst, ulsost +c + logical exisol +c + character*6 saux + character*8 action + character*8 nohman, nocsol, nochso + character*8 typobs + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c +#include "impr03.h" +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.1. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.2. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.3. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' QUESTIONS / REPONSES'')' + texte(1,5) = '(27(''=''),/)' +c + texte(2,4) = '(/,a6,'' QUESTIONS / ANSWERS'')' + texte(2,5) = '(26(''=''),/)' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les noms d'objets a conserver +c + if ( codret.eq.0 ) then + call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif + endif +c +c 1.8. ==> les numeros d'unite logique au terminal +c + call dmunit ( ulenst, ulsost ) +c +c 1.9. ==> l'action en cours +c + action = smem(adopts+29) +c +c 1.10. ==> le numero d'unite logique du fichier de donnees correct +c + call utulfd ( action, nbiter, ulfido, codret ) +c +c==== +c 2. le maillage d'entree +c==== +c + if ( codret.eq.0 ) then +c + nohman = smem(adopts+2) +c + endif +c +c==== +c 3. Lecture de tous les champs presents dans le fichier +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Lecture des champs ; codret', codret +#endif +c +c 3.1. ==> Recherche du type de code de calcul associe +c + if ( codret.eq.0 ) then +c + call gmliat ( nohman, 9, typcca, codret ) +c + endif +c +c 3.2. ==> Lecture de l'eventuelle solution +c Attention, c'est obligatoirement du format MED +c +c 3.2.1. ==> La solution existe-t-elle ? +c + if ( codret.eq.0 ) then +c + if ( mod(typcca-6,10).eq.0 ) then +c + typobs = mccson + iaux = 0 + jaux = 0 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then + exisol = .true. + else + exisol = .false. + codret = 0 + endif +c + else + exisol = .false. + endif +c + endif +c +c 3.2.2. ==> Une solution existe +c + if ( exisol ) then +c +c 3.2.2.1. ==> Lecture du format MED +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLSMD', nompro +#endif + nochso = ' ' + iaux = 0 + call eslsmd ( nocsol, nochso, + > imem(adopti+8), iaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2.2.2. ==> pour le cas extrude, passage du 3D au 2D +c + if ( imem(adopti+38).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEXT', nompro +#endif + iaux = 1 + call utsext ( nocsol, iaux, typcca, + > lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c + endif +c + else +c +c 3.2.3. ==> S'il n'y a pas de solution, on en alloue une vide. +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALSO', nompro +#endif + iaux = 0 + call utalso ( nocsol, + > iaux, iaux, iaux, iaux, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c + endif +cgn call gmprsx (nompro,nocsol) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Fin etape 4 avec codret = ', codret +#endif +c +c==== +c 4. questions / reponses +c==== +c + if ( codret.eq.0 ) then +c + imem(adetco+3) = imem(adetco+3) + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'INQUR1', nompro +#endif + call inqur1 ( nohman, nocsol, + > ulfido, ulenst, ulsost, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c +c 5.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 5.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + jaux = 0 + end diff --git a/src/tool/Modification/CMakeLists.txt b/src/tool/Modification/CMakeLists.txt new file mode 100644 index 00000000..e766aa4a --- /dev/null +++ b/src/tool/Modification/CMakeLists.txt @@ -0,0 +1,67 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Modification + +SET(Modification_SOURCES + ./mmag10.F + ./mmag11.F + ./mmag12.F + ./mmag13.F + ./mmag30.F + ./mmag31.F + ./mmag32.F + ./mmag33.F + ./mmag34.F + ./mmag35.F + ./mmag36.F + ./mmag40.F + ./mmag41.F + ./mmag42.F + ./mmag43.F + ./mmag91.F + ./mmag92.F + ./mmag93.F + ./mmag94.F + ./mmagco.F + ./mmagf0.F + ./mmagf1.F + ./mmagr0.F + ./mmagr2.F + ./mmagr4.F + ./mmagr5.F + ./mmagr6.F + ./mmagre.F + ./mmagve.F + ./mmcnp2.F + ./mmdeg0.F + ./mmdegr.F + ./mmelde.F + ./mmmodi.F + ./mmsn21.F + ./mmsn22.F + ./mmsnp2.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Modification ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Modification ${Modification_SOURCES}) + +INSTALL(TARGETS Modification EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Modification/mmag01.h b/src/tool/Modification/mmag01.h new file mode 100644 index 00000000..a9f29716 --- /dev/null +++ b/src/tool/Modification/mmag01.h @@ -0,0 +1,43 @@ +c + texte(1,4) = '(/,a,''Traitement du '',a,i8)' + texte(1,5) = '(27("="),/,'' Parcours des '',a,/,27("="))' + texte(1,6) = '(''Numero du joint a creer :'',i6)' + texte(1,7) = '(''Nombre de creations de '',a,'' :'',i8)' + texte(1,8) = '(''Nombre de duplications de '',a,'' :'',i8)' + texte(1,9) = '('' ==> '',a,i8,'' a dupliquer.'')' + texte(1,10) = '(''Nouveau nombre de '',a,'' :'',i8)' + texte(1,11) = '(5x,''Nombre de '',a,'' a creer :'',i8)' + texte(1,12) = '(/,5x,''Nombre de joints simples'',12x,'':'',i8)' + texte(1,13) = '(/,5x,''Nombre de joints triples'',12x,'':'',i8)' + texte(1,14) = '(/,5x,''Nombre de joints quadruples'',9x,'':'',i8)' + texte(1,15) = '(''Nouveau nombre de '',a,'' :'',i8)' + texte(1,16) = '(''. Creation du '',a,i8,'', cote'',i3)' + texte(1,17) = '('' extremites '',6i8)' + texte(1,18) = '(a,a,'' de famille :'',i4)' + texte(1,19) = '(''Nombre de familles de '',a,'' :'',i8)' + texte(1,20) = '(''. Caracteristiques :'',4i6)' + texte(1,21) = + >'(/,5x,''Nombre de joints ponctuels ordre '',i2,'' :'',i8)' + texte(1,22) = '(/,5x,''Nombre de joints ponctuels :'',i8)' + texte(1,30) = '(''Famille MED du '',a,i10,'' :'',i4)' +c + texte(2,4) = '(/,a,''Treatment of the '',a,i8)' + texte(2,5) = '(''Treatment of the '',a)' + texte(2,6) = '(''Creation of the junctions #'',i6)' + texte(2,7) = '(''Number of creations of '',a,'' :'',i8)' + texte(2,8) = '(''Number of duplications of '',a,'' :'',i8)' + texte(2,9) = '('' ==> '',a,i8,'' to duplicate.'')' + texte(2,10) ='(''New number of'',a,'' :'',i8)' + texte(2,11) = '(5x,''Number of '',a,'' to create :'',i8)' + texte(2,12) = '(/,5x,''Number of simple junctions :'',i8)' + texte(2,13) = '(/,5x,''Number of triple junctions :'',i8)' + texte(2,14) = '(/,5x,''Number of 4order junctions :'',i8)' + texte(2,15) = '(''New number of'',a,'' :'',i8)' + texte(2,16) = '(''. Creation of the '',a,i8,'', side'',i3)' + texte(2,17) = '('' ends '',6i8)' + texte(2,18) = '(a,'' Family of the ''a,'' :'',i4)' + texte(2,19) = '(''Number of families of '',a,'' :'',i8)' + texte(2,20) = '(''. Characteristics :'',4i6)' + texte(2,21) = '(/,5x,''Number of nodal junctions :'',i8)' + texte(2,22) = '(/,5x,''Number of nodal junctions :'',i8)' + texte(2,30) = '(''MED family of the '',a,i10,'':'',i4)' diff --git a/src/tool/Modification/mmag02.h b/src/tool/Modification/mmag02.h new file mode 100644 index 00000000..0f57eee6 --- /dev/null +++ b/src/tool/Modification/mmag02.h @@ -0,0 +1,12 @@ +c + texte(1,31) = '('' Joint triple'',i6)' + texte(1,32) = '('' Joint quadruple'',i6)' + texte(1,38) = '(''Impossible de trouver les '',a,'' doubles.'')' + texte(1,39) = '('' ==> Joints simples :'',4i6)' + texte(1,40) = '('' Pour le '',a,i8,'' => '',a,i8)' +c + texte(2,31) = '('' Triple junction #'',i6)' + texte(2,32) = '('' 4th order junction #'',i6)' + texte(2,38) = '(''Double '',a,'' cannot be found.'')' + texte(2,39) = '('' ==> Simple junctions :'',4i6)' + texte(2,40) = '('' For the '',a,i8,'' => '',a,i8)' diff --git a/src/tool/Modification/mmag10.F b/src/tool/Modification/mmag10.F new file mode 100644 index 00000000..d466d029 --- /dev/null +++ b/src/tool/Modification/mmag10.F @@ -0,0 +1,505 @@ + subroutine mmag10 ( somare, + > aretri, + > tritet, cotrte, + > nbjois, nbpejs, tbaux1, tbaux2, + > tbau30, tbau40, + > tbau31, tbau41, + > nbduno, nbduar, nbdutr, + > nbnotn, nbartn, nbtrtn, nbqutn, + > nbtetn, nbpetn, nbhetn, + > nbjoit, nbpejt, nbtrjt, + > nbjoiq, nbhejq, nbqujq, + > nbjp06, nbte06, + > nbjp09, nbpe09, + > nbjp12, nbhe12, + > nbvojm, + > tbaux5, + > ntra51, ptra51, ntra52, ptra52, + > ntra53, ptra53, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - phase 1.0 +c - - -- - - +c Connaissant le nombre et les caracteristiques des pentaedres +c a creer pour les joints simples : +c . Decompte du nombre de noeuds, aretes, quadrangles a creer +c . Decompte du nombre de joints multiples +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . nbjois . e . 1 . nombre de joints simples . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbaux2 . es . 4** . Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . s . 8** . Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . s . 6** . Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbau31 . s . 2** . Les triangles puis les quadrangles . +c . . . . construits sur un noeud multiple : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : numero du joint multiple cree . +c . tbau41 . s . 4** . Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . nbduno . s . 1 . nombre de duplications de noeuds . +c . nbduar . s . 1 . nombre de duplications d'aretes . +c . nbdutr . s . 1 . nombre de duplications de triangles . +c . nbnotn . s . 1 . nombre de noeuds total nouveau . +c . nbartn . s . 1 . nombre d'aretes total nouveau . +c . nbtrtn . s . 1 . nombre de triangles total nouveau . +c . nbqutn . s . 1 . nombre de quadrangles total nouveau . +c . nbtetn . s . 1 . nombre de tetraaedres total nouveau . +c . nbpetn . s . 1 . nombre de pentaedres total nouveau . +c . nbhetn . s . 1 . nombre d'hexaedres total nouveau . +c . nbjoit . s . 1 . nombre de joints triples . +c . nbpejt . s . 1 . nombre de pentaedres de joints triples . +c . nbtrjt . s . 1 . nombre de triangles de joints triples . +c . nbjoiq . s . 1 . nombre de joints quadruples . +c . nbhejq . s . 1 . nombre d'hexaedres de joints quadruples . +c . nbqujq . s . 1 . nombre de quad. crees pour j. quadruples . +c . nbjp06 . s . 1 . nombre de joints ponctuels ordre 6 . +c . nbte06 . s . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . nbjp09 . s . 1 . nombre de joints ponctuels ordre 9 . +c . nbpe09 . s . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . nbjp12 . s . 1 . nombre de joints ponctuels ordre 12 . +c . nbhe12 . s . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . nbvojm . s . 1 . nombre de volumes de joints multiples . +c . tbaux5 . --- . 4** . Pour la i-eme duplication d'arete : . +c . . . . (1,i), (2,i), (3,i), (4,i) . +c . . . . numeros ordonnes des joints simples crees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG10' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "envex1.h" +#include "impr02.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer nbjois, nbpejs + integer tbaux1(4,nbpejs), tbaux2(4,*) + integer tbau30(8,*), tbau40(6,*) + integer tbau31(2,*), tbau41(4,*) + integer tbaux5(4,*) +c + integer nbduno, nbduar, nbdutr + integer nbnotn, nbartn, nbtrtn, nbqutn + integer nbtetn, nbpetn, nbhetn + integer nbjoit, nbpejt, nbtrjt + integer nbjoiq, nbhejq, nbqujq + integer nbjp06, nbte06 + integer nbjp09, nbpe09 + integer nbjp12, nbhe12 + integer nbvojm + integer ptra51, ptra52, ptra53 +c + character*8 ntra51, ntra52, ntra53 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3 + integer codre0 +c + integer iaux, jaux +#ifdef _DEBUG_HOMARD_ + integer kaux +#endif + integer indnoe, indare + integer multax, multnx +c + integer muarmx + parameter ( muarmx = 4 ) + integer nbarmu(muarmx) +c + integer munomx + parameter ( munomx = 12 ) + integer nbnomu(munomx) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nbjois + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs +#endif +c +c 1.2. ==> Constantes +c + codret = 0 +c + nbduno = 0 + nbduar = 0 + indnoe = nbnoto + indare = nbarto + nbdutr = nbpejs +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr +#endif +c +c==== +c 2. Reperage des joints simples +c==== +c + if ( codret.eq.0 ) then +c + call gtdems (62) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG11', nompro +#endif + call mmag11 ( somare, + > aretri, + > tritet, cotrte, + > nbpejs, tbaux1, tbaux2, + > tbau30, tbau40, + > nbduno, nbduar, nbdutr, + > indnoe, indare, + > ulsort, langue, codret ) +c + call gtfims (62) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,3,-1),indnoe-nbnoto + write (ulsort,texte(langue,11)) mess14(langue,3,1), indare-nbarto + write (ulsort,texte(langue,11)) mess14(langue,3,2), 2*nbdutr + write (ulsort,texte(langue,11)) mess14(langue,3,4), nbduar +#endif +c + nbnotn = indnoe + nbartn = indare + nbtrtn = nbtrto + 2*nbdutr + nbqutn = nbduar +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,-1), nbnotn + write (ulsort,texte(langue,10)) mess14(langue,3,1), nbartn + write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn + write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn +#endif +c + endif +c +c==== +c 3. Reperage des joints multiples +c==== +c + call gtdems (63) +c +c 3.1. ==> Recherche des aretes et des noeuds multiples +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG12', nompro +#endif + call mmag12 ( muarmx, nbarmu, multax, + > munomx, nbnomu, multnx, + > nbduno, nbduar, + > tbau30, tbau40, + > tbaux5, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Allocation +c + if ( codret.eq.0 ) then +c + jaux = 0 + do 32 , iaux = 4 , multnx + jaux = jaux + nbnomu(iaux) + 32 continue +c + iaux = (1+2*4)*nbnomu(6) + call gmalot ( ntra51, 'entier ', iaux, ptra51, codre1 ) +c + iaux = (1+2*5)*nbnomu(9) + call gmalot ( ntra52, 'entier ', iaux, ptra52, codre2 ) +c + iaux = (1+2*6)*nbnomu(12) + call gmalot ( ntra53, 'entier ', iaux, ptra53, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 3.3. ==> Creation des mailles a partir des aretes et noeuds multiples +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG13', nompro +#endif + call mmag13 ( muarmx, nbarmu, multax, multnx, + > somare, + > nbjois, tbaux2, + > nbduno, nbduar, nbtrtn, nbqutn, + > tbau30, tbau40, + > tbau31, tbau41, + > imem(ptra51), imem(ptra52), imem(ptra53), + > nbjoit, nbpejt, nbtrjt, + > nbjoiq, nbhejq, nbqujq, + > nbjp06, nbte06, + > nbjp09, nbpe09, + > nbjp12, nbhe12, + > tbaux5, + > ulsort, langue, codret ) +c + endif +cgn nbjp06=0 +cgn nbte06=0 +c + call gtfims (63) +c +c==== +c 4. Messages +c==== +c +c 4.1. ==> Nouvelles entites +c + if ( codret.eq.0 ) then +c + nbtrtn = nbtrtn + nbtrjt + nbqutn = nbqutn + nbqujq + nbtetn = nbteto + nbte06 + nbpetn = nbpejs + nbpejt + nbpe09 + nbhetn = nbhejq + nbhe12 +c + nbvojm = nbpejt + nbhejq +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn + write (ulsort,texte(langue,10)) mess14(langue,3,3), nbtetn + write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn + write (ulsort,texte(langue,10)) mess14(langue,3,7), nbpetn + write (ulsort,texte(langue,10)) mess14(langue,3,6), nbhetn +#endif +c + endif +c +c 4.2. ==> Joints triples +c + if ( nbjoit.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,13)) nbjoit + write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpejt +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,3,2), nbtrjt +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1420) + jaux = nbjois + 1 + kaux = nbjois + nbjoit + do 42 , iaux = jaux, kaux + write (ulsort,1421) iaux-nbjois, + > tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux) + 42 continue + write (ulsort,1422) +c + 1420 format( /,5x,41('*'), + > /,5x,'* Joint t *',3(' Joint s *'), + > /,5x,41('*')) + 1421 format(4x,4(' *',i8),' *') + 1422 format(5x,41('*'),/) +#endif +c + endif +c + endif +c +c 4.3. ==> Joints quadruples +c + if ( nbjoiq.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,14)) nbjoiq + write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhejq +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) mess14(langue,3,4), nbqujq +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1430) + jaux = nbjois + nbjoit + 1 + kaux = nbjois + nbjoit + nbjoiq + do 43 , iaux = jaux, kaux + write (ulsort,1431) iaux-nbjois-nbjoit, + > tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux), tbaux2(4,iaux) + 43 continue + write (ulsort,1432) +c + 1430 format( /,5x,51('*'), + > /,5x,'* Joint q *',4(' Joint s *'), + > /,5x,51('*')) + 1431 format(4x,5(' *',i8),' *') + 1432 format(5x,51('*'),/) +#endif +c + endif +c + endif +c +c 4.4. ==> Joints ponctuels +c + if ( nbjp06.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,21)) 6, nbjp06 + write (ulsort,texte(langue,11)) mess14(langue,3,3), nbte06 +c + endif +c + endif +c + if ( nbjp09.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,21)) 9, nbjp09 + write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpe09 +c + endif +c + endif +c + if ( nbjp12.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,21)) 12, nbjp12 + write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhe12 +c + endif +c + endif +cc +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag11.F b/src/tool/Modification/mmag11.F new file mode 100644 index 00000000..16ed8f40 --- /dev/null +++ b/src/tool/Modification/mmag11.F @@ -0,0 +1,444 @@ + subroutine mmag11 ( somare, + > aretri, + > tritet, cotrte, + > nbpejs, tbaux1, tbaux2, + > tbau30, tbau40, + > nbduno, nbduar, nbdutr, + > indnoe, indare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - phase 1.1 +c - - -- - - +c Connaissant le nombre et les caracteristiques des pentaedres +c a creer pour les joints simples : +c . Liste des duplications de noeuds avec pour chacune d'elles : +c - numero du noeud a dupliquer +c - numero de l'arete entre les noeuds doubles +c - numero des 2 noeuds doubles a creer +c - numero du joint simple exigeant la duplication +c . Liste des duplications d'aretes avec pour chacune d'elles : +c - numero de l'arete entre les noeuds doubles +c - numero des 2 aretes doubles a creer +c - numero du joint simple exigeant la duplication +c . Decompte du nombre de duplications de noeuds, d'aretes et +c de triangles +c . Numero du dernier noeud cree +c . Numero de la derniere arete creee +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des 4 triangles des tetraedres . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbaux2 . e . 4** . Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . s . 8** . Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . s . 6** . Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . nbduno . s . 1 . nombre de duplications de noeuds . +c . nbduar . s . 1 . nombre de duplications d'aretes . +c . nbdutr . s . 1 . nombre de duplications de triangles . +c . indnoe . es . 1 . dernier noeud a creer . +c . indare . es . 1 . derniere arete a creer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG11' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer nbpejs + integer tbaux1(4,nbpejs), tbaux2(4,*) + integer tbau30(8,*), tbau40(6,*) +c + integer nbduno, nbduar, nbdutr + integer indnoe, indare +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer letria + integer letetr, listar(6) + integer laret0(2), laret1(2) + integer lenoe0(2) + integer nujois, nujoi0 + integer fammed(2) + integer som1, arejnt +c + integer are(3), som(3) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "impr03.h" +c + texte(1,31) = '('' ==> '',a,''en lien :'',2i8)' +c + texte(2,31) = '('' ==> connected '',a,'':'',2i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs +#endif +c +c 1.2. ==> Constantes +c + codret = 0 +c + nbduno = 0 + nbduar = 0 + nbdutr = nbpejs +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr +#endif +c +c==== +c 2. Parcours des pentaedres a creer pour noter les aretes a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,7)//' - ar dupl' +#endif +c + if ( codret.eq.0 ) then +c + do 2 , iaux = 1 , nbpejs +c + letria = tbaux1(1,iaux) + nujois = tbaux1(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria +#endif +c + do 21 , jaux = 1 , 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '.. ',mess14(langue,1,1), + > aretri(letria,jaux) +#endif +c +c 2.1.1. ==> Si l'arete a deja ete dupliquee pour ce joint, on +c passe a la suite +c + do 211 , kaux = 1 , nbduar +c + if ( tbau40(1,kaux).eq.aretri(letria,jaux) .and. + > tbau40(4,kaux).eq.nujois ) then + goto 21 + endif +c + 211 continue +c +c 2.1.2. ==> L'arete est a dupliquer. +c On repere si elle l'a deja ete pour un des cotes. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,1,1), + > aretri(letria,jaux) +#endif +c + fammed(1) = tbaux2(1,nujois) + fammed(2) = tbaux2(2,nujois) +cgn write(ulsort,*) fammed + do 212 , laux = 1 , 2 + do 2121 , kaux = 1 , nbduar +cgn write(ulsort,*) kaux, tbau40(1,kaux),tbau40(4,kaux) + if ( tbau40(1,kaux).eq.aretri(letria,jaux) ) then + nujoi0 = tbau40(4,kaux) + if ( tbaux2(1,nujoi0).eq.fammed(laux) ) then + laret0(laux) = tbau40(2,kaux) + goto 212 + elseif ( tbaux2(2,nujoi0).eq.fammed(laux) ) then + laret0(laux) = tbau40(3,kaux) + goto 212 + endif + endif + 2121 continue + indare = indare + 1 + laret0(laux) = indare + 212 continue +c +c 2.1.3. ==> Le triangle est a dupliquer pour le joint en cours. +c L'arete dupliquee est tbau40(1,kaux). On cherche l'autre +c arete du triangle dont une extremite est le point de depart +c de cette arete dupliquee. Cela servira a orienter les +c joints multiples. +c + som1 = somare(1,aretri(letria,jaux)) + do 213 , kaux = 1 ,3 + if ( kaux.ne.jaux ) then + if ( som1.eq.somare(1,aretri(letria,kaux)) .or. + > som1.eq.somare(2,aretri(letria,kaux)) ) then + arejnt = aretri(letria,kaux) + endif + endif + 213 continue +c +c 2.1.4. ==> Enregistrement +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) mess14(langue,3,1), laret0 +#endif + nbduar = nbduar + 1 + tbau40(1,nbduar) = aretri(letria,jaux) + tbau40(2,nbduar) = laret0(1) + tbau40(3,nbduar) = laret0(2) + tbau40(4,nbduar) = nujois + tbau40(6,nbduar) = arejnt +c + 21 continue +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbduar +#endif +c + endif +c +c==== +c 3. Parcours des pentaedres a creer pour noter les aretes a creer +c Remarque : on le fait en deux fois pour gerer les numerotations +c des aretes de manieres independantes : d'abord celles +c issues de duplication, ensuite celles issues de +c duplications de noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,7)//' - ar crea' +#endif +c + if ( codret.eq.0 ) then +c + do 3 , iaux = 1 , nbpejs +c + letria = tbaux1(1,iaux) + nujois = tbaux1(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria +#endif +c +c 3.1. ==> Aretes et les sommets +c + are(1) = aretri(letria,1) + are(2) = aretri(letria,2) + are(3) = aretri(letria,3) +c + call utsotr ( somare, are(1), are(2), are(3), + > som(1), som(2), som(3) ) +c +c 3.2. ==> Les noeuds +c + do 32 , jaux = 1 , 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '..',mess14(langue,1,-1),som(jaux) +#endif +c +c 3.2.1. ==> Si le noeud a deja ete duplique pour ce joint, on +c passe a la suite +c + do 321 , kaux = 1 , nbduno +c + if ( tbau30(1,kaux).eq.som(jaux) .and. + > tbau30(5,kaux).eq.nujois ) then +cgn write(ulsort,*) '.... noeud deja duplique' + goto 32 + endif +c + 321 continue +c +c 3.2.2. ==> Le noeud est a dupliquer. +c On repere si il l'a deja ete pour un des cotes. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,1,-1), som(jaux) +#endif + fammed(1) = tbaux2(1,nujois) + fammed(2) = tbaux2(2,nujois) +cgn write(ulsort,*) 'fammed des 2 cotes', fammed + do 322 , laux = 1 , 2 + do 3221 , kaux = 1 , nbduno +cgn write(ulsort,*) 'Duplication nro', kaux +cgn write(ulsort,*)'no dup', tbau30(1,kaux), ', j simp',tbau30(5,kaux) + if ( tbau30(1,kaux).eq.som(jaux) ) then + nujoi0 = tbau30(5,kaux) +cgn write(ulsort,*) 'Joint nro', nujoi0 +cgn write(ulsort,*) 'avec fammed',tbaux2(1,nujoi0),tbaux2(2,nujoi0) + if ( tbaux2(1,nujoi0).eq.fammed(laux) ) then + lenoe0(laux) = tbau30(3,kaux) + goto 322 + elseif ( tbaux2(2,nujoi0).eq.fammed(laux) ) then + lenoe0(laux) = tbau30(4,kaux) + goto 322 + endif + endif + 3221 continue + indnoe = indnoe + 1 + lenoe0(laux) = indnoe + 322 continue +c +c 3.2.3. ==> Reperage de l'arete partant du noeud vers le volume +c + do 323 , kaux = 1 , 2 +c + letetr = tbaux1(2+kaux,iaux) + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +cgn write(ulsort,90002) mess14(langue,4,1)//'du noeud', listar +c + do 3231 , laux = 1 , 6 +c + if ( listar(laux).ne.are(1) .and. + > listar(laux).ne.are(2) .and. + > listar(laux).ne.are(3) ) then +cgn write(ulsort,90002) mess14(langue,2,1), listar(laux) + if ( somare(1,listar(laux)).eq.som(jaux) ) then + laret1(kaux) = listar(laux) + elseif ( somare(2,listar(laux)).eq.som(jaux) ) then + laret1(kaux) = -listar(laux) + endif + endif +c + 3231 continue +c + 323 continue +c +c 3.2.4. ==> Enregistrement +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) mess14(langue,3,-1), lenoe0 + write (ulsort,texte(langue,31)) mess14(langue,1,1), indare+1 +#endif + indare = indare + 1 + nbduno = nbduno + 1 + tbau30(1,nbduno) = som(jaux) + tbau30(2,nbduno) = indare + tbau30(3,nbduno) = lenoe0(1) + tbau30(4,nbduno) = lenoe0(2) + tbau30(5,nbduno) = nujois + tbau30(6,nbduno) = laret1(1) + tbau30(7,nbduno) = laret1(2) +c + 32 continue +c + 3 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag12.F b/src/tool/Modification/mmag12.F new file mode 100644 index 00000000..61f8036a --- /dev/null +++ b/src/tool/Modification/mmag12.F @@ -0,0 +1,536 @@ + subroutine mmag12 ( muarmx, nbarmu, multax, + > munomx, nbnomu, multnx, + > nbduno, nbduar, + > tbau30, tbau40, + > tbaux5, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - phase 1.2 +c - - -- - - +c Connaissant le nombre et les caracteristiques des duplications +c a effectuer pour les joints simples : +c . Pour chaque duplication de noeuds : +c - ordre de multiplicite de la duplication +c . Pour chaque duplication d'aretes : +c - ordre de multiplicite de la duplication +c . Pour chaque duplication d'aretes : +c - liste des joints simples pour lesquels l'arete initiale +c est dupliquee +c . Ordre de multiplicite maximal des aretes +c . Nombre d'aretes pour chacun des ordres possibles +c . Ordre de multiplicite maximal des noeuds +c . Nombre d'aretes pour chacun des ordres possibles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . muarmx . e . 1 . ordre de multiplicite des aretes maximal . +c . . . . possible . +c . nbarmu . s . muarmx . nombre d'aretes par ordre de multiplicite . +c . multax . s . 1 . ordre de multiplicite des aretes maximal . +c . munomx . e . 1 . ordre de multiplicite des noeuds maximal . +c . . . . possible . +c . nbnomu . s . munomx . nombre de noeuds par ordre de multiplicite . +c . multnx . s . 1 . ordre de multiplicite des noeuds maximal . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . tbau30 . es .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . es .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbaux5 . --- . 4** . Pour la i-eme duplication d'arete : . +c . . . . (1,i), (2,i), (3,i), (4,i) . +c . . . . numeros ordonnes des joints simples crees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -30 : muarmx est trop petit . +c . . . . -50 : munomx est trop petit . +c . . . . >0 : problemes de multipicites imprevues . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG12' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +cc + integer muarmx, multax + integer nbarmu(muarmx) + integer munomx, multnx + integer nbnomu(munomx) +c + integer nbduno, nbduar + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbaux5(4,nbduar) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer larete + integer lenoeu + integer multip + integer nujois(4) +#ifdef _DEBUG_HOMARD_ + integer pbmult +#endif +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c + texte(1,31) = '(5x,''* Ordre de * Nombre de *'')' + texte(1,32) = '(5x,''* multiplicite * '',a, '' *'')' + texte(1,33) = '(''Multiplicite '',a,'' :'',i8)' + texte(1,34) = '(''Gestion impossible au dela de'',i3)' + texte(1,35) = + >'(a,'': impossible de traiter une multiplicite d''''ordre'',i4,/)' + texte(1,36) = + >'(a,'': multiplicite d''''ordre'',i4,'' impossible.''/)' + texte(1,37) = + >'(i4,'' cas de multiplicite impossibles a resoudre.''/)' +c + texte(2,31) = '(5x,''* Order of * Number of *'')' + texte(2,32) = '(5x,''* multiplicity * '',a, '' *'')' + texte(2,33) = '(''Order '',a,'' :'',i8)' + texte(2,34) = '(''Impossible above'',i3)' + texte(2,35) = + >'(a,'': a'',i4,''-order multiplicity cannot be solved.''/)' + texte(2,36) = + >'(a,'': a'',i4,''-order multiplicity cannot exist.''/)' + texte(2,37) = + >'(i4,'' cases of multiplicity cannot be solved.''/)' +c +#include "impr03.h" + 1000 format(5x,33('*')) + 1001 format(5x,'* ',i3,' * ',i6,' *') + 1002 format(5x,33('*'),/) + 1003 format(/,5x,33('*')) +c +c 1.2. ==> Constantes +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + pbmult = 0 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar +#endif +c +cgn write(ulsort,90002) 'tbaux2',4,nbjois +cgn do 1101 , kaux = 1,nbjois +cgn write(ulsort,91010) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,90002) 'tbau30',8,nbduno +cgn do 1102 , kaux = 1,nbduno +cgn write(ulsort,91010) (tbau30(jaux,kaux),jaux=1,8) +cgn 1102 continue +cgn write(ulsort,90002) 'tbau40',6,nbduar +cgn do 1103 , kaux = 1,nbduar +cgn write(ulsort,91010) (tbau40(jaux,kaux),jaux=1,6) +cgn 1103 continue +cgn write(ulsort,90002) 'tbau41',4,5 +cgn do 1104 , kaux = 1,5 +cgn write(ulsort,91010) (tbau41(jaux,kaux),jaux=1,4) +cgn 1104 continue +c +c==== +c 2. Recherche de l'ordre de multiplicite des aretes a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Parcours des aretes ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c +c 2.1. ==> Initialisation sans joint simple au voisinage des +c aretes dupliquees +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nbduar +c + tbaux5(1,iaux) = 0 + tbaux5(2,iaux) = 0 + tbaux5(3,iaux) = 0 + tbaux5(4,iaux) = 0 +c + 21 continue +c + endif +c +c 2.2. ==> Recherche de l'ordre de multiplicite des aretes a dupliquer +c On memorise le ou les joints simples associes. +c + multax = 0 +c + if ( codret.eq.0 ) then +c + do 22 , iaux = 1 , nbduar +c + larete = tbau40(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +#endif +cgn if ( larete.eq.2387 ) then +cgn write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +cgn write(ulsort,91010) (tbau40(kaux,iaux),kaux=1,6) +cgn endif +c + multip = 0 +c + do 221 , jaux = 1 , nbduar +c +c on tombe sur la meme arete (au moins quand jaux = iaux !) +c + if ( larete.eq.tbau40(1,jaux) ) then +c + multip = multip + 1 +c a la 1ere coincidence d'arete dupliquee, on garde le joint + if ( multip.eq.1 ) then + tbaux5(1,iaux) = tbau40(4,jaux) +c +c a la 2eme coincidence d'arete dupliquee, on prend le min +c et le max entre le joint deja vu et le joint courant + elseif ( multip.eq.2 ) then + nujois(1) = min(tbaux5(1,iaux),tbau40(4,jaux)) + nujois(2) = max(tbaux5(1,iaux),tbau40(4,jaux)) + tbaux5(1,iaux) = nujois(1) + tbaux5(2,iaux) = nujois(2) +c +c a la 3eme ou 4eme coincidence d'arete dupliquee, on +c positionne le joint courant a sa place vis-a-vis des joints +c deja enregistres + elseif ( multip.eq.3 .or.multip.eq.4 ) then +cgn write (ulsort,2222) tbau40(1,iaux),(tbaux5(kaux,iaux),kaux=1,2) + do 2211 , kaux = 1 , multip-1 +cgn write (ulsort,2222) tbau40(4,jaux),tbaux5(kaux,iaux) + if ( tbau40(4,jaux).lt.tbaux5(kaux,iaux) ) then + nujois(kaux) = tbau40(4,jaux) + do 2213 , laux = kaux , multip-1 + nujois(laux+1) = tbaux5(laux,iaux) + 2213 continue + goto 2212 + else + nujois(kaux) = tbaux5(kaux,iaux) + endif + 2211 continue + nujois(multip) = tbau40(4,jaux) + 2212 continue +cgn write (ulsort,2222) +cgn > tbau40(1,iaux),nujois(1),nujois(2),nujois(3) + tbaux5(1,iaux) = nujois(1) + tbaux5(2,iaux) = nujois(2) + tbaux5(3,iaux) = nujois(3) + if ( multip.eq.4 ) then + tbaux5(4,iaux) = nujois(4) + endif +cgn write (ulsort,2222) +cgn > tbau40(1,iaux),(tbaux5(kaux,iaux),kaux=1,multip) +c + endif +c + endif +c + 221 continue +c + tbau40(5,iaux) = multip + multax = max(multax,multip) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,33)) ' ', multip + write (ulsort,texte(langue,20)) (tbaux5(kaux,iaux),kaux=1,4) +#endif +cgn write(ulsort,90001) +cgn > 'tbau40 de',iaux,(tbau40(kaux,iaux),kaux=1,6) +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,33)) 'max', multax +#endif +c + endif +c +c==== +c 3. Decompte des aretes multiples +c Remarque : les doubles apparaissent quand deux joints simples se +c rencontrent au bord du domaine. Il n'y a donc rien +c de special a faire. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Decompte ar. multiples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Verification informatique +c + if ( multax.gt.muarmx ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1) + write (ulsort,texte(langue,33)) 'max', multax + write (ulsort,texte(langue,34)) muarmx + codret = -30 + endif +c + endif +c +c 3.2. ==> Decompte +c + if ( codret.eq.0 ) then +c + do 321 , iaux = 1 , muarmx + nbarmu(iaux) = 0 + 321 continue +cgn write(ulsort,90002) 'quadruple' +c + do 322 , iaux = 1 , nbduar + nbarmu(tbau40(5,iaux)) = nbarmu(tbau40(5,iaux)) + 1 +cgn if ( tbau40(5,iaux).eq.2 ) then +cgn print 91010, (tbau40(jaux,iaux),jaux=1,6) +cgn endif + 322 continue +c + do 323 , iaux = 2 , multax + nbarmu(iaux) = nbarmu(iaux)/iaux + 323 continue +c +c 3.3. ==> Affichage +c + write (ulsort,1003) + write (ulsort,texte(langue,31)) + write (ulsort,texte(langue,32)) mess14(langue,3,1) + write (ulsort,1000) + do 33 , iaux = 1 , multax + write (ulsort,1001) iaux, nbarmu(iaux) + 33 continue + write (ulsort,1002) +c +c 3.4. ==> Controle +c +#ifdef _DEBUG_HOMARD_ + do 34 , iaux = 5 , multax +c + if ( nbarmu(iaux).gt.0 ) then + pbmult = pbmult + 1 + write (ulsort,texte(langue,35)) mess14(langue,4,1), iaux + endif +c + 34 continue +#endif +c + endif +c +c==== +c 4. Recherche de l'ordre de multiplicite des noeuds a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Parcours des noeuds ; codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,-1) +#endif +c +c 4.1. ==> Recherche de l'ordre de multiplicite des noeuds a dupliquer +c + multnx = 0 +c + if ( codret.eq.0 ) then +c + do 4 , iaux = 1 , nbduno +c + lenoeu = tbau30(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu +#endif +c + multip = 0 + do 41 , jaux = 1 , nbduno + if ( lenoeu.eq.tbau30(1,jaux) ) then + multip = multip + 1 + endif + 41 continue + tbau30(8,iaux) = multip + multnx = max(multnx,multip) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,33)) ' ', multip +#endif +c + 4 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,33)) 'max', multnx +#endif +c + endif +c +c==== +c 5. Decompte des noeuds multiples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Decompte no. multiples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 5.1. ==> Verification informatique +c + if ( multnx.gt.munomx ) then + write (ulsort,texte(langue,5)) mess14(langue,3,-1) + write (ulsort,texte(langue,33)) 'max', multnx + write (ulsort,texte(langue,34)) munomx + codret = -50 + endif +c + endif +c +c 5.2. ==> Decompte +c + if ( codret.eq.0 ) then +c + do 521 , iaux = 1 , munomx + nbnomu(iaux) = 0 + 521 continue +c + do 522 , iaux = 1 , nbduno + nbnomu(tbau30(8,iaux)) = nbnomu(tbau30(8,iaux)) + 1 + 522 continue +c + do 523 , iaux = 2 , multnx + nbnomu(iaux) = nbnomu(iaux)/iaux + 523 continue +c +c 5.3. ==> Affichage +c + write (ulsort,1000) + write (ulsort,texte(langue,31)) + write (ulsort,texte(langue,32)) mess14(langue,3,-1) + write (ulsort,1000) + do 53 , iaux = 1 , multnx + write (ulsort,1001) iaux, nbnomu(iaux) + 53 continue + write (ulsort,1002) +c +c 5.4. ==> Controle +c +#ifdef _DEBUG_HOMARD_ + do 54 , iaux = 1 , multnx +c + if ( nbnomu(iaux).gt.0 ) then + if ( iaux.eq.2 .or. + > iaux.eq.5 ) then + pbmult = pbmult + 1 + write (ulsort,texte(langue,36)) mess14(langue,4,-1), iaux + elseif ( iaux.eq.7 .or. + > iaux.eq.8 .or. + > iaux.eq.10 .or. + > iaux.eq.11 ) then + pbmult = pbmult + 1 + write (ulsort,texte(langue,35)) mess14(langue,4,-1), iaux + endif + endif +c + 54 continue +#endif +c + endif +c +c==== +c 6. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( pbmult.ne.0 ) then + write (ulsort,texte(langue,37)) pbmult + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag13.F b/src/tool/Modification/mmag13.F new file mode 100644 index 00000000..be9a176c --- /dev/null +++ b/src/tool/Modification/mmag13.F @@ -0,0 +1,744 @@ + subroutine mmag13 ( muarmx, nbarmu, multax, multnx, + > somare, + > nbjois, tbaux2, + > nbduno, nbduar, nbtrtn, nbqutn, + > tbau30, tbau40, + > tbau31, tbau41, + > tbau51, tbau52, tbau53, + > nbjoit, nbpejt, nbtrjt, + > nbjoiq, nbhejq, nbqujq, + > nbjp06, nbte06, + > nbjp09, nbpe09, + > nbjp12, nbhe12, + > tbaux5, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - phase 1.3 +c - - -- - - +c . Creation des mailles a partir des aretes et noeuds multiples +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . muarmx . e . 1 . ordre de multiplicite des aretes maximal . +c . . . . possible . +c . nbarmu . e . muarmx . nombre d'aretes par ordre de multiplicite . +c . multax . e . 1 . ordre de multiplicite des aretes maximal . +c . munrmx . e . 1 . ordre de multiplicite des noeuds maximal . +c . . . . possible . +c . multnx . e . 1 . ordre de multiplicite des noeuds maximal . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nbjois . e . 1 . nombre de joints simples . +c . tbaux2 . es . 4** . Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . es .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . es .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbtrtn . e . 1 . nouveau nombre total de triangles . +c . nbqutn . e . 1 . nouveau nombre total de quadrangles . +c . tbau31 . s . 2** . Les triangles puis les quadrangles . +c . . . . construits sur un noeud multiple : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : numero du joint multiple cree . +c . tbau41 . s . 4** . Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . tbau51 . s . 9** . Les tetraedres ponctuels entre les joints . +c . . . . triples (ordre 6) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : triangle cote du 3eme joint triple . +c . . . . (5,i) : triangle cote du 4eme joint triple . +c . . . . (1+k) : pour le k-eme triangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . tbau52 . s . 11** . Les pentaedres ponctuels entre les joints . +c . . . . triples et quadruples (ordre 9) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . tbau53 . s . 13** . Les hexaedres ponctuels entre les joints . +c . . . . quadruples (ordre 12) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : quadrangle cote du 1er joint quad. . +c . . . . (3,i) : quadrangle cote du 2eme joint quad.. +c . . . . (4,i) : quadrangle cote du 3eme joint quad.. +c . . . . (5,i) : quadrangle cote du 4eme joint quad.. +c . . . . (6,i) : quadrangle cote du 5eme joint quad.. +c . . . . (7,i) : quadrangle cote du 6eme joint quad.. +c . . . . (1+k) : pour le k-eme quadrangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . nbjoit . s . 1 . nombre de joints triples . +c . nbpejt . s . 1 . nombre de pentaedres de joints triples . +c . nbtrjt . s . 1 . nombre de triangles de joints triples . +c . nbjoiq . s . 1 . nombre de joints quadruples . +c . nbhejq . s . 1 . nombre d'hexaedres de joints quadruples . +c . nbqujq . s . 1 . nombre de quad. crees pour j. quadruples . +c . nbjp06 . s . 1 . nombre de joints ponctuels ordre 6 . +c . nbte06 . s . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . nbjp09 . s . 1 . nombre de joints ponctuels ordre 9 . +c . nbpe09 . s . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . nbjp12 . s . 1 . nombre de joints ponctuels ordre 12 . +c . nbhe12 . s . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . tbaux5 . --- . 4** . Pour la i-eme duplication d'arete : . +c . . . . (1,i), (2,i), (3,i), (4,i) . +c . . . . numeros ordonnes des joints simples crees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG13' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer muarmx, multax, multnx + integer nbarmu(muarmx) +c + integer somare(2,nbarto) + integer nbjois + integer nbduno, nbduar, nbtrtn, nbqutn + integer tbaux2(4,*) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbau31(2,*), tbau41(4,*) + integer tbau51(9,*), tbau52(11,*), tbau53(13,*) + integer tbaux5(4,nbduar) +c + integer nbtrjt, nbqujq + integer nbjoit, nbpejt + integer nbjoiq, nbhejq + integer nbjp06, nbte06 + integer nbjp09, nbpe09 + integer nbjp12, nbhe12 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer jdeb, kdeb + integer lequad, letria, larete + integer lenoeu + integer nujoin +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "impr03.h" +c + texte(1,31) = '(''Ordre de multiplicite :'',i2)' + texte(1,32) = '(''Nombre estime de '',a,'':'',i6)' + texte(1,33) = '(''Nombre reel de '',a,'' :'',i6)' + texte(1,34) = '(''Creation du joint :'',i6)' +c + texte(2,31) = '(''Ordre of multiplicity :'',i2)' + texte(2,32) = '(''Estimate number of '',a,'':'',i6)' + texte(2,33) = '(''Real number of '',a,'' :'',i6)' + texte(2,34) = '(''Creation of junction #'',i6)' +c +c 1.2. ==> Constantes +c + codret = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar +#endif +c + nbtrjt = 0 + nbjoit = 0 + nbpejt = 0 +c + nbqujq = 0 + nbjoiq = 0 + nbhejq = 0 +c + nbjp06 = 0 + nbte06 = 0 +c + nbjp09 = 0 + nbpe09 = 0 +c + nbjp12 = 0 + nbhe12 = 0 +c +cgn write(ulsort,90002) 'tbaux2',4,nbjois +cgn do 1101 , kaux = 1,nbjois +cgn write(ulsort,90010) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,90002) 'tbau30',8,nbduno +cgn do 1102 , kaux = 1,nbduno +cgn write(ulsort,90010) (tbau30(jaux,kaux),jaux=1,8) +cgn 1102 continue +cgn write(ulsort,90002) 'tbau40',5,nbduar +cgn do 1102 , kaux = 1,nbduar +cgn write(ulsort,90010) (tbau40(jaux,kaux),jaux=1,6) +cgn 1102 continue +cgn write(ulsort,90002) 'tbau41',4,5 +cgn do 1103 , kaux = 1,5 +cgn write(ulsort,90010) (tbau41(jaux,kaux),jaux=1,4) +cgn 1103 continue +c +c==== +c 2. Caracterisation des noeuds muliples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Caract noeuds multiples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( multnx.ge.6 ) then +c + do 21 , iaux = 1 , nbduno +cgn write (ulsort,90002) 'Ordre', tbau30(8,iaux) +c +c 2.1. ==> Les noeuds d'ordre 6 +c Ils sont a la jonction de 4 joints triples. +c Ils formeront un joint ponctuel forme d'un tetraedre. +c + if ( tbau30(8,iaux).eq.6 ) then +c + lenoeu = tbau30(1,iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu +#endif +c On recherche dans les tetraedres deja crees si on en a +c un qui est base sur le meme noeud multiple. Si oui, +c on ne recommence pas ! +c + do 211 , jaux = 1 , nbjp06 +c + if ( tbau51(1,jaux).eq.lenoeu ) then + goto 21 + endif +c + 211 continue +c +c Il faut noter un nouveau joint ponctuel +c + nbjp06 = nbjp06 + 1 + tbau51(1,nbjp06) = lenoeu + tbau51(2,nbjp06) = 0 + tbau51(3,nbjp06) = 0 + tbau51(4,nbjp06) = 0 + tbau51(5,nbjp06) = 0 +c +c 2.2. ==> Les noeuds d'ordre 9 +c Ils sont a la jonction de 2 joints triples et de 3 joints +c quadruples. +c Ils formeront un joint ponctuel forme d'un pentaedre. +c + elseif ( tbau30(8,iaux).eq.9 ) then +c + lenoeu = tbau30(1,iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu +#endif +c On recherche dans les pentaedres deja crees si on en a +c un qui est base sur le meme noeud multiple. Si oui, +c on ne recommence pas ! +c + do 221 , jaux = 1 , nbjp09 +c + if ( tbau52(1,jaux).eq.lenoeu ) then + goto 21 + endif +c + 221 continue +c +c Il faut noter un nouveau joint ponctuel +c + nbjp09 = nbjp09 + 1 + tbau52(1,nbjp09) = lenoeu + tbau52(2,nbjp09) = 0 + tbau52(3,nbjp09) = 0 + tbau52(4,nbjp09) = 0 + tbau52(5,nbjp09) = 0 + tbau52(6,nbjp09) = 0 +cgn write (ulsort,texte(langue,34)) nbjp09 +cgn write (ulsort,texte(langue,20))(tbau52(jaux,nbjp09),jaux=1,1) +c +c 2.3. ==> Les noeuds d'ordre 12 +c Ils sont a la jonction de 6 joints quadruples. +c Ils formeront un joint ponctuel forme d'un hexaedre. +c + elseif ( tbau30(8,iaux).eq.12 ) then +c + lenoeu = tbau30(1,iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu +#endif +c On recherche dans les hexaedres deja crees si on en a +c un qui est base sur le meme noeud multiple. Si oui, +c on ne recommence pas ! +c + do 231 , jaux = 1 , nbjp12 +c + if ( tbau53(1,jaux).eq.lenoeu ) then + goto 21 + endif +c + 231 continue +c +c Il faut noter un nouveau joint ponctuel +c + nbjp12 = nbjp12 + 1 + tbau53(1,nbjp12) = lenoeu + do 232 , jaux = 2 , 13 + tbau53(jaux,nbjp12) = 0 + 232 continue +cgn write (ulsort,texte(langue,34)) nbjp12 +cgn write (ulsort,texte(langue,20))(tbau53(jaux,nbjp12),jaux=1,1) +c + endif +c + 21 continue +c + nbte06 = nbjp06 + nbpe09 = nbjp09 + nbhe12 = nbjp12 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,21)) 6, nbjp06 + write (ulsort,texte(langue,21)) 9, nbjp09 + write (ulsort,texte(langue,21)) 12, nbjp12 +#endif +c + endif +c +c==== +c 3. Caracterisation des aretes triples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Caract aretes triples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( multax.ge.3 ) then +c + do 3 , iaux = 1 , nbduar +c + larete = tbau40(1,iaux) +c + if ( tbau40(5,iaux).eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +#endif +c +c 3.1. ==> On recherche dans les pentaedres deja crees si on en a +c un qui est base sur la meme arete triple. Si oui, +c on ne recommence pas ! +c + do 31 , jaux = 1 , nbpejt +c + if ( tbau41(1,jaux).eq.larete ) then + goto 3 + endif +c + 31 continue +c +c 3.2. ==> On doit donc creer un nouveau pentaedre. +c On recherche dans les joints triples deja crees si on +c en a un qui est base sur les memes joints simples. Si oui, +c on en deduit le numero de joint triple a associer. +c + do 32 , jaux = nbjois+1 , nbjois+nbjoit +c + if ( tbaux5(1,iaux).eq.tbaux2(1,jaux) .and. + > tbaux5(2,iaux).eq.tbaux2(2,jaux) .and. + > tbaux5(3,iaux).eq.tbaux2(3,jaux) ) then +c + nujoin = jaux + goto 320 +c + endif +c + 32 continue +c +c Il faut creer un nouveau joint +c + nbjoit = nbjoit + 1 + nujoin = nbjois + nbjoit + tbaux2(1,nujoin) = tbaux5(1,iaux) + tbaux2(2,nujoin) = tbaux5(2,iaux) + tbaux2(3,nujoin) = tbaux5(3,iaux) +cgn write (ulsort,texte(langue,34)) nbjoit +cgn write (ulsort,texte(langue,20))(tbaux2(jaux,nujoin),jaux=1,3) +c + 320 continue +c +c +c 3.3. ==> Pour ce pentaedre : +c 1 : son arete directrice est la courante +c 2 : le joint associe +c + nbpejt = nbpejt + 1 +c + tbau41(1,nbpejt) = larete + tbau41(2,nbpejt) = nujoin +c +c Creations/Recuperation des 2 triangles associes +c + do 33 , jaux = 1 , 2 +c + lenoeu = somare(jaux,larete) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,-1), lenoeu +#endif +c + do 331 , kaux = 1 , nbtrjt + if ( tbau31(1,kaux).eq.lenoeu .and. + > tbau31(2,kaux).eq.nujoin ) then + letria = kaux + goto 332 + endif + 331 continue +c + nbtrjt = nbtrjt + 1 + tbau31(1,nbtrjt) = lenoeu + tbau31(2,nbtrjt) = nujoin + letria = nbtrjt +c + 332 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria +#endif +c + tbau41(2+jaux,nbpejt) = nbtrtn + letria +c +c Reperage des eventuels joints ponctuels +c + do 333 , kaux = 1 , nbjp06 +c + if ( tbau51(1,kaux).eq.lenoeu ) then + do 3331 , laux = 2 , 5 + if ( tbau51(laux,kaux).eq.nbtrtn+letria ) then + goto 33 + elseif ( tbau51(laux,kaux).eq.0 ) then + tbau51(laux,kaux) = nbtrtn+letria + goto 33 + endif + 3331 continue + endif +c + 333 continue +c + do 334 , kaux = 1 , nbjp09 +c + if ( tbau52(1,kaux).eq.lenoeu ) then + do 3341 , laux = 2 , 3 + if ( tbau52(laux,kaux).eq.nbtrtn+letria ) then + goto 33 + elseif ( tbau52(laux,kaux).eq.0 ) then + tbau52(laux,kaux) = nbtrtn+letria + goto 33 + endif + 3341 continue + endif +c + 334 continue +c + 33 continue +c + endif +c + 3 continue +c + endif +c + endif +c +c==== +c 4. Caracterisation des aretes quadruples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Caract aretes quadruples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( multax.ge.4 ) then +c + jdeb = nbjois + nbjoit + kdeb = nbtrjt +c + do 4 , iaux = 1 , nbduar +c + larete = tbau40(1,iaux) +c + if ( tbau40(5,iaux).eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +#endif +c +c 4.1. ==> On recherche dans les hexaedres deja crees si on en a +c un qui est base sur la meme arete quadruple. Si oui, +c on ne recommence pas ! +c + do 41 , jaux = 1 , nbhejq +c + if ( tbau41(1,nbpejt+jaux).eq.larete ) then + goto 4 + endif +c + 41 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +#endif +c +c 4.2. ==> On doit donc creer un nouvel hexaedre. +c On recherche dans les joints quadruples deja crees si on +c en a un qui est base sur les memes joints simples. Si oui, +c on en deduit le numero de joint quadruple a associer. +c + do 42 , jaux = jdeb+1 , jdeb+nbjoiq +c + if ( tbaux5(1,iaux).eq.tbaux2(1,jaux) .and. + > tbaux5(2,iaux).eq.tbaux2(2,jaux) .and. + > tbaux5(3,iaux).eq.tbaux2(3,jaux) .and. + > tbaux5(4,iaux).eq.tbaux2(4,jaux) ) then +c + nujoin = jaux + goto 420 +c + endif +c + 42 continue +c +c Il faut creer un nouveau joint +c + nbjoiq = nbjoiq + 1 + nujoin = jdeb + nbjoiq + tbaux2(1,nujoin) = tbaux5(1,iaux) + tbaux2(2,nujoin) = tbaux5(2,iaux) + tbaux2(3,nujoin) = tbaux5(3,iaux) + tbaux2(4,nujoin) = tbaux5(4,iaux) +cgn write (ulsort,texte(langue,34)) nbjoiq +cgn write (ulsort,texte(langue,20))(tbaux2(jaux,nujoin),jaux=1,4) +c + 420 continue +c +c 4.3. ==> Pour cet hexaedre : +c 1 : son arete directrice est la courante +c 2 : le joint associe +c + nbhejq = nbhejq + 1 +c + tbau41(1,nbpejt+nbhejq) = larete + tbau41(2,nbpejt+nbhejq) = nujoin +c +c Creations/Recuperation des 2 quadrangles associes +c + do 43 , jaux = 1 , 2 +c + lenoeu = somare(jaux,larete) +c + do 431 , kaux = kdeb+1 , kdeb+nbqujq + if ( tbau31(1,kaux).eq.lenoeu .and. + > tbau31(2,kaux).eq.nujoin ) then + lequad = kaux - kdeb + goto 432 + endif + 431 continue +c + nbqujq = nbqujq + 1 + tbau31(1,kdeb+nbqujq) = lenoeu + tbau31(2,kdeb+nbqujq) = nujoin + lequad = nbqujq +c + 432 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,4), lequad + write (ulsort,*) 'nbqujq =', nbqujq,', kaux =',kdeb+nbqujq +#endif +c + tbau41(2+jaux,nbpejt+nbhejq) = nbqutn + lequad +c +c Reperage des eventuels joints ponctuels +c + do 433 , kaux = 1 , nbjp09 +c + if ( tbau52(1,kaux).eq.lenoeu ) then + do 4331 , laux = 4 , 6 + if ( tbau52(laux,kaux).eq.nbqutn+lequad ) then + goto 43 + elseif ( tbau52(laux,kaux).eq.0 ) then + tbau52(laux,kaux) = nbqutn+lequad + goto 43 + endif + 4331 continue + endif +c + 433 continue +c +c Reperage des eventuels joints ponctuels +c + do 434 , kaux = 1 , nbjp12 +c + if ( tbau53(1,kaux).eq.lenoeu ) then + do 4341 , laux = 2 , 7 + if ( tbau53(laux,kaux).eq.0 ) then + tbau53(laux,kaux) = nbqutn+lequad + goto 43 + endif + 4341 continue + endif +c + 434 continue +c + 43 continue +c + endif +c + 4 continue +c + endif +c + endif +c +c==== +c 5. Controle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Controle ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpejt.ne.nbarmu(3) ) then + write (ulsort,texte(langue,31)) 3 + write (ulsort,texte(langue,32)) mess14(langue,3,1), nbarmu(3) + write (ulsort,texte(langue,33)) mess14(langue,3,1), nbpejt + codret = 51 + endif +c + if ( nbhejq.ne.nbarmu(4) ) then + write (ulsort,texte(langue,31)) 4 + write (ulsort,texte(langue,32)) mess14(langue,3,1), nbarmu(4) + write (ulsort,texte(langue,33)) mess14(langue,3,1), nbhejq + codret = codret*100 + 52 + endif +c + endif +c +cgn write(ulsort,4001) 'tbaux2',4,nbjois+nbjoit+nbjoiq +cgn do 4101 , kaux = 1,nbjois+nbjoit+nbjoiq +cgn write(ulsort,4000) (tbaux2(jaux,kaux),jaux=1,4) +cgn 4101 continue +cgn write(ulsort,4001) 'tbau41',4,nbpejt+nbhejq +cgn do 4102 , kaux = 1,nbpejt+nbhejq +cgn write(ulsort,4000) (tbau41(jaux,kaux),jaux=1,4) +cgn 4102 continue +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag30.F b/src/tool/Modification/mmag30.F new file mode 100644 index 00000000..95b00279 --- /dev/null +++ b/src/tool/Modification/mmag30.F @@ -0,0 +1,508 @@ + subroutine mmag30 ( nbduno, nbduar, nbdutr, + > nbpejs, + > nbpejt, nbtrjt, nbhejq, nbqujq, + > nbte06, nbpe09, nbhe12, + > nbvojm, + > nbjoto, nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > tbaux1, tbaux2, + > tbau30, tbau40, + > tbau41, tbau51, tbau52, tbau53, + > coonoe, hetnoe, arenoe, + > somare, hetare, + > filare, merare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, hetqua, + > filqua, perqua, nivqua, + > tritet, cotrte, + > hettet, filtet, pertet, + > facpen, cofape, + > hetpen, filpen, perpen, + > quahex, coquhe, + > hethex, filhex, perhex, + > famnoe, famare, + > famtri, famqua, + > famtet, fampen, famhex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.0 +c - - -- - - +c Creation des pentaedres +c Et donc des noeuds, aretes, triangles, quadrangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbduno . e . 1 . nombre de duplications de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbdutr . e . 1 . nombre de duplications de triangles . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . nbpejt . e . 1 . nombre de pentaedres de joints triples . +c . nbtrjt . e . 1 . nombre de triangles de joints triples . +c . nbhejq . e . 1 . nombre d'hexaedres de joints quadruples . +c . nbqujq . e . 1 . nombre de quad. crees pour j. quadruples . +c . nbte06 . e . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . nbpe09 . s . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . nbhe12 . s . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbjoto . e . 1 . nombre total de joints . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . nbjoiq . e . 1 . nombre de joints quadruples . +c . nbjp06 . e . 1 . nombre de joints ponctuels ordre 6 . +c . nbjp09 . e . 1 . nombre de joints ponctuels ordre 9 . +c . nbjp12 . e . 1 . nombre de joints ponctuels ordre 12 . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbaux2 . e .4*nbjoto. Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . tbau51 . e .9*nbte06. Les tetraedres ponctuels entre les joints . +c . . . . triples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : triangle cote du 3eme joint triple . +c . . . . (5,i) : triangle cote du 4eme joint triple . +c . . . . (1+k) : pour le k-eme triangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . tbau52 . e . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . tbau53 . e . 13* . Les hexaedres ponctuels entre les joints . +c . . . nbhe12 . quadruples (ordre 12) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : quadrangle cote du 1er joint quad. . +c . . . . (3,i) : quadrangle cote du 2eme joint quad.. +c . . . . (4,i) : quadrangle cote du 3eme joint quad.. +c . . . . (5,i) : quadrangle cote du 4eme joint quad.. +c . . . . (6,i) : quadrangle cote du 5eme joint quad.. +c . . . . (7,i) : quadrangle cote du 6eme joint quad.. +c . . . . (1+k) : pour le k-eme quadrangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . coonoe . es .nbnoto*3. coordonnees des noeuds . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . arete liee a un nouveau noeud . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . merare . es . nbarto . mere des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . filtri . es . nbtrto . premier fils des triangles . +c . pertri . es . nbtrto . pere des triangles . +c . nivtri . es . nbtrto . niveau des triangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . filqua . es . nbquto . premier fils des quadrangles . +c . perqua . es . nbquto . pere des quadrangles . +c . nivqua . es . nbquto . niveau des quadrangles . +c . tritet . es .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . es .nbtecf*4. codes des triangles des tetraedres . +c . hettet . es . nbteto . historique de l'etat des tetraedres . +c . filtet . es . nbteto . premier fils des tetraedres . +c . pertet . es . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nbteto . famille des tetraedres . +c . facpen . es .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . es .nbpecf*5. code des 5 faces des pentaedres . +c . hetpen . es . nbpeto . historique de l'etat des pentaedres . +c . filpen . es . nbpeto . premier fils des pentaedres . +c . perpen . es . nbpeto . pere des pentaedres . +c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . hethex . es . nbheto . historique de l'etat des hexaedres . +c . filhex . es . nbheto . premier fils des hexaedres . +c . perhex . es . nbheto . pere des hexaedres . +c . famnoe . es . nbnoto . famille des noeuds . +c . famare . es . nbarto . famille des aretes . +c . famtri . es . nbtrto . famille des triangles . +c . famqua . es . nbquto . famille des quadrangles . +c . fampen . es . nbpeto . famille des pentaedres . +c . famhex . es . nbheto . famille des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG30' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbduno, nbduar, nbdutr + integer nbpejs + integer nbpejt, nbtrjt, nbhejq, nbqujq + integer nbte06, nbpe09, nbhe12 + integer nbvojm + integer nbjoto, nbjois, nbjoit, nbjoiq + integer nbjp06, nbjp09, nbjp12 + integer tbaux1(4,nbpejs), tbaux2(4,nbjoto) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbau41(4,nbvojm) + integer tbau51(9,nbte06), tbau52(11,nbpe09), tbau53(13,nbhe12) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer somare(2,nbarto), hetare(nbarto) + integer filare(nbarto), merare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer hettet(nbteto), filtet(nbteto), pertet(nbteto) + integer facpen(nbpecf,5), cofape(nbpecf,5) + integer hetpen(nbpeto), filpen(nbpeto), perpen(nbpeto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer hethex(nbheto), filhex(nbheto), perhex(nbheto) + integer famnoe(nbnoto), famare(nbarto) + integer famtri(nbtrto), famqua(nbquto) + integer famtet(nbteto), fampen(nbpeto), famhex(nbheto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer indtri, indtet, indpen, indhex +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr + write (ulsort,texte(langue,7)) mess14(langue,3,3), nbte06 + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbduar+nbqujq + write (ulsort,texte(langue,7)) mess14(langue,3,7), + > nbpejs+nbpejt+nbpe09 + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhejq+nbhe12 +#endif +c + codret = 0 +c +c==== +c 2. Creation des mailles pour les joints simples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Mailles joints S ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then + call gtdems (65) +c + indtri = nbtrto - 2*nbdutr - nbtrjt + indpen = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG31', nompro +#endif + call mmag31 ( indtri, indpen, + > nbduno, nbduar, nbpejs, + > tbaux1, tbau30, tbau40, + > coonoe, hetnoe, arenoe, + > somare, hetare, + > filare, merare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, hetqua, + > filqua, perqua, nivqua, + > tritet, cotrte, + > facpen, cofape, + > hetpen, filpen, perpen, + > famnoe, famare, famtri, + > famqua, fampen, + > ulsort, langue, codret ) + call gtfims (65) +c + endif +c +c==== +c 3. Creation des mailles pour les joints triples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Mailles joints T ; codret = ', codret +#endif +c + if ( nbjoit.gt.0 ) then +c + if ( codret.eq.0 ) then + call gtdems (66) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG32', nompro +#endif + call mmag32 ( indpen, + > nbduno, nbduar, + > nbpejt, nbvojm, nbjoto, + > tbaux2, tbau30, tbau40, + > tbau41, + > nbte06, tbau51, + > nbpe09, tbau52, + > coonoe, somare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, + > facpen, cofape, + > hetpen, filpen, perpen, + > famtri, fampen, + > ulsort, langue, codret ) + call gtfims (66) +c + endif +c + endif +c +c==== +c 4. Creation des mailles pour les joints quadruples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Mailles joints Q ; codret = ', codret +#endif +c + indhex = 0 +c + if ( nbjoiq.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gtdems (67) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG33', nompro +#endif + call mmag33 ( indhex, + > nbduno, nbduar, + > nbpejt, nbhejq, nbvojm, nbjoto, + > nbjois, nbjoit, + > tbaux2, tbau30, tbau40, + > tbau41, + > nbhe12, tbau53, + > nbpe09, tbau52, + > coonoe, somare, + > arequa, hetqua, + > filqua, perqua, nivqua, + > quahex, coquhe, + > hethex, filhex, perhex, + > famqua, famhex, + > ulsort, langue, codret ) +c + call gtfims (67) +c + endif +c + endif +c +c==== +c 5. Creation des mailles pour les joints ponctuels +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Mailles joints P ; codret = ', codret +#endif + if ( codret.eq.0 ) then +c + call gtdems (68) +c +c 5.1. ==> Les tetraedres pour les joints d'ordre 6 +c + if ( nbjp06.gt.0 ) then +c + indtet = nbteto - nbte06 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG34', nompro +#endif + call mmag34 ( indtet, + > nbte06, + > tbau51, + > aretri, + > tritet, cotrte, + > hettet, filtet, pertet, + > famtet, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.2. ==> Les pentaedres pour les joints d'ordre 9 +c + if ( nbjp09.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbjois + nbjoit + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG35', nompro +#endif + call mmag35 ( indpen, iaux, + > nbpe09, + > tbau52, + > aretri, arequa, + > facpen, cofape, + > hetpen, filpen, perpen, + > fampen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.3. ==> Les hexaedres pour les joints d'ordre 12 +c + if ( nbjp12.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbjoiq + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG36', nompro +#endif + call mmag36 ( indhex, iaux, + > nbhe12, + > tbau53, + > arequa, + > quahex, coquhe, + > hethex, filhex, perhex, + > famhex, + > ulsort, langue, codret ) +c + endif +c + endif +c + call gtfims (68) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag31.F b/src/tool/Modification/mmag31.F new file mode 100644 index 00000000..28e5d33d --- /dev/null +++ b/src/tool/Modification/mmag31.F @@ -0,0 +1,743 @@ + subroutine mmag31 ( indtri, indpen, + > nbduno, nbduar, nbpejs, + > tbaux1, tbau30, tbau40, + > coonoe, hetnoe, arenoe, + > somare, hetare, + > filare, merare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, hetqua, + > filqua, perqua, nivqua, + > tritet, cotrte, + > facpen, cofape, + > hetpen, filpen, perpen, + > famnoe, famare, famtri, + > famqua, fampen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.1 +c - - -- - - +c Creation des mailles pour les joints simples : +c . pentaedres +c Et donc des noeuds, aretes, triangles, quadrangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtri . es . 1 . indice du dernier triangle cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . coonoe . es .nbnoto*3. coordonnees des noeuds . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . arete liee a un nouveau noeud . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . merare . es . nbarto . mere des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . filtri . es . nbtrto . premier fils des triangles . +c . pertri . es . nbtrto . pere des triangles . +c . nivtri . es . nbtrto . niveau des triangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . filqua . es . nbquto . premier fils des quadrangles . +c . perqua . es . nbquto . pere des quadrangles . +c . nivqua . es . nbquto . niveau des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . facpen . es .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . es .nbpecf*5. code des 5 faces des pentaedres . +c . hetpen . es . nbpeto . historique de l'etat des pentaedres . +c . filpen . es . nbpeto . premier fils des pentaedres . +c . perpen . es . nbpeto . pere des pentaedres . +c . famnoe . es . nbnoto . famille des noeuds . +c . famare . es . nbarto . famille des aretes . +c . famtri . es . nbtrto . famille des triangles . +c . famqua . es . nbquto . famille des quadrangles . +c . fampen . es . nbpeto . famille des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG31' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer indtri, indpen + integer nbduno, nbduar, nbpejs + integer tbaux1(4,nbpejs) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer somare(2,nbarto), hetare(nbarto) + integer filare(nbarto), merare(nbarto) + integer aretri(nbtrto,3), hettri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpen(nbpecf,5), cofape(nbpecf,5) + integer hetpen(nbpeto), filpen(nbpeto), perpen(nbpeto) + integer famnoe(nbnoto), famare(nbarto) + integer famtri(nbtrto), famqua(nbquto), fampen(nbpeto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer sommet + integer lenoeu, larete, letria, letet1 + integer nucode + integer indnoe, indqua +c + integer som(4), are(9), qua(3) + integer sa1a2, sa2a3, sa3a1 + integer sompen(6) + integer tabcod(6) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + data tabcod / 4, 5, 6, 1, 2, 3 / +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbduar +#endif +c + codret = 0 +c +cgn write(ulsort,*) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto +cgn write(ulsort,91010) (iaux,iaux=1,20) +cgn write(ulsort,90002) 'tbaux1',4,nbduno +cgn write(ulsort,91010) tbaux1 +cgn write(ulsort,90002) 'tbau30',8,nbduno +cgn do 1101 , kaux = 1,nbduno +cgn write(ulsort,91010) (tbau30(jaux,kaux),jaux=1,8) +cgn 1101 continue +cgn write(ulsort,90002) 'tbau40',6,nbduar +cgn do 1102 , kaux = 1,nbduar +cgn write(ulsort,91010) (tbau40(jaux,kaux),jaux=1,5) +cgn 1102 continue +c +c==== +c 2. Parcours des noeuds a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,-1) +#endif +c + do 2 , iaux = 1 , nbduno +c + lenoeu = tbau30(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( tbau30(5,iaux).eq.-4444 ) then +cgn if ( lenoeu.eq.2 .or. lenoeu.eq.8 ) then + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu + write (ulsort,texte(langue,18)) ' pour ',mess14(langue,1,7), + > tbau30(5,iaux) + endif +#endif +c +c 2.1. ==> Duplications du noeud +c Remarque : dans le cas de points multiples, on recree +c plusieurs fois le meme noeud. Pas grave. +c + do 21 , jaux = 1 , 2 +c + indnoe = tbau30(2+jaux,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( tbau30(5,iaux).eq.-4444 ) then +cgn if ( lenoeu.eq.2 .or. lenoeu.eq.8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,-1), indnoe, jaux + endif +#endif +c + arenoe(indnoe) = 0 + hetnoe(indnoe) = 1 + do 210 , kaux = 1 , 3 + coonoe(indnoe,kaux) = coonoe(lenoeu,kaux) + 210 continue +c + famnoe(indnoe) = famnoe(lenoeu) +c + 21 continue +c +c 2.2. ==> Creation de l'arete entre ces 2 noeuds +c + jaux = tbau30(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( tbau30(5,iaux).eq.-4444 ) then +cgn if ( lenoeu.eq.2 .or. lenoeu.eq.8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,1), jaux, + > tbau30(5,iaux) + write (ulsort,texte(langue,17))min(tbau30(3,iaux),tbau30(4,iaux)), + > max(tbau30(3,iaux),tbau30(4,iaux)) + endif +#endif +c + somare(1,jaux) = min(tbau30(3,iaux),tbau30(4,iaux)) + somare(2,jaux) = max(tbau30(3,iaux),tbau30(4,iaux)) +c + famare(jaux) = 1 +c + hetare(jaux) = 0 + merare(jaux) = 0 + filare(jaux) = 0 +c + 2 continue +c +c==== +c 3. Parcours des aretes a dupliquer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Parcours des aretes ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c + indqua = 0 +c + do 3 , iaux = 1 , nbduar +c + larete = tbau40(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,18)) ' ' ,mess14(langue,1,7), + > tbau40(4,iaux) + endif +#endif +c +c 3.1. ==> Reperage des noeuds +c +c are(1) et are(2) : aretes entre les noeuds dupliques +c are(3) et are(4) : aretes apres duplication +c +c are(3) +c som(1)------ arete tbau40(2,iaux) ------som(2) +c . . +c are(1) . . are(2) +c . . +c som(3)------ arete tbau40(3,iaux) ------som(4) +c are(4) +c + do 31 , jaux = 1 , 2 +c sommet = numero absolu du jaux-eme sommet de l'arete +c a dupliquer, de numero absolu larete + sommet = somare(jaux,larete) +cgn print *,'sommet ',sommet +c boucle 311 : on cherche parmi tous les noeuds dupliques celui +c qui correspond a 'sommet', en verifiant que l'on +c traite le meme joint tbau30(5,kaux)=tbau40(4,iaux) +c on stocke les numeros absolus des sommets crees +c par la duplication et de l'arete qui les relie + do 311 , kaux = 1 , nbduno +cgn print *,tbau30(1,kaux),tbau30(2,kaux),tbau30(3,kaux) +cgn print *,tbau30(4,kaux),tbau30(5,kaux) + if ( tbau30(1,kaux).eq.sommet ) then + if ( tbau30(5,kaux).eq.tbau40(4,iaux) ) then +cgn print *,'ok pour ',kaux + are(jaux) = tbau30(2,kaux) + som(jaux ) = tbau30(3,kaux) + som(jaux+2) = tbau30(4,kaux) + goto 31 + endif + endif + 311 continue + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1),larete + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1),sommet + codret = 31 + goto 5555 + 31 continue +c +c som(1) et som(2) sont les sommets de la future arete mais +c il faut les trier car rien ne dit qu'ils sont dans le bon ordre +c meme remarque pour som(3) et som(4) +c + if ( som(1).gt.som(2) ) then + jaux = som(1) + som(1) = som(2) + som(2) = jaux + jaux = som(3) + som(3) = som(4) + som(4) = jaux + jaux = are(1) + are(1) = are(2) + are(2) = jaux + endif +c +c 3.2. ==> Duplications de l'arete +c Remarque : dans le cas d'aretes multiples, on recree +c plusieurs fois la meme arete. Pas grave. +c + are(3) = tbau40(2,iaux) +c + somare(1,are(3)) = som(1) + somare(2,are(3)) = som(2) + famare(are(3)) = 1 + hetare(are(3)) = 0 + merare(are(3)) = 0 + filare(are(3)) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,1), are(3), 0 + write (ulsort,texte(langue,17)) som(1), som(2) + endif +#endif +c + are(4) = tbau40(3,iaux) +c + somare(1,are(4)) = som(3) + somare(2,are(4)) = som(4) + famare(are(4)) = 1 + hetare(are(4)) = 0 + merare(are(4)) = 0 + filare(are(4)) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,1), are(4), 0 + write (ulsort,texte(langue,17)) som(3), som(4) + endif +#endif +c +c 3.2. ==> Creation du quadrangle +c On fait les choix suivants : +c Sa 1ere arete est celle issue de la duplication d'une arete +c pour le cote 1 : are(3) +c Sa 2eme arete est celle dont une extremite est la fin de +c la 1ere arete : are(2) +c Ensuite, il n'y a plus de choix : are(4), are(1) +c + indqua = indqua + 1 +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,4), indqua, + > tbau40(4,iaux) + write (ulsort,texte(langue,17)) are(3),are(2),are(4),are(1) + endif +#endif +c + arequa(indqua,1) = are(3) + arequa(indqua,2) = are(2) + arequa(indqua,3) = are(4) + arequa(indqua,4) = are(1) +c + famqua(indqua) = 1 +c + hetqua(indqua) = 0 + filqua(indqua) = 0 + perqua(indqua) = 0 + nivqua(indqua) = 0 +c + 3 continue +c +c==== +c 4. Parcours des triangles base des pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Parcours des triangles ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,2) +#endif +c +c Triangle a dupliquer +c +c St3 +c x +c . +c . . +c art3 . +c . . +c . +c . .art1 +c . +cSt2. . +c x +c . . +c . +c art2 . . +c x +c St1 +c +c +c S3=tbau30(3,i/St3) a9=tbau30(2,i/St3) S6=tbau30(4,i/St3) +c x------------------------------------------x +c . . +c . . . . +c a3=tbau40(2,i/art3) a6=tbau40(3,i/art3) +c . . . . +c . . +c . .a1=tbau40(2,i/art1) . a4=tbau40(3,i/art1) +c . . +c S2. . a8=tbau30(2,i/St2) S5.=tbau30(4,i/St2) +c x - - - - - - - - - - - - - - - - - - - - -x +ctbau30(3,i/St2). . . +c . . +c a2=tbau40(2,i/art2) a5=tbau40(3,i/art2). . +c x------------------------------------------x +c S1=tbau30(3,i/St1) a7=tbau30(2,i/St1) S4=tbau30(4,i/St1) +c +c voir utarpe pour le croquis ci-dessus +c + do 4 , iaux = 1 , nbpejs +c + letria = tbaux1(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.-27 ) then + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,2), letria + write (ulsort,texte(langue,18)) ' ',mess14(langue,1,7), + > tbaux1(2,iaux) + endif +#endif +c +c 4.1. ==> Reperage des noeuds, aretes et faces +c + do 41 , jaux = 1 , 3 + larete = aretri(letria,jaux) +cgn write (ulsort,*)'larete ',larete + do 411 , kaux = 1 , nbduar +cgn write (ulsort,*)tbau40(1,kaux),tbau40(4,kaux) + if ( tbau40(1,kaux).eq.larete ) then + if ( tbau40(4,kaux).eq.tbaux1(2,iaux) ) then +cgn print *,'ok pour ',kaux + are(jaux ) = tbau40(2,kaux) + are(jaux+3) = tbau40(3,kaux) + qua(jaux) = kaux + goto 41 + endif + endif + 411 continue + codret = 41 + goto 5555 + 41 continue +cgn write (ulsort,*)(are(jaux), jaux = 1 , 6) +cgn write (ulsort,*)(qua(jaux), jaux = 1 , 3) +c +c 4.2. ==> Triangle entrant ou sortant dans le tetraedre du cote 1 ? +c + letet1 = tbaux1(3,iaux) +c + do 421 , jaux = 1 , 3 , 2 + if ( tritet(letet1,jaux).eq.letria ) then + if ( cotrte(letet1,jaux).le.3 ) then + nucode = -1 + else + nucode = 1 + endif + goto 420 + endif + 421 continue + do 422 , jaux = 2 , 4 , 2 + if ( tritet(letet1,jaux).eq.letria ) then + if ( cotrte(letet1,jaux).le.3 ) then + nucode = 1 + else + nucode = -1 + endif + goto 420 + endif + 422 continue + codret = 24 + goto 5555 +c + 420 continue +c +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.-27 ) then + write (ulsort,90002) mess14(langue,1,3)//'cote 1', letet1 + write (ulsort,90002) 'entrant/sortant', nucode + endif +#endif +c +c 4.3. ==> Duplication du triangle +c + do 43 , jaux = 1 , 2 +c + indtri = indtri + 1 +c +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.-27 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,2), indtri, jaux + write (ulsort,90002) mess14(langue,3,1), + > (are(kaux),kaux=3*jaux-2,3*jaux) + endif +#endif +c + aretri(indtri,1) = are(3*jaux-2) + aretri(indtri,2) = are(3*jaux-1) + aretri(indtri,3) = are(3*jaux) +c + famtri(indtri) = famtri(letria) +c + hettri(indtri) = 0 + filtri(indtri) = 0 + pertri(indtri) = 0 + nivtri(indtri) = 0 +c + 43 continue +c +c 4.4. ==> Creation du pentaedre +c + indpen = indpen + 1 +c +c 4.4.1. ==> Face 1 : c'est le triangle en cours de traitement. +c On impose : la 1ere arete du pentaedre est la 1ere arete du triangle +c le code sera donc 1 ou 4. +c Si le triangle entrait dans le tetraedre, il va sortir du pentaedre. +c On lui donnera donc le code 4. +C Inversement, si le triangle sortait dans le tetraedre, il entre +c dans le pentaedre. On lui donnera alors le code 1. +c +c Avec utsotr, on recupere les sommets du triangle dans l'ordre de +c ses aretes. On en deduit les 3 premiers sommets du pentaedre selon +c le positionnement du triangle. +c + facpen(indpen,1) = indtri-1 + if ( nucode.eq.1 ) then + cofape(indpen,1) = 4 + else + cofape(indpen,1) = 1 + endif +c + call utsotr ( somare, are(1), are(2), are(3), + > sa1a2, sa2a3, sa3a1 ) + if ( nucode.eq.1 ) then + sompen(1) = sa3a1 + sompen(3) = sa1a2 + else + sompen(1) = sa1a2 + sompen(3) = sa3a1 + endif + sompen(2) = sa2a3 +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.-27 ) then + write (ulsort,90002)'sommets tria ',sa1a2, sa2a3, sa3a1 + write (ulsort,90002)'sommets penta',(sompen(jaux),jaux=1,3) + endif +#endif +c +c 4.4.2. ==> Face 2 : c'est le 2nd triangle qui est translate de celui +c en cours de traitement. +c Suite aux choix faits sur f1, sa 1ere arete est a4. +c Si le code du triangle en tant que face 1 est 1, alors sa 2eme arete +c est la translatee de a2, donc a5, ce qui fait un code 4. +c Si le code du triangle en tant que face 1 est 4, alors sa 2eme arete +c est la translatee de a3, donc a5, ce qui fait un code 1. +c + facpen(indpen,2) = indtri + cofape(indpen,2) = tabcod(cofape(indpen,1)) +c +c 4.4.3. ==> Face 3 : par definition du pentaedre, elle s'appuie sur a1. +c Par construction, qua(1) a pour 1ere arete a1, donc f3=qua(1) +c Il reste deux possibilites de positionnement : +c (a1,a9,a4,a7) donnant le code 1 +c (a1,a7,a4,a9) donnant le code 5 +c Par construction, l'arete 2 du quadrangle est celle qui part de la +c fin de a1, donc du max(sompen(1),sompen(3)). +c Si le max est sompen(1), l'arete 2 est a7 donc le code est 5 ; +c sinon, c'est le code 1. +c + facpen(indpen,3) = qua(1) + if ( sompen(1).gt.sompen(3) ) then + cofape(indpen,3) = 5 + else + cofape(indpen,3) = 1 + endif +c +c 4.4.4. ==> Face 4 : par definition du pentaedre, elle s'appuie sur a2. +c Si le code du triangle en tant que face 1 est 1, alors sa 2eme arete +c est a2, donc f4=qua(2). Sinon, sa 3eme arete est a2, donc f4=qua(3). +c Il reste deux possibilites de positionnement : +c (a2,a7,a5,a8) donnant le code 1 +c (a2,a8,a5,a7) donnant le code 5 +c Par construction, l'arete 2 du quadrangle est celle qui part de la +c fin de a2, donc du max(sompen(2),sompen(1)). +c Si le max est sompen(2), l'arete 2 est a8 donc le code est 5 ; +c sinon, c'est le code 1. +c + if ( cofape(indpen,1).eq.1 ) then + facpen(indpen,4) = qua(2) + else + facpen(indpen,4) = qua(3) + endif + if ( sompen(2).gt.sompen(1) ) then + cofape(indpen,4) = 5 + else + cofape(indpen,4) = 1 + endif +c +c 4.4.5. ==> Face 5 : par definition du pentaedre, elle s'appuie sur a3. +c Si le code du triangle en tant que face 1 est 1, alors sa 3eme arete +c est a3, donc f5=qua(3). Sinon, sa 2eme arete est a3, donc f5=qua(2). +c Il reste deux possibilites de positionnement : +c (a3,a8,a6,a9) donnant le code 1 +c (a3,a9,a6,a8) donnant le code 5 +c Par construction, l'arete 2 du quadrangle est celle qui part de la +c fin de a3, donc du max(sompen(3),sompen(2)). +c Si le max est sompen(3), l'arete 2 est a9 donc le code est 5 ; +c sinon, c'est le code 1. + if ( cofape(indpen,1).eq.1 ) then + facpen(indpen,5) = qua(3) + else + facpen(indpen,5) = qua(2) + endif + if ( sompen(3).gt.sompen(2) ) then + cofape(indpen,5) = 5 + else + cofape(indpen,5) = 1 + endif + if ( letria.eq.27 ) then + endif +c +c 4.4.6. ==> tbaux1(2,iaux) est le numero du joint parmi tous les +c joints. Il faut ajouter 1 pour tenir compte de la famille +c libre. +c + fampen(indpen) = tbaux1(2,iaux) + 1 +c + hetpen(indpen) = 0 + filpen(indpen) = 0 + perpen(indpen) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( letria.eq.-27 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, + > tbaux1(2,iaux) + do 4444 , jaux = 1, 5 + write (ulsort,90001) 'face/code', jaux, + > facpen(indpen,jaux),cofape(indpen,jaux) + 4444 continue + write (ulsort,90002)'aretes 1/2/3',are(1),are(2),are(3) + write (ulsort,90002)'aretes 4/5/6',are(4),are(5),are(6) + write (ulsort,90002)'sommets f1', (sompen(jaux),jaux=1,3) + endif +#endif +c + 4 continue +c +c==== +c 5. la fin +c==== +c + 5555 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag32.F b/src/tool/Modification/mmag32.F new file mode 100644 index 00000000..560e5f89 --- /dev/null +++ b/src/tool/Modification/mmag32.F @@ -0,0 +1,702 @@ + subroutine mmag32 ( indpen, + > nbduno, nbduar, + > nbpejt, nbvojm, nbjoto, + > tbaux2, tbau30, tbau40, + > tbau41, + > nbte06, tbau51, + > nbpe09, tbau52, + > coonoe, somare, + > aretri, hettri, + > filtri, pertri, nivtri, + > arequa, + > facpen, cofape, + > hetpen, filpen, perpen, + > famtri, fampen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.2 +c - - -- - - +c Creation des mailles pour les joints triples : +c . pentaedres +c Et donc des triangles supplementaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbpejt . e . 1 . nombre de pentaedres de joints triples . +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbjoto . e . 1 . nombre total de joints . +c . tbaux2 . e .4*nbjoto. Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . nbte06 . e . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . tbau51 . es .9*nbte06. Les tetraedres ponctuels entre les joints . +c . . . . triples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : triangle cote du 3eme joint triple . +c . . . . (5,i) : triangle cote du 4eme joint triple . +c . . . . (1+k) : pour le k-eme triangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . nbpe09 . e . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . tbau52 . es . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . filtri . es . nbtrto . premier fils des triangles . +c . pertri . es . nbtrto . pere des triangles . +c . nivtri . es . nbtrto . niveau des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . es .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . es .nbpecf*5. code des 5 faces des pentaedres . +c . hetpen . es . nbpeto . historique de l'etat des pentaedres . +c . filpen . es . nbpeto . premier fils des pentaedres . +c . perpen . es . nbpeto . pere des pentaedres . +c . famtri . es . nbtrto . famille des triangles . +c . fampen . es . nbpeto . famille des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG32' ) +c +#include "nblang.h" +c + integer ordre + parameter ( ordre = 3 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer indpen + integer nbduno, nbduar + integer nbpejt, nbvojm, nbjoto + integer tbaux2(4,nbjoto) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbau41(4,nbvojm) + integer nbte06, tbau51(9,nbte06) + integer nbpe09, tbau52(11,nbpe09) + integer somare(2,nbarto) + integer aretri(nbtrto,3), hettri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5) + integer hetpen(nbpeto), filpen(nbpeto), perpen(nbpeto) + integer famtri(nbtrto), fampen(nbpeto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer larete + integer letria(2), lequad +c + integer nujoin, nujois(ordre) + integer aredup(2*ordre) + integer arejoi(ordre), quajoi(ordre) + integer nujolo(ordre) + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1 + integer sompen(6), arepen(9), orient + integer tabcod(6) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + data tabcod / 4, 5, 6, 1, 2, 3 / +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejt + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar +#endif +c + codret = 0 +c +cgn write(ulsort,1001) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto +cgn write(ulsort,1001) 'nbpejt',nbpejt +cgn write(ulsort,1000) (iaux,iaux=1,20) +cgn write(ulsort,1001) 'tbaux2',4,nbjoto +cgn do 1101 , kaux = 1,nbjoto +cgn write(ulsort,1000) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,1001) 'tbau41',4,nbvojm +cgn do 1102 , kaux = 1,nbvojm +cgn write(ulsort,1000) (tbau41(jaux,kaux),jaux=1,4) +cgn 1102 continue +cgn 1000 format(10i9) +cgn 1001 format(a,4i6) +c +c==== +c 2. Parcours des aretes triples / pentaedres de joint triple +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c +c Le long de l'arete triple : +c Le triangle (a1,a2,a3) est defini du cote du 1er sommet +c a1 est du cote du 1er joint simple voisin +c a2 est du cote du 2eme joint simple voisin +c a3 est du cote du 3eme joint simple voisin +c Le triangle (a4,a5,a6) est defini du cote du 2nd sommet +c a4 est du cote du 1er joint simple voisin +c a5 est du cote du 2eme joint simple voisin +c a6 est du cote du 3eme joint simple voisin +c L'arete triple se retrouve dans a7, a8, a9. +c +c S3=tbau30(3,i/St3) arepen(9) S6=tbau30(4,i/St3) +c x------------------------------------------x +c . . +c . . . . +c arepen(3) arepen(6) +c . . . . +c . . +c . .arepen(1) . . arepen(4) +c . . +c S2. . arepen(8) S5.=tbau30(4,i/St2) +c x - - - - - - - - - - - - - - - - - - - - -x +ctbau30(3,i/St2). . . +c . . +c arepen(2) arepen(5). . +c x------------------------------------------x +c S1=tbau30(3,i/St1) arepen(7) S4=tbau30(4,i/St1) +c +c voir utarpe pour le croquis ci-dessus +c + do 2 , iaux = 1 , nbpejt +c + indpen = indpen + 1 +c + larete = tbau41(1,iaux) +c + nujoin = tbau41(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,31)) nujoin + endif +#endif +c +c 2.1. ==> reperage des numeros des 3 joints simples voisins +c + do 21 , jaux = 1 , ordre + nujois(jaux) = tbaux2(jaux,nujoin) + 21 continue +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,39)) nujois + endif +#endif +c +c 2.2. ==> Reperage des aretes qui partent de chacun des noeuds. +C Elles delimitent les faces 1 et 2 du pentaedre en cours. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG91', nompro +#endif + call mmag91 ( larete, ordre, nujois, + > nbduno, tbau30, + > somare, + > aredup, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 + write (ulsort,texte(langue,31)) nujoin + goto 5555 + endif +c +c 2.3. ==> Reperage des aretes et des quadrangles batis sur les joints +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG92', nompro +#endif + call mmag92 ( larete, ordre, nujois, + > nbduar, tbau40, + > arejoi, quajoi, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 + write (ulsort,texte(langue,31)) nujoin + goto 5555 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + do 23111 , jaux = 1 , ordre + write (ulsort,90015)'Joint',jaux,', quadrangle',quajoi(jaux) + write (ulsort,90015)'arete de joints',arejoi(jaux), + > ', de sommets',somare(1,arejoi(jaux)),somare(2,arejoi(jaux)) +23111 continue + endif +#endif +c +c 2.4. ==> Determination de l'orientation des joints +c Par hypothese, la face f3 du pentaedre s'appuie sur le 1er +c joint simple. Ensuite, par definition du pentaedre, les +c faces f4 et f5 arrivent dans le sens positif quand on +c entre dans le pentaedre depuis la face f1. +c On cherche donc le positionnement des 3 joints relativement +c a l'arete dupliquee et on en deduit l'ordre d'apparition +c des joints qui creeront les faces f4 et f5. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3', nompro +#endif + call utora3 ( orient, + > larete, + > arejoi(1), arejoi(2), arejoi(3), + > coonoe, somare, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'orient',orient + endif +#endif +c + nujolo(1) = 1 + if ( orient.gt.0 ) then + nujolo(2) = 2 + nujolo(3) = 3 + else + nujolo(2) = 3 + nujolo(3) = 2 + endif +c +c 2.5. ==> Creation des triangles +c Eventuellement, on recree plusieurs fois le meme triangle. +c Pas grave car il est toujours cree en s'orientant sur les +c joints simples adjacents. +c + do 25 , jaux = 1 , 2 +c +c 2.5.1. ==> Numero du triangle +c + kaux = tbau41(2+jaux,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,2), kaux, + > jaux + write (ulsort,texte(langue,17)) + > (aredup(kaux),kaux=ordre*(jaux-1)+1,ordre*jaux) + endif +#endif +c +c 2.5.2. ==> Aretes +c La 1ere arete est celle jouxtant le 1er joint simple. +c La 2eme arete est celle jouxtant le 2eme joint simple. +c La 3eme arete est la derniere. +c + aretri(kaux,1) = aredup(ordre*jaux-2) + aretri(kaux,2) = aredup(ordre*jaux-1) + aretri(kaux,3) = aredup(ordre*jaux) +c +c 2.5.3. ==> Caracteristiques +c + famtri(kaux) = 1 +c + hettri(kaux) = 0 + filtri(kaux) = 0 + pertri(kaux) = 0 + nivtri(kaux) = 0 +c + letria(jaux) = kaux +c +c 2.5.4. ==> Impact pour l'eventuel joint ponctuel voisin +c Pour le 1er triangle : +c . Si l'orientation est positive, le triangle entre dans le +c pentaedre, donc sort de l'eventuel joint ponctuel +c voisin : -1 = 2*1 - 3 +c . Sinon, le triangle sort du pentaedre, donc entre dans +c l'eventuel joint ponctuel voisin : 1 = 3 - 2*1 +c Pour le 2nd triangle : raisonnement symetrique +c . Orientation >0, entree : 1 = 2*2 - 3 +c . Orientation <0, sortie : -1 = 3 - 2*2 +c + if ( orient.gt.0 ) then + laux = 2*jaux - 3 + else + laux = 3 - 2*jaux + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG93', nompro +#endif + call mmag93 ( kaux, laux, + > nbte06, tbau51, + > nbpe09, tbau52, + > ulsort, langue, codret ) +c + 25 continue +c +c 2.6. ==> Creation du pentaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 +#endif +c +c 2.6.1. ==> Face 1 : c'est le triangle cree du cote du debut de +c l'arete triple +c On impose : +c la 1ere arete du pentaedre est la 1ere arete du triangle ; +c --> le code sera donc 1 ou 4. +c Si l'orientation est positive, le triangle entre dans le pentaedre. +c On lui donnera donc le code 1. +C Inversement, si l'orientation est negative, il va sortir +c du pentaedre. On lui donnera alors le code 4. +c +c Avec utsotr, on recupere les sommets du triangle dans l'ordre de +c ses aretes. On en deduit les 3 premiers sommets du pentaedre selon +c le positionnement du triangle. +c + facpen(indpen,1) = letria(1) + if ( orient.gt.0 ) then + cofape(indpen,1) = 1 + else + cofape(indpen,1) = 4 + endif +c + call utsotr ( somare, aredup(1), aredup(2), aredup(3), + > sa1a2, sa2a3, sa3a1 ) + arepen(1) = aredup(1) + if ( orient.gt.0 ) then + arepen(2) = aredup(2) + arepen(3) = aredup(3) + sompen(1) = sa1a2 + sompen(3) = sa3a1 + else + arepen(2) = aredup(3) + arepen(3) = aredup(2) + sompen(1) = sa3a1 + sompen(3) = sa1a2 + endif + sompen(2) = sa2a3 +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'sommets tria',sa1a2, sa2a3, sa3a1 + write (ulsort,90002)'sommets penta 1-3',(sompen(jaux),jaux=1,3) + write (ulsort,90002)'aretes penta 1-3',(arepen(jaux),jaux=1,3) + endif +#endif +c +c 2.6.2. ==> Face 2 : c'est le 2nd triangle cree, du cote de la fin +c de l'arete triple. +c Suite aux choix faits sur f1, sa 1ere arete est a4. +c Si le code du triangle en tant que face 1 est 1, alors sa 2eme arete +c est la translatee de a2, donc a5, ce qui fait un code 4. +c Si le code du triangle en tant que face 1 est 4, alors sa 2eme arete +c est la translatee de a3, donc a5, ce qui fait un code 1. +c + facpen(indpen,2) = letria(2) + cofape(indpen,2) = tabcod(cofape(indpen,1)) +c + call utsotr ( somare, aredup(4), aredup(5), aredup(6), + > sa1a2, sa2a3, sa3a1 ) + arepen(4) = aredup(4) + if ( orient.gt.0 ) then + arepen(5) = aredup(5) + arepen(6) = aredup(6) + sompen(4) = sa1a2 + sompen(6) = sa3a1 + else + arepen(5) = aredup(6) + arepen(6) = aredup(5) + sompen(4) = sa3a1 + sompen(6) = sa1a2 + endif + sompen(5) = sa2a3 +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'sommets tria',sa1a2, sa2a3, sa3a1 + write (ulsort,90002)'sommets penta 4-6',(sompen(jaux),jaux=4,6) + write (ulsort,90002)'aretes penta 4-6',(arepen(jaux),jaux=4,6) + endif +#endif +c +c 2.6.3. ==> Face 3 : par definition du pentaedre, elle s'appuie sur a1. +c Par construction, quajoi(1) borde le 1er joint, donc f3=quajoi(1) +c Par construction, l'arete dupliquee est la 1ere et la 3eme du +c quadrangle (mmag31), donc il y a 4 possibilites de positionnement : +c Si (a1,a9,a4,a7) du pentaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a1,a9,a4,a7) du pentaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a1,a9,a4,a7) du pentaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a1,a9,a4,a7) du pentaedre = (a2,a3,a4,a1) du quad : code = 4 +c On va positionner le tout en recherchant les extremites de l'arete +c dupliquee et en les comparant aux sommets du pentaedre +c + facpen(indpen,3) = quajoi(1) + a1 = arequa(quajoi(1),1) + a2 = arequa(quajoi(1),2) + a3 = arequa(quajoi(1),3) + a4 = arequa(quajoi(1),4) +cgn write (ulsort,90002) 'aretes de fac 3 1/9/4/7', +cgn > arepen(1),arepen(9), arepen(4), arepen(7) + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +cgn write (ulsort,90002) 'aretes de qua 1', a1, a2, a3, a4 +cgn write (ulsort,90002) 'sommet de qua 1', sa1a2, sa2a3, sa3a4, sa4a1 +c + if ( sa1a2.eq.sompen(1) .or. sa1a2.eq.sompen(4) ) then + arepen(7) = a1 + arepen(9) = a3 + elseif ( sa1a2.eq.sompen(3) .or. sa1a2.eq.sompen(6) ) then + arepen(7) = a3 + arepen(9) = a1 + else + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 + write (ulsort,texte(langue,31)) nujoin + write (ulsort,texte(langue,39)) nujois +cgn write (ulsort,90002) 'aretes de fac 1 1/2/3', +cgn > aredup(1),aredup(2), aredup(3) +cgn write (ulsort,90002) 'aretes de fac 1 4/5/6', +cgn > aredup(4),aredup(5), aredup(6) +cgn write (ulsort,90002) 'aretes de fac 3 1/9/4/7', +cgn > aredup(1), 0 , aredup(4), 0 +cgn write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4 +cgn write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4 +cgn write (ulsort,90002) 'sommet de qua 1 ', +cgn > sa1a2, sa2a3, sa3a4, sa4a1 + codret = 263 + goto 5555 + endif +c + if ( arepen(9).eq.a1 ) then + if ( arepen(1).eq.a4 ) then + cofape(indpen,3) = 2 + else + cofape(indpen,3) = 6 + endif + else + if ( arepen(1).eq.a4 ) then + cofape(indpen,3) = 8 + else + cofape(indpen,3) = 4 + endif + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'aretes penta 7-9',(arepen(jaux),jaux=7,9) + endif +#endif +c +c 2.6.4. ==> Face 4 : par definition du pentaedre, elle s'appuie sur a2. +c Selon l'orientation, la 2eme arete du pentaedre borde le 2eme ou +c le 3eme joint. +c Par construction, l'arete dupliquee est la 1ere et la 3eme du +c quadrangle (mmag31), donc il y a 4 possibilites de positionnement : +c Si (a2,a7,a5,a8) du pentaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a2,a7,a5,a8) du pentaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a2,a7,a5,a8) du pentaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a2,a7,a5,a8) du pentaedre = (a2,a3,a4,a1) du quad : code = 4 +c + lequad = quajoi(nujolo(2)) + facpen(indpen,4) = lequad +c + if ( arepen(7).eq.arequa(lequad,1) ) then + if ( arepen(2).eq.arequa(lequad,4) ) then + cofape(indpen,4) = 2 + else + cofape(indpen,4) = 6 + endif + arepen(8) = arequa(lequad,3) + else + if ( arepen(2).eq.arequa(lequad,4) ) then + cofape(indpen,4) = 8 + else + cofape(indpen,4) = 4 + endif + arepen(8) = arequa(lequad,1) + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'aretes penta 7-9',(arepen(jaux),jaux=7,9) + endif +#endif +c +c 2.6.5. ==> Face 5 : par definition du pentaedre, elle s'appuie sur a3. +c Selon l'orientation, la 3eme arete du pentaedre borde le 2eme ou +c le 3eme joint. +c Par construction, l'arete dupliquee est la 1ere et la 3eme du +c quadrangle (mmag31), donc il y a 4 possibilites de positionnement : +c Si (a3,a8,a6,a9) du pentaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a3,a8,a6,a9) du pentaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a3,a8,a6,a9) du pentaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a3,a8,a6,a9) du pentaedre = (a2,a3,a4,a1) du quad : code = 4 +c + lequad = quajoi(nujolo(3)) + facpen(indpen,5) = lequad +c + if ( arepen(9).eq.arequa(quajoi(3),3) ) then + if ( arepen(3).eq.arequa(quajoi(3),4) ) then + cofape(indpen,5) = 2 + else + cofape(indpen,5) = 6 + endif + else + if ( aredup(3).eq.arequa(quajoi(3),4) ) then + cofape(indpen,5) = 8 + else + cofape(indpen,5) = 4 + endif + endif +c +c 2.6.6. ==> nujoin est le numero du joint parmi tous les joints. +c Il faut ajouter 1 pour tenir compte de la famille libre. +c + fampen(indpen) = nujoin + 1 +c + hetpen(indpen) = 0 + filpen(indpen) = 0 + perpen(indpen) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 + do 4444 , jaux = 1, 5 + write (ulsort,90001) 'face/code', jaux, + > facpen(indpen,jaux),cofape(indpen,jaux) + 4444 continue + write (ulsort,90002)'aretes penta 1-3',(arepen(jaux),jaux=1,3) + write (ulsort,90002)'aretes penta 4-6',(arepen(jaux),jaux=4,6) + write (ulsort,90002)'aretes penta 7-9',(arepen(jaux),jaux=7,9) + write (ulsort,90002)'sommets penta 1-3', (sompen(jaux),jaux=1,3) + write (ulsort,90002)'sommets penta 4-6', (sompen(jaux),jaux=4,6) + endif +#endif +c + 2 continue +c +c==== +c 5. la fin +c==== +c + 5555 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag33.F b/src/tool/Modification/mmag33.F new file mode 100644 index 00000000..c13c0b40 --- /dev/null +++ b/src/tool/Modification/mmag33.F @@ -0,0 +1,788 @@ + subroutine mmag33 ( indhex, + > nbduno, nbduar, + > nbpejt, nbhejq, nbvojm, nbjoto, + > nbjois, nbjoit, + > tbaux2, tbau30, tbau40, + > tbau41, + > nbhe12, tbau53, + > nbpe09, tbau52, + > coonoe, somare, + > arequa, hetqua, + > filqua, perqua, nivqua, + > quahex, coquhe, + > hethex, filhex, perhex, + > famqua, famhex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.3 +c - - -- - - +c Creation des mailles pour les joints quadruples : +c . hexaedres +c Et donc des quadrangles supplementaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbpejt . e . 1 . nombre de pentaedres de joints triples . +c . nbhejq . e . 1 . nombre d'hexaedres de joints quadruples . +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbjoto . e . 1 . nombre total de joints . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . tbaux2 . e .4*nbjoto. Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . nbhe12 . e . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . tbau53 . es . 13* . Les hexaedres ponctuels entre les joints . +c . . . nbhe12 . quadruples (ordre 12) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : quadrangle cote du 1er joint quad. . +c . . . . (3,i) : quadrangle cote du 2eme joint quad.. +c . . . . (4,i) : quadrangle cote du 3eme joint quad.. +c . . . . (5,i) : quadrangle cote du 4eme joint quad.. +c . . . . (6,i) : quadrangle cote du 5eme joint quad.. +c . . . . (7,i) : quadrangle cote du 6eme joint quad.. +c . . . . (1+k) : pour le k-eme quadrangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . nbpe09 . e . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . tbau52 . es . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 3 aretes des quadrangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . filqua . es . nbquto . premier fils des quadrangles . +c . perqua . es . nbquto . pere des quadrangles . +c . nivqua . es . nbquto . niveau des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . hethex . es . nbheto . historique de l'etat des hexaedres . +c . filhex . es . nbheto . premier fils des hexaedres . +c . perhex . es . nbheto . pere des hexaedres . +c . famqua . es . nbquto . famille des quadrangles . +c . famhex . es . nbheto . famille des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG33' ) +c +#include "nblang.h" +c + integer ordre + parameter ( ordre = 4 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer indhex + integer nbduno, nbduar + integer nbpejt, nbhejq, nbvojm, nbjoto + integer nbjois, nbjoit + integer tbaux2(4,nbjoto) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbau41(4,nbvojm) + integer nbhe12, tbau53(13,nbhe12) + integer nbpe09, tbau52(11,nbpe09) + integer somare(2,nbarto) + integer arequa(nbquto,4), hetqua(nbquto) + integer filqua(nbquto), perqua(nbquto), nivqua(nbquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer hethex(nbheto), filhex(nbheto), perhex(nbheto) + integer famqua(nbquto), famhex(nbheto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer ideb, ifin + integer larete + integer lequad(2) + integer nbjoin +c + integer nujoin, nujois(ordre) + integer aredup(2*ordre) + integer arejoi(ordre), quajoi(ordre) + integer nujolo(ordre), nujol2(ordre) + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer somhex(8), arehex(12), orient + integer tabcod(8) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + data tabcod / 5, 8, 7, 6, 1, 4, 3, 2 / +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c + nbjoin = nbjois + nbjoit +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nbjois + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhejq + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar +#endif +c + codret = 0 +c + ideb = nbpejt + 1 + ifin = nbpejt + nbhejq +cgn write (ulsort,90002) 'nbpejt', nbpejt +cgn write (ulsort,90002) 'nbhejq', nbhejq +cgn write (ulsort,*) '==> ideb , ifin =', ideb , ifin +c +cgn write(ulsort,1001) 'nbnoto, nbarto, nbquto',nbnoto, nbarto,nbquto +cgn write(ulsort,1001) 'nbhejq',nbhejq +cgn write(ulsort,1000) (iaux,iaux=1,20) +cgn write(ulsort,1001) 'tbaux2',4,nbjoto +cgn do 1101 , kaux = 1,nbjoto +cgn write(ulsort,1000) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,1001) 'tbau41',4,nbvojm +cgn do 1102 , kaux = 1,nbvojm +cgn write(ulsort,1000) (tbau41(jaux,kaux),jaux=1,4) +cgn 1102 continue +cgn 1000 format(10i9) +cgn 1001 format(a,4i6) +c +c==== +c 2. Parcours des aretes quadruples / hexaedres de joint quadruple +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c +c S5 a9 S6 +c ---------------------------- +c /. /. +c / . / . +c / . / . +c / . / . +c a6/ . /a5 . +c / . / . +c / a11. / .a10 +c / . a1 / . +c S2----------------------------- S1 . +c . . . . +c . . a12 . . +c . S8 -------------------.--------.S7 +c . / . / +c a3. / .a2 / +c . / . / +c . / . / +c . a8/ . /a7 +c . / . / +c . / . / +c ./ ./ +c ----------------------------- +c S3 a4 S4 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c Avec le code 1, les faces sont : +c Face 1 : aretes 1, 2, 4, 3 +c Face 2 : aretes 1, 6, 9, 5 +c Face 3 : aretes 2, 5, 10, 7 +c Face 4 : aretes 3, 8, 11, 6 +c Face 5 : aretes 4, 7, 12, 8 +c Face 6 : aretes 9, 11, 12, 10 +c +c L'arete quadruple se retrouve dans a5, a7, a8, a6. +c On impose que : +c Le long de l'arete quadruple : +c . La face F1 (a1,a2,a4,a3) est definie du cote du 1er sommet et +c a1 est du cote du 1er joint simple voisin +c . La face F2 borde le 1er joint simple.c + ideb = nbpejt + 1 + ifin = nbpejt + nbhejq +cgn write (ulsort,90002) 'nbpejt', nbpejt +cgn write (ulsort,90002) 'nbhejq', nbhejq +cgn write (ulsort,*) '==> ideb , ifin =', ideb , ifin + +c . La face F3 borde le joint qui suit le 1er. +c . La face F4 borde le joint qui suit le 2eme. +c . La face F5 est opposee a F2. +c . La face F6 (a9,a11,a12,a10) est definie du cote du 2nd sommet : +c a9 est du cote du 1er joint simple voisin +c +c voir utarhe pour le croquis ci-dessus +c + do 2 , iaux = ideb , ifin +c + indhex = indhex + 1 +c + larete = tbau41(1,iaux) +c + nujoin = tbau41(2,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,32)) nujoin - nbjoin + endif +#endif +c +c 2.1. ==> reperage des numeros des 4 joints simples voisins +c + do 21 , jaux = 1 , ordre + nujois(jaux) = tbaux2(jaux,nujoin) + 21 continue +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,texte(langue,39)) nujois + endif +#endif +c +c 2.2. ==> Reperage des aretes qui partent de chacun des noeuds. +C Elles delimitent les faces 1 et 6 de l'hexaedre en cours. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG91', nompro +#endif + call mmag91 ( larete, ordre, nujois, + > nbduno, tbau30, + > somare, + > aredup, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0 + write (ulsort,texte(langue,31)) nujoin + goto 5555 + endif +c +c 2.3. ==> Reperage des aretes et des quadrangles batis sur les joints +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG92', nompro +#endif + call mmag92 ( larete, ordre, nujois, + > nbduar, tbau40, + > arejoi, quajoi, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indhex, 0 + write (ulsort,texte(langue,31)) nujoin + goto 5555 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + do 23111 , jaux = 1 , ordre + write (ulsort,90015)'Joint',jaux,', quadrangle',quajoi(jaux) + write (ulsort,90015)'arete de joints',arejoi(jaux), + > ', de sommets',somare(1,arejoi(jaux)),somare(2,arejoi(jaux)) +23111 continue + endif +#endif +c +c 2.4. ==> Determination de l'orientation des joints +c Par hypothese, la face f2 de l'hexaedre s'appuie sur le 1er +c joint simple. Ensuite, par definition de l'hexaedre, les +c faces f3, f5 et f4 arrivent dans le sens positif quand on +c entre dans l'hexaedre depuis la face f1. +c On cherche donc le positionnement des 4 joints relativement +c a l'arete dupliquee et on en deduit l'ordre d'apparition +c des joints qui creeront les faces f3, f5 et f4. +c Ensuite, il faut definir un enchainement des aretes de joint +c dans un ordre coherent. +c . Soit on suit l'ordre entrant dans l'hexaedre que l'on veut +c creer ; +c . Soit on suit l'ordre inverse +c Il faut que le choix entre les deux soit independant de +c l'hexaedre car ce quadrangle peut apparaitre pour l'hexaedre +c courant ou pour son voisin. Et donc le caractere +c entrant/sortant va changer. On choisira de tourner dans +c un sens ou dans un autre en fonction du plus petit numero de +c joint qui suit. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3', nompro +#endif + call utora4 ( nujolo, + > larete, + > arejoi(1), arejoi(2), arejoi(3), arejoi(4), + > coonoe, somare, + > ulsort, langue, codret ) +c + if ( nujois(nujolo(2)).lt.nujois(nujolo(4)) ) then + orient = 1 + nujol2(2) = nujolo(2) + nujol2(4) = nujolo(4) + else + orient = -1 + nujol2(2) = nujolo(4) + nujol2(4) = nujolo(2) + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'orient',orient + endif +#endif +c +c 2.5. ==> Creation des quadrangles +c Eventuellement, on recree plusieurs fois le meme quadrangle. +c Pas grave car il est toujours cree en s'orientant sur les +c joints simples adjacents. +c + do 25 , jaux = 1 , 2 +c +c 2.5.1. ==> Numero du quadrangle +c + kaux = tbau41(2+jaux,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,4), kaux, + > jaux + write (ulsort,texte(langue,17)) + > (aredup(kaux),kaux=ordre*(jaux-1)+1,ordre*jaux) +#endif +c +c 2.5.2. ==> Aretes +c La 1ere arete est celle jouxtant le 1er joint simple. +c La 2eme arete est celle qui suit selon la regle precedente. +c La 3eme arete est celle qui borde le 3eme joint. +c La 4eme arete est celle qui suit selon la regle precedente. +c + arequa(kaux,1) = aredup(ordre*(jaux-1)+1) + arequa(kaux,2) = aredup(ordre*(jaux-1)+nujol2(2)) + arequa(kaux,3) = aredup(ordre*(jaux-1)+nujolo(3)) + arequa(kaux,4) = aredup(ordre*(jaux-1)+nujol2(4)) +c +c 2.5.3. ==> Caracteristiques +c + famqua(kaux) = 1 +c + hetqua(kaux) = 0 + filqua(kaux) = 0 + perqua(kaux) = 0 + nivqua(kaux) = 0 +c + lequad(jaux) = kaux +c +c 2.5.4. ==> Impact pour l'eventuel joint ponctuel voisin +c Pour le 1er quadrangle : +c . Si l'orientation est positive, le quadrangle entre dans +c l'hexaedre, donc sort de l'eventuel joint ponctuel +c voisin : -1 = 2*1 - 3 +c . Sinon, le triangle sort de l'hexaedre, donc entre dans +c l'eventuel joint ponctuel voisin : 1 = 3 - 2*1 +c Pour le 2nd quadrangle : raisonnement symetrique +c . Orientation >0, entree : 1 = 2*2 - 3 +c . Orientation <0, sortie : -1 = 3 - 2*2 +c + if ( orient.gt.0 ) then + laux = 2*jaux - 3 + else + laux = 3 - 2*jaux + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG94', nompro +#endif + call mmag94 ( kaux, laux, + > nbhe12, tbau53, + > nbpe09, tbau52, + > ulsort, langue, codret ) +c + 25 continue +c +c 2.6. ==> Creation de l'hexaedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0 +#endif +c +c 2.6.1. ==> La face f1 est le 1er quadrangle. +c On impose : +c la 1ere arete de l'hexaedre est la 1ere arete du quadrangle ; +c --> le code sera donc 1 ou 5. +c Si l'orientation est positive, le quadrangle entre dans l'hexaedre. +c On lui donnera donc le code 1. +C Inversement, si l'orientation est negative, il va sortir +c de l'hexaedre. On lui donnera alors le code 5. +c + quahex(indhex,1) = lequad(1) + if ( orient.gt.0 ) then + coquhe(indhex,1) = 1 + else + coquhe(indhex,1) = 5 + endif +c + call utsoqu ( somare, + > aredup(1), aredup(nujol2(2)), + > aredup(nujolo(3)), aredup(nujol2(4)), + > sa1a2, sa2a3, sa3a4, sa4a1 ) + arehex(1) = aredup(1) + arehex(2) = aredup(nujolo(2)) + arehex(4) = aredup(nujolo(3)) + arehex(3) = aredup(nujolo(4)) + if ( orient.gt.0 ) then + somhex(1) = sa1a2 + somhex(4) = sa2a3 + somhex(3) = sa3a4 + somhex(2) = sa4a1 + else + somhex(1) = sa4a1 + somhex(4) = sa3a4 + somhex(3) = sa2a3 + somhex(2) = sa1a2 + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'sommets quad',sa1a2, sa2a3, sa3a4, sa4a1 + write (ulsort,90002)'sommets hexa 1-4',(somhex(jaux),jaux=1,4) + write (ulsort,90002)'aretes hexa 1-4',(arehex(jaux),jaux=1,4) + endif +#endif +c +c 2.6.2. ==> Face 6 : c'est le quadrangle cree du cote de la fin +c de l'arete quadruple. +c Suite aux choix faits sur f1, sa 1ere arete est a9. +c Si le code du quadrangle en tant que face 1 est 1, alors sa 2eme +c arete est la translatee de a2, donc a10, ce qui fait un code 5. +c Si le code du quadrangle en tant que face 1 est 4, alors sa 2eme +c arete est la translatee de a3, donc a11, ce qui fait un code 1. +c + quahex(indhex,6) = lequad(2) + coquhe(indhex,6) = tabcod(coquhe(indhex,1)) +c + call utsoqu ( somare, + > aredup(5), aredup(ordre+nujol2(2)), + > aredup(ordre+nujolo(3)), aredup(ordre+nujol2(4)), + > sa1a2, sa2a3, sa3a4, sa4a1 ) + arehex( 9) = aredup(5) + arehex(10) = aredup(ordre+nujolo(2)) + arehex(12) = aredup(ordre+nujolo(3)) + arehex(11) = aredup(ordre+nujolo(4)) + if ( orient.gt.0 ) then + somhex(6) = sa1a2 + somhex(7) = sa2a3 + somhex(8) = sa3a4 + somhex(5) = sa4a1 + else + somhex(6) = sa4a1 + somhex(7) = sa3a4 + somhex(8) = sa2a3 + somhex(5) = sa1a2 + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'sommets quad',sa1a2, sa2a3, sa3a4, sa4a1 + write (ulsort,90002)'sommets hexa 5-8',(somhex(jaux),jaux=5,8) + write (ulsort,90002)'aretes hexa 9-12',(arehex(jaux),jaux=9,12) + endif +#endif +c +c 2.6.3. ==> Face 2 : par definition de l'hexa, elle s'appuie sur a1. +c Par construction, quajoi(1) borde le 1er joint, donc f2=quajoi(1). +c Par construction, l'arete dupliquee est la 1ere et la 3eme +c du quadrangle (cf. mmag31), donc : +c Les aretes 1 et 3 du quadrangle peuvent etre a5 ou a6 +c Les aretes 2 et 4 du quadrangle peuvent etre a1 ou a9 +c Si (a1,a6,a9,a5) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a1,a6,a9,a5) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a1,a6,a9,a5) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a1,a6,a9,a5) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4 +c + quahex(indhex,2) = quajoi(1) + a1 = arequa(quajoi(1),1) + a2 = arequa(quajoi(1),2) + a3 = arequa(quajoi(1),3) + a4 = arequa(quajoi(1),4) +cgn write (ulsort,90002) 'aretes de fac 2 1/6/9/5', +cgn > arehex(1),arehex(6), arehex(9), arehex(5) + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +cgn write (ulsort,90002) 'aretes de qua 1', a1, a2, a3, a4 +cgn write (ulsort,90002) 'sommet de qua 1', sa1a2, sa2a3, sa3a4, sa4a1 + if ( sa1a2.eq.somhex(1) .or. sa1a2.eq.somhex(6) ) then + arehex(5) = a1 + arehex(6) = a3 + elseif ( sa1a2.eq.somhex(2) .or. sa1a2.eq.somhex(5) ) then + arehex(5) = a3 + arehex(6) = a1 + else + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0 + write (ulsort,texte(langue,32)) nujoin - nbjoin + write (ulsort,texte(langue,39)) nujois +cgn write (ulsort,90002) 'aretes de fac 1 1/2/3', +cgn > arehex(1),arehex(2), arehex(3) +cgn write (ulsort,90002) 'aretes de fac 1 4/5/6', +cgn > arehex(4),arehex(5), arehex(6) +cgn write (ulsort,90002) 'aretes de fac 3 1/9/4/7', +cgn > arehex(1), 0 , arehex(4), 0 +cgn write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4 +cgn write (ulsort,90002) 'sommet de fac 3 1/3/6/4', +cgn > somhex(1),somhex(3), somhex(6), somhex(4) +cgn write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4 +cgn write (ulsort,90002) 'sommet de qua 1 ', +cgn > sa1a2, sa2a3, sa3a4, sa4a1 + codret = 263 + goto 5555 + endif +cgn write (ulsort,90002) 'arehex(5), arehex(6)',arehex(5), arehex(6) + if ( arehex(6).eq.a1 ) then + if ( arehex(1).eq.a4 ) then + coquhe(indhex,2) = 2 + else + coquhe(indhex,2) = 6 + endif + else +c La face f3 est le quadrangle quajoi(2). + if ( arehex(1).eq.a4 ) then + coquhe(indhex,2) = 8 + else + coquhe(indhex,2) = 4 + endif + endif +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-8 ) then + write (ulsort,90002)'aretes hexa 5-6',(arehex(jaux),jaux=5,6) + endif +#endif +c +c 2.6.4. ==> Face 3 : par definition de l'hexa, elle s'appuie sur a2. +c Par construction, f3=quajoi(du 2eme dans l'ordre entrant). +c Par construction, l'arete dupliquee est la 1ere et la 3eme +c du quadrangle (cf. mmag31), donc : +c Les aretes 1 et 3 du quadrangle peuvent etre a5 ou a7 +c Les aretes 2 et 4 du quadrangle peuvent etre a2 ou a10 +c Si (a2,a5,a10,a7) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a2,a5,a10,a7) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a2,a5,a10,a7) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a2,a5,a10,a7) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4 +c + quahex(indhex,3) = quajoi(nujolo(2)) +cgn write (ulsort,90002) 'quadrangle de F3', qua(2) +cgn write (ulsort,90002) 'aretes de qua 1/2/3/4', +cgn > arequa(qua(2),1),arequa(qua(2),2), +cgn > arequa(qua(2),3),arequa(qua(2),4) + if ( arehex(5).eq.arequa(quajoi(nujolo(2)),1) ) then + if ( arehex(2).eq.arequa(quajoi(nujolo(2)),4) ) then + coquhe(indhex,3) = 2 + else + coquhe(indhex,3) = 6 + endif + else + if ( arehex(2).eq.arequa(quajoi(nujolo(2)),4) ) then + coquhe(indhex,3) = 8 + else + coquhe(indhex,3) = 4 + endif + endif +cgn write (ulsort,1001) 'aretes de fac 3 2/5/10/7', +cgn > arehex(2),arehex(5), arehex(10), arehex(7) +c +c 2.6.5. ==> Face 4 : par definition de l'hexa, elle s'appuie sur a3. +c Par construction, f4=quajoi(du 4eme dans l'ordre entrant). +c Les aretes 1 et 3 du quadrangle peuvent etre a8 ou a6 +c Les aretes 2 et 4 du quadrangle peuvent etre a3 ou a11 +c Si (a3,a8,a11,a6) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a3,a8,a11,a6) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a3,a8,a11,a6) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a3,a8,a11,a6) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4 +c + quahex(indhex,4) = quajoi(nujolo(4)) +cgn write (ulsort,90002) 'quadrangle de F4', qua(2) +cgn write (ulsort,90002) 'aretes de qua 1/2/3/4', +cgn > arequa(qua(3),1),arequa(qua(3),2), +cgn > arequa(qua(3),3),arequa(qua(3),4) + if ( arehex(6).eq.arequa(quajoi(nujolo(4)),3) ) then + if ( arehex(3).eq.arequa(quajoi(nujolo(4)),4) ) then + coquhe(indhex,4) = 2 + else + coquhe(indhex,4) = 6 + endif + arehex(8) = arequa(quajoi(nujolo(4)),1) + else + if ( arehex(3).eq.arequa(quajoi(nujolo(4)),4) ) then + coquhe(indhex,4) = 8 + else + coquhe(indhex,4) = 4 + endif + arehex(8) = arequa(quajoi(nujolo(4)),3) + endif +c +c 2.6.6. ==> Face 5 : par definition de l'hexa, elle s'appuie sur a4. +c Par construction, f5=quajoi(du 3eme dans l'ordre entrant). +c Les aretes 1 et 3 du quadrangle peuvent etre a7 ou a8 +c Les aretes 2 et 4 du quadrangle peuvent etre a4 ou a12 +c Si (a4,a7,a12,a8) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2 +c Si (a4,a7,a12,a8) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6 +c Si (a4,a7,a12,a8) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8 +c Si (a4,a7,a12,a8) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4 +c + quahex(indhex,5) = quajoi(nujolo(3)) +cgn write (ulsort,90002) 'quadrangle de F5', qua(2) +cgn write (ulsort,90002) 'aretes de qua 1/2/3/4', +cgn > arequa(qua(4),1),arequa(qua(4),2), +cgn > arequa(qua(4),3),arequa(qua(4),4) + if ( arehex(8).eq.arequa(quajoi(nujolo(3)),3) ) then + if ( arehex(4).eq.arequa(quajoi(nujolo(3)),4) ) then + coquhe(indhex,5) = 2 + else + coquhe(indhex,5) = 6 + endif + else + if ( arehex(4).eq.arequa(quajoi(nujolo(3)),4) ) then + coquhe(indhex,5) = 8 + else + coquhe(indhex,5) = 4 + endif + endif +c +c 2.6.8.==> nujoin est le numero du joint parmi tous les joints. +c Il faut retrancher le nombre de joints de pentaedres qui +c ont ete crees auparavant +c Il faut ajouter 1 pour tenir compte de la famille libre. +c + famhex(indhex) = nujoin - nbjoin + 1 +c + hethex(indhex) = 0 + filhex(indhex) = 0 + perhex(indhex) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( indhex.eq.-1 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0 + write (ulsort,90002)'faces ',(quahex(indhex,jaux),jaux=1,6) + write (ulsort,90002)'coquhe',(coquhe(indhex,jaux),jaux=1,6) + write (ulsort,90002)'aretes 1-4',(arehex(jaux),jaux=1,4) + write (ulsort,90002)'aretes 5-8',(arehex(jaux),jaux=5,8) + write (ulsort,90002)'aretes 9-12',(arehex(jaux),jaux=9,12) + write (ulsort,90002)'sommets 1-4', (somhex(jaux),jaux=1,4) + write (ulsort,90002)'sommets 5-8', (somhex(jaux),jaux=5,8) + endif +#endif +c + 2 continue +c +c==== +c 5. la fin +c==== +c + 5555 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag34.F b/src/tool/Modification/mmag34.F new file mode 100644 index 00000000..4a5e54a0 --- /dev/null +++ b/src/tool/Modification/mmag34.F @@ -0,0 +1,463 @@ + subroutine mmag34 ( indtet, + > nbte06, + > tbau51, + > aretri, + > tritet, cotrte, + > hettet, filtet, pertet, + > famtet, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.4 +c - - -- - - +c Creation des mailles pour les joints ponctuels : +c . tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . nbte06 . e . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . tbau51 . e .9*nbte06. Les tetraedres ponctuels entre les joints . +c . . . . triples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : triangle cote du 3eme joint triple . +c . . . . (5,i) : triangle cote du 4eme joint triple . +c . . . . (1+k) : pour le k-eme triangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . es .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . es .nbtecf*4. codes des triangles des tetraedres . +c . hettet . es . nbteto . historique de l'etat des tetraedres . +c . filtet . es . nbteto . premier fils des tetraedres . +c . pertet . es . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . famtet . es . nbteto . famille des tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG34' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "nombtr.h" +#include "nombte.h" +#include "impr02.h" +#include "i1i2i3.h" +#include "op0123.h" +c +c 0.3. ==> arguments +c + integer indtet + integer nbte06 + integer tbau51(9,nbte06) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer hettet(nbteto), filtet(nbteto), pertet(nbteto) + integer famtet(nbteto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux +c + integer nulofa(4), nuloar(4,3), orient(4) + integer aretet(6), letria(4) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "mmag02.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + > mess14(langue,3,3)//'d''ordre 6', nbte06 +#endif +c + codret = 0 +c +cgn write(ulsort,90002) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto +cgn write(ulsort,90002) 'nbte06',nbte06 +cgn write(ulsort,90015) (iaux,iaux=1,20) +cgn write(ulsort,90002) 'tbaux2',4,nbjoto +cgn do 1101 , kaux = 1,nbjoto +cgn write(ulsort,90015) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,90002) 'tbau51',5,nbte06 +cgn do 1102 , kaux = 1,nbte06 +cgn write(ulsort,90015) (tbau51(jaux,kaux),jaux=1,5) +cgn 1102 continue +c +c==== +c 2. Parcours des tetraedres de joint ponctuel d'ordre 6 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,3) +#endif +c +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a3 +c . . . +c . . . +c a1 . a2 . . n4 +c . . * +c . . . . +c . a5 . . . a6 +c . . . . +c . . .. +c . . . +c *..................................* +c n2 a4 n3 +c +c . Les noeuds (1,2,3) definissent un triangle a orientation +c vers l'exterieur +c Avec le code 1, les faces sont : +c Face 1 : aretes 4, 5, 6 (sortante) +c Face 2 : aretes 2, 3, 6 (entrante) +c Face 3 : aretes 1, 3, 5 (sortante) +c Face 4 : aretes 1, 2, 4 (entrante) +c +c voir utarte pour le croquis ci-dessus +c + do 2 , iaux = 1 , nbte06 +c + indtet = indtet + 1 +c +c 2.1 ==> Recuperation des triangles et de leur orientation +c + do 21 , jaux = 1 , 4 + letria(jaux) = tbau51(jaux+1,iaux) + orient(jaux) = tbau51(jaux+5,iaux) +cgn write (ulsort,90015) 'triangle', letria(jaux), +cgn > ', d''orientation', orient(jaux) +cgn write (ulsort,90002) 'aretes ', +cgn > (aretri(letria(jaux),kaux),kaux=1,3) + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', + > mess14(langue,1,1), tbau51(1,iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,3), indtet, 0 +#endif +c +c 2.2 ==> Positionnement des triangles en tant que face +c nulofa(i) = numero local du triangle dans letria qui +c correspond a la face Fi +c nuloar(i,j) = pour la face Fi, numero local de sa i-eme arete +c dans la description de la face +c 2.2.1. ==> La face F1 est le 1er triangle enregistre. +c On impose : +c la 4eme arete du tetraedre est la 1ere arete du triangle ; +c --> le code sera donc 1 ou 4. +c Si l'orientation est positive, le triangle entre dans le tetraedre. +c On lui donnera donc le code 4. +C Inversement, si l'orientation est negative, il va sortir +c du tetraedre. On lui donnera alors le code 1. +c + tritet(indtet,1) = letria(1) + if ( orient(1).gt.0 ) then + cotrte(indtet,1) = 4 + else + cotrte(indtet,1) = 1 + endif +c +c Reperage des aretes de cette face +c + aretet(4) = aretri(letria(1),1) + if ( orient(1).gt.0 ) then + aretet(5) = aretri(letria(1),3) + aretet(6) = aretri(letria(1),2) + else + aretet(5) = aretri(letria(1),2) + aretet(6) = aretri(letria(1),3) + endif +#ifdef _DEBUG_HOMARD_ + if ( indtet.lt.0 ) then + write (ulsort,90002) 'triangle pour F1', letria(1) + write (ulsort,90002) 'aretes de tet 4-6',(aretet(jaux),jaux=4,6) + endif +#endif +c +c 2.2.2. ==> La face F2 est l'autre triangle qui contient l'arete 6 +c C'est son arete numero 3 +c + do 222 , jaux = 2 , 4 + if ( aretet(6).eq.aretri(letria(jaux),1) ) then + nulofa(2) = jaux + nuloar(2,3) = 1 + goto 2221 + elseif ( aretet(6).eq.aretri(letria(jaux),2) ) then + nulofa(2) = jaux + nuloar(2,3) = 2 + goto 2221 + elseif ( aretet(6).eq.aretri(letria(jaux),3) ) then + nulofa(2) = jaux + nuloar(2,3) = 3 + goto 2221 + endif + 222 continue + codret = 222 + goto 3333 +c + 2221 continue +#ifdef _DEBUG_HOMARD_ + if ( indtet.lt.0 ) then + write (ulsort,90002) 'triangle pour F2', letria(nulofa(2)) + endif +#endif +c +c 2.2.3. ==> La face F3 est l'autre triangle qui contient l'arete 5 +c C'est son arete numero 3 +c + do 223 , jaux = 2 , 4 + if ( aretet(5).eq.aretri(letria(jaux),1) ) then + nulofa(3) = jaux + nuloar(3,3) = 1 + goto 2231 + elseif ( aretet(5).eq.aretri(letria(jaux),2) ) then + nulofa(3) = jaux + nuloar(3,3) = 2 + goto 2231 + elseif ( aretet(5).eq.aretri(letria(jaux),3) ) then + nulofa(3) = jaux + nuloar(3,3) = 3 + goto 2231 + endif + 223 continue + codret = 223 + goto 3333 +c + 2231 continue +#ifdef _DEBUG_HOMARD_ + if ( indtet.lt.0 ) then + write (ulsort,90002) 'triangle pour F3', letria(nulofa(3)) + endif +#endif +c +c 2.2.4. ==> La face F4 est l'autre triangle qui contient l'arete 4 +c C'est son arete numero 3 +c + do 224 , jaux = 2 , 4 + if ( aretet(4).eq.aretri(letria(jaux),1) ) then + nulofa(4) = jaux + nuloar(4,3) = 1 + goto 2241 + elseif ( aretet(4).eq.aretri(letria(jaux),2) ) then + nulofa(4) = jaux + nuloar(4,3) = 2 + goto 2241 + elseif ( aretet(4).eq.aretri(letria(jaux),3) ) then + nulofa(4) = jaux + nuloar(4,3) = 3 + goto 2241 + endif + 224 continue + codret = 224 + goto 3333 +c + 2241 continue +#ifdef _DEBUG_HOMARD_ + if ( indtet.lt.0 ) then + write (ulsort,90002) 'triangle pour F4', letria(nulofa(4)) + endif +#endif +c +c 2.3. ==> Recherche de l'arete 1, commune aux faces F3 et F4 +c + do 23 , jaux = 1 , 3 + laux = aretri(letria(nulofa(3)),jaux) + do 231 , kaux = 1, 3 + if ( laux.eq.aretri(letria(nulofa(4)),kaux) ) then + nuloar(3,1) = jaux + nuloar(4,1) = kaux + aretet(1) = laux + goto 2311 + endif + 231 continue + 23 continue + codret = 23 + goto 3333 + 2311 continue +c +c On en deduit les aretes 2 et 3 +c + nuloar(3,2) = fp0123(nuloar(3,1),nuloar(3,3)) + aretet(3) = aretri(letria(nulofa(3)),nuloar(3,2)) +c + nuloar(4,2) = fp0123(nuloar(4,1),nuloar(4,3)) + aretet(2) = aretri(letria(nulofa(4)),nuloar(4,2)) +c +c 2.4. ==> On termine les aretes de la face F2 +c + do 24 , jaux = 1 , 3 + if ( aretri(letria(nulofa(2)),jaux).eq.aretet(2) ) then + nuloar(2,1) = jaux + nuloar(2,2) = fp0123(nuloar(2,1),nuloar(2,3)) + goto 2411 + endif + 24 continue + codret = 24 + goto 3333 + 2411 continue +c +cgn write (ulsort,90002) 'nuloar 2',(nuloar(2,jaux),jaux=1,3) +cgn write (ulsort,90002) 'nuloar 3',(nuloar(3,jaux),jaux=1,3) +cgn write (ulsort,90002) 'nuloar 4',(nuloar(4,jaux),jaux=1,3) +c +c 2.5.==> Mise en place de la face 2 +c + tritet(indtet,2) = letria(nulofa(2)) +c + do 25 , jaux = 1 , 6 + if ( i1(jaux).eq.nuloar(2,1) .and. + > i2(jaux).eq.nuloar(2,2) .and. + > i3(jaux).eq.nuloar(2,3) ) then + cotrte(indtet,2) = jaux + goto 2511 + endif + 25 continue + codret = 25 + goto 3333 + 2511 continue +c +c 2.6.==> Mise en place de la face 3 +c + tritet(indtet,3) = letria(nulofa(3)) +c + do 26 , jaux = 1 , 6 + if ( i1(jaux).eq.nuloar(3,1) .and. + > i2(jaux).eq.nuloar(3,2) .and. + > i3(jaux).eq.nuloar(3,3) ) then + cotrte(indtet,3) = jaux + goto 2611 + endif + 26 continue + codret = 26 + goto 3333 + 2611 continue +c +c 2.7.==> Mise en place de la face 4 +c + tritet(indtet,4) = letria(nulofa(4)) +c + do 27 , jaux = 1 , 6 + if ( i1(jaux).eq.nuloar(4,1) .and. + > i2(jaux).eq.nuloar(4,2) .and. + > i3(jaux).eq.nuloar(4,3) ) then + cotrte(indtet,4) = jaux + goto 2711 + endif + 27 continue + codret = 27 + goto 3333 + 2711 continue +c +c 2.8.==> Caracteristiques +c iaux est le numero du joint ponctuel. +c On decale pour tenir compte des familles HOMARD precedentes +c + famtet(indtet) = nbftet + iaux +c + hettet(indtet) = 0 + filtet(indtet) = 0 + pertet(indtet) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( indtet.ne.-1 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,3), indtet, 0 + write (ulsort,90002)'faces ',(tritet(indtet,jaux),jaux=1,4) + write (ulsort,90002)'cotrte',(cotrte(indtet,jaux),jaux=1,4) + write (ulsort,90002)'aretes 1-3',(aretet(jaux),jaux=1,3) + write (ulsort,90002)'aretes 4-6',(aretet(jaux),jaux=4,6) + endif +#endif +c + 2 continue +c +c==== +c 3. la fin +c==== +c + 3333 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag35.F b/src/tool/Modification/mmag35.F new file mode 100644 index 00000000..8bc77773 --- /dev/null +++ b/src/tool/Modification/mmag35.F @@ -0,0 +1,584 @@ + subroutine mmag35 ( indpen, nbfpe0, + > nbpe09, + > tbau52, + > aretri, arequa, + > facpen, cofape, + > hetpen, filpen, perpen, + > fampen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.5 +c - - -- - - +c Creation des mailles pour les joints ponctuels : +c . pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . nbfpe0 . e . 1 . nombre de familles de pentaedres creees . +c . nbpe09 . e . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . tbau52 . e . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . es .nbpecf*5. numeros des faces des pentaedres . +c . cofape . es .nbpecf*5. codes des faces des pentaedres . +c . hetpen . es . nbpeto . historique de l'etat des pentaedres . +c . filpen . es . nbpeto . premier fils des pentaedres . +c . perpen . es . nbpeto . pere des pentaedres . +c . fampen . es . nbpeto . famille des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG35' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +#include "impr02.h" +#include "i1i2i3.h" +#include "j1234j.h" +#include "op1234.h" +c +c 0.3. ==> arguments +c + integer indpen, nbfpe0 + integer nbpe09 + integer tbau52(11,nbpe09) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5) + integer hetpen(nbpeto), filpen(nbpeto), perpen(nbpeto) + integer fampen(nbpeto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux +c + integer nulofa(5), nuloar(5,4), orient(5) + integer arepen(9), letria(2), lequad(3) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "mmag02.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + > mess14(langue,3,7)//'d''ordre 9', nbpe09 +#endif +c + codret = 0 +c +cgn write(ulsort,90002) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto +cgn write(ulsort,90002) 'nbpe09',nbpe09 +cgn do 1102 , kaux = 1,nbpe09 +cgn write(ulsort,90001) 'penta',kaux,(tbau52(jaux,kaux),jaux=1,6) +cgn 1102 continue +c +c==== +c 2. Parcours des pentaedres de joint ponctuel d'ordre 9 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,7) +#endif +c +c Sur ce croquis, semblable a la documentation sur les structures de +c donnees, la droite S2-S5 est a l'arriere-plan. +c +c S3 arepen(9) S6 +c x------------------------------------------x +c . . +c . . . . +c arepen(3) arepen(6) +c . . . . +c . . +c . .arepen(1) . . arepen(4) +c . . +c S2. . arepen(8) S5. . +c x - - - - - - - - - - - - - - - - - - - - -x +c . . . +c . . +c arepen(2) arepen(5). . +c x-----------------------------------------x +c S1 arepen(7) S4 +c La face f1 est le triangle (S1,S2,S3). +c La face f2 est le triangle (S4,S6,S5). +c L'arete a1 est relie les sommets S1 et S3. +c Les aretes (a1,a2,a3) realisent une rotation entrante dans le +c pentaedre. L'arete ai+3 est parallele a l'arete ai. +c La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2. +c +c voir utarpe pour le croquis ci-dessus +c + do 2 , iaux = 1 , nbpe09 +c + indpen = indpen + 1 +c +c 2.1 ==> Recuperation des triangles et quadrangles +c + do 211 , jaux = 1 , 2 + letria(jaux) = tbau52(jaux+1,iaux) + orient(jaux) = tbau52(jaux+6,iaux) +cgn write (ulsort,90015) 'triangle', letria(jaux), +cgn > ', d''orientation', orient(jaux) +cgn write (ulsort,90002) 'aretes ', +cgn > (aretri(letria(jaux),kaux),kaux=1,3) + 211 continue +c + do 212 , jaux = 3, 5 + lequad(jaux-2) = tbau52(jaux+1,iaux) + orient(jaux) = tbau52(jaux+6,iaux) +cgn write (ulsort,90015) 'quadrangle', lequad(jaux-2), +cgn > ', d''orientation', orient(jaux) +cgn write (ulsort,90002) 'aretes ', +cgn > (arequa(lequad(jaux-2),kaux),kaux=1,4) + 212 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', + > mess14(langue,1,1), tbau52(1,iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 +#endif +c +c 2.2 ==> Positionnement des triangles et quadrangles en tant que face +c nulofa(i) = numero local du triangle (quadrangle) dans letria +c (lequad) qui correspond a la face Fi +c nuloar(i,j) = pour la face Fi, numero local de sa i-eme arete +c dans la description de la face +c 2.2.1. ==> La face F1 est le 1er triangle enregistre. +c On impose : +c la 1ere arete du pentaedre est la 1ere arete du triangle ; +c --> le code sera donc 1 ou 4. +c Si l'orientation est positive, le triangle entre dans le pentaedre. +c On lui donnera donc le code 1. +C Inversement, si l'orientation est negative, il va sortir +c du pentaedre. On lui donnera alors le code 4. +c + facpen(indpen,1) = letria(1) + cofape(indpen,1) = 1 + if ( orient(1).gt.0 ) then + cofape(indpen,1) = 1 + else + cofape(indpen,1) = 4 + endif +c +c Reperage des aretes de cette face +c + arepen(1) = aretri(letria(1),1) + if ( orient(1).gt.0 ) then + arepen(2) = aretri(letria(1),2) + arepen(3) = aretri(letria(1),3) + else + arepen(2) = aretri(letria(1),3) + arepen(3) = aretri(letria(1),2) + endif +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90015) 'triangle pour F1', letria(1), + > ', d''orientation', orient(1) + write (ulsort,90002) 'aretes de pen 1-3',(arepen(jaux),jaux=1,3) + endif +#endif +c +c 2.2.2. ==> La face F3 est le quadrangle qui contient l'arete 1 +c C'est son arete numero 1 +c +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'F3 bati sur arete 1',arepen(1) + endif +#endif +c + do 222 , jaux = 1 , 3 + if ( arepen(1).eq.arequa(lequad(jaux),1) ) then + nulofa(3) = jaux + nuloar(3,1) = 1 + goto 2221 + elseif ( arepen(1).eq.arequa(lequad(jaux),2) ) then + nulofa(3) = jaux + nuloar(3,1) = 2 + goto 2221 + elseif ( arepen(1).eq.arequa(lequad(jaux),3) ) then + nulofa(3) = jaux + nuloar(3,1) = 3 + goto 2221 + elseif ( arepen(1).eq.arequa(lequad(jaux),4) ) then + nulofa(3) = jaux + nuloar(3,1) = 4 + goto 2221 + endif + 222 continue + codret = 222 + goto 3333 +c + 2221 continue +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F3', lequad(nulofa(3)), + > ', d''orientation', orient(nulofa(3)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(3)),jaux),jaux=1,4) + endif +#endif +c +c 2.2.3. ==> La face F4 est le quadrangle qui contient l'arete 2 +c C'est son arete numero 1 +c +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'F4 bati sur arete 2',arepen(2) + endif +#endif +c + do 223 , jaux = 1, 3 + if ( arepen(2).eq.arequa(lequad(jaux),1) ) then + nulofa(4) = jaux + nuloar(4,1) = 1 + goto 2231 + elseif ( arepen(2).eq.arequa(lequad(jaux),2) ) then + nulofa(4) = jaux + nuloar(4,1) = 2 + goto 2231 + elseif ( arepen(2).eq.arequa(lequad(jaux),3) ) then + nulofa(4) = jaux + nuloar(4,1) = 3 + goto 2231 + elseif ( arepen(2).eq.arequa(lequad(jaux),4) ) then + nulofa(4) = jaux + nuloar(4,1) = 4 + goto 2231 + endif + 223 continue + codret = 223 + goto 3333 +c + 2231 continue +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F4', lequad(nulofa(4)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(4)),jaux),jaux=1,4) + endif +#endif +c +c 2.2.4. ==> La face F5 est le quadrangle qui contient l'arete 3 +c C'est son arete numero 1 +c +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'F5 bati sur arete 3',arepen(3) + endif +#endif +c + do 224 , jaux = 1, 3 + if ( arepen(3).eq.arequa(lequad(jaux),1) ) then + nulofa(5) = jaux + nuloar(5,1) = 1 + goto 2241 + elseif ( arepen(3).eq.arequa(lequad(jaux),2) ) then + nulofa(5) = jaux + nuloar(5,1) = 2 + goto 2241 + elseif ( arepen(3).eq.arequa(lequad(jaux),3) ) then + nulofa(5) = jaux + nuloar(5,1) = 3 + goto 2241 + elseif ( arepen(3).eq.arequa(lequad(jaux),4) ) then + nulofa(5) = jaux + nuloar(5,1) = 4 + goto 2241 + endif + 224 continue + codret = 224 + goto 3333 +c + 2241 continue +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F5', lequad(nulofa(5)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(5)),jaux),jaux=1,4) + endif +#endif +c +c 2.3. ==> Recherche des aretes 7, 8 et 9 +c 2.3.1. ==> Recherche de l'arete 7, commune aux faces F3 et F4 +c + do 231 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(3)),jaux) + do 2311 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(4)),kaux) ) then + nuloar(3,4) = jaux + nuloar(4,2) = kaux + arepen(7) = laux + goto 2312 + endif + 2311 continue + 231 continue + codret = 231 + goto 3333 +c + 2312 continue +c +c 2.3.2. ==> Recherche de l'arete 8, commune aux faces F4 et F5 +c + do 232 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(4)),jaux) + do 2321 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(5)),kaux) ) then + nuloar(4,4) = jaux + nuloar(5,2) = kaux + arepen(8) = laux + goto 2322 + endif + 2321 continue + 232 continue + codret = 232 + goto 3333 +c + 2322 continue +c +c 2.3.3. ==> Recherche de l'arete 9, commune aux faces F5 et F3 +c + do 233 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(5)),jaux) + do 2331 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(3)),kaux) ) then + nuloar(5,4) = jaux + nuloar(3,2) = kaux + arepen(9) = laux + goto 2332 + endif + 2331 continue + 233 continue + codret = 233 + goto 3333 +c + 2332 continue +c +c 2.4. ==> Recherche des aretes 4, 5 et 6 +c + nuloar(3,3) = fp1234(nuloar(3,1),nuloar(3,2),nuloar(3,4)) + arepen(4) = arequa(lequad(nulofa(3)),nuloar(3,3)) +c + nuloar(4,3) = fp1234(nuloar(4,1),nuloar(4,2),nuloar(4,4)) + arepen(5) = arequa(lequad(nulofa(4)),nuloar(4,3)) +c + nuloar(5,3) = fp1234(nuloar(5,1),nuloar(5,2),nuloar(5,4)) + arepen(6) = arequa(lequad(nulofa(5)),nuloar(5,3)) +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'aretes de pen 1-3',(arepen(jaux),jaux=1,3) + write (ulsort,90002) 'aretes de pen 3-6',(arepen(jaux),jaux=4,6) + write (ulsort,90002) 'aretes de pen 7-9',(arepen(jaux),jaux=7,9) + endif +#endif +c + do 24 , jaux = 1 , 3 + if ( aretri(letria(2),jaux).eq.arepen(4) ) then + nuloar(2,1) = jaux + elseif ( aretri(letria(2),jaux).eq.arepen(6) ) then + nuloar(2,2) = jaux + elseif ( aretri(letria(2),jaux).eq.arepen(5) ) then + nuloar(2,3) = jaux + else + codret = 24 + goto 3333 + endif + 24 continue +c +c 2.5.==> Mise en place de la face 2 +c + facpen(indpen,2) = letria(2) +c + do 25 , jaux = 1 , 6 + if ( i1(jaux).eq.nuloar(2,1) .and. + > i2(jaux).eq.nuloar(2,2) .and. + > i3(jaux).eq.nuloar(2,3) ) then + cofape(indpen,2) = jaux + goto 2511 + endif + 25 continue + codret = 25 + goto 3333 +c + 2511 continue +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F5', lequad(nulofa(5)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(3)),jaux),jaux=1,4) + endif +#endif +c +c 2.6.==> Mise en place de la face 3 +c + facpen(indpen,3) = lequad(nulofa(3)) +c + do 26 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(3,1) .and. + > j2(jaux).eq.nuloar(3,2) .and. + > j3(jaux).eq.nuloar(3,3) .and. + > j4(jaux).eq.nuloar(3,4) ) then + cofape(indpen,3) = jaux + goto 2611 + endif + 26 continue + codret = 26 + goto 3333 +c + 2611 continue +c +c 2.7.==> Mise en place de la face 4 +c + facpen(indpen,4) = lequad(nulofa(4)) +c + do 27 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(4,1) .and. + > j2(jaux).eq.nuloar(4,2) .and. + > j3(jaux).eq.nuloar(4,3) .and. + > j4(jaux).eq.nuloar(4,4) ) then + cofape(indpen,4) = jaux + goto 2711 + endif + 27 continue + codret = 27 + goto 3333 +c + 2711 continue +c +c 2.8.==> Mise en place de la face 5 +c + facpen(indpen,5) = lequad(nulofa(5)) +c + do 28 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(5,1) .and. + > j2(jaux).eq.nuloar(5,2) .and. + > j3(jaux).eq.nuloar(5,3) .and. + > j4(jaux).eq.nuloar(5,4) ) then + cofape(indpen,5) = jaux + goto 2811 + endif + 28 continue + codret = 28 + goto 3333 +c + 2811 continue +c +c 2.9.==> Caracteristiques +c iaux est le numero du joint ponctuel. +c On decale pour tenir compte des familles HOMARD precedentes +c + fampen(indpen) = nbfpe0 + iaux +c + hetpen(indpen) = 0 + filpen(indpen) = 0 + perpen(indpen) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( indpen.lt.0 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0 + write (ulsort,90002)'faces ',(facpen(indpen,jaux),jaux=1,5) + write (ulsort,90002)'cofape',(cofape(indpen,jaux),jaux=1,5) + write (ulsort,90002) 'aretes 1-3',(arepen(jaux),jaux=1,3) + write (ulsort,90002) 'aretes 3-6',(arepen(jaux),jaux=4,6) + write (ulsort,90002) 'aretes 7-9',(arepen(jaux),jaux=7,9) + endif +#endif +c + 2 continue +c +c==== +c 3. la fin +c==== +c + 3333 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag36.F b/src/tool/Modification/mmag36.F new file mode 100644 index 00000000..7688312f --- /dev/null +++ b/src/tool/Modification/mmag36.F @@ -0,0 +1,659 @@ + subroutine mmag36 ( indhex, nbfhe0, + > nbhe12, + > tbau53, + > arequa, + > quahex, coquhe, + > hethex, filhex, perhex, + > famhex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 3.6 +c - - -- - - +c Creation des mailles pour les joints ponctuels : +c . hexaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . nbfhe0 . e . 1 . nombre de familles de hexaedres creees . +c . nbhe12 . e . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . tbau53 . e . 13* . Les hexaedres ponctuels entre les joints . +c . . . nbhe12 . quadruples (ordre 12) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : quadrangle cote du 1er joint quad. . +c . . . . (3,i) : quadrangle cote du 2eme joint quad.. +c . . . . (4,i) : quadrangle cote du 3eme joint quad.. +c . . . . (5,i) : quadrangle cote du 4eme joint quad.. +c . . . . (6,i) : quadrangle cote du 5eme joint quad.. +c . . . . (7,i) : quadrangle cote du 6eme joint quad.. +c . . . . (1+k) : pour le k-eme quadrangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . es .nbhecf*6. numeros des faces des hexaedres . +c . coquhe . es .nbhecf*6. codes des faces des hexaedres . +c . hethex . es . nbheto . historique de l'etat des hexaedres . +c . filhex . es . nbheto . premier fils des hexaedres . +c . perhex . es . nbheto . pere des hexaedres . +c . famhex . es . nbheto . famille des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG36' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +#include "j1234j.h" +#include "op1234.h" +#include "op1aa6.h" +c +c 0.3. ==> arguments +c + integer indhex, nbfhe0 + integer nbhe12 + integer tbau53(13,nbhe12) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer hethex(nbheto), filhex(nbheto), perhex(nbheto) + integer famhex(nbheto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux +c + integer nulofa(6), nuloar(6,4), orient(6) + integer arehex(12), lequad(6) +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +#include "mmag02.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + > mess14(langue,3,6)//'d''ordre 12', nbhe12 +#endif +c + codret = 0 +c +cgn write(ulsort,90002) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto +cgn write(ulsort,90002) 'nbhe12',nbhe12 +cgn write(ulsort,90015) (iaux,iaux=1,20) +cgn write(ulsort,90002) 'tbaux2',4,nbjoto +cgn do 1101 , kaux = 1,nbjoto +cgn write(ulsort,90015) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn write(ulsort,90002) 'tbau53',7,nbhe12 +cgn do 1102 , kaux = 1,nbhe12 +cgn write(ulsort,90015) (tbau53(jaux,kaux),jaux=1,7) +cgn 1102 continue +c +c==== +c 2. Parcours des hexaedres de joint ponctuel d'ordre 12 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,6) +#endif +c +c S5 a9 S6 +c ---------------------------- +c /. /. +c / . / . +c / . / . +c / . / . +c a6/ . /a5 . +c / . / . +c / a11. / .a10 +c / . a1 / . +c S2----------------------------- S1 . +c . . . . +c . . a12 . . +c . S8 -------------------.--------.S7 +c . / . / +c a3. / .a2 / +c . / . / +c . / . / +c . a8/ . /a7 +c . / . / +c . / . / +c ./ ./ +c ----------------------------- +c S3 a4 S4 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c Avec le code 1, les faces sont : +c Face 1 : aretes 1, 2, 4, 3 +c Face 2 : aretes 1, 6, 9, 5 +c Face 3 : aretes 2, 5, 10, 7 +c Face 4 : aretes 3, 8, 11, 6 +c Face 5 : aretes 4, 7, 12, 8 +c Face 6 : aretes 9, 11, 12, 10 +c +c voir utarhe pour le croquis ci-dessus +c + do 2 , iaux = 1 , nbhe12 +c + indhex = indhex + 1 +c +c 2.1 ==> Recuperation des quadrangles et de leur orientation +c + do 21 , jaux = 1 , 6 + lequad(jaux) = tbau53(jaux+1,iaux) + orient(jaux) = tbau53(jaux+7,iaux) +cgn write (ulsort,90015) 'quadrangle', lequad(jaux), +cgn > ', d''orientation', orient(jaux) +cgn write (ulsort,90002) 'aretes ', +cgn > (arequa(lequad(jaux),kaux),kaux=1,4) + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', + > mess14(langue,1,1), tbau53(1,iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0 +#endif +c +c 2.2 ==> Positionnement des quadrangles en tant que face +c nulofa(i) = numero local dans lequad du quadrangle +c qui correspond a la face Fi +c nuloar(i,j) = pour la face Fi, numero local de sa i-eme arete +c dans la description de la face +c 2.2.1. ==> La face F1 est le 1er quadrangle enregistre. +c On impose : +c la 1ere arete de l'hexaedre est la 1ere arete du quadrangle ; +c --> le code sera donc 1 ou 5. +c Si l'orientation est positive, le quadrangle entre dans l'hexaedre. +c On lui donnera donc le code 1. +C Inversement, si l'orientation est negative, il va sortir +c de l'hexaedre. On lui donnera alors le code 5. +c + quahex(indhex,1) = lequad(1) + if ( orient(1).gt.0 ) then + coquhe(indhex,1) = 1 + else + coquhe(indhex,1) = 5 + endif +c +c Reperage des aretes de cette face +c + arehex(1) = arequa(lequad(1),1) + if ( orient(1).gt.0 ) then + arehex(2) = arequa(lequad(1),2) + arehex(3) = arequa(lequad(1),4) + else + arehex(2) = arequa(lequad(1),4) + arehex(3) = arequa(lequad(1),2) + endif + arehex(4) = arequa(lequad(1),3) +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90015) 'quadrangle pour F1', lequad(1), + > ', d''orientation', orient(1) + write (ulsort,90002) 'aretes de hex 1-4',(arehex(jaux),jaux=1,4) + endif +#endif +c +c 2.2.2. ==> La face F2 est le quadrangle qui contient l'arete 1 +c C'est son arete numero 1 +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'F2 bati sur arete 1',arehex(1) + endif +#endif +c + do 222 , jaux = 2 , 6 + if ( arehex(1).eq.arequa(lequad(jaux),1) ) then + nulofa(2) = jaux + nuloar(2,1) = 1 + goto 2221 + elseif ( arehex(1).eq.arequa(lequad(jaux),2) ) then + nulofa(2) = jaux + nuloar(2,1) = 2 + goto 2221 + elseif ( arehex(1).eq.arequa(lequad(jaux),3) ) then + nulofa(2) = jaux + nuloar(2,1) = 3 + goto 2221 + elseif ( arehex(1).eq.arequa(lequad(jaux),4) ) then + nulofa(2) = jaux + nuloar(2,1) = 4 + goto 2221 + endif + 222 continue + codret = 222 + goto 5555 +c + 2221 continue +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F2', lequad(nulofa(2)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(2)),jaux),jaux=1,4) + endif +#endif +c +c 2.2.3. ==> La face F3 est le quadrangle qui contient l'arete 2 +c C'est son arete numero 1 +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'F3 bati sur arete 2',arehex(2) + endif +#endif +c + do 223 , jaux = 2 , 6 + if ( arehex(2).eq.arequa(lequad(jaux),1) ) then + nulofa(3) = jaux + nuloar(3,1) = 1 + goto 2231 + elseif ( arehex(2).eq.arequa(lequad(jaux),2) ) then + nulofa(3) = jaux + nuloar(3,1) = 2 + goto 2231 + elseif ( arehex(2).eq.arequa(lequad(jaux),3) ) then + nulofa(3) = jaux + nuloar(3,1) = 3 + goto 2231 + elseif ( arehex(2).eq.arequa(lequad(jaux),4) ) then + nulofa(3) = jaux + nuloar(3,1) = 4 + goto 2231 + endif + 223 continue + codret = 223 + goto 5555 +c + 2231 continue +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F3', lequad(nulofa(3)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(3)),jaux),jaux=1,4) + endif +#endif +c +c 2.2.4. ==> La face F4 est le quadrangle qui contient l'arete 3 +c C'est son arete numero 1 +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'F4 bati sur arete 3',arehex(3) + endif +#endif +c + do 224 , jaux = 2 , 6 + if ( arehex(3).eq.arequa(lequad(jaux),1) ) then + nulofa(4) = jaux + nuloar(4,1) = 1 + goto 2241 + elseif ( arehex(3).eq.arequa(lequad(jaux),2) ) then + nulofa(4) = jaux + nuloar(4,1) = 2 + goto 2241 + elseif ( arehex(3).eq.arequa(lequad(jaux),3) ) then + nulofa(4) = jaux + nuloar(4,1) = 3 + goto 2241 + elseif ( arehex(3).eq.arequa(lequad(jaux),4) ) then + nulofa(4) = jaux + nuloar(4,1) = 4 + goto 2241 + endif + 224 continue + codret = 224 + goto 5555 +c + 2241 continue +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F4', lequad(nulofa(4)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(4)),jaux),jaux=1,4) + endif +#endif +c +c 2.2.5. ==> La face F5 est le quadrangle qui contient l'arete 4 +c C'est son arete numero 1 +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'F5 bati sur arete 4',arehex(4) + endif +#endif +c + do 225 , jaux = 2 , 6 + if ( arehex(4).eq.arequa(lequad(jaux),1) ) then + nulofa(5) = jaux + nuloar(5,1) = 1 + goto 2251 + elseif ( arehex(4).eq.arequa(lequad(jaux),2) ) then + nulofa(5) = jaux + nuloar(5,1) = 2 + goto 2251 + elseif ( arehex(4).eq.arequa(lequad(jaux),3) ) then + nulofa(5) = jaux + nuloar(5,1) = 3 + goto 2251 + elseif ( arehex(4).eq.arequa(lequad(jaux),4) ) then + nulofa(5) = jaux + nuloar(5,1) = 4 + goto 2251 + endif + 225 continue + codret = 225 + goto 5555 +c + 2251 continue +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'quadrangle pour F5', lequad(nulofa(5)) + write (ulsort,90002) 'aretes', + > (arequa(lequad(nulofa(5)),jaux),jaux=1,4) + endif +#endif +c +c 2.3. ==> Recherche des aretes 5, 6, 7, 8, 9, 10, 11 et 12 +c 2.3.1. ==> Recherche de l'arete 5, commune aux faces F2 et F3 +c + do 231 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(2)),jaux) + do 2311 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(3)),kaux) ) then + nuloar(2,4) = jaux + nuloar(3,2) = kaux + arehex(5) = laux + goto 2312 + endif + 2311 continue + 231 continue + codret = 231 + goto 5555 +c + 2312 continue +c +c 2.3.2. ==> Recherche de l'arete 6, commune aux faces F4 et F2 +c + do 232 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(4)),jaux) + do 2321 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(2)),kaux) ) then + nuloar(4,4) = jaux + nuloar(2,2) = kaux + arehex(6) = laux + goto 2322 + endif + 2321 continue + 232 continue + codret = 232 + goto 5555 +c + 2322 continue +c +c 2.3.3. ==> Recherche de l'arete 7, commune aux faces F3 et F5 +c + do 233 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(3)),jaux) + do 2331 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(5)),kaux) ) then + nuloar(3,4) = jaux + nuloar(5,2) = kaux + arehex(7) = laux + goto 2332 + endif + 2331 continue + 233 continue + codret = 233 + goto 5555 +c + 2332 continue +c +c 2.3.4. ==> Recherche de l'arete 8, commune aux faces F5 et F4 +c + do 234 , jaux = 1 , 4 + laux = arequa(lequad(nulofa(5)),jaux) + do 2341 , kaux = 1, 4 + if ( laux.eq.arequa(lequad(nulofa(4)),kaux) ) then + nuloar(5,4) = jaux + nuloar(4,2) = kaux + arehex(8) = laux + goto 2342 + endif + 2341 continue + 234 continue + codret = 234 + goto 5555 +c + 2342 continue +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'aretes de hex 5-8',(arehex(jaux),jaux=5,8) + endif +#endif +c +c 2.4. ==> Recherche des aretes 9, 10, 11, 12 +c + nuloar(2,3) = fp1234(nuloar(2,1),nuloar(2,2),nuloar(2,4)) + arehex(9) = arequa(lequad(nulofa(2)),nuloar(2,3)) +c + nuloar(3,3) = fp1234(nuloar(3,1),nuloar(3,2),nuloar(3,4)) + arehex(10) = arequa(lequad(nulofa(3)),nuloar(3,3)) +c + nuloar(4,3) = fp1234(nuloar(4,1),nuloar(4,2),nuloar(4,4)) + arehex(11) = arequa(lequad(nulofa(4)),nuloar(4,3)) +c + nuloar(5,3) = fp1234(nuloar(5,1),nuloar(5,2),nuloar(5,4)) + arehex(12) = arequa(lequad(nulofa(5)),nuloar(5,3)) +#ifdef _DEBUG_HOMARD_ + if ( indhex.lt.0 ) then + write (ulsort,90002) 'aretes de hex 9-12',(arehex(jaux),jaux=9,12) + endif +#endif +c +c 2.5.==> Mise en place de la face 2 +c + quahex(indhex,2) = lequad(nulofa(2)) +c + do 25 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(2,1) .and. + > j2(jaux).eq.nuloar(2,2) .and. + > j3(jaux).eq.nuloar(2,3) .and. + > j4(jaux).eq.nuloar(2,4) ) then + coquhe(indhex,2) = jaux + goto 2511 + endif + 25 continue + codret = 25 + goto 5555 + 2511 continue +c +c 2.6.==> Mise en place de la face 3 +c + quahex(indhex,3) = lequad(nulofa(3)) +c + do 26 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(3,1) .and. + > j2(jaux).eq.nuloar(3,2) .and. + > j3(jaux).eq.nuloar(3,3) .and. + > j4(jaux).eq.nuloar(3,4) ) then + coquhe(indhex,3) = jaux + goto 2611 + endif + 26 continue + codret = 26 + goto 5555 + 2611 continue +c +c 2.7.==> Mise en place de la face 4 +c + quahex(indhex,4) = lequad(nulofa(4)) +c + do 27 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(4,1) .and. + > j2(jaux).eq.nuloar(4,2) .and. + > j3(jaux).eq.nuloar(4,3) .and. + > j4(jaux).eq.nuloar(4,4) ) then + coquhe(indhex,4) = jaux + goto 2711 + endif + 27 continue + codret = 27 + goto 5555 + 2711 continue +c +c 2.8.==> Mise en place de la face 5 +c + quahex(indhex,5) = lequad(nulofa(5)) +c + do 28 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(5,1) .and. + > j2(jaux).eq.nuloar(5,2) .and. + > j3(jaux).eq.nuloar(5,3) .and. + > j4(jaux).eq.nuloar(5,4) ) then + coquhe(indhex,5) = jaux + goto 2811 + endif + 28 continue + codret = 28 + goto 5555 + 2811 continue +c +c 2.9.==> Mise en place de la face 6 : le dernier des quadrangles +c + nulofa(6) = fp1aa6( 1, nulofa(2), nulofa(3), + > nulofa(4), nulofa(5)) +c + do 291 , jaux = 1 , 4 + if ( arequa(lequad(nulofa(6)),jaux).eq.arehex(9) ) then + nuloar(6,1) = jaux + elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(11) ) then + nuloar(6,2) = jaux + elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(12) ) then + nuloar(6,3) = jaux + elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(10) ) then + nuloar(6,4) = jaux + else + codret = 291 + goto 5555 + endif + 291 continue +c + quahex(indhex,6) = lequad(nulofa(6)) +c + do 292 , jaux = 1 , 8 + if ( j1(jaux).eq.nuloar(6,1) .and. + > j2(jaux).eq.nuloar(6,2) .and. + > j3(jaux).eq.nuloar(6,3) .and. + > j4(jaux).eq.nuloar(6,4) ) then + coquhe(indhex,6) = jaux + goto 2921 + endif + 292 continue + codret = 292 + goto 5555 + 2921 continue +c +c 2.10.==> Caracteristiques +c iaux est le numero du joint ponctuel. +c On decale pour tenir compte des familles HOMARD precedentes +c + famhex(indhex) = nbfhe0 + iaux +c + hethex(indhex) = 0 + filhex(indhex) = 0 + perhex(indhex) = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( indhex.eq.-1 ) then + write (ulsort,texte(langue,16)) mess14(langue,1,7), indhex, 0 + write (ulsort,90002)'faces ',(quahex(indhex,jaux),jaux=1,6) + write (ulsort,90002)'coquhe',(coquhe(indhex,jaux),jaux=1,6) + write (ulsort,90002)'aretes 1-4 ',(arehex(jaux),jaux=1,4) + write (ulsort,90002)'aretes 5-8 ',(arehex(jaux),jaux=5,8) + write (ulsort,90002)'aretes 9-12',(arehex(jaux),jaux=9,12) + endif +#endif +c + 2 continue +c +c==== +c 5. la fin +c==== +c + 5555 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag40.F b/src/tool/Modification/mmag40.F new file mode 100644 index 00000000..81edc1d6 --- /dev/null +++ b/src/tool/Modification/mmag40.F @@ -0,0 +1,293 @@ + subroutine mmag40 ( nbpejs, nbpejt, nbhejq, + > nbvojm, nbjoto, + > nbjois, nbjoit, nbjoiq, + > tbaux1, tbau41, + > coonoe, somare, aretri, + > famhex, cfahex, + > fampen, cfapen, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 4.0 +c - - -- - - +c Taille des joints +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . nbpejt . e . 1 . nombre de pentaedres de joints triples . +c . nbhejq . e . 1 . nombre d'hexaedres de joints quadruples . +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbjoto . e . 1 . nombre total de joints . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . nbjoiq . e . 1 . nombre de joints quadruples . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . e . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG40' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombhe.h" +#include "nombpe.h" +#include "dicfen.h" +#include "nbfami.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbpejs, nbpejt, nbhejq + integer nbvojm, nbjoto + integer nbjois, nbjoit, nbjoiq + integer tbaux1(4,nbpejs), tbau41(4,nbvojm) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + double precision coonoe(nbnoto,sdim) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs+nbpejt + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhejq +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nbjois + write (ulsort,texte(langue,13)) nbjoit + write (ulsort,texte(langue,14)) nbjoiq + write (ulsort,texte(langue,21)) 0, nbjoto-nbjois-nbjoit-nbjoiq +#endif +c + codret = 0 +c +c==== +c 2. Calcul des tailles des joints simples +c Remarque : on s'inspire de utb13c +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Joints simples ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG41', nompro +#endif + call mmag41 ( coonoe, somare, aretri, + > fampen, cfapen, + > nbpejs, nbjois, + > tbaux1, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Calcul des tailles des joints triples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Joints triples ; codret = ', codret +#endif +c + if ( nbpejt.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG42', nompro +#endif + call mmag42 ( coonoe, somare, + > fampen, cfapen, + > nbvojm, nbpejt, nbpejs, nbjois, nbjoit, + > tbau41, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Calcul des tailles des joints quadruples +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Joints quadruples ; codret = ', codret +#endif +c + if ( nbhejq.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG43', nompro +#endif + call mmag43 ( coonoe, somare, + > famhex, cfahex, + > nbvojm, nbhejq, + > nbjois, nbjoiq, + > tbau41, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag41.F b/src/tool/Modification/mmag41.F new file mode 100644 index 00000000..81ecc51c --- /dev/null +++ b/src/tool/Modification/mmag41.F @@ -0,0 +1,282 @@ + subroutine mmag41 ( coonoe, somare, aretri, + > fampen, cfapen, + > nbpejs, nbjois, + > tbaux1, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 4.1 +c - - -- - - +c Taille des joints simples +c ______________________________________________________________________ +c +c Remarque : ce programme est une copie de utb13c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . nbjois . e . 1 . nombre de joints simples . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG41' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpe.h" +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbpejs, nbjois + integer somare(2,nbarto), aretri(nbtrto,3) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) + integer tbaux1(4,nbpejs) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer numpen + integer sa1a2, sa2a3, sa3a1 + integer letria +c + double precision v2(3), v3(3), vn(3) + double precision daux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbjois', nbjois + write (ulsort,90002) 'nbpejs', nbpejs +#endif +c + codret = 0 +c +c==== +c 2. calcul des surfaces +c==== +c +c 2.1. ==> initialisation +c + do 21 , iaux = 1 , nbjois + famval(iaux) = 0.d0 + 21 continue +c +c 2.2. ==> calcul +c + do 22 , numpen = 1 , nbpejs +c + letria = tbaux1(1,numpen) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'numpen', numpen + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,2), letria + write (ulsort,texte(langue,18)) ' ',mess14(langue,1,7), + > tbaux1(2,numpen) +#endif +c +c 2.2.1. ==> les aretes et les noeuds du triangle +c + iaux = aretri(letria,1) + jaux = aretri(letria,2) + kaux = aretri(letria,3) +c + call utsotr ( somare, iaux, jaux, kaux, + > sa1a2, sa2a3, sa3a1 ) +c +c 2.2.2. ==> calcul de la surface +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c + v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) +c + v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1) + v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2) + v3(3) = coonoe(sa3a1,3) - coonoe(sa1a2,3) +c + vn(1) = v2(2)*v3(3) - v2(3)*v3(2) + vn(2) = v2(3)*v3(1) - v2(1)*v3(3) + vn(3) = v2(1)*v3(2) - v2(2)*v3(1) +c + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + daux = 0.5d0 * daux +c +c 2.2.3. ==> stockage dans le bon joint +c + iaux = tbaux1(2,numpen) + famnum(iaux) = cfapen(cofamd,fampen(numpen)) + famval(iaux) = famval(iaux) + daux +cgn if ( iaux.ge.1 ) then +cgn write (ulsort,90002) 'noeuds', sa1a2, sa2a3, sa3a1 +cgn write (ulsort,92010) '==> surface =', daux +cgn write (ulsort,90002) 'iaux, fampen, fammed', iaux, +cgn > fampen(numpen),cfapen(cofamd,fampen(numpen)) +cgn write (ulsort,92010) '==> cumul =',famval(iaux) +cgn endif +c + 22 continue +c +c==== +c 3. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. impression ; codret =', codret + write (ulsort,91010) (famnum(iaux),iaux=1,nbjois) + write (ulsort,92010) (famval(iaux),iaux=1,nbjois) +#endif +c + iaux = 2 + kaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_j_simple', nompro +#endif + call utb13e ( kaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > nbjois, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c + end diff --git a/src/tool/Modification/mmag42.F b/src/tool/Modification/mmag42.F new file mode 100644 index 00000000..c9a0c91c --- /dev/null +++ b/src/tool/Modification/mmag42.F @@ -0,0 +1,258 @@ + subroutine mmag42 ( coonoe, somare, + > fampen, cfapen, + > nbvojm, nbpejt, nbpejs, nbjois, nbjoit, + > tbau41, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 4.2 +c - - -- - - +c Taille des joints triples +c ______________________________________________________________________ +c +c Remarque : ce programme est une copie de utb13d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbpejt . e . 1 . nombre de pentaedres de joints triples . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG42' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombpe.h" +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbvojm, nbpejt, nbpejs, nbjois, nbjoit + integer somare(2,nbarto) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) + integer tbau41(4,nbvojm) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numpen + integer larete +c + double precision vn(3) + double precision daux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. calcul des longueurs +c==== +c +c 2.1. ==> initialisation +c + do 21 , iaux = 1 , nbjoit + famval(iaux) = 0.d0 + 21 continue +c +c 2.2. ==> calcul +c + do 22 , numpen = 1 , nbpejt +c + larete = tbau41(1,numpen) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,18)) ' ',mess14(langue,1,7), + > tbau41(2,numpen) +#endif +c +c 2.2.1. ==> calcul de la longueur +c + vn(1) = coonoe(somare(2,larete),1) - coonoe(somare(1,larete),1) + vn(2) = coonoe(somare(2,larete),2) - coonoe(somare(1,larete),2) + vn(3) = coonoe(somare(2,larete),3) - coonoe(somare(1,larete),3) +c + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c +c 2.2.3. ==> stockage dans le bon joint +c + iaux = tbau41(2,numpen) - nbjois + famnum(iaux) = cfapen(cofamd,fampen(numpen+nbpejs)) + famval(iaux) = famval(iaux) + daux +cgn if ( iaux.ge.1 ) then +cgn write (ulsort,92010) '==> longueur =', daux +cgn write (ulsort,90002) 'iaux, fampen, fammed', iaux, +cgn > fampen(numpen+nbpejs),cfapen(cofamd,fampen(numpen+nbpejs)) +cgn write (ulsort,92010) '==> cumul =',famval(iaux) +cgn endif +c + 22 continue +c +c==== +c 3. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. impression ; codret =', codret + write (ulsort,91010) (famnum(iaux),iaux=1,nbjoit) + write (ulsort,92010) (famval(iaux),iaux=1,nbjoit) +#endif +c + iaux = 3 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_j_triple', nompro +#endif + call utb13e ( jaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > nbjoit, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c + end diff --git a/src/tool/Modification/mmag43.F b/src/tool/Modification/mmag43.F new file mode 100644 index 00000000..d3a47407 --- /dev/null +++ b/src/tool/Modification/mmag43.F @@ -0,0 +1,259 @@ + subroutine mmag43 ( coonoe, somare, + > famhex, cfahex, + > nbvojm, nbhejq, + > nbjois, nbjoiq, + > tbau41, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 4.3 +c - - -- - - +c Taille des joints quadruples +c ______________________________________________________________________ +c +c Remarque : ce programme est une copie de utb13d +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . e . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbvojm . e . 1 . nombre de volumes de joints multiples . +c . nbhejq . e . 1 . nombre de pentaedres de joints triples . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoiq . e . 1 . nombre de joints quadruples . +c . tbau41 . e .4*nbvojm. Les pentaedres de joint triple, puis les . +c . . . . hexaedres de joint quadruple : . +c . . . . (1,i) : arete multiple . +c . . . . (2,i) : numero du joint . +c . . . . Pour le i-eme pentaedre de joint triple : . +c . . . . (3,i) : triangle cree cote 1er sommet . +c . . . . (4,i) : triangle cree cote 2nd sommet . +c . . . . Pour le i-eme hexaedre de joint quadruple :. +c . . . . (3,i) : quadrangle cree cote 1er sommet . +c . . . . (4,i) : quadrangle cree cote 2nd sommet . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG43' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombhe.h" +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbvojm, nbhejq + integer nbjois, nbjoiq + integer somare(2,nbarto) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer tbau41(4,nbvojm) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numhex + integer larete +c + double precision vn(3) + double precision daux +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) nbjois + write (ulsort,texte(langue,14)) nbjoiq +#endif +c +c==== +c 2. calcul des longueurs +c==== +c +c 2.1. ==> initialisation +c + do 21 , iaux = 1 , nbjoiq + famval(iaux) = 0.d0 + 21 continue +c +c 2.2. ==> calcul +c + do 22 , numhex = 1 , nbhejq +c + larete = tbau41(1,numhex) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,18)) ' ',mess14(langue,1,7), + > tbau41(2,numhex) +#endif +c +c 2.2.1. ==> calcul de la longueur +c + vn(1) = coonoe(somare(2,larete),1) - coonoe(somare(1,larete),1) + vn(2) = coonoe(somare(2,larete),2) - coonoe(somare(1,larete),2) + vn(3) = coonoe(somare(2,larete),3) - coonoe(somare(1,larete),3) +c + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c +cgn write (ulsort,*) '==> surface =', daux +c +c 2.2.3. ==> stockage dans le bon joint +c + iaux = tbau41(2,numhex) - nbjois + famnum(iaux) = cfahex(cofamd,famhex(numhex)) + famval(iaux) = famval(iaux) + daux +c + 22 continue +c +c==== +c 3. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. impression ; codret =', codret +cgn write (ulbila,*) (famval(iaux),iaux=1,nbjoiq) +#endif +c + iaux = 4 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_j_quadruple', nompro +#endif + call utb13e ( jaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > nbjoiq, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c + end diff --git a/src/tool/Modification/mmag91.F b/src/tool/Modification/mmag91.F new file mode 100644 index 00000000..42308bd6 --- /dev/null +++ b/src/tool/Modification/mmag91.F @@ -0,0 +1,191 @@ + subroutine mmag91 ( larete, ordre, nujois, + > nbduno, tbau30, + > somare, + > aredup, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 9.1 +c - - -- - - +c Reperage des aretes liees aux joints simples formant +c le joint multiple +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . larete . e . 1 . arete support du joint multiple . +c . ordre . e . 1 . ordre du joint a explorer . +c . nujois . e . ordre . numeros des joints simples associes . +c . nbduno . e . 1 . nombre de duplication de noeuds . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aredup . s .2*nbduno. aretes issues de la duplication . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG91' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer larete + integer ordre, nujois(ordre) + integer nbduno, tbau30(8,nbduno) + integer somare(2,nbarto) + integer aredup(2*ordre) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbarlo +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c + codret = 0 +c +c==== +c 2. On explore tous les noeuds qui ont ete dupliques +c On est bon quand : +c . le noeud duplique est un des sommets de l'arete triple +c . la duplication a lieu pour un des joints simples associes +c +c On stocke les aretes qui partent de chacun des noeuds. +c==== +c + nbarlo = 0 +c + do 21 , iaux = 1 , nbduno +c + do 211 , jaux = 1 , 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,-1), + > somare(jaux,larete) +#endif +c + if ( tbau30(1,iaux).eq.somare(jaux,larete) ) then +c + do 2111 , kaux = 1 , ordre +c +c write (ulsort,*) 'nujois(kaux) =', nujois(kaux) +c + if ( tbau30(5,iaux).eq.nujois(kaux) ) then + aredup(ordre*(jaux-1)+kaux) = tbau30(2,iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,40)) mess14(langue,1,-1), + > tbau30(1,iaux),mess14(langue,1,1),tbau30(2,iaux) +#endif + nbarlo = nbarlo + 1 + if ( nbarlo.eq.2*ordre ) then + goto 210 + endif + goto 2110 + endif + 2111 continue +c + 2110 continue +c + endif +c + 211 continue +c + 21 continue +c +c Si on arrive ici, c'est que les aretes n'ont pas ete trouvees +c + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,38)) mess14(langue,3,-1) + codret = 21 +c + 210 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag92.F b/src/tool/Modification/mmag92.F new file mode 100644 index 00000000..600521a3 --- /dev/null +++ b/src/tool/Modification/mmag92.F @@ -0,0 +1,169 @@ + subroutine mmag92 ( larete, ordre, nujois, + > nbduar, tbau40, + > arejoi, quajoi, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 9.2 +c - - -- - - +c Reperage des aretes liees aux joints simples formant +c le joint multiple +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . larete . e . 1 . arete support du joint multiple . +c . ordre . e . 1 . ordre du joint a explorer . +c . nujois . e . ordre . numeros des joints simples associes . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . arejoi . s . ordre . aretes bordant le i-eme joint . +c . quajoi . s . ordre . quadrangles bordant le i-eme joint . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG92' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer larete + integer ordre, nujois(ordre) + integer nbduar, tbau40(6,nbduar) + integer arejoi(ordre), quajoi(ordre) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbqulo +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c + codret = 0 +c +c==== +c 2. On explore toutes les aretes qui ont ete dupliquees +c On est bon quand : +c . l'arete dupliquee est l'arete multiple +c On stocke le quadrangle construit sur l'arete en cours +c dedoublee ; attention a les mettre dans l'ordre des joints +c On rappelle que les quadrangles sont numerotes en suivant le +c dedoublement des aretes (cf. mmag31). +c==== +c + nbqulo = 0 +c + do 21 , iaux = 1 , nbduar +c + if ( tbau40(1,iaux).eq.larete ) then +c + do 211 , jaux = 1 , ordre + if ( nujois(jaux).eq.tbau40(4,iaux) ) then + nbqulo = nbqulo + 1 + quajoi(jaux) = iaux + arejoi(jaux) = tbau40(6,iaux) + if ( nbqulo.eq.ordre ) then + goto 210 + endif + endif + 211 continue +c + endif +c + 21 continue +c +c Si on arrive ici, c'est que les quadrangles n'ont pas ete trouves +c + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,38)) mess14(langue,3,1) + codret = 21 +c + 210 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag93.F b/src/tool/Modification/mmag93.F new file mode 100644 index 00000000..f1cb8ccb --- /dev/null +++ b/src/tool/Modification/mmag93.F @@ -0,0 +1,182 @@ + subroutine mmag93 ( letria, orient, + > nbte06, tbau51, + > nbpe09, tbau52, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 9.3 +c - - -- - - +c Memorisation de l'orientation du triangle dans un joint ponctuel +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . triangle a examiner . +c . orient . e . 1 . 1 si le triangle entre dans le joint . +c . . . . ponctuel, -1 sinon . +c . nbte06 . e . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . tbau51 . es .9*nbte06. Les tetraedres ponctuels entre les joints . +c . . . . triples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : triangle cote du 3eme joint triple . +c . . . . (5,i) : triangle cote du 4eme joint triple . +c . . . . (1+k) : pour le k-eme triangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . nbpe09 . e . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . tbau52 . es . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG93' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer letria, orient + integer nbte06, tbau51(9,nbte06) + integer nbpe09, tbau52(11,nbpe09) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,23)) mess14(langue,1,2), letria, orient +#endif +c +c==== +c 2. Parcours des tetraedres de joint ponctuel d'ordre 6 +c==== +c + do 21 , iaux = 1 , nbte06 +c + do 211 , jaux = 1 , 4 +c + kaux = tbau51(1+jaux,iaux) + if ( kaux.eq.letria ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Vu dans le joint ponctuel', iaux +#endif + tbau51(5+jaux,iaux) = orient + endif +c + 211 continue +c + 21 continue +c +c==== +c 3. Parcours des pentaedres de joint ponctuel d'ordre 9 +c==== +c + do 31 , iaux = 1 , nbpe09 +c + do 311 , jaux = 1 , 2 +c + kaux = tbau52(1+jaux,iaux) + if ( kaux.eq.letria ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Vu dans le joint ponctuel', iaux +#endif + tbau52(6+jaux,iaux) = orient + endif +c + 311 continue +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmag94.F b/src/tool/Modification/mmag94.F new file mode 100644 index 00000000..621a04fe --- /dev/null +++ b/src/tool/Modification/mmag94.F @@ -0,0 +1,184 @@ + subroutine mmag94 ( lequad, orient, + > nbhe12, tbau53, + > nbpe09, tbau52, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 9.4 +c - - -- - - +c Memorisation de l'orientation du quadrangle dans un joint ponctuel +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a examiner . +c . orient . e . 1 . 1 si le quadrangle entre dans le joint . +c . . . . ponctuel, -1 sinon . +c . nbhe12 . e . 1 . nombre de hexa. des j. ponctuels d'ordre 12. +c . tbau53 . es . 13* . Les hexaedres ponctuels entre les joints . +c . . . nbhe12 . quadruples (ordre 12) : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : quadrangle cote du 1er joint quad. . +c . . . . (3,i) : quadrangle cote du 2eme joint quad.. +c . . . . (4,i) : quadrangle cote du 3eme joint quad.. +c . . . . (5,i) : quadrangle cote du 4eme joint quad.. +c . . . . (6,i) : quadrangle cote du 5eme joint quad.. +c . . . . (7,i) : quadrangle cote du 6eme joint quad.. +c . . . . (1+k) : pour le k-eme quadrangle, 1 s'il . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . nbpe09 . e . 1 . nombre de pent. des j. ponctuels d'ordre 9 . +c . tbau52 . es . 11* . Les pentaedres ponctuels entre les joints . +c . . . nbpe09 . triples et quadruples : . +c . . . . (1,i) : noeud multiple . +c . . . . (2,i) : triangle cote du 1er joint triple . +c . . . . (3,i) : triangle cote du 2eme joint triple . +c . . . . (4,i) : quadrangle cote du 1er joint quad. . +c . . . . (5,i) : quadrangle cote du 2eme joint quad.. +c . . . . (6,i) : quadrangle cote du 3eme joint quad.. +c . . . . (1+k) : pour la k-eme face, 1 si elle . +c . . . . entre dans le joint ponctuel, -1 sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAG93' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lequad, orient + integer nbhe12, tbau53(13,nbhe12) + integer nbpe09, tbau52(11,nbpe09) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +#include "mmag02.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,23)) mess14(langue,1,4), lequad, orient +#endif +c +c==== +c 2. Parcours des hexaedres de joint ponctuel d'ordre 12 +c==== +c + do 21 , iaux = 1 , nbhe12 +c + do 211 , jaux = 1 , 6 +c + kaux = tbau53(1+jaux,iaux) + if ( kaux.eq.lequad ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Vu dans le joint ponctuel', iaux +#endif + tbau53(7+jaux,iaux) = orient + endif +c + 211 continue +c + 21 continue +c +c==== +c 3. Parcours des pentaedres de joint ponctuel d'ordre 9 +c==== +c + do 31 , iaux = 1 , nbpe09 +c + do 311 , jaux = 1 , 3 +c + kaux = tbau52(3+jaux,iaux) + if ( kaux.eq.lequad ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Vu dans le joint ponctuel', iaux +#endif + tbau52(8+jaux,iaux) = orient + endif +c + 311 continue +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagco.F b/src/tool/Modification/mmagco.F new file mode 100644 index 00000000..13facbdf --- /dev/null +++ b/src/tool/Modification/mmagco.F @@ -0,0 +1,614 @@ + subroutine mmagco ( option, shrink, + > coonoe, + > somare, + > nbduno, tbau30, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - COordonnees +c - - -- -- +c Modification eventuelle des coordonnes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . type de modification . +c . . . . 0 : aucune . +c . . . . 1 : mod_joint_qt_d1 . +c . . . . 2 : mod_joint_qua2_d1 . +c . . . . 3 : mod_joint_qua_d1 . +c . . . . 4 : mod_joint_tri_d1 . +c . . . . 5 : mod_joint_tri_d2 . +c . . . . -1 : automatique . +c . shrink . e . 1 . coefficient de shrink . +c . coonoe . es .nbnoto*3. coordonnees des noeuds . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nbduno . e . 1 . nombre de duplications de noeuds . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer somare(2,nbarto) + integer nbduno, tbau30(8,nbduno) +c + double precision coonoe(nbnoto,sdim) + double precision shrink +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lenoeu, larete + integer noebis, noeext +c + double precision vare(3) +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Option', option +#endif +c + codret = 0 +c +c==== +c 2. Modification pour mod_joint_qt_d1 +c==== +c + if ( option.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Modif des coordonnees pour mod_joint_qt_d1' +#endif +c decalage de 1 + coonoe(19,3) = coonoe(19,3)+0.05d2 + coonoe(20,1) = coonoe(20,1)+0.05d2 +c decalage de 3 + coonoe(35,3) = coonoe(35,3)+0.05d2 + coonoe(36,1) = coonoe(36,1)+0.05d2 +c decalage de 4 + coonoe(39,3) = coonoe(39,3)+0.05d2 + coonoe(40,1) = coonoe(40,1)-0.05d2 +c decalage de 6 + coonoe(48,3) = coonoe(48,3)+0.05d2 + coonoe(49,1) = coonoe(49,1)-0.05d2 +c decalage de 11 + coonoe(32,2) = coonoe(32,2)+0.05d2 + coonoe(33,2) = coonoe(33,2)-0.05d2 +c decalage de 14 + coonoe(45,2) = coonoe(45,2)+0.05d2 + coonoe(46,2) = coonoe(46,2)-0.05d2 +c decalage de 16 + coonoe(51,1) = coonoe(51,1)+0.05d2 + coonoe(52,1) = coonoe(52,1)-0.05d2 +c decalage de 18 + coonoe(57,1) = coonoe(57,1)+0.05d2 + coonoe(58,1) = coonoe(58,1)-0.05d2 +c decalage de 7 + coonoe(23,1) = coonoe(23,1)-0.05d2 + coonoe(24,3) = coonoe(24,3)-0.05d2 + coonoe(42,1) = coonoe(42,1)+0.05d2 +c decalage de 9 + coonoe(37,1) = coonoe(37,1)-0.05d2 + coonoe(38,3) = coonoe(38,3)-0.05d2 + coonoe(50,1) = coonoe(50,1)+0.05d2 +c decalage de 2 + coonoe(21,2) = coonoe(21,2)-0.05d2 + coonoe(21,3) = coonoe(21,3)+0.05d2 + coonoe(22,1) = coonoe(22,1)+0.05d2 + coonoe(22,2) = coonoe(22,2)-0.05d2 + coonoe(27,1) = coonoe(27,1)+0.05d2 + coonoe(27,2) = coonoe(27,2)+0.05d2 + coonoe(31,2) = coonoe(31,2)+0.05d2 + coonoe(31,3) = coonoe(31,3)+0.05d2 +c decalage de 5 + coonoe(29,1) = coonoe(29,1)-0.05d2 + coonoe(29,2) = coonoe(29,2)+0.05d2 + coonoe(30,1) = coonoe(30,1)-0.05d2 + coonoe(30,2) = coonoe(30,2)-0.05d2 + coonoe(44,2) = coonoe(44,2)+0.05d2 + coonoe(44,3) = coonoe(44,3)+0.05d2 + coonoe(41,2) = coonoe(41,2)-0.05d2 + coonoe(41,3) = coonoe(41,3)+0.05d2 +c decalage de 17 + coonoe(53,1) = coonoe(53,1)-0.05d2 + coonoe(53,2) = coonoe(53,2)+0.05d2 + coonoe(54,1) = coonoe(54,1)-0.05d2 + coonoe(54,2) = coonoe(54,2)-0.05d2 + coonoe(55,1) = coonoe(55,1)+0.05d2 + coonoe(55,2) = coonoe(55,2)-0.05d2 + coonoe(56,1) = coonoe(56,1)+0.05d2 + coonoe(56,2) = coonoe(56,2)+0.05d2 +c decalage de 8 + coonoe(25,1) = coonoe(25,1)-0.05d2 + coonoe(25,2) = coonoe(25,2)-0.05d2 + coonoe(26,2) = coonoe(26,2)-0.05d2 + coonoe(26,3) = coonoe(26,3)-0.05d2 + coonoe(28,2) = coonoe(28,2)+0.05d2 + coonoe(28,3) = coonoe(28,3)-0.05d2 + coonoe(34,1) = coonoe(34,1)-0.05d2 + coonoe(34,2) = coonoe(34,2)+0.05d2 + coonoe(43,1) = coonoe(43,1)+0.05d2 + coonoe(43,2) = coonoe(43,2)-0.05d2 + coonoe(47,1) = coonoe(47,1)+0.05d2 + coonoe(47,2) = coonoe(47,2)+0.05d2 +c +c==== +c 3. Modification pour mod_joint_qua2_d1 +c==== +c + elseif ( option.eq.2 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Modif des coordonnees pour mod_joint_qua2_d1' +#endif +c decalage de 2 + coonoe(72,1) = coonoe(72,1)+0.05d2 + coonoe(73,1) = coonoe(73,1)-0.05d2 +c decalage de 3 + coonoe(76,1) = coonoe(76,1)+0.05d2 + coonoe(76,2) = coonoe(76,2)-0.05d2 + coonoe(77,1) = coonoe(77,1)-0.05d2 + coonoe(77,2) = coonoe(77,2)-0.05d2 + coonoe(80,1) = coonoe(80,1)-0.05d2 + coonoe(80,2) = coonoe(80,2)+0.05d2 + coonoe(88,1) = coonoe(88,1)+0.05d2 + coonoe(88,2) = coonoe(88,2)+0.05d2 +c decalage de 4 + coonoe(83,2) = coonoe(83,2)+0.05d2 + coonoe(84,2) = coonoe(84,2)-0.05d2 +c decalage de 5 + coonoe(100,3) = coonoe(100,3)+0.05d2 + coonoe(101,3) = coonoe(101,3)-0.05d2 +c decalage de 6 + coonoe(78,1) = coonoe(78,1)+0.05d2 + coonoe(78,3) = coonoe(78,3)-0.05d2 + coonoe(79,1) = coonoe(79,1)-0.05d2 + coonoe(79,3) = coonoe(79,3)-0.05d2 + coonoe(105,1) = coonoe(105,1)-0.05d2 + coonoe(105,3) = coonoe(105,3)+0.05d2 + coonoe(107,1) = coonoe(107,1)+0.05d2 + coonoe(107,3) = coonoe(107,3)+0.05d2 +c decalage de 7 + coonoe(85,1) = coonoe(85,1)-0.05d2 + coonoe(85,2) = coonoe(85,2)+0.05d2 + coonoe(85,3) = coonoe(85,3)-0.05d2 + coonoe(86,1) = coonoe(86,1)-0.05d2 + coonoe(86,2) = coonoe(86,2)-0.05d2 + coonoe(86,3) = coonoe(86,3)-0.05d2 + coonoe(87,1) = coonoe(87,1)+0.05d2 + coonoe(87,2) = coonoe(87,2)-0.05d2 + coonoe(87,3) = coonoe(87,3)-0.05d2 + coonoe(91,1) = coonoe(91,1)+0.05d2 + coonoe(91,2) = coonoe(91,2)+0.05d2 + coonoe(91,3) = coonoe(91,3)-0.05d2 + coonoe(106,1) = coonoe(106,1)-0.05d2 + coonoe(106,2) = coonoe(106,2)-0.05d2 + coonoe(106,3) = coonoe(106,3)+0.05d2 + coonoe(110,1) = coonoe(110,1)+0.05d2 + coonoe(110,2) = coonoe(110,2)-0.05d2 + coonoe(110,3) = coonoe(110,3)+0.05d2 + coonoe(117,1) = coonoe(117,1)-0.05d2 + coonoe(117,2) = coonoe(117,2)+0.05d2 + coonoe(117,3) = coonoe(117,3)+0.05d2 + coonoe(126,1) = coonoe(126,1)+0.05d2 + coonoe(126,2) = coonoe(126,2)+0.05d2 + coonoe(126,3) = coonoe(126,3)+0.05d2 +c decalage de 8 + coonoe(98,2) = coonoe(98,2)+0.05d2 + coonoe(98,3) = coonoe(98,3)-0.05d2 + coonoe(99,2) = coonoe(99,2)-0.05d2 + coonoe(99,3) = coonoe(99,3)-0.05d2 + coonoe(104,2) = coonoe(104,2)-0.05d2 + coonoe(104,3) = coonoe(104,3)+0.05d2 + coonoe(120,2) = coonoe(120,2)+0.05d2 + coonoe(120,3) = coonoe(120,3)+0.05d2 +c decalage de 12 + coonoe(81,2) = coonoe(81,2)+0.05d2 + coonoe(82,2) = coonoe(82,2)-0.05d2 +c decalage de 13 + coonoe(74,1) = coonoe(74,1)+0.05d2 + coonoe(75,1) = coonoe(75,1)-0.05d2 +c decalage de 14 + coonoe(102,3) = coonoe(102,3)+0.05d2 + coonoe(103,3) = coonoe(103,3)-0.05d2 +c decalage de 22 + coonoe(89,2) = coonoe(89,2)+0.05d2 + coonoe(90,2) = coonoe(90,2)-0.05d2 +c decalage de 33 + coonoe(92,2) = coonoe(92,2)+0.05d2 + coonoe(93,2) = coonoe(93,2)-0.05d2 +c decalage de 17 + coonoe(94,2) = coonoe(94,2)+0.05d2 + coonoe(95,2) = coonoe(95,2)-0.05d2 +c decalage de 18 + coonoe(113,3) = coonoe(113,3)+0.05d2 + coonoe(114,3) = coonoe(114,3)-0.05d2 +c decalage de 19 + coonoe(123,2) = coonoe(123,2)+0.05d2 + coonoe(123,3) = coonoe(123,3)-0.05d2 + coonoe(124,2) = coonoe(124,2)-0.05d2 + coonoe(124,3) = coonoe(124,3)-0.05d2 + coonoe(125,2) = coonoe(125,2)-0.05d2 + coonoe(125,3) = coonoe(125,3)+0.05d2 + coonoe(129,2) = coonoe(129,2)+0.05d2 + coonoe(129,3) = coonoe(129,3)+0.05d2 +c decalage de 24 + coonoe(108,3) = coonoe(108,3)+0.05d2 + coonoe(109,3) = coonoe(109,3)-0.05d2 +c decalage de 26 + coonoe(96,1) = coonoe(96,1)+0.05d2 + coonoe(97,1) = coonoe(97,1)-0.05d2 +c decalage de 28 + coonoe(132,1) = coonoe(132,1)+0.05d2 + coonoe(132,3) = coonoe(132,3)-0.05d2 + coonoe(133,1) = coonoe(133,1)-0.05d2 + coonoe(133,3) = coonoe(133,3)-0.05d2 + coonoe(134,1) = coonoe(134,1)-0.05d2 + coonoe(134,3) = coonoe(134,3)+0.05d2 + coonoe(135,1) = coonoe(135,1)+0.05d2 + coonoe(135,3) = coonoe(135,3)+0.05d2 +c decalage de 29 + coonoe(142,3) = coonoe(142,3)+0.05d2 + coonoe(143,3) = coonoe(143,3)-0.05d2 +c decalage de 34 + coonoe(118,3) = coonoe(118,3)+0.05d2 + coonoe(119,3) = coonoe(119,3)-0.05d2 +c decalage de 37 + coonoe(146,3) = coonoe(146,3)+0.05d2 + coonoe(147,3) = coonoe(147,3)-0.05d2 +c decalage de 41 + coonoe(127,3) = coonoe(127,3)+0.05d2 + coonoe(128,3) = coonoe(128,3)-0.05d2 +c decalage de 44 + coonoe(115,1) = coonoe(115,1)+0.05d2 + coonoe(116,1) = coonoe(116,1)-0.05d2 +c decalage de 45 + coonoe(138,1) = coonoe(138,1)-0.05d2 + coonoe(138,2) = coonoe(138,2)+0.05d2 + coonoe(139,1) = coonoe(139,1)-0.05d2 + coonoe(139,2) = coonoe(139,2)-0.05d2 + coonoe(140,1) = coonoe(140,1)+0.05d2 + coonoe(140,2) = coonoe(140,2)-0.05d2 + coonoe(141,1) = coonoe(141,1)+0.05d2 + coonoe(141,2) = coonoe(141,2)+0.05d2 +c decalage de 46 + coonoe(144,2) = coonoe(144,2)+0.05d2 + coonoe(145,2) = coonoe(145,2)-0.05d2 +c decalage de 49 + coonoe(121,2) = coonoe(121,2)+0.05d2 + coonoe(122,2) = coonoe(122,2)-0.05d2 +c decalage de 50 + coonoe(111,1) = coonoe(111,1)+0.05d2 + coonoe(112,1) = coonoe(112,1)-0.05d2 +c decalage de 54 + coonoe(148,2) = coonoe(148,2)+0.05d2 + coonoe(149,2) = coonoe(149,2)-0.05d2 +c decalage de 56 + coonoe(130,2) = coonoe(130,2)+0.05d2 + coonoe(131,2) = coonoe(131,2)-0.05d2 +c decalage de 60 + coonoe(150,1) = coonoe(150,1)+0.05d2 + coonoe(151,1) = coonoe(151,1)-0.05d2 +c decalage de 64 + coonoe(136,1) = coonoe(136,1)+0.05d2 + coonoe(137,1) = coonoe(137,1)-0.05d2 +c +c==== +c 4. Modification pour mod_joint_qua_d1 +c==== +c + elseif ( option.eq.3 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Modif des coordonnees pour mod_joint_qua_d1' +#endif +c decalage de 1 et 5 + coonoe(16,1) = coonoe(16,1)+0.05d2 + coonoe(17,2) = coonoe(17,2)+0.05d2 + coonoe(22,1) = coonoe(22,1)+0.05d2 + coonoe(23,2) = coonoe(23,2)+0.05d2 +c decalage de 2 et 6 + coonoe(24,1) = coonoe(24,1)-0.05d2 + coonoe(25,2) = coonoe(25,2)+0.05d2 + coonoe(28,1) = coonoe(28,1)-0.05d2 + coonoe(29,2) = coonoe(29,2)+0.05d2 +c decalage de 3 et 7 + coonoe(30,2) = coonoe(30,2)-0.05d2 + coonoe(31,1) = coonoe(31,1)-0.05d2 + coonoe(34,2) = coonoe(34,2)-0.05d2 + coonoe(35,1) = coonoe(35,1)-0.05d2 +c decalage de 4 et 8 + coonoe(36,1) = coonoe(36,1)+0.05d2 + coonoe(37,2) = coonoe(37,2)-0.05d2 + coonoe(38,1) = coonoe(38,1)+0.05d2 + coonoe(39,2) = coonoe(39,2)-0.05d2 +c decalage de 9 et 14 + coonoe(20,2) = coonoe(20,2)-0.05d2 + coonoe(40,2) = coonoe(40,2)-0.05d2 + coonoe(21,1) = coonoe(21,1)-0.05d2 + coonoe(41,1) = coonoe(41,1)-0.05d2 + coonoe(27,1) = coonoe(27,1)+0.05d2 + coonoe(42,1) = coonoe(42,1)+0.05d2 + coonoe(33,2) = coonoe(33,2)+0.05d2 + coonoe(43,2) = coonoe(43,2)+0.05d2 +c decalage de 15 + coonoe(18,2) = coonoe(18,2)-0.05d2 + coonoe(19,1) = coonoe(19,1)-0.05d2 + coonoe(26,1) = coonoe(26,1)+0.05d2 + coonoe(32,2) = coonoe(32,2)+0.05d2 +c +c==== +c 5. Modification pour mod_joint_tri_d1 +c==== +c + elseif ( option.eq.4 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Modif des coordonnees pour mod_joint_tri_d1' +#endif +c decalage de 1 + coonoe(19,3) = coonoe(19,3)+0.05d2 + coonoe(20,1) = coonoe(20,1)+0.05d2 +c decalage de 2 + coonoe(21,2) = coonoe(21,2)-0.05d2 + coonoe(21,3) = coonoe(21,3)+0.05d2 + coonoe(22,1) = coonoe(22,1)+0.05d2 + coonoe(27,2) = coonoe(27,2)+0.05d2 + coonoe(27,3) = coonoe(27,3)+0.05d2 +c decalage de 3 + coonoe(31,3) = coonoe(31,3)+0.05d2 + coonoe(32,1) = coonoe(32,1)+0.05d2 +c decalage de 4 + coonoe(35,3) = coonoe(35,3)+0.05d2 + coonoe(36,1) = coonoe(36,1)-0.05d2 +c decalage de 5 + coonoe(37,3) = coonoe(37,3)+0.05d2 + coonoe(38,1) = coonoe(38,1)-0.05d2 +c decalage de 6 + coonoe(41,3) = coonoe(41,3)+0.05d2 + coonoe(42,1) = coonoe(42,1)-0.05d2 +c decalage de 7 + coonoe(23,1) = coonoe(23,1)-0.05d2 + coonoe(23,3) = coonoe(23,3)+0.05d2 + coonoe(24,3) = coonoe(24,3)-0.05d2 + coonoe(39,1) = coonoe(39,1)+0.05d2 + coonoe(39,3) = coonoe(39,3)+0.05d2 +c decalage de 8 + coonoe(25,1) = coonoe(25,1)-0.05d2 + coonoe(25,2) = coonoe(25,2)-0.05d2 + coonoe(25,3) = coonoe(25,3)+0.05d2 + coonoe(26,3) = coonoe(26,3)-0.05d2 + coonoe(30,1) = coonoe(30,1)-0.05d2 + coonoe(30,2) = coonoe(30,2)+0.05d2 + coonoe(30,3) = coonoe(30,3)+0.05d2 + coonoe(40,1) = coonoe(40,1)+0.05d2 + coonoe(40,3) = coonoe(40,3)+0.05d2 +c decalage de 9 + coonoe(33,1) = coonoe(33,1)-0.05d2 + coonoe(33,3) = coonoe(33,3)+0.05d2 + coonoe(34,3) = coonoe(34,3)-0.05d2 + coonoe(43,1) = coonoe(43,1)+0.05d2 + coonoe(43,3) = coonoe(43,3)+0.05d2 +c decalage de 11 + coonoe(28,2) = coonoe(28,2)+0.05d2 + coonoe(29,2) = coonoe(29,2)-0.05d2 +c decalage de 16 + coonoe(45,1) = coonoe(45,1)-0.05d2 + coonoe(44,1) = coonoe(44,1)+0.05d2 +c decalage de 17 + coonoe(46,1) = coonoe(46,1)-0.05d2 + coonoe(46,2) = coonoe(46,2)+0.05d2 + coonoe(47,1) = coonoe(47,1)-0.05d2 + coonoe(47,2) = coonoe(47,2)-0.05d2 + coonoe(48,1) = coonoe(48,1)+0.05d2 +c decalage de 18 + coonoe(49,1) = coonoe(49,1)+0.05d2 + coonoe(50,1) = coonoe(50,1)-0.05d2 +c +c==== +c 5. Modification pour mod_joint_tri_d2 +c==== +c + elseif ( option.eq.5 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Modif des coordonnees pour mod_joint_tri_d2' +#endif + coonoe(10,1) = coonoe(10,1)-0.05d0 + coonoe(10,2) = coonoe(10,2)-0.05d0 + coonoe(12,1) = coonoe(12,1)-0.05d0 + coonoe(12,2) = coonoe(12,2)-0.05d0 + coonoe(14,1) = coonoe(14,1)-0.05d0 + coonoe(14,2) = coonoe(14,2)-0.05d0 + coonoe(20,1) = coonoe(20,1)-0.05d0 + coonoe(20,2) = coonoe(20,2)-0.05d0 + coonoe(9,1) = coonoe(9,1)+0.05d0 + coonoe(9,2) = coonoe(9,2)+0.05d0 + coonoe(11,1) = coonoe(11,1)+0.05d0 + coonoe(11,2) = coonoe(11,2)+0.05d0 + coonoe(13,1) = coonoe(13,1)+0.05d0 + coonoe(13,2) = coonoe(13,2)+0.05d0 + coonoe(15,1) = coonoe(15,1)+0.05d0 + coonoe(15,2) = coonoe(15,2)+0.05d0 + coonoe(18,1) = coonoe(18,1)+0.05d0 + coonoe(18,2) = coonoe(18,2)+0.05d0 + coonoe(19,1) = coonoe(19,1)+0.05d0 + coonoe(19,2) = coonoe(19,2)+0.05d0 +c + coonoe(9,1) = coonoe(9,1)+0.05d0 + coonoe(9,2) = coonoe(9,2)+0.05d0 + coonoe(9,3) = coonoe(9,3)+0.05d0 + coonoe(15,1) = coonoe(15,1)-0.05d0 + coonoe(15,2) = coonoe(15,2)-0.05d0 + coonoe(15,3) = coonoe(15,3)-0.05d0 + coonoe(18,1) = coonoe(18,1)-0.05d0 + coonoe(18,2) = coonoe(18,2)-0.05d0 + coonoe(18,3) = coonoe(18,3)-0.05d0 + coonoe(11,1) = coonoe(11,1)+0.05d0 + coonoe(11,2) = coonoe(11,2)+0.05d0 + coonoe(11,3) = coonoe(11,3)+0.05d0 + coonoe(16,1) = coonoe(16,1)-0.05d0 + coonoe(16,2) = coonoe(16,2)-0.05d0 + coonoe(16,3) = coonoe(16,3)-0.05d0 + coonoe(17,1) = coonoe(17,1)+0.05d0 + coonoe(17,2) = coonoe(17,2)+0.05d0 + coonoe(17,3) = coonoe(17,3)+0.05d0 +c +c==== +c 6. Modification automatique des noeuds dupliques +c Pour chacun, on explore la duplication du cote 1, puis 2 +c==== +c + elseif ( option.eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Modif automatique avec coeff', shrink +#endif +c + do 6 , iaux = 1 , nbduno +c + lenoeu = tbau30(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.le.-8 ) then + write (ulsort,90002) mess14(langue,2,-1), lenoeu + endif +#endif +c + do 61 , jaux = 1 , 2 +c +c 6.1. ==> Caracteristiques de l'arete qui entre dans le volume +c + larete = tbau30(5+jaux,iaux) + if ( larete.gt.0 ) then + noeext = somare(2,larete) + else + noeext = somare(1,-larete) + endif +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.le.-8 ) then + write (ulsort,90015) 'arete', larete, + > ', de sommets', lenoeu, noeext + endif +#endif +c +c 6.2. ==> Nouvelles coordonnees +c +c B est le noeud lenoeu, dont la duplication donne M +c A est le noeud noeext, autre extremite de l'arete +c A M B +c o------------------------X--o +c +c AM = shrink*AB +c ==> XM = XA + shrink*(XB-XA) +c + vare(1) = coonoe(lenoeu,1) - coonoe(noeext,1) + vare(2) = coonoe(lenoeu,2) - coonoe(noeext,2) + vare(3) = coonoe(lenoeu,3) - coonoe(noeext,3) +c + noebis = tbau30(2+jaux,iaux) +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.le.-8 ) then + write (ulsort,90002) 'noeud bis', noebis + endif +#endif + coonoe(noebis,1) = coonoe(noeext,1) + shrink*vare(1) + coonoe(noebis,2) = coonoe(noeext,2) + shrink*vare(2) + coonoe(noebis,3) = coonoe(noeext,3) + shrink*vare(3) +c + 61 continue +c + 6 continue +c + endif +c +c==== +c 7. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagf0.F b/src/tool/Modification/mmagf0.F new file mode 100644 index 00000000..e6d5112a --- /dev/null +++ b/src/tool/Modification/mmagf0.F @@ -0,0 +1,677 @@ + subroutine mmagf0 ( nbjoto, nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsupe, nhsups, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - Famille - phase 0 +c - - -- - - +c Creation des nouvelles familles MED +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbjoto . e . 1 . nombre total de joints . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . nbjoiq . e . 1 . nombre de joints quadruples . +c . nbjp06 . e . 1 . nombre de joints ponctuels ordre 6 . +c . nbjp09 . e . 1 . nombre de joints ponctuels ordre 9 . +c . nbjp12 . e . 1 . nombre de joints ponctuels ordre 12 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGF0' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "meddc0.h" +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +#include "coftex.h" +#include "nbfami.h" +#include "dicfen.h" +c +#ifdef _DEBUG_HOMARD_ +#include "nombmp.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#endif +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbjoto, nbjois, nbjoit, nbjoiq + integer nbjp06, nbjp09, nbjp12 +c + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhsupe, nhsups +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nbfmed, nbfme0, nbfmaj + integer lgte6n, lgte60 + integer lgts2n, lgts20 + integer adtae5, adtae6, adtae9, adtas2, adtas4 + integer typenh + integer nctfen, nbfaen, pcfaen + integer nbfte0 + integer pcfaqu + integer pcfate + integer pcfahe + integer pcfape +#ifdef _DEBUG_HOMARD_ + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu + integer pfamte + integer pfamhe + integer pfampy, pcfapy + integer pfampe +#endif +c + integer decafa +c + character*8 nhqufa, nhtefa, nhpefa, nhhefa + character*8 nhenti +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decalage dans les numeros des familles :'',i5)' + texte(1,5) = + >'(''Ancien nombre de familles HOMARD de '',a,'' :'',i5)' + texte(1,6) = + >'(''Nouveau nombre de familles HOMARD de '',a,'' :'',i5)' + texte(1,7) = '(''Nombre de familles MED '',a,'' :'',i5)' +c + texte(2,4) = '(''Shift with numbers of the families :'',i5)' + texte(2,5) = + >'(''Old number of HOMARD families of '',a,'' :'',i5)' + texte(2,6) = + >'(''New number of HOMARD families of '',a,'' :'',i5)' + texte(2,7) = '(''Number of MED families '',a,'' :'',i5)' +c + codret = 0 +c +c==== +c 2. Gestion des tableaux +c==== +c 2.1. ==> Familles des quadrangles : uniquement la famille libre +c + nbfqua = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,4), nbfqua +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhquad//'.Famille', nhqufa, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nctfqu = ncffqu +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM1_qu', nompro +#endif + iaux = 4 + call utfam1 ( iaux, nhqufa, pcfaqu, + > nctfqu, jaux, nbfqua, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Familles des tetraedres +c + nbfte0 = nbftet +c + if ( nbjp06.ne.0 ) then +c + nbftet = nbfte0 + nbjp06 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,3), nbfte0 + write (ulsort,texte(langue,6)) mess14(langue,3,3), nbftet +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhtetr//'.Famille', nhtefa, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nctfhe = ncffhe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM1_te', nompro +#endif + iaux = 3 + call utfam1 ( iaux, nhtefa, pcfate, + > nctfte, nbfte0, nbftet, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.3. ==> Familles des pentaedres +c + nbfpen = 1 + nbjois + nbjoit + nbjp09 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfpen +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhpent//'.Famille', nhpefa, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nctfpe = ncffpe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM1_pe', nompro +#endif + iaux = 7 + call utfam1 ( iaux, nhpefa, pcfape, + > nctfpe, jaux, nbfpen, + > ulsort, langue, codret ) +c + endif +c +c 2.4. ==> Familles des hexaedres +c + if ( nbjoiq.ne.0 ) then +c + nbfhex = 1 + nbjoiq + nbjp12 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfhex +#endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nhhexa//'.Famille', nhhefa, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nctfhe = ncffhe +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAM1_he', nompro +#endif + iaux = 6 + call utfam1 ( iaux, nhhefa, pcfahe, + > nctfhe, jaux, nbfhex, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Memorisation des familles MED +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.2. ; codret = ', codret +#endif +cgn call gmprsx(nompro,nhpefa//'.Codes') +cgn call gmprsx(nompro,nhsupe) +cgn call gmprsx(nompro,nhsupe//'.Tab5') +cgn call gmprsx(nompro,nhsupe//'.Tab6') +cgn call gmprsx(nompro,nhsupe//'.Tab9') +cgn call gmprsx(nompro,nhsups) +cgn call gmprsx(nompro,nhsups//'.Tab2') +cgn call gmprsx(nompro,nhsups//'.Tab4') +c +c 3.1. ==> Nombre de familles MED +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.1. Nombre familles MED ; codret = ', codret +#endif +c +c Ancien nombre +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 9, nbfme0, codret ) +c + endif +c +c Nombre de familles MED ajoute : +c Pour un type de mailles, il y a 1 famille MED de moins que +c de familles HOMARD +c + nbfmaj = nbfpen - 1 + if ( nbfhex.gt.0 ) then + nbfmaj = nbfmaj + nbfhex - 1 + endif + nbfmaj = nbfmaj + nbjp06 +c + nbfmed = nbfme0 + nbfmaj +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) 'avant', nbfme0 + write (ulsort,texte(langue,5)) mess14(langue,3,3), nbfte0 + write (ulsort,texte(langue,6)) mess14(langue,3,3), nbftet + write (ulsort,texte(langue,6)) mess14(langue,3,6), nbfhex + write (ulsort,texte(langue,6)) mess14(langue,3,7), nbfpen + write (ulsort,texte(langue,7)) 'apres', nbfmed +#endif +c +c 3.1. ==> Gestions des groupes +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.1. Groupes ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 6, lgte60, codre1 ) + call gmliat ( nhsups, 2, lgts20, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhsupe, 5, nbfmed, codre1 ) + lgte6n = lgte60 + 10*2*nbfmaj + call gmecat ( nhsupe, 6, lgte6n, codre2 ) + call gmecat ( nhsupe, 9, nbfmed, codre3 ) + lgts2n = lgts20 + 10*2*nbfmaj + call gmecat ( nhsups, 2, lgts2n, codre4 ) + iaux = 10*nbfmed + call gmecat ( nhsups, 4, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( nhsupe//'.Tab5', adtae5, + > 1, 1, nbfme0+1, nbfmed+1, codre1 ) + call gmmod ( nhsupe//'.Tab6', adtae6, + > 1, 1, lgte60, lgte6n, codre2 ) + call gmmod ( nhsupe//'.Tab9', adtae9, + > 1, 1, nbfme0, nbfmed, codre3 ) + call gmmod ( nhsups//'.Tab2', adtas2, + > 1, 1, lgts20, lgts2n, codre4 ) + call gmmod ( nhsups//'.Tab4', adtas4, + > 1, 1, 10*nbfme0, 10*nbfmed, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 4. Recherche du decalage dans les numeros de familles MED de mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. decalage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + decafa = 0 +c + do 40 , typenh = 0 , 4 +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.0 ) then + nhenti = nhmapo + nctfen = nctfmp + nbfaen = nbfmpo + elseif ( typenh.eq.1 ) then + nhenti = nharet + nctfen = nctfar + nbfaen = nbfare + elseif ( typenh.eq.2 ) then + nhenti = nhtria + nctfen = nctftr + nbfaen = nbftri + elseif ( typenh.eq.3 ) then + nhenti = nhtetr + nctfen = nctfte + nbfaen = nbfte0 + elseif ( typenh.eq.4 ) then + nhenti = nhquad + nctfen = nctfqu + nbfaen = nbfqua + endif +c + endif +c + if ( nbfaen.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,*) mess14(langue,4,typenh) + write (ulsort,*) 'nbfaen', nbfaen + write (ulsort,*) 'nctfen', nctfen +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Famille.Codes', + > pcfaen, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + do 401 , iaux = 1 , nbfaen +c +cgn write (ulsort,*)imem(pcfaen+(iaux-1)*nctfen+cofamd-1) + decafa = min(decafa,imem(pcfaen+(iaux-1)*nctfen+cofamd-1)) +c + 401 continue +c + endif +c + endif +c + 40 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) decafa +#endif +c + endif +c +c==== +c 5. Creation des tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Creation des tableaux ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx(nompro,nhpefa//'.Codes') +cgn call gmprsx(nompro,nhsupe) +cgn call gmprsx(nompro,nhsupe//'.Tab5') +cgn call gmprsx(nompro,nhsupe//'.Tab6') +cgn call gmprsx(nompro,nhsupe//'.Tab9') +cgn call gmprsx(nompro,nhsups) +cgn call gmprsx(nompro,nhsups//'.Tab2') +cgn call gmprsx(nompro,nhsups//'.Tab4') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGF1', nompro +#endif + call mmagf1 ( decafa, + > imem(pcfaqu), + > imem(pcfate), nbfte0, imem(pcfape), imem(pcfahe), + > nbfme0, nbfmed, + > nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > imem(adtae5), imem(adtae6), smem(adtas2), + > imem(adtae9), smem(adtas4), + > nbjoto, + > ulsort, langue, codret ) +cgn call gmprsx(nompro,nhtefa//'.Codes') +cgn call gmprsx(nompro,nhpefa//'.Codes') +cgn call gmprsx(nompro,nhsupe) +cgn call gmprsx(nompro,nhsupe//'.Tab5') +cgn call gmprsx(nompro,nhsupe//'.Tab6') +cgn call gmprsx(nompro,nhsupe//'.Tab9') +cgn call gmprsx(nompro,nhsups) +cgn call gmprsx(nompro,nhsups//'.Tab2') +cgn call gmprsx(nompro,nhsups//'.Tab4') +c + endif +c +#ifdef _DEBUG_HOMARD_ +c==== +c 6. Impression eventuelle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Impression eventuelle ; codret = ', codret +#endif +c +c 6.1.==> Pointeurs +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 7 + call utad01 ( iaux, nhnoeu, + > jaux, + > pfamno, pcfano, jaux, + > jaux, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbmpto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhmapo, + > jaux, jaux, jaux , jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 259 + call utad02 ( iaux, nharet, + > jaux, jaux, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, jaux, + > pfamtr, pcfatr, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhtetr, + > jaux, jaux, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhhexa, + > jaux, jaux, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhpyra, + > jaux, jaux, jaux, jaux, + > pfampy, pcfapy, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhpent, + > jaux, jaux, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 6.2 ==> Impressions +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECFE', nompro +#endif + call utecfe ( iaux, + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > ulsort, langue, codret ) +c + endif +c +#endif +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagf1.F b/src/tool/Modification/mmagf1.F new file mode 100644 index 00000000..af8bf9de --- /dev/null +++ b/src/tool/Modification/mmagf1.F @@ -0,0 +1,478 @@ + subroutine mmagf1 ( decafa, + > cfaqua, + > cfatet, nbfte0, cfapen, cfahex, + > nbfme0, nbfmed, + > nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > grfmpo, grfmtl, grfmtb, + > numfam, nomfam, + > nbjoto, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - Famille - phase 1 +c - - -- - - +c Creation des nouvelles familles MED +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . cfaqua . s . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . cfatet . es . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . nbfte0 . e . 1 . ancien nombre de familles des tetraedres . +c . cfapen . s . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . cfahex . s . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . decafa . e . 1 . decalage dans le numero de famille . +c . nbjois . e . 1 . nombre de joints simples . +c . nbjoit . e . 1 . nombre de joints triples . +c . nbjoiq . e . 1 . nombre de joints quadruples . +c . nbjp06 . e . 1 . nombre de joints ponctuels ordre 6 . +c . nbjp09 . e . 1 . nombre de joints ponctuels ordre 9 . +c . nbjp12 . e . 1 . nombre de joints ponctuels ordre 12 . +c . grfmpo . es .nbfmed+1. pointeur des groupes des familles . +c . grfmtl . es .nbfmed+1. taille des groupes des familles . +c . grfmtb . es .10ngrouc. table des groupes des familles . +c . numfam . es . nbfmed . numero des familles MED . +c . nbjoto . e . 1 . nombre total de joints . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 33 : trop de groupes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGF1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "meddc0.h" +#include "envex1.h" +c +#include "coftex.h" +#include "cofatq.h" +#include "cofina.h" +#include "coftfq.h" +#include "cofpfh.h" +#include "coftfh.h" +#include "cofpfp.h" +#include "coftfp.h" +#include "envca1.h" +#include "nbfami.h" +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decafa + integer nbfme0, nbfmed + integer nbjois, nbjoit, nbjoiq + integer nbjp06, nbjp09, nbjp12 + integer nbfte0 + integer cfaqua(nctfqu,nbfqua) + integer cfatet(nctfte,nbftet) + integer cfapen(nctfpe,nbfpen) + integer cfahex(nctfhe,nbfhex) + integer grfmpo(0:nbfmed), grfmtl(*) + integer numfam(nbfmed) + integer nbjoto +c + character*8 grfmtb(*) + character*8 nomfam(10,nbfmed) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lgnogr, nufame, nufaho + integer rgfame, ptnogr + integer tymate, tymape, tymahe +c + character*1 saux01 + character*8 nomgro + character*30 saux30 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. prealables +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Decalage dans les numeros des familles :'',i5)' + texte(1,5) = '(''Nombre de familles de '',a,'' :'',i5)' + texte(1,6) = '(''. Creation de la famille :'',i5)' + texte(1,7) = '(''.. Groupe : '',a)' + texte(1,8) = '(''.. Famille : '',a)' + texte(1,9) = + > '(''.. Trop de groupes pour coder les noms sur 8 caracteres.'')' +c + texte(2,4) = '(''Shift with numbers of the families :'',i5)' + texte(2,5) = '(''Number of families of '',a,'' :'',i5)' + texte(2,6) = '(''. Creation of the family :'',i5)' + texte(2,7) = '(''.. Group : '',a)' + texte(2,8) = '(''.. Family : '',a)' + texte(2,9) = + > '(''.. Too many groups for 8 character coding of the names.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) decafa + write (ulsort,texte(langue,5)) mess14(langue,3,7), nbfpen + if ( nbjoiq.gt.0 ) then + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbfhex + endif +#endif +c + codret = 0 +c + if ( degre.eq.1 ) then + tymape = edpen6 + if ( nbjoiq.gt.0 ) then + tymahe = edhex8 + endif + if ( nbjp06.gt.0 ) then + tymate = edtet4 + endif + else + tymape = edpe15 + if ( nbjoiq.gt.0 ) then + tymahe = edhe20 + endif + if ( nbjp06.gt.0 ) then + tymate = edte10 + endif + endif +c +c==== +c 2. Les familles libres +c==== +c 2.1. ==> Les quadrangles +c + if ( nbfqua.gt.0 ) then + cfaqua(cofamd,1) = 0 + cfaqua(cotyel,1) = 0 + cfaqua(cosfsu,1) = 0 + cfaqua(cofafa,1) = 1 + cfaqua(cosfin,1) = 0 + cfaqua(coftfq,1) = 1 + endif +c +c 2.2. ==> Les pentaedres +c + if ( nbfpen.gt.0 ) then + cfapen(cofamd,1) = 0 + cfapen(cotyel,1) = 0 + cfapen(coftfp,1) = 1 + cfapen(cofpfp,1) = 1 + endif +c +c 2.3. ==> Les hexaedres +c + if ( nbfhex.gt.0 ) then + cfahex(cofamd,1) = 0 + cfahex(cotyel,1) = 0 + cfahex(coftfh,1) = 1 + cfahex(cofpfh,1) = 1 + endif +c +c==== +c 3. familles de tetraedres, d'hexaedres et de pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. familles ; codret = ', codret +#endif +c + rgfame = nbfme0 + ptnogr = grfmpo(rgfame) +c +cgn write (ulsort,*) 'nbjois = ', nbjois +cgn write (ulsort,*) 'nbjoit = ', nbjoit +cgn write (ulsort,*) 'nbjoiq = ', nbjoiq +cgn write (ulsort,*) 'nbjp06 = ', nbjp06 +cgn write (ulsort,*) 'nbjp09 = ', nbjp09 +cgn write (ulsort,*) 'nbjp12 = ', nbjp12 +cgn write (ulsort,*) 'nbjoto = ', nbjoto + do 3 , iaux = 1 , nbjoto +c +c 3.1. ==> Numero de la famille MED +c + if ( codret.eq.0 ) then +c + nufame = decafa - iaux + rgfame = rgfame + 1 + numfam(rgfame) = nufame +cgn write (ulsort,*)'rgfame, nufame,ptnogr ',rgfame,nufame,ptnogr +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nufame +#endif +c + endif +c +c 3.2. ==> Caracteristiques des familles de pentaedres, de +c tetraedres ou d'hexaedres +c + if ( iaux.le.(nbjois+nbjoit) ) then + nufaho = iaux + 1 + cfapen(cofamd,nufaho) = nufame + cfapen(cotyel,nufaho) = tymape + cfapen(coftfp,nufaho) = 1 + cfapen(cofpfp,nufaho) = 1 + elseif ( iaux.le.(nbjois+nbjoit+nbjoiq) ) then + nufaho = iaux - (nbjois+nbjoit) + 1 + cfahex(cofamd,nufaho) = nufame + cfahex(cotyel,nufaho) = tymahe + cfahex(coftfh,nufaho) = 1 + cfahex(cofpfh,nufaho) = 1 + elseif ( nbjp06.gt.0 .and. + > iaux.le.(nbjois+nbjoit+nbjoiq+nbjp06) ) then + nufaho = iaux - (nbjois+nbjoit+nbjoiq) + nbfte0 + cfatet(cofamd,nufaho) = nufame + cfatet(cotyel,nufaho) = tymate + elseif ( nbjp09.gt.0 .and. + > iaux.le.(nbjois+nbjoit+nbjoiq+nbjp06+nbjp09) ) then + nufaho = iaux - (nbjoiq+nbjp06) + 1 + cfapen(cofamd,nufaho) = nufame + cfapen(cotyel,nufaho) = tymape + cfapen(coftfp,nufaho) = 1 + cfapen(cofpfp,nufaho) = 1 + elseif ( nbjp12.gt.0 ) then + nufaho = iaux - (nbjois+nbjoit+nbjp06+nbjp09) + 1 + cfahex(cofamd,nufaho) = nufame + cfahex(cotyel,nufaho) = tymahe + cfahex(coftfh,nufaho) = 1 + cfahex(cofpfh,nufaho) = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nufaho +#endif +c +c 3.3. ==> Nom du groupe et de la famille +c + if ( codret.eq.0 ) then +c + if ( iaux.le.nbjois ) then + jaux = iaux + saux01 = 'J' + elseif ( iaux.le.(nbjois+nbjoit) ) then + jaux = iaux - nbjois + saux01 = 'T' + elseif ( iaux.le.(nbjois+nbjoit+nbjoiq) ) then + jaux = iaux - (nbjois+nbjoit) + saux01 = 'Q' + else + jaux = iaux - (nbjois+nbjoit+nbjoiq) + saux01 = 'P' + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTENCH', nompro +#endif + call utench ( jaux, 'G', kaux, saux30, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( kaux.ge.8 ) then +c + write (ulsort,texte(langue,9)) + codret = 33 +c + endif +c + endif +c +c 3.4. ==> nom du groupe du joint +c + if ( codret.eq.0 ) then +c +c 1 2345678 + nomgro = saux01//'_ ' + lgnogr = kaux + 2 + nomgro(3:lgnogr) = saux30(1:kaux) +cgn write (ulsort,*) nomgro +c + grfmtb(ptnogr+1) = nomgro + do 342 , jaux = 2, 10 + grfmtb(ptnogr+jaux) = ' ' +c 12345678 + 342 continue + do 343 , jaux = 1, 10 + grfmtl(ptnogr+jaux) = 0 + 343 continue +cgn if ( lgnogr.le.8 ) then + grfmtl(ptnogr+1) = lgnogr +cgn elseif ( lgnogr.le.16 ) then +cgn grfmtl(ptnogr+1) = 8 +cgn grfmtl(ptnogr+2) = lgnogr - 8 +cgn elseif ( lgnogr.le.24) then +cgn grfmtl(ptnogr+1) = 8 +cgn grfmtl(ptnogr+2) = 8 +cgn grfmtl(ptnogr+3) = lgnogr - 8 +cgn else +cgn grfmtl(ptnogr+1) = 8 +cgn grfmtl(ptnogr+2) = 8 +cgn grfmtl(ptnogr+3) = 8 +cgn grfmtl(ptnogr+4) = lgnogr - 8 +cgn endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nomgro +#endif +c + ptnogr = ptnogr + 10 +c +c 3.5. ==> nom du groupe global de tous les joints +c + if ( codret.eq.0 ) then +c + if ( saux01.eq.'J' ) then +c 12345678 + grfmtb(ptnogr+1) = 'JOINT ' + grfmtl(ptnogr+1) = 5 + elseif ( saux01.eq.'T' ) then + grfmtb(ptnogr+1) = 'TRIPLE ' + grfmtl(ptnogr+1) = 6 + elseif ( saux01.eq.'Q' ) then + grfmtb(ptnogr+1) = 'QUADRUPL' + grfmtl(ptnogr+1) = 8 + else + grfmtb(ptnogr+1) = 'POINT ' + grfmtl(ptnogr+1) = 8 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) grfmtb(ptnogr+1) +#endif + do 351 , jaux = 2 , 10 +c 12345678 + grfmtb(ptnogr+jaux) = ' ' + grfmtl(ptnogr+jaux) = 0 + 351 continue +c + ptnogr = ptnogr + 10 + grfmpo(rgfame) = ptnogr +c + endif +c +c 3.6. ==> Stockage du nom de la famille +c + if ( codret.eq.0 ) then +c + nomfam(1,rgfame) = blan08 + nomfam(2,rgfame) = blan08 + nomfam(3,rgfame) = blan08 + nomfam(4,rgfame) = blan08 + nomfam(5,rgfame) = blan08 + nomfam(6,rgfame) = blan08 + nomfam(7,rgfame) = blan08 + nomfam(8,rgfame) = blan08 +cgn if ( lgnogr.le.8 ) then + nomfam(1,rgfame)(1:lgnogr) = nomgro(1:lgnogr) +cgn elseif ( lgnogr.le.16 ) then +cgn nomfam(1,rgfame) = saux64( 1: 8) +cgn nomfam(2,rgfame)( 1:lgnogr-8) = nomgro( 9:lgnogr) +cgn elseif ( lgnogr.le.24) then +cgn nomfam(1,rgfame) = saux64( 1: 8) +cgn nomfam(2,rgfame) = saux64( 9:16) +cgn nomfam(3,rgfame)( 1:lgnogr-8) = nomgro(17:lgnogr) +cgn else +cgn nomfam(1,rgfame) = saux64( 1: 8) +cgn nomfam(2,rgfame) = saux64( 9:16) +cgn nomfam(3,rgfame) = saux64(17:24) +cgn nomfam(4,rgfame)( 1:lgnogr-8) = nomgro(25:lgnogr) +cgn endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nomfam(1,rgfame)// + > nomfam(2,rgfame)//nomfam(3,rgfame)//nomfam(4,rgfame) + > //nomfam(5,rgfame)//nomfam(6,rgfame) + > //nomfam(7,rgfame)//nomfam(8,rgfame) +#endif +c + endif +c + 3 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagr0.F b/src/tool/Modification/mmagr0.F new file mode 100644 index 00000000..8c60d9b4 --- /dev/null +++ b/src/tool/Modification/mmagr0.F @@ -0,0 +1,285 @@ + subroutine mmagr0 ( voltri, + > famtet, cfatet, + > tbaux1, tbaux2, + > nbjois, nbpejs, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 0 +c - - --- - +c Reperage des triangles a l'interface entre deux grains +c . Memorisation des familles MED de part et d'autre d'un joint +c . Decompte du nombre de pentaedres a creer +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . e . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . tbaux1 . s . 4** . Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbaux2 . s . 4** . Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . nbjois . s . 1 . nombre de joints simples . +c . nbpejs . s . 1 . nombre de pentaedres de joints simples . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGR0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "coftex.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer voltri(2,nbtrto) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer tbaux1(4,nbtrto), tbaux2(4,*) +c + integer nbjois, nbpejs +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer famhom(2), fammed(2) + integer letet1, letet2 + integer nujoin +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,19)) mess14(langue,3,3), nbftet +#endif +c + codret = 0 +c +c==== +c 2. Parcours des triangles +c Si les caracteristiques des deux tetraedres voisins sont les +c memes, on ne fait rien. +c Si le groupe des deux tetraedres voisins est different, on +c memorise l'information : pentaedre a creer et famille +c Remarque : on part du principe qu'une famille MED est identifiee +c a un groupe, donc un grain +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,2) +#endif +c + nbpejs = 0 + nbjois = 0 +c + do 21 , iaux = 1 , nbtrto +c + if ( voltri(2,iaux).ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,2), iaux +#endif +c +c 2.1. ==> Comparaison des familles HOMARD +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,3,3), + > voltri(1,iaux),voltri(2,iaux) +#endif + famhom(1) = famtet(voltri(1,iaux)) + famhom(2) = famtet(voltri(2,iaux)) +cgn write(ulsort,*) famhom(1),famhom(2) + if ( famhom(1).eq.famhom(2) ) then + goto 21 + endif +c +c 2.2. ==> Comparaison des familles MED +c + fammed(1) = cfatet(cofamd,famhom(1)) + fammed(2) = cfatet(cofamd,famhom(2)) +cgn write(ulsort,*) fammed(1),fammed(2) + if ( fammed(1).eq.fammed(2) ) then + goto 21 + endif +c +c 2.4. ==> Si on arrive ici, un pentaedre de joint simple est a creer. +c Quel joint pour ce pentaedre ? +c + do 24 , jaux = 1 , nbjois +cgn write(ulsort,*) jaux,tbaux2(1,jaux),tbaux2(2,jaux) + if ( ( tbaux2(1,jaux).eq.fammed(1) .and. + > tbaux2(2,jaux).eq.fammed(2) ) .or. + > ( tbaux2(1,jaux).eq.fammed(2) .and. + > tbaux2(2,jaux).eq.fammed(1) ) ) then + nujoin = jaux + goto 241 + endif + 24 continue +c +c Il faut creer un nouveau joint +c + nbjois = nbjois + 1 +cgn write (ulsort,texte(langue,6)) nbjois +cgn write (ulsort,texte(langue,20)) fammed(1),fammed(2) + tbaux2(1,nbjois) = min(fammed(1),fammed(2)) + tbaux2(2,nbjois) = max(fammed(1),fammed(2)) + nujoin = nbjois +c + 241 continue +c +c 2.5. ==> Reperage du positionnement du triangle pour le tetraedre +c du cote 1 +c + if ( fammed(1).eq.tbaux2(1,nujoin) ) then + letet1 = voltri(1,iaux) + letet2 = voltri(2,iaux) + else + letet1 = voltri(2,iaux) + letet2 = voltri(1,iaux) + endif +cgn if ( iaux.eq.33 .or. iaux.eq.56 ) then +cgn write (ulsort,90001)'triangle', iaux, +cgn > fammed(1),fammed(2),tbaux2(1,nbjois) +cgn write (ulsort,90002)' voltri', voltri(1,iaux),voltri(2,iaux) +cgn write (ulsort,90002)'=> letet1', letet1 +cgn endif +c +c 2.6. ==> Pour ce pentaedre : +c 1 : son triangle de base est le courant +c 2 : son joint simple +c 3 : le tetraedre du cote 1 +c 4 : le tetraedre du cote 2 +c + nbpejs = nbpejs + 1 +c + tbaux1(1,nbpejs) = iaux + tbaux1(2,nbpejs) = nujoin + tbaux1(3,nbpejs) = letet1 + tbaux1(4,nbpejs) = letet2 +c + endif +c + 21 continue +c +c==== +c 3. Messages +c==== +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,12)) nbjois + if ( nbjois.gt.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpejs + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) + iaux = 1 + jaux = nbjois + do 31 , nujoin = iaux, jaux + write (ulsort,1001) nujoin, tbaux2(1,nujoin), tbaux2(2,nujoin) + 31 continue + write (ulsort,1002) +c + 1000 format( /,5x,31('*'), + > /,5x,'* Joint *',2(' MED *'), + > /,5x,31('*')) + 1001 format(4x,3(' *',i8),' *') + 1002 format(5x,31('*'),/) +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagr2.F b/src/tool/Modification/mmagr2.F new file mode 100644 index 00000000..d0bf05c0 --- /dev/null +++ b/src/tool/Modification/mmagr2.F @@ -0,0 +1,518 @@ + subroutine mmagr2 ( nbnotn, nbartn, nbtrtn, nbqutn, + > nbtetn, nbpetn, nbhetn, + > nhnoeu, nharet, nhtria, nhquad, + > nhtetr, nhpent, nhhexa, + > phetno, pcoono, pareno, pderno, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, pfilte, pperte, pcotrt, + > phetpe, pfacpe, pfilpe, pperpe, pcofap, + > phethe, pquahe, pfilhe, pperhe, pcoquh, + > pfamno, pfamar, pfamtr, pfamqu, + > pfamte, pfampe, pfamhe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c Modification de Maillage - AGRegat - phase 2 +c - - --- - +c Reallocation des tableaux +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnotn . e . 1 . nombre de noeuds total nouveau . +c . nbartn . e . 1 . nombre d'aretes total nouveau . +c . nbtrtn . e . 1 . nombre de triangles total nouveau . +c . nbqutn . e . 1 . nombre de quadrangles total nouveau . +c . nbtetn . e . 1 . nombre de tetraaedres total nouveau . +c . nbpetn . e . 1 . nombre de pentaedres total nouveau . +c . nbhetn . s . 1 . nombre d'hexaedres total nouveau . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGR2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +#include "envca1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer nbnotn, nbartn, nbtrtn, nbqutn + integer nbtetn, nbpetn, nbhetn + integer phetno, pcoono, pareno, pderno + integer phetar, psomar, pfilar, pmerar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer phette, ptrite, pfilte, pperte, pcotrt + integer phetpe, pfacpe, pfilpe, pperpe, pcofap + integer phethe, pquahe, pfilhe, pperhe, pcoquh + integer pfamno, pfamar, pfamtr, pfamqu + integer pfamte, pfampe, pfamhe +c + character*8 nhnoeu, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpent +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, paux +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c + texte(1,4) = '(''(Re)allocation des tableaux des '',a)' + texte(1,5) = '(5x,''==> code de retour :'',i8)' +c + texte(2,4) = '(''(Re)allocation of arrays for '',a)' + texte(2,5) = '(5x,''==> error code :'',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( nbnotn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,-1), nbnotn + endif + if ( nbartn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,1), nbartn + endif + if ( nbtrtn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,2), nbtrtn + endif + if ( nbqutn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,4), nbqutn + endif + if ( nbtetn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,3), nbtetn + endif + if ( nbpetn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,7), nbpetn + endif + if ( nbhetn.gt.0 ) then + write (ulsort,texte(langue,15)) mess14(langue,3,6), nbhetn + endif +#endif +c + codret = 0 +c +c==== +c 2. Les noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. noeuds ; codret', codret +#endif +c + if ( nbnotn.gt.0 .and. nbnoto.ne.nbnotn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nhnoeu) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + iaux = 2730 + jaux = 1 + call utad05 ( iaux, jaux, nhnoeu, + > nbnoto, nbnotn, sdim, + > phetno, + > pfamno, + > pcoono, pareno, jaux, pderno, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbnoto = nbnotn +c + endif +cgn call gmprsx(nompro,nhnoeu) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,-1) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 3. Les aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Les aretes ; codret', codret +#endif +c + if ( nbartn.gt.0 .and. nbarto.ne.nbartn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nharet) +c + iaux = 1 + jaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_ar', nompro +#endif + call utad06 ( iaux, jaux, 1, nharet, + > nbarto, nbartn, 0, 0, + > phetar, psomar, pfilar, pmerar, + > pfamar, + > paux, paux, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbarto = nbartn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 4. Les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Les triangles ; codret', codret +#endif +c + if ( nbtrtn.gt.0 .and. nbtrto.ne.nbtrtn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nhtria) +c + iaux = 2 + jaux = 2310 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_tr', nompro +#endif + call utad06 ( iaux, jaux, 1, nhtria, + > nbtrto, nbtrtn, 0, 0, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, + > pnivtr, paux, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbtrto = nbtrtn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 5. Les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Les quadrangles ; codret', codret +#endif +c + if ( nbqutn.gt.0 .and. nbquto.ne.nbqutn ) then +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 330 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_qu', nompro +#endif + call utal02 ( iaux, jaux, + > nhquad, nbqutn, kaux, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, paux, + > pnivqu, paux, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_qu', nompro +#endif + call utad06 ( iaux, jaux, 1, nhquad, + > nbquto, nbqutn, 0, 0, + > paux, paux, paux, paux, + > pfamqu, + > paux, paux, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx(nompro,nhquad) +c + if ( codret.eq.0 ) then +c + nbquto = nbqutn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,4) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 6. Les tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Les tetraedres ; codret', codret +#endif +c + if ( nbtetn.gt.0 .and. nbteto.ne.nbtetn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nhtria) +c + iaux = 3 + jaux = 2730 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_te', nompro +#endif + call utad06 ( iaux, jaux, 1, nhtetr, + > nbteto, nbtetn, 0, 0, + > phette, ptrite, pfilte, pperte, + > pfamte, + > paux, pcotrt, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbteto = nbtetn + nbtecf = nbtetn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 7. Les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Les pentaedres ; codret', codret +#endif +c + if ( nbpetn.gt.0 .and. nbpeto.ne.nbpetn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nhpent) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_pe', nompro +#endif + iaux = 7 + jaux = 390 + kaux = 0 + call utal02 ( iaux, jaux, + > nhpent, nbpetn, kaux, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, paux, + > paux , pcofap, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 7 + jaux = 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_pe', nompro +#endif + call utad06 ( iaux, jaux, 1, nhpent, + > nbpeto, nbpetn, 0, 0, + > paux, paux, paux, paux, + > pfampe, + > paux, paux, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbpeto = nbpetn + nbpecf = nbpetn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,7) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 8. Les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Les hexaedres ; codret', codret +#endif +c + if ( nbhetn.gt.0 .and. nbheto.ne.nbhetn ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx(nompro,nhhexa) +c + iaux = 6 + jaux = 390 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAL02_he', nompro +#endif + call utal02 ( iaux, jaux, + > nhhexa, nbhetn, kaux, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, paux, + > paux , pcoquh, paux, + > paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 6 + jaux = 7 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_he', nompro +#endif + call utad06 ( iaux, jaux, 1, nhhexa, + > nbheto, nbhetn, 0, 0, + > paux, paux, paux, paux, + > pfamhe, + > paux, paux, paux, + > paux, paux, paux, paux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbheto = nbhetn + nbhecf = nbhetn +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,6) + write (ulsort,texte(langue,5)) codret +#endif +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagr4.F b/src/tool/Modification/mmagr4.F new file mode 100644 index 00000000..14a395f3 --- /dev/null +++ b/src/tool/Modification/mmagr4.F @@ -0,0 +1,182 @@ + subroutine mmagr4 ( nbte06, tbaux5, tbaux6, + > aretri, + > tritet, cotrte, + > famtet, cfatet, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 4 +c - - --- - +c On marque chaque triangle et chaque arete avec la famille MED +c du tetraedre voisin. Quand une arete ou un triangle est voisin +c de deux familles differentes, la derniere valeur est gardee +c mais peu importe car ces aretes/triangles sont ailleurs +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbte06 . e . 1 . nombre de tetr. des j. ponctuels d'ordre 6 . +c . tbaux5 . s . nbarto . numero MED du volume de l'arete . +c . tbaux6 . s . nbtrto . numero MED du volume du triangle . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . e . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGR4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "coftex.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbte06 + integer tbaux5(nbarto), tbaux6(nbtrto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer famtet(nbteto), cfatet(nctfte,nbftet) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer letetr + integer listar(6) + integer fammed +c + integer nbmess + parameter ( nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c +c 1.2. ==> rien au depart +c + do 121 , iaux = 1 , nbarto + tbaux5(iaux) = 0 + 121 continue + do 122 , iaux = 1 , nbtrto + tbaux6(iaux) = 0 + 122 continue +c + codret = 0 +c +c==== +c 2. Parcours des tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,3) +#endif +c + kaux = nbteto - nbte06 +c + do 21 , iaux = 1 , kaux +c + letetr = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,3), letetr +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARTE', nompro +#endif + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + fammed = cfatet(cofamd,famtet(letetr)) +cgn write(ulsort,*) fammed + do 211 , jaux = 1 , 6 + tbaux5(listar(jaux)) = fammed + 211 continue + do 212 , jaux = 1 , 4 + tbaux6(tritet(letetr,jaux)) = fammed + 212 continue +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagr5.F b/src/tool/Modification/mmagr5.F new file mode 100644 index 00000000..e2d8f61c --- /dev/null +++ b/src/tool/Modification/mmagr5.F @@ -0,0 +1,423 @@ + subroutine mmagr5 ( nbduno, nbduar, nbdutr, nbtrjt, + > nbpejs, nbjoto, + > tbaux1, tbaux2, tbau30, tbau40, + > tbaux5, tbaux6, + > somare, + > aretri, + > tritet, famtet, cfatet, + > povoso, voisom, + > posifa, facare, + > voltri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 5 +c - - --- - +c Renumerotation des noeuds, aretes et triangles apres duplication +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbduno . e . 1 . nombre de duplications de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbdutr . e . 1 . nombre de duplications de triangles . +c . nbtrjt . e . 1 . nombre de triangles de joints triples . +c . nbpejs . e . 1 . nombre de pentaedres de joints simples . +c . nbjoto . e . 1 . nombre total de joints . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbaux2 . e .4*nbjoto. Pour le i-eme joint : . +c . . . . Numeros des familles MED des volumes . +c . . . . jouxtant le pentaedre/hexaedre, classes du . +c . . . . plus petit (1,i) au plus grand . +c . . . . 0, si pas de volume voisin . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbaux5 . e . nbarto . numero MED du volume de l'arete . +c . tbaux6 . e . nbtrto . numero MED du volume du triangle . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . arete liee a un nouveau noeud . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . merare . es . nbarto . mere des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . filtri . es . nbtrto . premier fils des triangles . +c . pertri . es . nbtrto . pere des triangles . +c . nivtri . es . nbtrto . niveau des triangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . filqua . es . nbquto . premier fils des quadrangles . +c . perqua . es . nbquto . pere des quadrangles . +c . nivqua . es . nbquto . niveau des quadrangles . +c . facpen . es .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . es .nbpecf*5. code des 5 faces des pentaedres . +c . famtet . e . nbteto . famille des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . perpen . e . nbpeto . pere des pentaedres . +c . famnoe . e . nbnoto . famille des noeuds . +c . famare . e . nbarto . famille des aretes . +c . famtri . e . nbtrto . famille des triangles . +c . famqua . e . nbquto . famille des quadrangles . +c . fampen . e . nbpeto . famille des pentaedres . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . e . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGR5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "coftex.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbduno, nbduar, nbdutr, nbtrjt + integer nbpejs, nbjoto + integer tbaux1(4,nbpejs), tbaux2(4,nbjoto) + integer tbau30(8,nbduno), tbau40(6,nbduar) + integer tbaux5(nbarto), tbaux6(nbtrto) + integer povoso(0:nbnoto), voisom(*) + integer somare(2,nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), voltri(2,nbtrto) + integer famtet(nbteto), cfatet(nctfte,nbftet) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer tbaux(2) + integer famhom, fammed(2) + integer letetr, letria, larete, laret0 + integer lenoeu, lenoe0(2) + integer nbtrol + integer indtri +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c + texte(1,31) = '(5x,''==> substitution par le '',a,i8)' +c + texte(2,31) = '(5x,''==> substitution by the '',a,i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbduar +#endif +c + codret = 0 +c +c 1.2. ==> vieux nombres +c + nbtrol = nbtrto - 2*nbdutr - nbtrjt +c +cgn write(ulsort,1001) 'tbaux2',4,nbjoto +cgn do 1101 , kaux = 1,nbjoto +cgn write(ulsort,1000) (tbaux2(jaux,kaux),jaux=1,4) +cgn 1101 continue +cgn 1000 format(10i9) +cgn 1001 format(a,4i6) +c +c==== +c 2. Parcours des triangles dupliques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,2) +#endif +c + indtri = nbtrol +c + do 2 , iaux = 1 , nbdutr +c + letria = tbaux1(1,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,2), letria +#endif +c +c 2.1. ==> On classe les deux tetraedres voisins. Par convention, le 1er +c est celui de plus petit numero de famille MED (cf. mmagr0) +c La face qui est dupliquee doit etre remplacee +c Pour les autres faces, on doit changer les aretes communes +c avec la face dupliquee. +c Pour les aretes de ces faces, ne bordant pas la face +c dupliquee, on doit changer les extremites. +c + fammed(1) = cfatet(cofamd,famtet(voltri(1,letria))) + fammed(2) = cfatet(cofamd,famtet(voltri(2,letria))) + if ( fammed(1).lt.fammed(2) ) then + tbaux(1) = 1 + tbaux(2) = 2 + else + tbaux(1) = 2 + tbaux(2) = 1 + endif +c +c 2.2. ==> Substitution +c + do 22 , jaux = 1 , 2 +c + letetr = voltri(tbaux(jaux),letria) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '. ', mess14(langue,1,3), letetr +#endif +c + indtri = indtri + 1 +c + do 221 , kaux = 1 , 4 +c + if ( tritet(letetr,kaux).eq.letria ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) mess14(langue,1,2), indtri +#endif + tritet(letetr,kaux) = indtri + goto 22 + endif +c + 221 continue +c + 22 continue +c + 2 continue +c +c==== +c 3. Parcours des aretes dupliquees +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c + do 3 , iaux = 1 , nbduar +c +c 3.1. ==> On repere les familles MED des deux volumes qui ont conduit +c a la duplication de l'arete +c + larete = tbau40(1,iaux) + famhom = tbau40(4,iaux) + fammed(1) = tbaux2(1,famhom) + fammed(2) = tbaux2(2,famhom) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete + write (ulsort,texte(langue,18)) ' ', mess14(langue,1,7), famhom + write (ulsort,*) ' ==> MED', fammed +#endif +c +c 3.2. ==> Parcours des faces s'enroulant autour de l'arete +c + jdeb = posifa(larete-1) + 1 + jfin = posifa(larete) + do 32 , jaux = jdeb , jfin +c + letria = facare(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '..', mess14(langue,1,2), letria +#endif +c + do 321 , kaux = 1 , 3 +c + if ( aretri(letria,kaux).eq.larete ) then + if ( tbaux6(letria).eq.fammed(1) ) then + laret0 = tbau40(2,iaux) + elseif ( tbaux6(letria).eq.fammed(2) ) then + laret0 = tbau40(3,iaux) + else + laret0 = aretri(letria,kaux) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ==> MED', tbaux6(letria) + write (ulsort,texte(langue,31)) mess14(langue,1,1), laret0 +#endif + aretri(letria,kaux) = laret0 + goto 32 + endif +c + 321 continue +c + 32 continue +c + 3 continue +c +c==== +c 4. Parcours des sommets dupliques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,-1) +#endif +c + do 4 , iaux = 1 , nbduno +c +c 3.1. ==> On repere les familles MED des deux volumes qui ont conduit +c a la duplication du noeud +c + lenoeu = tbau30(1,iaux) + famhom = tbau30(5,iaux) + fammed(1) = tbaux2(1,famhom) + fammed(2) = tbaux2(2,famhom) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) '.', mess14(langue,1,-1), lenoeu + write (ulsort,texte(langue,18)) ' ', mess14(langue,1,7), famhom + write (ulsort,*) ' ==> MED', fammed +#endif +c +c 3.2. ==> Parcours des aretes ayant ce noeud pour extremite +c + jdeb = povoso(lenoeu-1) + 1 + jfin = povoso(lenoeu) + do 42 , jaux = jdeb , jfin +c + larete = voisom(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '..', mess14(langue,1,1), larete +#endif +c + do 421 , kaux = 1 , 2 +c + lenoe0(kaux) = somare(kaux,larete) + if ( somare(kaux,larete).eq.lenoeu ) then + if ( tbaux5(larete).eq.fammed(1) ) then + lenoe0(kaux) = tbau30(3,iaux) + elseif ( tbaux5(larete).eq.fammed(2) ) then + lenoe0(kaux) = tbau30(4,iaux) + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ==> MED', tbaux5(larete) + write (ulsort,texte(langue,31)) mess14(langue,1,-1), lenoe0(kaux) +#endif + endif +c + 421 continue +c + somare(1,larete) = min(lenoe0(1),lenoe0(2)) + somare(2,larete) = max(lenoe0(1),lenoe0(2)) +c + 42 continue +c + 4 continue +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagr6.F b/src/tool/Modification/mmagr6.F new file mode 100644 index 00000000..72ede774 --- /dev/null +++ b/src/tool/Modification/mmagr6.F @@ -0,0 +1,494 @@ + subroutine mmagr6 ( nbduno, nbduar, nbdutr, + > tbaux1, tbau30, tbau40, + > tbaux2, tbaux5, tbaux6, + > coonoe, famnoe, + > somare, famare, + > aretri, famtri, arequa, + > tritet, facpen, + > anctri, noutri, + > ancare, nouare, + > ancnoe, nounoe, + > nbtrtn, nbartn, nbnotn, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGRegat - phase 6 +c - - --- - +c Suppression des noeuds, aretes et triangles dupliques +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbduno . e . 1 . nombre de duplications de noeuds . +c . nbduar . e . 1 . nombre de duplications d'aretes . +c . nbdutr . e . 1 . nombre de duplications de triangles . +c . tbaux1 . e .4*nbpejs. Pour le i-eme pentaedre de joint simple : . +c . . . . (1,i) : numero du triangle a dupliquer . +c . . . . (2,i) : numero du joint simple cree . +c . . . . (3,i) : tetraedre du cote min(fammed) . +c . . . . (4,i) : tetraedre du cote max(fammed) . +c . tbau30 . e .8*nbduno. Pour la i-eme duplication de noeud : . +c . . . . (1,i) : noeud a dupliquer . +c . . . . (2,i) : arete construite sur le noeud . +c . . . . (3,i) : noeud cree cote min(fammed) . +c . . . . (4,i) : noeud cree cote max(fammed) . +c . . . . (5,i) : numero du joint simple cree . +c . . . . (6,i) : arete entrant dans le cote 1 . +c . . . . (7,i) : arete entrant dans le cote 2 . +c . . . . (8,i) : ordre de multiplicite . +c . tbau40 . e .6*nbduar. Pour la i-eme duplication d'arete : . +c . . . . (1,i) : arete a dupliquer . +c . . . . (2,i) : arete creee cote min(fammed) . +c . . . . (3,i) : arete creee cote max(fammed) . +c . . . . (4,i) : numero du joint simple cree . +c . . . . (5,i) : ordre de multiplicite . +c . . . . (6,i) : arete d'orientation de joint . +c . tbaux2 . -- . nbnoto . auxiliaire . +c . tbaux5 . -- . nbarto . auxiliaire . +c . tbaux6 . -- . nbtrto . auxiliaire . +c . coonoe . es .nbnoto*3. coordonnees des noeuds . +c . famnoe . es . nbnoto . famille des noeuds . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . famare . es . nbarto . famille des aretes . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . famtri . es . nbtrto . famille des triangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangle . +c . tritet . e/s .nbtecf*4. numeros des 4 triangles des tetraedres . +c . facpen . e/s .nbpecf*5. numeros des 5 faces des pentaedres . +c . nbnotn . s . 1 . nombre de noeuds total nouveau . +c . nbartn . s . 1 . nombre d'aretes total nouveau . +c . nbtrtn . s . 1 . nombre de triangles total nouveau . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGR6' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "coftex.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbduno, nbduar, nbdutr + integer tbaux1(4,nbdutr), tbau30(8,nbduno), tbau40(6,nbduar) + integer tbaux2(nbnoto), tbaux5(nbarto), tbaux6(nbtrto) + integer famnoe(nbnoto) + integer somare(2,nbarto), famare(nbarto) + integer aretri(nbtrto,3), famtri(nbtrto) + integer arequa(nbquto,4) + integer tritet(nbtecf,4) + integer facpen(nbpecf,5) + integer anctri(nbtrto), noutri(0:nbtrto) + integer ancare(nbarto), nouare(0:nbarto) + integer ancnoe(nbnoto), nounoe(0:nbnoto) + integer nbtrtn, nbartn, nbnotn +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lepent, letetr, letria, lequad, larete + integer lenoeu + integer nbarmu, nbnomu +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "mmag01.h" +c + texte(1,31) = '(a,'' Traitement du '',a,i8,'', ordre'',i3)' +c + texte(2,31) = '(a,'' Treatment of the '',a,i8,'', order'',i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr +#endif +c + codret = 0 +c +c==== +c 2. Reperages +c==== +c 2.1. ==> Triangles +c + do 211 , iaux = 1 , nbtrto + tbaux6(iaux) = 0 + 211 continue +c + do 212 , iaux = 1 , nbdutr + letria = tbaux1(1,iaux) + tbaux6(letria) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) '.', mess14(langue,1,2), + > letria, tbaux6(letria) +#endif + 212 continue +c +c 2.2. ==> Aretes +c + do 221 , iaux = 1 , nbarto + tbaux5(iaux) = 0 + 221 continue +c + nbarmu = 0 + do 222 , iaux = 1 , nbduar + larete = tbau40(1,iaux) + if ( tbaux5(larete).ge.1 ) then + nbarmu = nbarmu + 1 +cgn write (ulsort,*)'LARETE',larete + endif + tbaux5(larete) = tbaux5(larete) + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) '.', mess14(langue,1,1), + > larete, tbaux5(larete) +#endif + 222 continue +c +c 2.3. ==> Noeuds +c + do 231 , iaux = 1 , nbnoto + tbaux2(iaux) = 0 + 231 continue +c + nbnomu = 0 + do 232 , iaux = 1 , nbduno + lenoeu = tbau30(1,iaux) + if ( tbaux2(lenoeu).ge.1 ) then + nbnomu = nbnomu + 1 +cgn write (ulsort,*)'LENOEU',lenoeu + endif + tbaux2(lenoeu) = tbaux2(lenoeu) +1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,31)) '.', mess14(langue,1,-1), + > lenoeu, tbaux2(lenoeu) +#endif + 232 continue +c +c==== +c 3. suppression des entites +c==== +c 3.1. ==> suppression des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.1. suppression tria ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + nbtrtn = 0 + noutri(0) = 0 +c + do 31 , letria = 1 , nbtrto +c + if ( tbaux6(letria).gt.0 ) then +c + noutri(letria) = 0 +c + else +c + nbtrtn = nbtrtn + 1 + anctri(nbtrtn) = letria + noutri(letria) = nbtrtn +c + endif +c + 31 continue +c + if ( nbtrtn+nbdutr.ne.nbtrto ) then + codret = 31 + endif +cgn print*,nbtrtn,nbdutr,nbtrto +c + endif +c +c 3.2. ==> suppression des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.2. suppression aret ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + nbartn = 0 + nouare(0) = 0 +c + do 32 , larete = 1 , nbarto +c + if ( tbaux5(larete).gt.0 ) then +c + nouare(larete) = 0 +c + else +c + nbartn = nbartn + 1 + ancare(nbartn) = larete + nouare(larete) = nbartn +c + endif +cgn write (ulsort,*) larete,tbaux5(larete),nbartn +c + 32 continue +c + if ( nbartn+nbduar-nbarmu.ne.nbarto ) then + codret = 32 + write (ulsort,*) nbartn,nbduar,nbarmu,nbarto + endif +cgn write (ulsort,*) nbartn,nbduar,nbarmu,nbarto +c + endif +c +c 3.3. ==> suppression des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3.3. suppression noeuds ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + nbnotn = 0 + nounoe(0) = 0 +c + do 33 , lenoeu = 1 , nbnoto +c + if ( tbaux2(lenoeu).gt.0 ) then +c + nounoe(lenoeu) = 0 +c + else +c + nbnotn = nbnotn + 1 + ancnoe(nbnotn) = lenoeu + nounoe(lenoeu) = nbnotn +c + endif +c + 33 continue +c + if ( nbnotn+nbduno-nbnomu.ne.nbnoto ) then + codret = 33 + write (ulsort,*) nbnotn,nbduno,nbnomu,nbnoto + endif +cgn write (ulsort,*) nbnotn,nbduno,nbnomu,nbnoto +c + endif +c +c==== +c 4. compactage des numerotations +c==== +c 4.1. ==> compactage des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.1 compactage tria ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c +c 4.1.1. ==> Impact sur la definition des tetraedres +c + do 411 , letetr = 1 , nbteto +c + do 4111 , iaux = 1 , 4 + tritet(letetr,iaux) = noutri(tritet(letetr,iaux)) + 4111 continue +c + 411 continue +c +c 4.1.2. ==> Impact sur la definition des pentaedres +c + do 412 , lepent = 1 , nbpeto +c + do 4121 , iaux = 1 , 2 + facpen(lepent,iaux) = noutri(facpen(lepent,iaux)) + 4121 continue +c + 412 continue +c +c 4.1.3. ==> Dans les tableaux des triangles, on ne traite pas : +c hettri : toujours = 0 +c mertri : toujours = 0 +c filtri : toujours = 0 +c + do 413 , letria = 1 , nbtrtn +c + do 4131, iaux = 1 , 3 + aretri(letria,iaux) = aretri(anctri(letria),iaux) + 4131 continue +c + famtri(letria) = famtri(anctri(letria)) +c + 413 continue +c + endif +c +c 4.2. ==> compactage des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.2 compactage aret ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c +c 4.2.1. ==> Impact sur la definition des triangles +c + do 421 , letria = 1 , nbtrtn +c +cgn write (ulsort,*) (nouare(aretri(letria,iaux)), iaux = 1 , 3) + do 4211, iaux = 1 , 3 + aretri(letria,iaux) = nouare(aretri(letria,iaux)) + 4211 continue +c + 421 continue +c +c 4.2.2. ==> Impact sur la definition des quadrangles +c + do 422 , lequad = 1 , nbquto +c +cgn write (ulsort,*) lequad,(arequa(lequad,iaux), iaux = 1,4) +cgn write (ulsort,*) lequad,(nouare(arequa(lequad,iaux)), iaux = 1,4) + do 4221, iaux = 1 , 4 + arequa(lequad,iaux) = nouare(arequa(lequad,iaux)) + 4221 continue +c + 422 continue +c +c 4.2.3. ==> Dans les tableaux des aretes, on ne traite pas : +c hetare : toujours = 0 +c merare : toujours = 0 +c filare : toujours = 0 +c + do 423 , larete = 1 , nbartn +c +cgn write (ulsort,*) larete +cgn write (ulsort,*) ancare(larete) + somare(1,larete) = somare(1,ancare(larete)) + somare(2,larete) = somare(2,ancare(larete)) +c + famare(larete) = famare(ancare(larete)) +c + 423 continue +c + endif +c +c 4.3 ==> compactage des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.3. compactage noeuds ; codret =', codret +#endif +c +c 4.3.1. ==> Impact sur la definition des aretes +c + if ( codret.eq.0 ) then +c + do 431 , larete = 1 , nbartn +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete +#endif + iaux = nounoe(somare(1,larete)) + jaux = nounoe(somare(2,larete)) + somare(1,larete) = min(iaux,jaux) + somare(2,larete) = max(iaux,jaux) +c + 431 continue +c +c 4.3.2. ==> Dans les tableaux des noeuds, on ne traite pas : +c hetnoe : toujours = 1 +c arenoe : toujours = 0 +c + do 432 , lenoeu = 1 , nbnotn +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu +#endif +c + if ( ancnoe(lenoeu).ne.lenoeu ) then +c + do 4321, iaux = 1 , sdim + coonoe(lenoeu,iaux) = coonoe(ancnoe(lenoeu),iaux) + 4321 continue +c + famnoe(lenoeu) = famnoe(ancnoe(lenoeu)) +c + endif +c + 432 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagre.F b/src/tool/Modification/mmagre.F new file mode 100644 index 00000000..080e7acb --- /dev/null +++ b/src/tool/Modification/mmagre.F @@ -0,0 +1,1451 @@ + subroutine mmagre ( lgopti, taopti, lgetco, taetco, + > nomail, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGREgat +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . nomail . e . char8 . nom de l'objet maillage homard iter. n . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGRE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "impr02.h" +c +#include "envca1.h" +#include "envada.h" +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombqu.h" +#include "nombpe.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer ulsort, langue, codret + integer lgetco + integer taetco(lgetco) +c + character*8 nomail +c +c 0.4. ==> variables locales +c + integer nrosec + integer iaux, jaux + integer nretap, nrsset + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer codre0 +c + integer nuroul, lnomfl + integer degre0 + integer nbnotn, nbartn, nbtrtn, nbqutn, nbtetn, nbpetn, nbhetn + integer pcoono, phetno, pareno, pderno + integer ppovos, pvoiso + integer pposif, pfacar + integer phetar, pfilar, pmerar, psomar + integer phettr, pfiltr, ppertr, pnivtr, paretr + integer phetqu, pfilqu, pperqu, pnivqu, parequ + integer phette, ptrite, pcotrt, pfilte, pperte + integer pquahe, pcoquh, phethe, pfilhe, pperhe + integer pfacpe, pcofap, phetpe, pfilpe, pperpe + integer pfamno + integer pfamar + integer pfamtr + integer pfamqu + integer pfamte, pcfate + integer pfampe, pcfape + integer pfamhe, pcfahe + integer advotr, advoqu + integer lgpptr, lgppqu, adpptr, adppqu + integer ptrav1, ptrav2, ptrav3, ptrav4 + integer ptra30, ptra40, ptra31, ptra41 + integer ptra51, ptra52, ptra53 + integer ptraat, ptrant + integer ptraaa, ptrana + integer ptraan, ptrann + integer nbduno, nbduar, nbdutr + integer nbjois, nbpejs + integer nbjoit, nbpejt, nbtrjt + integer nbjoiq, nbhejq, nbqujq + integer nbjp06, nbte06 + integer nbjp09, nbpe09 + integer nbjp12, nbhe12 + integer nbvojm, nbjoto + integer voarno, vofaar, vovoar, vovofa + integer ptra17, ptra18 + integer ptraw1, ptraw2, ptraw6 + integer nbgrfm, nbfmed, ngrouc + integer adnumf + integer adpoin, adtail, adtabl +c + character*6 saux + character*8 action + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3, ntrav4 + character*8 ntra30, ntra40, ntra31, ntra41 + character*8 ntra51, ntra52, ntra53 + character*8 ntraat, ntrant + character*8 ntraaa, ntrana + character*8 ntraan, ntrann + character*8 ntra17, ntra18 + character*8 ntraw1, ntraw2, ntraw6 + character*200 nomflo +c + double precision shrink +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' MAILLES DE JOINTS'')' + texte(1,5) = '(24(''=''),/)' + texte(1,7) = '(5x,''Nombre de '',a,'' a creer :'',i8)' + texte(1,8) = '(5x,''Nombre de '',a,'' a dupliquer :'',i8)' +c + texte(2,4) = '(/,a6,'' MESHES FOR THE JUNCTIONS'')' + texte(2,5) = '(31(''=''),/)' + texte(2,7) = '(5x,''Number of '',a,'' to create :'',i8)' + texte(2,8) = '(5x,''Number of '',a,'' to duplicate :'',i8)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 1.bis. fichier de sortie du bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '1.bis. fichier bilan codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI', nompro +#endif + action = 'modi ' + iaux = 1 + jaux = -1 + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, action, nbiter, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 2. conversion eventuelle en degre 1 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. conversion en degre 1 ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nomail, 3, degre0 , codret ) +c + endif +c + if ( degre0.eq.2 ) then + call gtdems (60) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'mmdeg0', nompro +#endif +c + call mmdeg0 ( nomail, + > ulsort, langue, codret ) +c + endif +c + call gtfims (60) + endif +c +c==== +c 3. structure generale +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. structure generale ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 3.2. ==> Tableaux +c + if ( codret.eq.0 ) then +c + iaux = 210 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > pfamar, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + iaux = 2310 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, jaux, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + iaux = 6734 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> les voisinages +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 15 + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > lgpptr, lgppqu, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGAN', nompro +#endif + call utvgan ( nhvois, nhnoeu, nharet, + > iaux, + > ppovos, pvoiso, + > ulsort, langue, codret) +c + endif +c +c==== +c 4. Verification +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Verification ; codret = ', codret +#endif +c +c 4.1. ==> Caracteristiques des groupes dans les familles MED +ccc call gmprsx (nompro,nhsupe//'.Tab5') +ccc call gmprsx (nompro,nhsupe//'.Tab6') +ccc call gmprsx (nompro,nhsupe//'.Tab9') +ccc call gmprsx (nompro,nhsups//'.Tab2') +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 9, nbfmed, codre1 ) + call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre2 ) + call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre3 ) + call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre4 ) + call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 5. Verification du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Verification ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGVE', nompro +#endif + call mmagve ( imem(pfamte), imem(pcfate), + > nbfmed, imem(adnumf), + > imem(adpoin), imem(adtail), smem(adtabl), + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Decompte des familles et des pentaedres a creer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Decompte ; codret = ', codret +#endif +c +c 6.1. ==> allocation des tableaux +c + if ( codret.eq.0 ) then +c + iaux = 4*nbtrto + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + iaux = 4*2*nbftet**2 +cgn print *,iaux/4 + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 6.2. ==> Decompte associe aux joints simples +c + if ( codret.eq.0 ) then + call gtdems (61) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR0', nompro +#endif + call mmagr0 ( imem(advotr), + > imem(pfamte), imem(pcfate), + > imem(ptrav1), imem(ptrav2), + > nbjois, nbpejs, + > ulsort, langue, codret ) + call gtfims (61) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbjois.eq.0 ) then + goto 1800 + endif +c + endif +c +c 6.3. ==> Tableaux +c + if ( codret.eq.0 ) then +c + iaux = 4 + call gmmod ( ntrav1, ptrav1, + > iaux, iaux, nbtrto, nbpejs, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + iaux = 8*3*nbpejs + call gmalot ( ntra30, 'entier ', iaux, ptra30, codre1 ) + iaux = 6*3*nbpejs + call gmalot ( ntra40, 'entier ', iaux, ptra40, codre2 ) + iaux = 2*3*nbpejs + call gmalot ( ntra31, 'entier ', iaux, ptra31, codre3 ) + iaux = 4*3*nbpejs + call gmalot ( ntra41, 'entier ', iaux, ptra41, codre4 ) + iaux = 4*3*nbpejs + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +cgn call gmprsx ( nompro//' apres MMAGR0, ntrav1 :', ntrav1 ) +c + endif +c +c 6.4. ==> Decompte des noeuds, aretes, quadrangles a creer/dupliquer +c et des familles deduites +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG10', nompro +#endif + call mmag10 ( imem(psomar), + > imem(paretr), + > imem(ptrite), imem(pcotrt), + > nbjois, nbpejs, imem(ptrav1), imem(ptrav2), + > imem(ptra30), imem(ptra40), + > imem(ptra31), imem(ptra41), + > nbduno, nbduar, nbdutr, + > nbnotn, nbartn, nbtrtn, nbqutn, + > nbtetn, nbpetn, nbhetn, + > nbjoit, nbpejt, nbtrjt, + > nbjoiq, nbhejq, nbqujq, + > nbjp06, nbte06, + > nbjp09, nbpe09, + > nbjp12, nbhe12, + > nbvojm, + > imem(ptrav3), + > ntra51, ptra51, ntra52, ptra52, + > ntra53, ptra53, + > ulsort, langue, codret ) +c +cgn call gmprsx(nompro//' apres MMAG10, ntra51 :',ntra51) +cgn call gmprsx(nompro//' apres MMAG10, ntra52 :',ntra52) +cgn call gmprsx(nompro//' apres MMAG10, ntra53 :',ntra53) +c + endif +c + if ( codret.eq.0 ) then +c + nbjoto = nbjois + nbjoit + nbjoiq + nbjp06 + nbjp09 + nbjp12 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr + write (ulsort,texte(langue,7)) mess14(langue,3,2), nbtrjt + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbqutn + write (ulsort,texte(langue,7)) mess14(langue,3,3), nbtetn + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpetn + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhetn +#endif +c + endif +c +c 6.5. ==> On raccourcit en fonction de ce qui a ete compte +c + if ( codret.eq.0 ) then +c + iaux = 4 + jaux = 2*nbftet**2 + call gmmod ( ntrav2, ptrav2, + > iaux, iaux, jaux, nbjoto, codre1 ) + iaux = 8 + jaux = 3*nbpejs + call gmmod ( ntra30, ptra30, + > iaux, iaux, jaux, nbduno, codre2 ) + iaux = 6 + jaux = 3*nbpejs + call gmmod ( ntra40, ptra40, + > iaux, iaux, jaux, nbduar, codre3 ) + iaux = 2 + jaux = 3*nbpejs + call gmmod ( ntra31, ptra31, + > iaux, iaux, jaux, nbtrjt, codre4 ) + iaux = 4 + jaux = 3*nbpejs + call gmmod ( ntra41, ptra41, + > iaux, iaux, jaux, nbvojm, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +cgn call gmprsx ( nompro, ntrav2 ) +cgn call gmprsx ( nompro, ntrav2 ) +cgn call gmprsx ( nompro, ntra31 ) +cgn call gmprsx ( nompro, ntra41 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav3 , codret ) +c + endif +c +c==== +c 7. Reallocation des tableaux du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. Reallocation ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gtdems (64) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR2', nompro +#endif + call mmagr2 ( nbnotn, nbartn, nbtrtn, nbqutn, + > nbtetn, nbpetn, nbhetn, + > nhnoeu, nharet, nhtria, nhquad, + > nhtetr, nhpent, nhhexa, + > phetno, pcoono, pareno, pderno, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, pfilte, pperte, pcotrt, + > phetpe, pfacpe, pfilpe, pperpe, pcofap, + > phethe, pquahe, pfilhe, pperhe, pcoquh, + > pfamno, pfamar, pfamtr, pfamqu, + > pfamte, pfampe, pfamhe, + > ulsort, langue, codret ) +c + call gtfims (64) +c + endif +c +c==== +c 8. Creation des noeuds, aretes, triangles, quadrangles, pentaedres, +c hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '8. Creation ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG30', nompro +#endif +c + call mmag30 ( nbduno, nbduar, nbdutr, + > nbpejs, + > nbpejt, nbtrjt, nbhejq, nbqujq, + > nbte06, nbpe09, nbhe12, + > nbvojm, + > nbjoto, nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > imem(ptrav1), imem(ptrav2), + > imem(ptra30), imem(ptra40), + > imem(ptra41), + > imem(ptra51), imem(ptra52), imem(ptra53), + > rmem(pcoono), imem(phetno), imem(pareno), + > imem(psomar), imem(phetar), + > imem(pfilar), imem(pmerar), + > imem(paretr), imem(phettr), + > imem(pfiltr), imem(ppertr), imem(pnivtr), + > imem(parequ), imem(phetqu), + > imem(pfilqu), imem(pperqu), imem(pnivqu), + > imem(ptrite), imem(pcotrt), + > imem(phette), imem(pfilte), imem(pperte), + > imem(pfacpe), imem(pcofap), + > imem(phetpe), imem(pfilpe), imem(pperpe), + > imem(pquahe), imem(pcoquh), + > imem(phethe), imem(pfilhe), imem(pperhe), + > imem(pfamno), imem(pfamar), + > imem(pfamtr), imem(pfamqu), + > imem(pfamte), imem(pfampe), imem(pfamhe), + > ulsort, langue, codret ) +cgn call gmprsx(nompro//' apres MMAG30, ntra52 :',ntra52) +cgn write (ulsort,*) mess14(langue,2,-1) +cgn call gmprsx(nompro,nhnoeu) +cgn call gmprsx(nompro,nhnoeu//'.Coor') +cgn call gmprsx(nompro,nhnoeu//'.AretSupp') +cgn call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,1) +cgn call gmprsx(nompro,nharet) +cgn call gmprsx(nompro,nharet//'.ConnDesc') +cgn call gmprsx(nompro,nharet//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,2) +cgn call gmprsx(nompro,nhtria) +cgn call gmprsx(nompro,nhtria//'.ConnDesc') +cgn call gmprsx(nompro,nhtria//'.HistEtat') +cgn call gmprsx(nompro,nhtria//'.Niveau') +cgn call gmprsx(nompro,nhtria//'.Fille') +cgn call gmprsx(nompro,nhtria//'.Mere') +cgn call gmprsx(nompro,nhtria//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,4) +cgn call gmprsx(nompro,nhquad) +cgn call gmprsx(nompro,nhquad//'.ConnDesc') +cgn call gmprsx(nompro,nhquad//'.HistEtat') +cgn call gmprsx(nompro,nhquad//'.Niveau') +cgn call gmprsx(nompro,nhquad//'.Fille') +cgn call gmprsx(nompro,nhquad//'.Mere') +cgn call gmprsx(nompro,nhquad//'.Famille') +cgn call gmprsx(nompro,nhquad//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,3) +cgn call gmprsx(nompro,nhtetr) +cgn call gmprsx(nompro,nhtetr//'.ConnDesc') +cgn call gmprsx(nompro,nhtetr//'.HistEtat') +cgn call gmprsx(nompro,nhtetr//'.InfoSupp') +cgn call gmprsx(nompro,nhtetr//'.Fille') +cgn call gmprsx(nompro,nhtetr//'.Mere') +cgn call gmprsx(nompro,nhtetr//'.Famille') +cgn call gmprsx(nompro,nhtetr//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,6) +cgn call gmprsx(nompro,nhhexa) +cgn call gmprsx(nompro,nhhexa//'.ConnDesc') +cgn call gmprsx(nompro,nhhexa//'.HistEtat') +cgn call gmprsx(nompro,nhhexa//'.InfoSupp') +cgn call gmprsx(nompro,nhhexa//'.Fille') +cgn call gmprsx(nompro,nhhexa//'.Mere') +cgn call gmprsx(nompro,nhhexa//'.Famille') +cgn call gmprsx(nompro,nhhexa//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,7) +cgn call gmprsx(nompro,nhpent) +cgn call gmprsx(nompro,nhpent//'.ConnDesc') +cgn call gmprsx(nompro,nhpent//'.HistEtat') +cgn call gmprsx(nompro,nhpent//'.InfoSupp') +cgn call gmprsx(nompro,nhpent//'.Fille') +cgn call gmprsx(nompro,nhpent//'.Mere') +cgn call gmprsx(nompro,nhpent//'.Famille') +cgn call gmprsx(nompro,nhpent//'.Famille.EntiFamm') +c + endif +c +c==== +c 9. Modification eventuelle des coordonnees +c 0 : aucune +c 1 : mod_joint_qt_d1 +c 2 : mod_joint_qua2_d1 +c 3 : mod_joint_qua_d1 +c 4 : mod_joint_tri_d1 +c 5 : mod_joint_tri_d2 +c -1 : automatique +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '9. Modif coordonnees ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + shrink = 0.95d0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGCO', nompro +#endif + call mmagco ( iaux, shrink, + > rmem(pcoono), + > imem(psomar), + > nbduno, imem(ptra30), + > ulsort, langue, codret ) +c + endif +c +c==== +c 10. Creation des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '10. Creation familles ; codret = ', codret +#endif +c +c 10.1. ==> Les utilitaires +c + if ( codret.eq.0 ) then +c + call gmalot ( ntraw1, 'entier ', nbjoto, ptraw1, codre1 ) + call gmalot ( ntraw2, 'entier ', nbjoto, ptraw2, codre2 ) + call gmalot ( ntraw6, 'reel ', nbjoto, ptraw6, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c 10.2. ==> Creation effective +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGF0', nompro +#endif + call mmagf0 ( nbjoto, nbjois, nbjoit, nbjoiq, + > nbjp06, nbjp09, nbjp12, + > nhnoeu, nhmapo, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhsupe, nhsups, + > ulsort, langue, codret ) +cgn write (ulsort,*) mess14(langue,2,2) +cgn call gmprsx(nompro,nhtria//'.Famille.Codes') +cgn write (ulsort,*) mess14(langue,2,4) +cgn call gmprsx(nompro,nhquad//'.Famille.Codes') +cgn write (ulsort,*) mess14(langue,2,3) +cgn call gmprsx(nompro,nhtetr//'.Famille.Codes') +cgn write (ulsort,*) mess14(langue,2,6) +cgn call gmprsx(nompro,nhhexa//'.Famille.Codes') +cgn write (ulsort,*) mess14(langue,2,7) +cgn call gmprsx(nompro,nhpent//'.Famille.Codes') +c + endif +c +c 10.3. ==> Reactualisation +c + if ( codret.eq.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > jaux, jaux, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 11. Reperage des grains +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '11. Reperage des grains ; codret = ', codret +#endif +c 11.1. ==> Les utilitaires +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav3, 'entier ', nbarto, ptrav3, codre1 ) + call gmalot ( ntrav4, 'entier ', nbtrto, ptrav4, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 11.2. ==> Reperage des grains +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '11.2. Grains ; codret = ', codret +#endif + + if ( codret.eq.0 ) then +c + call gtdems (76) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR4', nompro +#endif +c + call mmagr4 ( nbte06, imem(ptrav3), imem(ptrav4), + > imem(paretr), + > imem(ptrite), imem(pcotrt), + > imem(pfamte), imem(pcfate), + > ulsort, langue, codret ) +cc goto 5555 +c +cgn call gmprsx ( nompro, ntrav3 ) +cgn call gmprsx ( nompro, ntrav4 ) +c + call gtfims (76) +c + endif +c +c 11.3. ==> Repercussion dans les connectivites +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '11.3. Repercussion ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gtdems (77) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR5', nompro +#endif + call mmagr5 ( nbduno, nbduar, nbdutr, nbtrjt, + > nbpejs, nbjoto, + > imem(ptrav1), imem(ptrav2), + > imem(ptra30), imem(ptra40), + > imem(ptrav3), imem(ptrav4), + > imem(psomar), + > imem(paretr), + > imem(ptrite), imem(pfamte), imem(pcfate), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(advotr), + > ulsort, langue, codret ) +c + call gtfims (77) +c +cgn write (ulsort,*) mess14(langue,2,-1) +cgn call gmprsx(nompro,nhnoeu) +cgn call gmprsx(nompro,nhnoeu//'.Coor') +cgn call gmprsx(nompro,nhnoeu//'.HistEtat') +cgn call gmprsx(nompro,nhnoeu//'.AretSupp') +cgn call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,1) +cgn call gmprsx(nompro,nharet) +cgn call gmprsx(nompro,nharet//'.ConnDesc') +cgn call gmprsx(nompro,nharet//'.Fille') +cgn call gmprsx(nompro,nharet//'.Mere') +cgn call gmprsx(nompro,nharet//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,2) +cgn call gmprsx(nompro,nhtria) +cgn call gmprsx(nompro,nhtria//'.ConnDesc') +cgn call gmprsx(nompro,nhtria//'.HistEtat') +cgn call gmprsx(nompro,nhtria//'.Niveau') +cgn call gmprsx(nompro,nhtria//'.Fille') +cgn call gmprsx(nompro,nhtria//'.Mere') +cgn call gmprsx(nompro,nhtria//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,4) +cgn call gmprsx(nompro,nhquad) +cgn call gmprsx(nompro,nhquad//'.ConnDesc') +cgn call gmprsx(nompro,nhquad//'.HistEtat') +cgn call gmprsx(nompro,nhquad//'.Niveau') +cgn call gmprsx(nompro,nhquad//'.Fille') +cgn call gmprsx(nompro,nhquad//'.Mere') +cgn call gmprsx(nompro,nhquad//'.Famille') +cgn call gmprsx(nompro,nhquad//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,3) +cgn call gmprsx(nompro,nhtetr) +cgn call gmprsx(nompro,nhtetr//'.ConnDesc') +cgn call gmprsx(nompro,nhtetr//'.HistEtat') +cgn call gmprsx(nompro,nhtetr//'.InfoSupp') +cgn call gmprsx(nompro,nhtetr//'.Fille') +cgn call gmprsx(nompro,nhtetr//'.Mere') +cgn call gmprsx(nompro,nhtetr//'.Famille') +cgn call gmprsx(nompro,nhtetr//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,7) +cgn call gmprsx(nompro,nhpent) +cgn call gmprsx(nompro,nhpent//'.ConnDesc') +cgn call gmprsx(nompro,nhpent//'.HistEtat') +cgn call gmprsx(nompro,nhpent//'.InfoSupp') +cgn call gmprsx(nompro,nhpent//'.Fille') +cgn call gmprsx(nompro,nhpent//'.Mere') +cgn call gmprsx(nompro,nhpent//'.Famille') +cgn call gmprsx(nompro,nhpent//'.Famille.EntiFamm') + endif +c +c==== +c 12. Taille des joints +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '12. Taille des joints ; codret = ', codret +#endif +c 12.1. ==> Les donnees +c + if ( codret.eq.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > jaux, jaux, jaux, jaux, + > pfamte, pcfate, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > jaux, jaux, jaux, jaux, + > pfampe, pcfape, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 259 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > jaux, jaux, jaux, jaux, + > pfamhe, pcfahe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 6, iaux, codre1 ) + call gmliat ( nhsupe, 9, nbfmed, codre2 ) + call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre3 ) + call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre4 ) + call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre5 ) + call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + ngrouc = iaux/10 +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 10*ngrouc + call gmalot ( ntra17, 'chaine ', iaux, ptra17, codre1 ) + iaux = ngrouc + nbfmed + call gmalot ( ntra18, 'entier ', iaux, ptra18, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 12.2. ==> Liste des noms des groupes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMLG', nompro +#endif + call utfmlg ( nbfmed, ngrouc, + > imem(adpoin), imem(adtail), smem(adtabl), + > nbgrfm, smem(ptra17), imem(ptra18), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbgrfm', nbgrfm + call gmprsx ( nompro, ntra17 ) + call gmprsx ( nompro, ntra18 ) +#endif +c + endif +c +c 12.3. ==> Affichage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAG40', nompro +#endif +c + call mmag40 ( nbpejs, nbpejt, nbhejq, + > nbvojm, nbjoto, + > nbjois, nbjoit, nbjoiq, + > imem(ptrav1), imem(ptra41), + > rmem(pcoono), imem(psomar), imem(paretr), + > imem(pfamhe), imem(pcfahe), + > imem(pfampe), imem(pcfape), + > nbfmed, imem(adnumf), + > imem(adpoin), imem(adtail), smem(adtabl), + > nbgrfm, smem(ptra17), imem(ptra18), + > imem(ptraw1), rmem(ptraw6), + > imem(ptraw2), + > nuroul, + > ulsort, langue, codret ) +c + endif +c +c==== +c 13. Suppression des entites dupliquees +c==== +c 13.1. ==> Tableaux de travail +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '13.1. Tab de travail ; codret = ', codret +#endif + call gtdems (78) +c + if ( codret.eq.0 ) then + call gmlboj ( ntrav2 , codret ) + endif +c + if ( codret.eq.0 ) then + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codret ) + endif +c + if ( codret.eq.0 ) then +c + call gmalot ( ntraat, 'entier ', nbtrto, ptraat, codre1 ) + iaux = nbtrto+1 + call gmalot ( ntrant, 'entier ', iaux, ptrant, codre2 ) + call gmalot ( ntraaa, 'entier ', nbarto, ptraaa, codre3 ) + iaux = nbarto+1 + call gmalot ( ntrana, 'entier ', iaux, ptrana, codre4 ) + call gmalot ( ntraan, 'entier ', nbnoto, ptraan, codre5 ) + iaux = nbnoto+1 + call gmalot ( ntrann, 'entier ', iaux, ptrann, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c +c 13.2. ==> Nettoyage de la structure des voisins +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '13.2. Voisins ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then + call gmlboj ( nhvois, codret ) + endif + if ( codret.eq.0 ) then + call gmaloj ( nomail//'.Voisins' , ' ', 0, iaux, codret ) + endif + if ( codret.eq.0 ) then + call gmnomc ( nomail//'.Voisins' , nhvois, codret ) + endif +c +c 13.3. ==> Suppression effective +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '13.3. suppression ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR6', nompro +#endif + call mmagr6 ( nbduno, nbduar, nbdutr, + > imem(ptrav1), imem(ptra30), imem(ptra40), + > imem(ptrav2), imem(ptrav3), imem(ptrav4), + > rmem(pcoono), imem(pfamno), + > imem(psomar), imem(pfamar), + > imem(paretr), imem(pfamtr), + > imem(parequ), + > imem(ptrite), imem(pfacpe), + > imem(ptraat), imem(ptrant), + > imem(ptraaa), imem(ptrana), + > imem(ptraan), imem(ptrann), + > nbtrtn, nbartn, nbnotn, + > ulsort, langue, codret ) +c + endif + call gtfims (78) +c +c==== +c 14. Reallocation des tableaux du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '14. Reallocation ; codret = ', codret +#endif + call gtdems (64) +c +c 14.1. ==> Reallocation +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGR2', nompro +#endif +c + if ( codret.eq.0 ) then +c + nbqutn = -1 + nbpetn = -1 + call mmagr2 ( nbnotn, nbartn, nbtrtn, nbqutn, + > nbtetn, nbpetn, nbhetn, + > nhnoeu, nharet, nhtria, nhquad, + > nhtetr, nhpent, nhhexa, + > phetno, pcoono, pareno, pderno, + > phetar, psomar, pfilar, pmerar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > phette, ptrite, pfilte, pperte, pcotrt, + > phetpe, pfacpe, pfilpe, pperpe, pcofap, + > phethe, pquahe, pfilhe, pperhe, pcoquh, + > pfamno, pfamar, pfamtr, pfamqu, + > pfamte, pfampe, pfamhe, + > ulsort, langue, codret ) +c + endif +c +c 14.2. ==> Mise a jour +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '14.2. Mise a jour ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + nbnoma = nbnoto + nbnop1 = nbnoto + numap1 = nbnoto + nbarac = nbarto + nbarma = nbarto + nbarpe = nbarto + nbtrac = nbtrto + nbtrma = nbtrto + nbtrpe = nbtrto + nbquac = nbquto + nbquma = nbquto + nbqupe = nbquto + nbteac = nbteto + nbtema = nbteto + nbtepe = nbteto + nbpeac = nbpeto + nbpema = nbpeto + nbpepe = nbpeto + nbheac = nbheto + nbhema = nbheto + nbhepe = nbheto +c + endif + call gtfims (64) +cgn write (ulsort,*) mess14(langue,2,-1) +cgn call gmprsx(nompro,nhnoeu) +cgn call gmprsx(nompro,nhnoeu//'.Coor') +cgn call gmprsx(nompro,nhnoeu//'.HistEtat') +cgn call gmprsx(nompro,nhnoeu//'.AretSupp') +cgn call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,1) +cgn call gmprsx(nompro,nharet) +cgn call gmprsx(nompro,nharet//'.ConnDesc') +cgn call gmprsx(nompro,nharet//'.Fille') +cgn call gmprsx(nompro,nharet//'.Mere') +cgn call gmprsx(nompro,nharet//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,2) +cgn call gmprsx(nompro,nhtria) +cgn call gmprsx(nompro,nhtria//'.ConnDesc') +cgn call gmprsx(nompro,nhtria//'.HistEtat') +cgn call gmprsx(nompro,nhtria//'.Niveau') +cgn call gmprsx(nompro,nhtria//'.Fille') +cgn call gmprsx(nompro,nhtria//'.Mere') +cgn call gmprsx(nompro,nhtria//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,4) +cgn call gmprsx(nompro,nhquad) +cgn call gmprsx(nompro,nhquad//'.ConnDesc') +cgn call gmprsx(nompro,nhquad//'.HistEtat') +cgn call gmprsx(nompro,nhquad//'.Niveau') +cgn call gmprsx(nompro,nhquad//'.Fille') +cgn call gmprsx(nompro,nhquad//'.Mere') +cgn call gmprsx(nompro,nhquad//'.Famille') +cgn call gmprsx(nompro,nhquad//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,3) +cgn call gmprsx(nompro,nhtetr) +cgn call gmprsx(nompro,nhtetr//'.ConnDesc') +cgn call gmprsx(nompro,nhtetr//'.HistEtat') +cgn call gmprsx(nompro,nhtetr//'.InfoSupp') +cgn call gmprsx(nompro,nhtetr//'.Fille') +cgn call gmprsx(nompro,nhtetr//'.Mere') +cgn call gmprsx(nompro,nhtetr//'.Famille') +cgn call gmprsx(nompro,nhtetr//'.Famille.EntiFamm') +cgn write (ulsort,*) mess14(langue,2,7) +cgn call gmprsx(nompro,nhpent) +cgn call gmprsx(nompro,nhpent//'.ConnDesc') +cgn call gmprsx(nompro,nhpent//'.HistEtat') +cgn call gmprsx(nompro,nhpent//'.InfoSupp') +cgn call gmprsx(nompro,nhpent//'.Fille') +cgn call gmprsx(nompro,nhpent//'.Mere') +cgn call gmprsx(nompro,nhpent//'.Famille') +cgn call gmprsx(nompro,nhpent//'.Famille.EntiFamm') +c +c==== +c 15. Conversion eventuelle en degre 2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '15. Conversion degre 2 ; codret = ', codret +#endif +c + if ( degre0.eq.2 ) then +c + call gtdems (79) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMDEG0', nompro +#endif +c + call mmdeg0 ( nomail, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + call gtfims (79) +c + endif +c +c==== +c 16. mise a jour des grandeurs caracteristiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '16. mise a jour ; codret = ', codret +#endif +c +c 16.1. ==> nbmane : nombre maximal de noeuds par element +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then + if ( nbjoiq.eq.0 ) then + nbmane = 6 + else + nbmane = 8 + endif + else + if ( nbjoiq.eq.0 ) then + nbmane = 15 + else + nbmane = 20 + endif + endif +c +cgn print *, nbmane + call gmecat ( nomail, 8, nbmane , codret ) +c + endif +c +c 16.2. ==> determination des voisinages +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '15.2. ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + voarno = 1 + vofaar = 1 + vovoar = 0 + vovofa = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro, nhvois ) +cgn call gmprsx (nompro, nhvois//'.0D/1D' ) +cgn call gmprsx (nompro, nhvois//'.0D/1D.Pointeur' ) +cgn call gmprsx (nompro, nhvois//'.0D/1D.Table' ) +cgn call gmprsx (nompro, nhvois//'.1D/2D' ) +cgn call gmprsx (nompro, nhvois//'.Vol/Tri' ) +cgn call gmprsx (nompro, nhvois//'.Vol/Qua' ) +cgn call gmprsx (nompro, nhvois//'.PyPe/Tri' ) +cgn call gmprsx (nompro, nhvois//'.PyPe/Qua' ) +c +c==== +c 17. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '17. Menage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) + call gmlboj ( ntrav3 , codre3 ) + call gmlboj ( ntrav4 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmlboj ( ntraw1 , codre1 ) + call gmlboj ( ntraw2 , codre2 ) + call gmlboj ( ntraw6 , codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +cgn print *,codre1, codre2, codre3 +c + call gmlboj ( ntra30 , codre1 ) + call gmlboj ( ntra40 , codre2 ) + call gmlboj ( ntra31 , codre3 ) + call gmlboj ( ntra41 , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +cgn print *,codre1, codre2, codre3, codre4 +c + call gmlboj ( ntra51 , codre1 ) + call gmlboj ( ntra52 , codre2 ) + call gmlboj ( ntra53 , codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +cgn print *,codre1, codre2 +c + call gmlboj ( ntraat , codre1 ) + call gmlboj ( ntrant , codre2 ) + call gmlboj ( ntraaa , codre3 ) + call gmlboj ( ntrana , codre4 ) + call gmlboj ( ntraan , codre5 ) + call gmlboj ( ntrann , codre6 ) +cgn print *,codre1, codre2, codre3, codre4, codre5, +cgn > codre6 +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + call gmlboj ( ntra17, codre1 ) + call gmlboj ( ntra18, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 18. la fin +c==== +c + 1800 continue +c +c 18.1. ==> erreurs +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 18.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmagve.F b/src/tool/Modification/mmagve.F new file mode 100644 index 00000000..1a43c86f --- /dev/null +++ b/src/tool/Modification/mmagve.F @@ -0,0 +1,251 @@ + subroutine mmagve ( famtet, cfatet, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - AGregat - VErifications +c - - -- -- +c Verifications de la possibilite de calculer les joints +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . e . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . nbfmed . e . 1 . nombre de familles MED dans le maillage . +c . numfam . e . nbfmed . numero MED des familles . +c . grfmpo . e .0:nbfmed. groupes calcul - pointeur . +c . grfmta . e . * . groupes calcul - taille . +c . grfmtb . e . * . groupes calcul - table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMAGVE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "coftex.h" +#include "nbfami.h" +#include "dicfen.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed), grfmtl(*) +c + character*8 grfmtb(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre0 +c + integer letetr + integer fammed, nufali + integer ptrdeb, ptrfin +c + character*80 saux80 +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#include "mmag01.h" +c + texte(1,31) = + >'(''Les seules mailles volumiques possibles sont les '',a,''.'')' + texte(1,32) = + >'(''Impossible de trouver la famille MED dans la liste.'')' + texte(1,33) = '(''Nombre de groupes :'',i4)' + texte(1,34) = + > '(''Un '',a,'' doit appartenir a un groupe et un seul.'')' + texte(1,35) = '(''. Groupe : '',a)' +c + texte(2,31) = + >'(''The only authorized volumic meshes are the '',a,''.'')' + texte(2,32) = '(''MED family cannot be found into the list.'')' + texte(2,33) = '(''Number of groups:'',i4)' + texte(2,34) = + > '(''A '',a,'' must belong to one single group.'')' + texte(2,35) = '(''. Group: '',a)' +c + codret = 0 +c +c==== +c 2. Uniquement des tetraedres +c==== +c +cgn write (ulsort,90002) 'nbteto', nbteto +cgn write (ulsort,90002) 'nbheto', nbheto +cgn write (ulsort,90002) 'nbpyto', nbpyto +cgn write (ulsort,90002) 'nbpeto', nbpeto + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + codret = 2 + endif +c +c==== +c 3. Parcours des tetraedres +c Si la famille MED du tetraedre n'a pas exactement un groupe, +c il y a un probleme +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,3) +#endif +c + if ( codret.eq.0 ) then +c + do 30 , iaux = 1 , nbteto +c +c 3.1. ==> Reperage de la famille MED +c + if ( codret.eq.0 ) then +c + fammed = cfatet(cofamd,famtet(iaux)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,30)) mess14(langue,1,3), iaux, fammed +#endif +c + do 31 , jaux = 1 , nbfmed + if ( fammed.eq.numfam(jaux) ) then + nufali = jaux +cgn write (ulsort,90002) 'fammed nufali',fammed,nufali + goto 310 + endif + 31 continue +c + letetr = iaux + codret = 31 +c + 310 continue +c + endif +c +c 3.2. ==> Nombre de groupes de la famille MED +c + if ( codret.eq.0 ) then +c + ptrdeb = grfmpo(nufali-1) + 1 + ptrfin = grfmpo(nufali) +c +cgn write (ulsort,90002) 'ptrdeb ptrfin',ptrdeb,ptrfin + if ( ptrfin.ne.ptrdeb+9 ) then + letetr = iaux + codret = 320 + ( ptrfin-ptrdeb + 1 ) / 10 + endif +c + endif +c + 30 continue +c + endif +c +c==== +c 4. Messages d'erreur +c==== +c + if ( codret.ne.0 ) then +c + if ( codret.eq.2 ) then + write (ulsort,texte(langue,31)) mess14(langue,3,3) + else + write (ulsort,texte(langue,30)) mess14(langue,1,3), + > letetr, fammed + if ( codret.eq.31 ) then + write (ulsort,texte(langue,32)) + else + jaux = codret - 320 + write (ulsort,texte(langue,33)) jaux + do 41 , iaux = 1 , jaux + kaux = grfmtl(ptrdeb) + call uts8ch ( grfmtb(ptrdeb), kaux, saux80, + > ulsort, langue, codre0 ) + write (ulsort,texte(langue,35)) saux80(1:kaux) + ptrdeb = ptrdeb + 10 + 41 continue + write (ulsort,texte(langue,34)) mess14(langue,1,3) + endif + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmcnp2.F b/src/tool/Modification/mmcnp2.F new file mode 100644 index 00000000..3460d579 --- /dev/null +++ b/src/tool/Modification/mmcnp2.F @@ -0,0 +1,163 @@ + subroutine mmcnp2 ( nomail, nhnoeu, nharet, + > indnoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - DEGRe +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nhnoeu . e . ch8 . branche des noeuds dans le maillage . +c . nharet . e . ch8 . branche des aretes dans le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMCNP2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +c +#include "nombar.h" +#include "nombno.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + character*8 nomail + character*8 nhnoeu, nharet +c + integer indnoe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer codre1, codre2, codre3, codre4 + integer phetno, pareno, pcoono + integer pfamno, pnp2ar + integer un + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#include "impr01.h" +c ______________________________________________________________________ +c +c==== +c 1. Reallocation des tableaux +c==== +c + if ( codret.eq.0 ) then +c + un = 1 +c + call gmmod ( nhnoeu//'.Coor', + > pcoono, nbnoto, nouvno, sdim, sdim, codre1 ) + call gmmod ( nhnoeu//'.HistEtat', + > phetno, nbnoto, nouvno, un, un, codre2 ) + call gmmod ( nhnoeu//'.AretSupp', + > pareno, nbnoto, nouvno, un, un, codre3 ) + call gmmod ( nhnoeu//'.Famille.EntiFamm', + > pfamno, nbnoto, nouvno, un, un, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nharet//'.InfoSupp', ' ', nbarto, pnp2ar, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +c==== +c 2. creation des noeuds +c==== +c + if ( codret.eq.0 ) then +c + jaux = pnp2ar + nbarto - 1 + do 21 , iaux = pnp2ar , jaux + imem(iaux) = 0 + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMNO22', nompro +#endif + call cmno22 ( nomail, + > indnoe, 1, nouvar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmdeg0.F b/src/tool/Modification/mmdeg0.F new file mode 100644 index 00000000..8af8ee08 --- /dev/null +++ b/src/tool/Modification/mmdeg0.F @@ -0,0 +1,543 @@ + subroutine mmdeg0 ( nomail, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - DEGre - phase 0 +c - - --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iter. n . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMDEG0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +c +#include "nombar.h" +#include "nombno.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + integer indnoe + integer degnou + integer nbsegm, nbtria, nbquad, nbtetr, nbhexa, nbpyra, nbpent + integer nbfare, pcfaar + integer nbftri, pcfatr + integer nbfqua, pcfaqu + integer nbftet, pcfate + integer nbfhex, pcfahe + integer nbfpyr, pcfapy + integer nbfpen, pcfape + integer adnbrn +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nharfa, nhtrfa, nhqufa + character*8 nhtefa, nhhefa, nhpyfa, nhpefa +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Passage du degre '',i1,'' au degre '',i1,/)' +c + texte(2,4) = '(5x,''From degree '',i1,'' to '',i1,/)' +c +c==== +c 2. structure de donnees +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +cgn call gmprsx (nompro, nomail ) +cgn call gmprsx (nompro, nomail//'.Volume' ) +cgn call gmprsx (nompro, nomail//'.Volume.HOM_Te04' ) +cgn call gmprsx (nompro, nharet//'.Famille' ) +cgn call gmprsx (nompro, nhtria//'.Famille' ) +cgn call gmprsx (nompro, nhquad//'.Famille' ) +cgn call gmprsx (nompro, nhtetr//'.Famille' ) +cgn call gmprsx(nompro,nhtetr//'.Famille') +c +c 2.2. ==> grandeurs +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then +c + degnou = 2 + nouvar = nbarto + nouvno = nbnoto + nbarto + indnoe = nbnoto +c + else +c + degnou = 1 + nouvno = nbnoto +c + endif +c + write (ulsort,texte(langue,4)) degre, degnou +c + endif +c +c==== +c 3. changement de degre pour les noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. chang. de degre noeuds; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Creation des noeuds P2 +c + if ( degre.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMCNP2', nompro +#endif +c + call mmcnp2 ( nomail, nhnoeu, nharet, + > indnoe, + > ulsort, langue, codret ) +c +c 3.2. ==> Suppression des noeuds P2 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMSNP2', nompro +#endif +c + call mmsnp2 ( nomail, + > indnoe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. changement de degre pour les elements +c les elements etant decrits par connectivite descendante, celle-ci +c est invariante par un changement de degre. Il suffit de changer la +c localisation de la branche. +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. chang. de degre elem ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then +c + call gmcpgp ( nharet, nomail//'.Arete.HOM_Se03' , codre1 ) + call gmcpgp ( nhtria, nomail//'.Face.HOM_Tr06' , codre2 ) + call gmcpgp ( nhquad, nomail//'.Face.HOM_Qu08' , codre3 ) + call gmcpgp ( nhtetr, nomail//'.Volume.HOM_Te10', codre4 ) + call gmcpgp ( nhpyra, nomail//'.Volume.HOM_Py13', codre5 ) + call gmcpgp ( nhhexa, nomail//'.Volume.HOM_He20', codre6 ) + call gmcpgp ( nhpent, nomail//'.Volume.HOM_Pe15', codre7 ) +c + else +c + call gmcpgp ( nharet, nomail//'.Arete.HOM_Se02' , codre1 ) + call gmcpgp ( nhtria, nomail//'.Face.HOM_Tr03' , codre2 ) + call gmcpgp ( nhquad, nomail//'.Face.HOM_Qu04' , codre3 ) + call gmcpgp ( nhtetr, nomail//'.Volume.HOM_Te04', codre4 ) + call gmcpgp ( nhpyra, nomail//'.Volume.HOM_Py05', codre5 ) + call gmcpgp ( nhhexa, nomail//'.Volume.HOM_He08', codre6 ) + call gmcpgp ( nhpent, nomail//'.Volume.HOM_Pe06', codre7 ) +c + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( nharet, codre1 ) + call gmlboj ( nhtria, codre2 ) + call gmlboj ( nhquad, codre3 ) + call gmlboj ( nhtetr, codre4 ) + call gmlboj ( nhpyra, codre5 ) + call gmlboj ( nhhexa, codre6 ) + call gmlboj ( nhpent, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c==== +c 5. mise a jour des grandeurs caracteristiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. mise a jour ; codret = ', codret +#endif +c +c 5.1. ==> nbmane : nombre maximal de noeud par element +c + if ( codret.eq.0 ) then +c + call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMH', nompro +#endif + call utnbmh ( imem(adnbrn), + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, + > iaux, iaux, iaux, iaux, + > iaux, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > iaux, iaux, + > iaux, iaux, + > ulsort, langue, codret ) +cgn print *, nbmane +cgn print *, nbsegm, nbtria, nbquad, nbtetr, nbhexa, nbpent +c + if ( degnou.eq.1 ) then +c + if ( nbhexa.gt.0 ) then + nbmane = 8 + elseif ( nbpent.gt.0 ) then + nbmane = 6 + elseif ( nbpyra.gt.0 ) then + nbmane = 5 + elseif ( nbtetr.gt.0 .or. nbquad.gt.0 ) then + nbmane = 4 + elseif ( nbtria.gt.0 ) then + nbmane = 3 + elseif ( nbsegm.gt.0 ) then + nbmane = 2 + else + nbmane = 1 + endif +c + else +c + if ( nbhexa.gt.0 ) then + nbmane = 20 + elseif ( nbpent.gt.0 ) then + nbmane = 15 + elseif ( nbpyra.gt.0 ) then + nbmane = 13 + elseif ( nbtetr.gt.0 ) then + nbmane = 10 + elseif ( nbquad.gt.0 ) then + nbmane = 8 + elseif ( nbtria.gt.0 ) then + nbmane = 6 + elseif ( nbsegm.gt.0 ) then + nbmane = 3 + else + nbmane = 1 + endif +c + endif +c +cgn print *, nbmane + call gmecat ( nomail, 8, nbmane , codret ) +c + endif +c +c 5.2. ==> le nombres d'entites +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.2. nombre entites ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + nbnop2 = nbarto - nbnop2 + nbnoto = indnoe + degre = degnou +c + call gmecat ( nhnoeu, 1, nbnoto, codre1 ) + call gmecat ( nomail, 3, degre , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 5.3. ==> reperage des tableaux des types d'elements +c attention, il faut refaire un appel a utnomh, car les +c branches ont ete permutees entre degres ... +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.3. reperage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c call gmprsx (nompro,nomail) +c call gmprsx (nompro,nomail//'.Volume') +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nharet//'.Famille', nharfa, codre1 ) + call gmnomc ( nhtria//'.Famille', nhtrfa, codre2 ) + call gmnomc ( nhquad//'.Famille', nhqufa, codre3 ) + call gmnomc ( nhtetr//'.Famille', nhtefa, codre4 ) + call gmnomc ( nhhexa//'.Famille', nhhefa, codre5 ) + call gmnomc ( nhpyra//'.Famille', nhpyfa, codre6 ) + call gmnomc ( nhpent//'.Famille', nhpefa, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nharfa, 1, nbfare, codre1 ) + call gmliat ( nhtrfa, 1, nbftri, codre2 ) + call gmliat ( nhqufa, 1, nbfqua, codre3 ) + call gmliat ( nhtefa, 1, nbftet, codre4 ) + call gmliat ( nhpyfa, 1, nbfpyr, codre5 ) + call gmliat ( nhhefa, 1, nbfhex, codre6 ) + call gmliat ( nhpefa, 1, nbfpen, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 , codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nharfa//'.Codes' , pcfaar, iaux, codre1 ) + call gmadoj ( nhtrfa//'.Codes' , pcfatr, iaux, codre2 ) + call gmadoj ( nhqufa//'.Codes' , pcfaqu, iaux, codre3 ) + call gmadoj ( nhtefa//'.Codes' , pcfate, iaux, codre4 ) + call gmadoj ( nhpyfa//'.Codes' , pcfapy, iaux, codre5 ) + call gmadoj ( nhhefa//'.Codes' , pcfahe, iaux, codre6 ) + call gmadoj ( nhpefa//'.Codes' , pcfape, iaux, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c 5.4. ==> on echange le code du second champ de la description des +c familles : c'est celui qui designe le type de l'element +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.4. echange de code ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Avant appel a mmelde, codes des familles : ' + call gmprsx (nompro, nharfa//'.Codes' ) + call gmprsx (nompro, nhtrfa//'.Codes' ) + call gmprsx (nompro, nhqufa//'.Codes' ) + call gmprsx (nompro, nhtefa//'.Codes' ) + call gmprsx (nompro, nhpyfa//'.Codes' ) + call gmprsx (nompro, nhhefa//'.Codes' ) + call gmprsx (nompro, nhpefa//'.Codes' ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMELDE', nompro +#endif + call mmelde ( typcca, + > nbfare, imem(pcfaar), + > nbftri, imem(pcfatr), + > nbfqua, imem(pcfaqu), + > nbftet, imem(pcfate), + > nbfhex, imem(pcfahe), + > nbfpyr, imem(pcfapy), + > nbfpen, imem(pcfape), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Apres appel a mmelde, codes des familles : ' + call gmprsx (nompro, nharfa//'.Codes' ) + call gmprsx (nompro, nhtrfa//'.Codes' ) + call gmprsx (nompro, nhqufa//'.Codes' ) + call gmprsx (nompro, nhtefa//'.Codes' ) + call gmprsx (nompro, nhpyfa//'.Codes' ) + call gmprsx (nompro, nhhefa//'.Codes' ) + call gmprsx (nompro, nhpefa//'.Codes' ) +#endif +c + endif +c +c==== +c 6. suppression des voisins par noeuds s'ils existent +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. voisins ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmobal ( nhvois//'.0D/1D', codre0 ) +c + if ( codre0.eq.1 ) then +c + call gmlboj ( nhvois//'.0D/1D', codret ) +c + elseif ( codre0.ne.0 ) then +c + codret = 5 +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmdegr.F b/src/tool/Modification/mmdegr.F new file mode 100644 index 00000000..1a8bf8c3 --- /dev/null +++ b/src/tool/Modification/mmdegr.F @@ -0,0 +1,153 @@ + subroutine mmdegr ( lgopti, taopti, lgetco, taetco, + > nomail, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - DEGRe +c - - ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options entieres . +c . taopti . e . lgopti . tableau des options entieres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . nomail . e . char8 . nom de l'objet maillage homard iter. n . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMDEGR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer ulsort, langue, codret + integer lgetco + integer taetco(lgetco) +c + character*8 nomail +c +c 0.4. ==> variables locales +c + integer iaux + integer nretap, nrsset +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CHANGEMENT DE DEGRE'')' + texte(1,5) = '(26(''=''),/)' + texte(1,6) = '(5x,''Passage du degre '',i1,'' au degre '',i1,/)' +c + texte(2,4) = '(/,a6,'' DEGREE MODIFICATION'')' + texte(2,5) = '(26(''=''),/)' + texte(2,6) = '(5x,''From degree '',i1,'' to '',i1,/)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. Programme de base +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMDEG0', nompro +#endif +c + call mmdeg0 ( nomail, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmelde.F b/src/tool/Modification/mmelde.F new file mode 100644 index 00000000..fb05a05b --- /dev/null +++ b/src/tool/Modification/mmelde.F @@ -0,0 +1,234 @@ + subroutine mmelde ( typcca, + > nbfare, cfaare, + > nbftri, cfatri, + > nbfqua, cfaqua, + > nbftet, cfatet, + > nbfhex, cfahex, + > nbfpyr, cfapyr, + > nbfpen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - ELements - changement de DEgre +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typcca . e . 1 . type du code de calcul . +c . nbfare . e . 1 . nombre de familles d'aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . nbftri . e . 1 . nombre de familles de triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . nbfqua . e . 1 . nombre de familles de quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . nbftet . e . 1 . nombre de familles de tetraedres . +c . cfatet . . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . . . . + l : appartenance a l'equivalence l . +c . nbfhex . e . 1 . nombre de familles d'hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbfpyr . e . 1 . nombre de familles de pyramides . +c . cfapyr . . nctfpy. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . nbfpen . e . 1 . nombre de familles de pyramides . +c . cfapen . . nctfpe. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMELDE' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "rftmed.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typcca +c + integer nbfare, nbftri, nbfqua, nbftet, nbfhex, nbfpyr, nbfpen + integer cfaare(nctfar,nbfare) + integer cfatri(nctftr,nbftri) + integer cfaqua(nctfqu,nbfqua) + integer cfatet(nctfte,nbftet) + integer cfahex(nctfhe,nbfhex) + integer cfapyr(nctfpy,nbfpyr) + integer cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + texte(1,4) = '(''Nombre de familles de '',a,'' :'',i8)' +c + texte(2,4) = '(''Number of families of '',a,'' :'',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbfare + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbftri + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbfqua + write (ulsort,texte(langue,4)) mess14(langue,3,3), nbftet + write (ulsort,texte(langue,4)) mess14(langue,3,5), nbfpyr + write (ulsort,texte(langue,4)) mess14(langue,3,6), nbfhex + write (ulsort,texte(langue,4)) mess14(langue,3,7), nbfpen +#endif +c +c==== +c 2. Modification des codes du type d'element +c==== +c + do 21 , iaux = 1, nbfare + if ( cfaare(cotyel,iaux).ne.0 ) then + cfaare(cotyel,iaux) = medt12(cfaare(cotyel,iaux)) + endif + 21 continue +c + do 22 , iaux = 1, nbftri + if ( cfatri(cotyel,iaux).ne.0 ) then + cfatri(cotyel,iaux) = medt12(cfatri(cotyel,iaux)) + endif + 22 continue +c + do 23 , iaux = 1, nbfqua + if ( cfaqua(cotyel,iaux).ne.0 ) then + cfaqua(cotyel,iaux) = medt12(cfaqua(cotyel,iaux)) + endif + 23 continue +c + do 24 , iaux = 1, nbftet + if ( cfatet(cotyel,iaux).ne.0 ) then + cfatet(cotyel,iaux) = medt12(cfatet(cotyel,iaux)) + endif + 24 continue +c + do 25 , iaux = 1, nbfpyr + if ( cfapyr(cotyel,iaux).ne.0 ) then + cfapyr(cotyel,iaux) = medt12(cfapyr(cotyel,iaux)) + endif + 25 continue +c + do 26 , iaux = 1, nbfhex + if ( cfahex(cotyel,iaux).ne.0 ) then + cfahex(cotyel,iaux) = medt12(cfahex(cotyel,iaux)) + endif + 26 continue +c + do 27 , iaux = 1, nbfpen + if ( cfapen(cotyel,iaux).ne.0 ) then + cfapen(cotyel,iaux) = medt12(cfapen(cotyel,iaux)) + endif + 27 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Modification/mmmodi.F b/src/tool/Modification/mmmodi.F new file mode 100644 index 00000000..d2b1fff9 --- /dev/null +++ b/src/tool/Modification/mmmodi.F @@ -0,0 +1,319 @@ + subroutine mmmodi ( codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - Modification +c - - ---- +c +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMMODI' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "cndoad.h" +c +c 0.3. ==> arguments +c + integer codret +c +c 0.4. ==> variables locales +c + integer ulsort, langue, codava + integer adopti, lgopti + integer adetco, lgetco + integer nrsect, nrssse + integer nretap, nrsset + integer iaux + integer codre0 + integer codre1, codre2 +c + integer ulenst, ulsost +c + character*6 saux + character*8 typobs, nohman, nohmap +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c 1.2. ==> le numero d'unite logique de la liste standard +c + call utulls ( ulsort, codret ) +c +c 1.3. ==> la langue des messages +c + call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret ) + if ( codret.eq.0 ) then + langue = imem(adopti) + else + langue = 1 + codret = 2 + endif +c +c 1.4. ==> l'etat courant +c + call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret ) +c + if ( codret.eq.0 ) then + nretap = imem(adetco) + 1 + imem(adetco) = nretap + nrsset = -1 + imem(adetco+1) = nrsset + nrsect = imem(adetco+2) + 10 + imem(adetco+2) = nrsect + nrssse = nrsect + imem(adetco+3) = nrssse + else + nretap = -1 + nrsset = -1 + nrsect = 200 + nrssse = nrsect + codret = 2 + endif +c +c 1.4. ==> le debut des mesures de temps +c + call gtdems (nrsect) +c +c 1.5. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,a6,'// + >''' M O D I F I C A T I O N D E M A I L L A G E'')' + texte(1,5) = '(56(''=''),/)' + texte(1,7) = '(''Changement de degre :'',i4)' + texte(1,8) = '(''Creation de joints :'',i4)' +c + texte(2,4) = '(//,a6,'' M E S H M O D I F I C A T I O N'')' + texte(2,5) = '(50(''=''),/)' + texte(2,7) = '(''Modification of degree :'',i4)' + texte(2,8) = '(''Creation of junctions :'',i4)' +c +c 1.6. ==> le titre +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + nrsset = 0 + imem(adetco+1) = nrsset +c +c 1.7. ==> les numeros d'unite logique au terminal +c + call dmunit ( ulenst, ulsost ) +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage homard a l'iteration n +c + typobs = mchman + iaux = 0 + call utosno ( typobs, nohman, iaux, ulsort, langue, codre1 ) +c +c 2.2. ==> le maillage homard a l'iteration n+1 +c + typobs = mchmap + iaux = 0 + call utosno ( typobs, nohmap, iaux, ulsort, langue, codre2 ) +c +c 2.3. ==> bilan +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c==== +c 3. Compactage de la memoire +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Compactage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOMP', nompro +#endif +c + call utcomp (ulsort, langue, codret) +c + endif +c +c==== +c 4. Modifications du maillage +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) imem(adopti+40) + write (ulsort,texte(langue,8)) imem(adopti+41) +#endif +c +c 4.1. ==> Modification du degre du maillage +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+40).eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMDEGR', nompro +#endif +c + call mmdegr ( lgopti, imem(adopti), lgetco, imem(adetco), + > nohman, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.2. ==> Creation de joints +c + imem(adetco+3) = imem(adetco+3) + 1 +c + if ( imem(adopti+41).eq.1 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMAGRE', nompro +#endif +c + call mmagre ( lgopti, imem(adopti), lgetco, imem(adetco), + > nohman, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. transfert du maillage dans la structure de l'iteration n+1 +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'CMTRNP', nompro +#endif +c + iaux = 1 + call cmtrnp ( nohman, nohmap, iaux, + > lgopti, imem(adopti), lgetco, imem(adetco), + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c +c 6.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 6.2. ==> fin des mesures de temps de la section +c + call gtfims (nrsect) +c + imem(adetco+2) = imem(adetco+2) + 20 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Modification/mmsn21.F b/src/tool/Modification/mmsn21.F new file mode 100644 index 00000000..3bce74f1 --- /dev/null +++ b/src/tool/Modification/mmsn21.F @@ -0,0 +1,104 @@ + subroutine mmsn21 ( disnoe, + > ancnoe, nounoe, hetnoe, + > nouare, + > nbnore, nbp2re, nbimre ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - Suppression des Noeuds P2 - phase 1 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disnoe . a . nbnoto . indicateurs de disparition des noeuds . +c . ancnoe . s . nbnoto . anciens numeros des noeuds conserves . +c . nounoe . s .0:nbnoto. nouveaux numeros des noeuds conserves . +c . hetnoe . e/s . nbnoto . historique de l'etat des noeuds . +c . nouare . s .0:nbarto. nouveaux numeros des aretes conservees . +c . nbnore . s . 1 . nombre de noeuds restants . +c . nbp2re . s . 1 . nombre de noeuds p2 restants . +c . nbimre . s . 1 . nombre de noeuds internes restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cc character*6 nompro +cc parameter ( nompro = 'MMSN21' ) +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombno.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer disnoe(nbnoto) + integer ancnoe(nbnoto), nounoe(0:nbnoto) + integer hetnoe(nbnoto) + integer nbnore, nbp2re, nbimre + integer nouare(0:nbarto) +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. on marque les noeuds P2 comme etant ceux a suprimer +c==== +c + do 11 , iaux = 1 , nbnoto +c + if ( mod(hetnoe(iaux),10).eq.2 ) then + disnoe(iaux) = 1 + else + disnoe(iaux) = 0 + endif +c + 11 continue +c +c==== +c 2. suppression des noeuds +c==== +c + call utsuno ( nbnoto, nouvno, disnoe, + > hetnoe, ancnoe, nounoe, + > nbnore, nbp2re, nbimre ) +c +c==== +c 3. on garde toutes les aretes +c==== +c + do 31 , iaux = 0 , nbarto +c + nouare(iaux) = iaux +c + 31 continue +c + end diff --git a/src/tool/Modification/mmsn22.F b/src/tool/Modification/mmsn22.F new file mode 100644 index 00000000..c2c000ad --- /dev/null +++ b/src/tool/Modification/mmsn22.F @@ -0,0 +1,70 @@ + subroutine mmsn22 ( lgtab, noeele, nounoe ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - Suppression des Noeuds P2 - phase 2 +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgtab . e . 1 . longueur du tableau noeele . +c . noeele . es . lgtab . noeuds des elements (maille-points/aretes) . +c . nounoe . e .0:nbnoto. nouveaux numeros des noeuds conserves . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cc character*6 nompro +cc parameter ( nompro = 'MMSN22' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lgtab + integer noeele(lgtab), nounoe(0:*) +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue tous les noeuds dans la connectivite a modifier +c on remplace le numero du noeud par son nouveau +c==== +c +cgn write(6,*) 'lgtab = ',lgtab + do 11 , iaux = 1 , lgtab +c +cgn write(6,*) 'noeele(',iaux,') = ',noeele(iaux) + noeele(iaux) = nounoe(noeele(iaux)) +c + 11 continue +c + end diff --git a/src/tool/Modification/mmsnp2.F b/src/tool/Modification/mmsnp2.F new file mode 100644 index 00000000..e6e77fff --- /dev/null +++ b/src/tool/Modification/mmsnp2.F @@ -0,0 +1,416 @@ + subroutine mmsnp2 ( nomail, + > indnoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Modification de Maillage - Suppression des Noeuds P2 +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'MMSNP2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer indnoe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ideb + integer tbiaux(1) +c + integer codre0, codre1, codre2, codre3, codre4 +c + integer phetno, pcoono, pareno + integer adnmtr + integer adnmqu + integer pfamno, pcfano + integer pancno + integer pnouar, pnouno + integer adhono + integer pdisno + integer nbnore, nbp2re, nbimre + integer adraux +c + character*8 saux08 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 nnouar, nnouno, ndisno +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = + > '(5x,''Nombre de noeuds p2 (milieux) supprimes : '',i10)' + texte(1,6) = '(5x,''Il reste encore '',i10,'' noeuds P2.'')' +c + texte(2,5) = + > '(5x,''Number of p2 nodes (center) destroyed : '',i10)' + texte(2,6) = '(5x,i10,'' P2 nodes are still present.'')' +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + iaux = 210 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, pareno, adhono, jaux, + > ulsort, langue, codret ) +c + call gmobal ( nhnoeu//'.Deraffin', codre0 ) + if ( codre0.eq.0 ) then + call gmaloj ( nhnoeu//'.Deraffin', ' ', nbnoto, pancno, codre1 ) + if ( codre1.eq.0 ) then + do 221 , iaux = 1, nbnoto + imem(pancno+iaux-1) = iaux + 221 continue + endif + elseif ( codre0.eq.2 ) then + call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codre1 ) + else + codre1 = 2 + endif + iaux = nbnoto + 1 + call gmalot ( nnouno, 'entier ', iaux, pnouno, codre2 ) + call gmalot ( ndisno, 'entier ', nbnoto, pdisno, codre3 ) + iaux = nbarto + 1 + call gmalot ( nnouar, 'entier ', iaux, pnouar, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( nbtrto.ne.0 ) then +c + if ( mod(mailet,2).eq.0 ) then + iaux = 19 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > adnmtr, jaux, jaux, + > ulsort, langue, codret ) + endif +c + endif +c + if ( nbquto.ne.0 ) then +c + if ( mod(mailet,3).eq.0 ) then + iaux = 19 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > adnmqu, jaux, jaux, + > ulsort, langue, codret ) + endif +c + endif +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Fin etape 2 avec codret = ', codret +#endif +c +c==== +c 3. suppression effective des noeuds p2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. suppression effective ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMSN21', nompro +#endif + call mmsn21 ( imem(pdisno), + > imem(pancno), imem(pnouno), imem(phetno), + > imem(pnouar), + > nbnore, nbp2re, nbimre ) +c + endif +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,5)) nbnoto - nbnore +c + if ( nbp2re.ne.0 ) then + write(ulsort,texte(langue,6)) nbp2re + codret = 1 + endif +c + indnoe = nbnore +c + endif +c +c==== +c 4. compactage des noeuds +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. compactage ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*2 + endif + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*3 + endif + if ( homolo.ge.1 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNNO', nompro +#endif + call utcnno ( iaux, + > rmem(pcoono), + > imem(phetno), imem(pfamno), imem(pareno), imem(adhono), + > tbiaux, tbiaux, + > imem(adnmtr), + > imem(adnmqu), + > imem(pnouar), imem(pnouno), nbnoto ) +c + endif +c +c==== +c 5. redimensionnement des tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. redimensionnement ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 2730 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD05', nompro +#endif + call utad05 ( iaux, jaux, nhnoeu, + > nbnoto, nbnore, sdim, + > phetno, + > pfamno, + > pcoono, pareno, adhono, pancno, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( nharet//'.InfoSupp',codret ) +c + endif +c +c==== +c 6. Changement de numerotation des noeuds dans les connectivites +c des mailles-points et des aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Renumerotation ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbmpto.gt.0 ) then + ideb = 1 + else + ideb = 2 + endif +c + do 60 , iaux = ideb , 2 +c +c 6.1. ==> caracterisation de la connectivite +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + saux08 = nhmapo + jaux = nbmpto + elseif ( iaux.eq.2 ) then + saux08 = nharet + jaux = 2*nbarto + endif +c + call gmadoj ( saux08//'.ConnDesc', adraux, kaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 6.2. ==> changement effectif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'MMSN22', nompro +#endif + call mmsn22 ( jaux, imem(adraux), imem(pnouno) ) +c + endif +c + 60 continue +c + endif +c +c==== +c 7. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. Menage ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( nnouno, codre1 ) + call gmlboj ( ndisno, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/CMakeLists.txt b/src/tool/Suivi_Frontiere/CMakeLists.txt new file mode 100644 index 00000000..b2d27211 --- /dev/null +++ b/src/tool/Suivi_Frontiere/CMakeLists.txt @@ -0,0 +1,80 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Suivi_Frontiere + +SET(Suivi_Frontiere_SOURCES + ./sfbatr.F + ./sfbatt.F + ./sfcaf1.F + ./sfcaf2.F + ./sfcafr.F + ./sfcoaq.F + ./sfcofa.F + ./sfcoi1.F + ./sfcoin.F + ./sfcon1.F + ./sfcona.F + ./sfconq.F + ./sfconv.F + ./sfcot1.F + ./sfcot2.F + ./sfcotl.F + ./sfcovo.F + ./sfctri.F + ./sfcvco.F + ./sfcvgf.F + ./sfdefg.F + ./sffa01.F + ./sffa02.F + ./sffa03.F + ./sffa05.F + ./sffaf1.F + ./sffaf2.F + ./sffaf3.F + ./sffaff.F + ./sfgrf0.F + ./sfgrf1.F + ./sfgrf2.F + ./sfgrf3.F + ./sfgrfa.F + ./sfgrfb.F + ./sfgrou.F + ./sfindr.F + ./sflgeo.F + ./sflise.F + ./sfliso.F + ./sfmop2.F + ./sfnnfl.F + ./sfnofl.F + ./sfnuli.F + ./sfpop2.F + ./sfprep.F + ./sfseno.F + ./sfslin.F + ./sftqqu.F + ./sftqtr.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Suivi_Frontiere ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Suivi_Frontiere ${Suivi_Frontiere_SOURCES}) + +INSTALL(TARGETS Suivi_Frontiere EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Suivi_Frontiere/sfbatr.F b/src/tool/Suivi_Frontiere/sfbatr.F new file mode 100644 index 00000000..57724a38 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfbatr.F @@ -0,0 +1,184 @@ + subroutine sfbatr ( lenoeu, larete, letria, + > somare, + > facare, posifa, + > hettri, aretri, filtri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Bascule d'Arete pour un TRiangle +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lenoeu . e . 1 . noeud en cours d'examen . +c . larete . e . 1 . arete en cours d'examen . +c . letria . e . 1 . triangle en cours d'examen . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFBATR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer lenoeu, larete, letria +c + integer somare(2,nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer sn + integer arep + integer inloc, iploc, iqloc +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a,'':'',i10)' + texte(1,5) = '(a,'' du triangle'',i10'' :'',3i10)' + texte(1,7) = '(''Annulation du SF pour le noeud : '',i10)' +c + texte(2,4) = '(a,'' # :'',i10)' + texte(2,5) = '(a,'' of triangle #'',i10'' :'',3i10)' + texte(2,7) = '(''Cancellation of BF for node # : '',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu + write (ulsort,texte(langue,4)) mess14(langue,2, 1), larete + write (ulsort,texte(langue,4)) mess14(langue,2, 2), letria +#endif +c + codret = 0 +c +c==== +c 2. Bascule +c==== +c +c 2.1. ==> reperage local des aretes +c + if ( larete.eq.aretri(letria,1) ) then + inloc = 1 + iploc = 2 + iqloc = 3 + elseif ( larete.eq.aretri(letria,2) ) then + inloc = 2 + iploc = 3 + iqloc = 1 + else + inloc = 3 + iploc = 1 + iqloc = 2 + endif +c +c 2.2. ==> reperage local des sommets +c + arep = aretri(letria,iploc) +c + if ( somare(1,larete).eq.somare(1,arep) ) then + sn = somare(2,arep) + elseif ( somare(1,larete).eq.somare(2,arep) ) then + sn = somare(1,arep) + elseif ( somare(2,larete).eq.somare(1,arep) ) then + sn = somare(2,arep) + else + sn = somare(1,arep) + endif +c +c 2.3. ==> Programme specifique +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFBATT', nompro +#endif + call sfbatt ( lenoeu, sn, letria, + > inloc, iploc, iqloc, + > somare, facare, posifa, + > filtri, aretri, hettri ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfbatt.F b/src/tool/Suivi_Frontiere/sfbatt.F new file mode 100644 index 00000000..f016187c --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfbatt.F @@ -0,0 +1,242 @@ + subroutine sfbatt ( nn, sn, tridec, + > inloc, iploc, iqloc, + > somare, facare, posifa, + > filtri, aretri, hettri ) +c +c Attention : ce decoupage ne permet plus de respecter la regle +c de placement du fils aine d'un triangle au centre +c du dit triangle. Cela peut affecter les interpolations +c de solutions aux points de Gauss. +c +c GN 23.01.98 +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - BAscule d'aretes pour Triangle - Traitement +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nn . e . 1 . noeud projete . +c . sn . e . 1 . noeud oppose . +c . tridec . e . 1 . triangle decoupe dont on va modifier les . +c . . . . fils . +c . inloc . e . 1 . position locale de l'arete dont le noeud . +c . . . . est projete (i.e. arete frontiere de ) . +c . iploc . e . 1 . position locale d'arete . +c . iqloc . e . 1 . position locale d'arete . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . facare . es . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . filtri . e . nbtrto . premier fils des triangles . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombtr.h" +c +c 0.3. ==> arguments +c + integer nn,sn + integer tridec + integer inloc, iploc, iqloc + integer somare(2,nbarto), posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto), filtri(nbtrto) +c +c 0.4. ==> variables locales +c + integer nf, nfn + integer arebas, arnqnn, arnqsn, arnpnn + integer iaux, ideb, ifin +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 2. traitement +c==== +c +c 2.1. ==> situation initiale +c +c +c inloc +c sp nn sq +c .-----------------------.-----------------------. +c . . . . +c . . . . +c . nfp . . nfq . +c . .i i. . +c . .p q. . +c . arnqnn.l l.arnpnn . +c . .o o. . +c iqloc . .c nf c. . iploc +c . . . . +c . . . . +c . . inloc . . +c .---------arebas--------. +c nq . inloc . np +c . . +c . . +c .i nfn i. +c .q p. +c arnqsn .l l. arnpsn +c .o o. +c .c c. +c . . +c . . +c . . +c . +c sn +c + nf = filtri(tridec) +c + nfn = nf + inloc +c +c on ne peut basculer que si le triangle de coin qui partage +c l'arete a basculer avec le triangle central n'est pas decoupe +c pour la conformite. +c + if ( mod(hettri(nfn),10).eq.0 ) then +c + arebas = aretri(nf,inloc) +c + arnqnn = aretri(nf,iploc) + arnpnn = aretri(nf,iqloc) +c + arnqsn = aretri(nfn,iqloc) +c +c 2.2. ==> apres basculement +c +c Attention : on ne peut pas conserver le numero local inloc a +c l'arete basculee, car alors l'orientation des deux +c triangles nf et nfn changerait. il faut donc permuter +c les numeros locaux de deux des trois aretes des triangles +c nf et nfn pour respecter cette orientation. +c on choisit de garder le numero local des aretes issues +c d'un decoupage en 2 des aretes du triangle pere. +c +c inloc +c sp nn sq +c .-----------------------.-----------------------. +c . ... . +c . . . . . +c . nfp . . . nfq . +c . .i a i. . +c . .n r n. . +c . arnqnn.l . e . l.arnpnn . +c . .o b o. . +c iqloc . .c a c. . iploc +c . . . s . . . +c . . . . . +c . . . . . +c . nf i.i nfn . +c nq . p.q . np +c .i l.l i. +c .q o.o p. +c .l c.c l. +c .o . o. +c arnqsn .c . c. arnpsn +c . . . +c . . . +c . . . +c . . . +c ... +c . +c sn +c +c 2.2.1. ==> description de l'arete basculee +c Rq : par construction, nn>sn, donc ok pour somare +c + somare(1,arebas) = sn + somare(2,arebas) = nn +c +c 2.2.2. ==> nouveau triangle "central" +c attention a l'orientation : la meme que tridec +c + aretri(nf,inloc) = arnqnn + aretri(nf,iploc) = arebas + aretri(nf,iqloc) = arnqsn +c +c 2.2.3. ==> nouveau triangle "oppose" +c attention a l'orientation : la meme que tridec +c l'arete iploc est inchangee : arnpsn +c + aretri(nfn,inloc) = arnpnn + aretri(nfn,iqloc) = arebas +c +c 2.2.4. ==> traingles voisins des aretes +c on doit examiner les 5 aretes impliquees +c . arete basculee : il n'y a pas de changement car elle +c borde toujours nf et nfn +c . arete arnqnn : il n'y a pas de changement car elle +c borde toujours nf, nfp et eventuellement +c une fille de nfp si nfp est coupee en 2 +c par l'arete sp-nq. +c . arete arnpsn : il n'y a pas de changement car elle +c borde toujours nfn, une voisine et +c eventuellement une fille de cette voisine +c si cette voisine est coupee en 2 +c par l'arete sn-np. +c . arete arnpnn : elle bordait nf, nfq et eventuellement +c une fille de nfq si nfq est coupee en 2 +c par l'arete sq-np. Pas de changement du +c cote de nfq, il faut remplacer nf par nfn. +c . arete arnqsn : elle bordait nfn, nfp et eventuellement +c une fille de nfp si nfp est coupee en 2 +c par l'arete sn-nq. Pas de changement du +c cote de nfp, il faut remplacer nfn par nf. +c + ideb = posifa(arnpnn-1) + 1 + ifin = posifa(arnpnn) + do 2241 , iaux = ideb , ifin + if ( facare(iaux).eq.nf ) then + facare(iaux) = nfn + endif + 2241 continue +c + ideb = posifa(arnqsn-1) + 1 + ifin = posifa(arnqsn) + do 2242 , iaux = ideb , ifin + if ( facare(iaux).eq.nfn ) then + facare(iaux) = nf + endif + 2242 continue +c +c 2.2.5. ==> modification de l'etat du triangle pere +c + hettri(tridec) = hettri(tridec) + 1 + inloc +c + endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcaf1.F b/src/tool/Suivi_Frontiere/sfcaf1.F new file mode 100644 index 00000000..16dd5971 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcaf1.F @@ -0,0 +1,860 @@ + subroutine sfcaf1 ( nomail, nbarfr, nbqufr, + > ncafdg, nocdfr, ncafan, ncafar, + > suifro, ulgrfr, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : CAlcul des nouvelles Frontieres - 1 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . ncafdg . e . char*8 . nom de l'objet des frontieres discretes :. +c . . . . nom des groupes . +c . nocdfr . e . char8 . nom de l'objet description de la frontiere . +c . ncafan . e . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . description des frontieres . +c . ncafar . e . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . valeurs reelles . +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . ulgrfr . e . * . unite logique des groupes frontieres CAO . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c Nombre d'aretes et de quadrangles concernes : +c ---> SFCONA +c ---> SFCONQ +c +c Reperage des noeuds P2 sur les lignes frontiere : +c ---> SFNOFL ---> SFNNFL +c ---> SFLISO ---> SFSENO +c ---> SFLISE +c Suivi des frontieres +c ---> SFCAF2 ---> SFFA01 +c ---> SFFA02 +c ---> SFFA03 +c ---> SFFA05 +c ---> SFSLIN +c ---> SFNULI +c Correction des noeuds P2 : +c ---> SFMOP2 +c Controles : +c ---> SFCOTL ---> SFCOT1 ---> SFCOVO ---> UTCOTE +c ---> UTCOHE +c ---> UTCORN ---> UTSOQU +c ---> SFCOVO ---> UTCOTE +c ---> UTCOHE +c ---> SFCOFA ---> SFTQTR +c ---> SFTQQU +c ---> UTCORN ---> UTSOQU +c ---> SFBATR ---> SFBATT +c ---> SFCOT2 ---> UTB3F1 +c ---> UTB3G1 +c ---> UTB3D1 +c ---> UTB3E1 +c Correction des noeuds P2 : +c ---> SFMOP2 +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCAF1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + character*8 nomail + character*8 ncafdg, nocdfr, ncafan, ncafar +c + integer suifro + integer ulgrfr(*) + integer nbarfr, nbqufr +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer pcoono, adcocs + integer adhono, pareno + integer adnuno, adlino, adacno + integer phetno + integer psomar, phetar, pfilar, pnp2ar, pfacar, pposif + integer pcfaar, pfamar + integer phettr, paretr, pfiltr + integer phetqu, parequ, pfilqu + integer pcfaqu, pfamqu + integer ptrite, pcotrt, parete, phette, pfilte + integer pquahe, pcoquh, parehe, phethe, pfilhe + integer pfacpy, pcofay, parepy, phetpy + integer pfacpe, pcofap, parepe, phetpe + integer advotr, advoqu + integer adpptr, adppqu + integer adabsc, psomse, psegli, pnumli, ptypli, pgeoco + integer adcafr + integer pttgrd + integer nbfrdi, nbfran + integer adtra4, adtra5 +c + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 +c + double precision unst2x, epsid2 +c +#ifdef _DEBUG_HOMARD_ + character*8 action + parameter ( action = 'sufr ' ) +#endif + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 +c +#ifdef _DEBUG_HOMARD_ + character*6 nompra +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 0 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2.==> tableaux du maillage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 30*19 + if ( homolo.ge.1 ) then + iaux = iaux*11 + endif + call utad01 ( iaux, nhnoeu, + > phetno, + > jaux, jaux, jaux, + > pcoono, pareno, adhono, adcocs, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 1554 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, jaux, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 6 + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 1554 + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 78 + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, jaux, + > jaux, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 78 + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 26 + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 26 + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*221 + endif + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx(nompro,nhvois) +cgn call gmprsx(nompro,nhvois//'.Vol/Tri') +c +c 2.3. ==> Stockage des entites concernees par la frontiere +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav4, 'entier', nbarfr, adtra4, codre1 ) + if ( nbquto.gt.0 ) then + call gmalot ( ntrav5, 'entier', nbqufr, adtra5, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONA', nompro +#endif + call sfcona ( iaux, nbarfr, imem(adtra4), + > imem(phetar), imem(pcfaar), imem(pfamar), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,ntrav4) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbqufr.gt.0 ) then +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONQ', nompro +#endif + call sfconq ( iaux, nbqufr, imem(adtra5), + > imem(phetqu), imem(pcfaqu), imem(pfamqu), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,ntrav5) +#endif +c + endif +c + endif +c +c 2.4. ==> Tolerance pour les tests de coincidence +c Attention : sfcaf1 et sfcoin doivent etre coherents +c + if ( codret.eq.0 ) then +c + unst2x = 1.d0 / rmem(adcocs+10)**2 + epsid2 = max(1.d-14,epsima) +c + endif +c +c==== +c 3. Les structures des frontieres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Les frontieres ; codret', codret +#endif +c +c 3.1. ==> Discretes +c + nbfrdi = 0 +c + if ( mod(suifro,2).eq.0 ) then +c +c 3.1.1. ==> Combien de frontieres discretes +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncafdg ) +#endif +c + if ( codret.eq.0 ) then +c + if ( suifro.gt.0 ) then +c + call gmliat ( ncafdg, 1, nbfrdi, codret ) +c + else +c + call gmadoj ( ncafdg, pttgrd, nbfrdi, codret ) +c + endif +c + endif +c +c 3.1.2. ==> Description des frontieres discretes +c + if ( nbfrdi.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmliat (nocdfr, 2, iaux, codret ) + call gmprot (nompro, nocdfr//'.CoorNoeu', 1 , 20 ) + call gmprot (nompro, nocdfr//'.CoorNoeu', 3*iaux-19 , 3*iaux ) + call gmprsx (nompro, nocdfr//'.NumeLign' ) + call gmprsx (nompro, nocdfr//'.PtrSomLi' ) + call gmprot (nompro, nocdfr//'.SommSegm', 1 , 20 ) + call gmprot (nompro, nocdfr//'.SommSegm', 999 , 1002 ) + call gmprot (nompro, nocdfr//'.SommSegm', 1003 , 1008 ) + call gmprot (nompro, nocdfr//'.SommSegm', 1999 , 2004 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 1 , 20 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 999 , 1002 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 1003 , 1008 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 1999 , 2004 ) +#endif +c + call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 ) + call gmadoj ( nocdfr//'.NumeLign', pnumli, iaux, codre2 ) + call gmadoj ( nocdfr//'.TypeLign', ptypli, iaux, codre3 ) + call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre4 ) + call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre5 ) + call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + endif +c + endif +c + endif +c +c 3.2. ==> Analytiques +c + nbfran = 0 +c + if ( mod(suifro,3).eq.0 ) then +c +c 3.2.1. ==> Combien de frontieres analytiques +c + if ( codret.eq.0 ) then +c + call gmliat ( ncafan, 1, nbfran, codret ) +c + endif +c +c 3.2.2. ==> Description des frontieres analytiques +c + if ( nbfran.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncafar ) +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncafar, adcafr, iaux, codret ) +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfrdi', nbfrdi + write (ulsort,90002) 'nbfran', nbfran +#endif +c +c==== +c 4. Noeuds initiaux et frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Noeuds ini / frontiere ; codret', codret +#endif +c + if ( nbfrdi.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFNOFL', nompro +#endif + call sfnofl ( ntrav1, ntrav2, ntrav3, + > adnuno, adlino, adacno, + > unst2x, epsid2, + > rmem(pcoono), + > imem(psomar), imem(phetar), imem(pfilar), + > imem(pnp2ar), + > imem(pcfaar), imem(pfamar), + > rmem(pgeoco), rmem(adabsc), + > imem(psomse), imem(psegli), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + nompra = 'sfnofl' + iaux = 2 + call utveri ( action, nomail, nompra, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c + endif +c +c==== +c 5. Suivi sur les frontieres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Suivi ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCAF2', nompro +#endif + call sfcaf2 ( suifro, ulgrfr, + > nbfrdi, rmem(pgeoco), rmem(adabsc), + > imem(adnuno), imem(adlino), rmem(adacno), + > imem(ptypli), imem(psomse), imem(psegli), + > nbfran, rmem(adcafr), + > unst2x, epsid2, + > rmem(pcoono), + > imem(adhono), + > imem(phetar), imem(psomar), imem(pfilar), + > imem(pnp2ar), imem(pcfaar), imem(pfamar), + > imem(pfacar), imem(pposif), + > imem(phettr), imem(paretr), imem(pfiltr), + > imem(advotr), + > imem(phetqu), imem(parequ), imem(pfilqu), + > imem(pcfaqu), imem(pfamqu), + > imem(advoqu), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + nompra = 'sfcaf2' + iaux = 2 + call utveri ( action, nomail, nompra, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 6. Retablissement des numeros de ligne +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. retablissement nros ; codret', codret +#endif +c + if ( nbfrdi.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFNULI', nompro +#endif + call sfnuli ( imem(pcfaar), imem(pnumli), iaux, + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. Mouvements de noeud induits +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Mouvements 1 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typsfr.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFMOP2', nompro +#endif + call sfmop2 ( rmem(pcoono), imem(phetno), imem(pareno), + > imem(psomar), + > ulsort, langue, codret) + endif +c + endif +c +c==== +c 8. Controles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Controles ; codret', codret +#endif +c + if ( mod(suifro,5).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOTL', nompro +#endif + call sfcotl ( rmem(pcoono), + > imem(psomar), imem(pfilar), imem(pnp2ar), + > imem(pcfaar), imem(pfamar), + > imem(pfacar), imem(pposif), + > imem(phettr), imem(paretr), imem(pfiltr), + > imem(phetqu), imem(parequ), imem(pfilqu), + > imem(pcfaqu), imem(pfamqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pfilte), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfilhe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > imem(advotr), imem(adpptr), + > imem(advoqu), imem(adppqu), + > nbarfr, imem(adtra4), + > nbqufr, imem(adtra5), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. Corrections P2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. Mouvements 2 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( typsfr.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFMOP2', nompro +#endif + call sfmop2 ( rmem(pcoono), imem(phetno), imem(pareno), + > imem(psomar), + > ulsort, langue, codret) + endif +c + endif +c +c==== +c 11. Mise a jour des coordonnes extremes +c==== +c + if ( mod(suifro,5).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMMCO', nompro +#endif + call utmmco ( rmem(adcocs+1), rmem(adcocs+4), rmem(adcocs+7), + > nbnoto, sdim, rmem(pcoono), + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 12. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbfrdi.gt.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav4, codre1 ) + if ( nbquto.gt.0 ) then + call gmlboj ( ntrav5, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 2 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 13. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcaf2.F b/src/tool/Suivi_Frontiere/sfcaf2.F new file mode 100644 index 00000000..bec63dec --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcaf2.F @@ -0,0 +1,760 @@ + subroutine sfcaf2 ( suifro, ulgrfr, + > nbfrdi, geocoo, abscur, + > numnoe, lignoe, abscno, + > typlig, somseg, seglig, + > nbfran, casfre, + > unst2x, epsid2, + > coonoe, + > noehom, + > hetare, somare, filare, + > np2are, cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > voltri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > volqua, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : CAlcul des nouvelles Frontieres - 2 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . ulgrfr . e . * . unite logique des groupes frontieres CAO . +c . nbfrdi . e . 1 . nombre de frontieres discretes . +c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . +c . abscur . e . sfnbse . abscisse curviligne des somm des segments . +c . numnoe . e . mcnvnf . liste des noeuds de calcul sur le bord . +c . lignoe . e . mcnvnf . liste lignes pour ces noeuds . +c . abscno . e . mcnvnf . abscisse curviligne de ces noeuds . +c . typlig . e . sfnbli . type de la ligne . +c . . . . 0 : ligne ouverte, a 2 extremites . +c . . . . 1 : ligne fermee . +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . casfre . e .13nbfran. caracteristiques des frontieres analytiques. +c . . . . 1 : 1., si cylindre . +c . . . . 2., si sphere . +c . . . . 3., si cone par origine, axe et angle . +c . . . . 4., si cone par 2 centres et 2 rayons . +c . . . . 5., si tore . +c . . . . de 2 a 13 : . +c . . . . . cylindre : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . . sphere : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . . cone : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 13 : angle en degre . +c . . . . . cone 2 : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . 9,10,11:xcent2, ycent2, zcent2. +c . . . . 12 : rayon2 . +c . . . . 13 : angle en radian . +c . . . . . tore : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon de revolution . +c . . . . 12 : rayon primaire . +c . unst2x . e . 1 . inverse de la taille maximale au carre . +c . epsid2 . e . 1 . precision relative pour carre de distance . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . noehom . e . nbnoto . ensemble des noeuds homologues . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 3 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nbarto . famille des aretes . +c . facare . es . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . hettri . es . nbtrto . historique de l'etat des triangles . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . arequa . es .nbquto*4. numeros des 3 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCAF2' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "front1.h" +#include "front2.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer suifro + integer ulgrfr(*) + integer nbfrdi + integer numnoe(mcnvnf), lignoe(mcnvnf) + integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli) + integer nbfran + integer noehom(nbnoto) + integer hetare(nbarto), somare(2,nbarto), filare(nbarto) + integer np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer volqua(2,nbquto) +c + double precision unst2x, epsid2 + double precision casfre(13,nbfran) + double precision geocoo(sfnbso,sdim) + double precision abscur(sfnbse) + double precision coonoe(nbnoto,sdim) + double precision abscno(mcnvnf) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux, kaux +c + integer lenoeu, larete, lequad + integer numfro, numlig, numsur + integer nbsomm, noeud(2), laret1(2), lesegm + integer etan, etanp1 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c + double precision coopro(3) +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + integer glop + data glop /0/ +#endif +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' SUIVI DES FRONTIERES'')' + texte(1,5) = '(27(''=''),/)' + texte(1,6) = '(''Nombre de frontieres discretes :'',i8)' + texte(1,7) = '(''Nombre de frontieres analytiques :'',i8)' + texte(1,8) = + > '(/,''. Examen du '',a,i10,'' (frontiere numero'',i8,'')'')' + texte(1,9) = '(''... '',a,i10,'' a deplacer'')' + texte(1,10) = '(''... Il est entre les '',a,i10,'' et'',i10)' + texte(1,11) = + > '(''. Type de frontiere analytique inconnu :'',i10)' +c + texte(2,4) = '(/,a6,'' BOUNDARY FITTING'')' + texte(2,5) = '(23(''=''),/)' + texte(2,6) = '(''Number of discrete boundaries :'',i8)' + texte(2,7) = '(''Number of analytical boundaries:'',i8)' + texte(2,8) = + >'(/,''. Examination of '',a,'' #'',i10,'' (boundary #'',i8,'')'')' + texte(2,9) = '(''... '',a,'' #'',i10,'' to move'')' + texte(2,10) = + > '(''... It is between '',a,'' #'',i10,'' and #'',i10)' + texte(2,11) = + > '(''. Unknown analytical boundary type:'',i10)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + if ( mod(suifro,5).ne.0 ) then +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c + endif +c +c 1.5. ==> le titre +c + if ( mod(suifro,5).ne.0 ) then +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro',suifro + write (ulsort,texte(langue,6)) nbfrdi + write (ulsort,texte(langue,7)) nbfran +#endif +c +c==== +c 2. boucle sur les noeuds homologues +c attention : rien pour le moment +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. boucle homologues ; codret', codret +#endif +c +c==== +c 3. boucle sur les aretes +c On ne s'interesse qu'aux aretes qui viennent d'etre decoupees +c et qui font partie d'une frontiere reconnue +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. boucle aretes ; codret', codret + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'cosfli', cosfli + write (ulsort,90002) 'cosfsa', cosfsa +#endif +c + do 31 , larete = 1 , nbarto +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-2793 .or. larete.eq.-3534 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( hetare(larete).eq.2 ) then +c + numlig = cfaare(cosfli,famare(larete)) + numsur = cfaare(cosfsa,famare(larete)) + numfro = max(numlig,numsur) +c + if ( numfro.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1), larete, numfro + endif +#endif +c +c 3.1. ==> reperage des noeuds a bouger +c + if ( typsfr.le.2 ) then +c +c 3.1. ==> typsfr = 1 : on est en en degre 1 ; on doit bouger le nouveau +c noeud P1 cree sur cette arete. +c typsfr = 2 : on est en degre 2 et les noeuds P2 sont au +c milieu des noeuds P1 ; on doit bouger le +c noeud P2 de l'arete qui est devenu P1 +c A chaque fois, c'est la seconde extremite d'une des filles +c de l'arete. +c + nbsomm = 1 + laret1(1) = larete + noeud (1) = somare(2,filare(larete)) +c +c 3.2. ==> typsfr = 3 : on est en degre 2 et les noeuds P2 sont sur la +c frontiere ; on doit bouger les 2 noeuds P2 +c crees sur chacune des filles de cette arete +c + else +c + nbsomm = 2 + laret1(1) = filare(larete) + noeud (1) = np2are(filare(larete)) + laret1(2) = filare(larete)+1 + noeud (2) = np2are(filare(larete)+1) +c + endif +c +c 3.2. ==> Deplacement des noeuds +c + do 32 , iaux = 1 , nbsomm +c +c 3.2.1. ==> Memorisation des coordonnees initiales +c + if ( codret.eq.0 ) then +c + lenoeu = noeud (iaux) + do 321 , jaux = 1 , sdim + coopro(jaux) = coonoe(lenoeu,jaux) + 321 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + lesegm = laret1(iaux) + write (ulsort,texte(langue,8)) mess14(langue,1,1), + > lesegm, numfro + write (ulsort,texte(langue,9)) mess14(langue,2,-1), lenoeu + write (ulsort,90004) 'coo',(coonoe(lenoeu,jaux),jaux=1,sdim) + endif +#endif +c + endif +c +c 3.2.2. ==> Frontiere CAO +c jaux et kaux sont les 2 noeuds voisins de lenoeu +c + if ( mod(suifro,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + lesegm = laret1(iaux) + jaux = somare(1,lesegm) + kaux = somare(2,lesegm) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,-1), jaux, kaux + write (ulsort,90002) 'frontiere', numfro +#endif + write (ulgrfr(numfro),91010) lenoeu, jaux, kaux +c + endif +c +c 3.2.3. ==> Frontiere discrete +c jaux et kaux sont les 2 noeuds voisins de lenoeu +c + elseif ( numfro.le.nbfrdi ) then +c + if ( codret.eq.0 ) then +c + lesegm = laret1(iaux) + jaux = somare(1,lesegm) + kaux = somare(2,lesegm) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,-1), jaux, kaux +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFSLIN', nompro +#endif + call sfslin ( lenoeu, jaux, kaux, + > numfro, unst2x, epsid2, + > geocoo, abscur, + > numnoe, lignoe, abscno, + > typlig, somseg, seglig, + > coopro, + > ulsort, langue, codret) +c + endif +c +c 3.2.4. ==> Frontiere analytique +c + else +c + if ( codret.eq.0 ) then +c + kaux = numfro - nbfrdi +cc + jaux = nint(casfre(1,kaux)) +c +c 3.2.3.1. ==> Cylindre +c + if ( jaux.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA01', nompro +#endif + call sffa01 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(5,kaux), + > casfre(8,kaux), + > ulsort, langue, codret) +c +c 3.2.3.2. ==> Sphere +c + elseif ( jaux.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA02', nompro +#endif + call sffa02 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(8,kaux), + > ulsort, langue, codret) +c +c 3.2.3.3./4. ==> Cone +c + elseif ( jaux.eq.3 .or. jaux.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA03', nompro +#endif + call sffa03 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(5,kaux), + > casfre(13,kaux), + > ulsort, langue, codret) +c +c 3.2.3.5. ==> Tore +c + elseif ( jaux.eq.5 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA05', nompro +#endif + call sffa05 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(5,kaux), + > casfre(8,kaux), casfre(12,kaux), + > ulsort, langue, codret) +c +c 3.2.3.n. ==> Inconnu +c + else +c + write (ulsort,texte(langue,8)) mess14(langue,1,1), + > laret1(iaux), kaux + write (ulsort,texte(langue,11)) jaux + codret = 322 +c + endif +c + endif +c + endif +c +c 3.2.4. ==> On realise le changement de coordonnees +c + if ( mod(suifro,5).ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then +32490 format(9x,'X',19x,'Y',19x,'Z') + write (ulsort,32490) + write (ulsort,90004) 'ancien ',(coonoe(lenoeu,jaux),jaux=1,sdim) + write (ulsort,90004) 'nouveau',(coopro(jaux),jaux=1,sdim) + endif +#endif + do 324 , jaux = 1 , sdim + coonoe(lenoeu,jaux) = coopro(jaux) + 324 continue +c + endif +c + endif +c + 32 continue +c + endif +c + endif +c + endif +c + 31 continue +c +c==== +c 4. boucle sur les quadrangles +c On ne s'interesse qu'aux quadrangles +c . qui viennent d'etre decoupes soit car ils etaient actifs, soit +c car ils etaient coupes en 3 triangles +c . qui font partie d'une frontiere reconnue +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. boucle quadrangles ; codret', codret +#endif +c + do 41 , lequad = 1 , nbquto +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( lequad.eq.-9 .or. lequad.eq.-10 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + numfro = cfaqua(cosfsu,famqua(lequad)) +c + if ( numfro.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad, numfro +#endif +c + etanp1 = mod(hetqua(lequad),100) +cgn write (ulsort,90002) 'etanp1', etanp1 +c + if ( ( etanp1.eq.4 ) .or. + > ( etanp1.ge.41 .and. etanp1.le.44) ) then +c + etan = (hetqua(lequad)-etanp1) / 100 +c + if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then +c +c 4.1. ==> reperage des noeuds a bouger +c + if ( typsfr.le.2 ) then +c +c 4.1. ==> typsfr = 1 : on est en en degre 1 ; on doit bouger le nouveau +c noeud P1 cree au centre du quadrangle +c typsfr = 2 : on est en degre 2 et les noeuds P2 sont au +c milieu des noeuds P1 ; on doit bouger le +c nouveau noeud P1 cree au centre du quadrangle +c ce noeud central est la seconde extremite de la 2eme ou 3eme +c arete de l'un quelconque des quadrangles fils (cf. cmrdqu) +c + nbsomm = 1 + iaux = lequad + call utnmqu ( iaux, jaux, + > somare, arequa, filqua ) + noeud (1) = jaux +c +c 4.2. ==> typsfr = 3 : on est en degre 2 et les noeuds P2 sont sur la +c frontiere ; +c A faire +c + else +c + codret = 42 +c + endif +c +c 4.2. ==> Deplacement des noeuds +c + do 42 , iaux = 1 , nbsomm +c +c 4.2.1. ==> Memorisation des coordonnees initiales +c + if ( codret.eq.0 ) then +c + lenoeu = noeud (iaux) + do 421 , jaux = 1 , sdim + coopro(jaux) = coonoe(lenoeu,jaux) + 421 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,2,-1), lenoeu +#endif +c + endif +c +c 4.2.2. ==> Frontiere CAO +c + if ( mod(suifro,5).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'surface numfro',numfro +#endif +c + call utsoqu ( somare, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4), + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + write (ulgrfr(numfro),91010) lenoeu, + > sa1a2, sa2a3, sa3a4, sa4a1 +c +c 4.2.3. ==> Frontiere analytique +c + else +c + if ( codret.eq.0 ) then +c + kaux = numfro - nbfrdi + jaux = nint(casfre(1,kaux)) +c +c 4.2.3.1. ==> Cylindre +c + if ( jaux.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA01', nompro +#endif + call sffa01 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(5,kaux), + > casfre(8,kaux), + > ulsort, langue, codret) +c +c 4.2.3.2. ==> Sphere +c + elseif ( jaux.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFA02', nompro +#endif + call sffa02 ( nbnoto, coopro, + > lenoeu, + > coonoe, + > casfre(2,kaux), casfre(8,kaux), + > ulsort, langue, codret) +c +c 4.2.3.n. ==> Inconnu +c + else +c + write (ulsort,texte(langue,11)) jaux + codret = 422 +c + endif +c + endif +c + endif +c +c 4.2.4. ==> On realise le changement de coordonnees +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then +42490 format(9x,'X',19x,'Y',19x,'Z') + write (ulsort,42490) + write (ulsort,90004) 'ancien ',(coonoe(lenoeu,jaux),jaux=1,sdim) + write (ulsort,90004) 'nouveau',(coopro(jaux),jaux=1,sdim) + endif +#endif +c + do 424 , jaux = 1 , sdim + coonoe(lenoeu,jaux) = coopro(jaux) + 424 continue +c + endif +c + 42 continue +c + endif +c + endif +c + endif +c + endif +c + 41 continue +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcafr.F b/src/tool/Suivi_Frontiere/sfcafr.F new file mode 100644 index 00000000..96c6e167 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcafr.F @@ -0,0 +1,219 @@ + subroutine sfcafr ( lgopti, taopti, + > lgopts, taopts, + > lgetco, taetco, + > nomail, nbarfr, nbqufr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : CAlcul des nouvelles FRontieres +c -- -- -- +c remarque : on n'execute ce programme que si le precedent s'est +c bien passe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . es . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCAFR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + character*8 nomail +c + integer nbarfr, nbqufr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codava + integer adulgr +c + character*8 ncafdg, nocdfr, ncafan, ncafar +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarfr', nbarfr + write (ulsort,90002) 'nbqufr', nbqufr +#endif +c +c==== +c 2. Les structures de base +c==== +c + nocdfr = taopts(16) + ncafdg = taopts(17) + ncafan = taopts(25) + ncafar = taopts(26) +c +c==== +c 3. Preparation pour la frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Preparation ; codret', codret +#endif +c + if ( mod(taopti(29),2).eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFPREP', nompro +#endif + call sfprep ( nomail, nocdfr, + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Traitement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Traitement ; codret', codret +#endif +c +c 4.1. ==> Numeros d'unite logiques pour la CAO +c + if ( mod(taopti(29),5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( taopts(27), adulgr, iaux, codret ) +c + endif +c + endif +c +c 4.2. ==> Calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCAF1', nompro +#endif + call sfcaf1 ( nomail, nbarfr, nbqufr, + > ncafdg, nocdfr, ncafan, ncafar, + > taopti(29), imem(adulgr), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Suivi_Frontiere/sfcoaq.F b/src/tool/Suivi_Frontiere/sfcoaq.F new file mode 100644 index 00000000..a31f71b9 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcoaq.F @@ -0,0 +1,286 @@ + subroutine sfcoaq ( nomail, option, + > nbarfr, nbqufr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : COntrole - Aretes et Quadrangles concernes +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . otpion . e . 1 . type de recherche : . +c . . . . 0 : toutes les entites actives . +c . . . . 1 : les actives qui viennent d'etre coupees. +c . nbarfr . s . 1 . nombre d'aretes concernees . +c . nbqufr . s . 1 . nombre de quadrangles concernes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOAQ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "gmenti.h" +c +#include "envca1.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer option + integer nbarfr, nbqufr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer psomar, phetar + integer pcfaar, pfamar + integer parequ, phetqu + integer pcfaqu, pfamqu +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de toutes les entites.'')' + texte(1,5) = '(''Examen des entites decoupees.'')' + texte(1,6) = '(''Option incorrecte :'',i10)' + texte(1,7) = '(''Aucun '',a,''n''''est concerne.'')' + texte(1,8) = '(''Nombre de '',a,''concernes :'',i10)' +c + texte(2,4) = '(''Examination of all the entities.'')' + texte(2,5) = '(''Examination of cut entities.'')' + texte(2,6) = '(''Non valid option :'',i10)' + texte(2,7) = '(''No '',a,''is involved'')' + texte(2,8) = '(''Number of involved '',a,'':'',i10)' +c +#include "impr03.h" +c +c 1.2. ==> Controle +c + if ( option.lt.0 .and. option.gt.1 ) then + write (ulsort,texte(langue,6)) option + codret = 1 + else + codret = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4+option)) +#endif + endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2.==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 518 + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 518 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Decompte des aretes concernees par la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Decompte aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONA', nompro +#endif + call sfcona ( option, nbarfr, imem(iaux), + > imem(phetar), imem(pcfaar), imem(pfamar), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbarfr +#endif +c + if ( nbarfr.eq.0 ) then +c + write (ulsort,texte(langue,7)) mess14(langue,1,1) +c + endif +c + endif +c +c==== +c 4. Decompte des quadrangles concernes par la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Decompte quad ; codret', codret +#endif +c + if ( nbquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONQ', nompro +#endif + call sfconq ( option, nbqufr, imem(iaux), + > imem(phetqu), imem(pcfaqu), imem(pfamqu), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbqufr +#endif +c + if ( nbqufr.eq.0 ) then +c + write (ulsort,texte(langue,7)) mess14(langue,1,4) +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcofa.F b/src/tool/Suivi_Frontiere/sfcofa.F new file mode 100644 index 00000000..b3b441b9 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcofa.F @@ -0,0 +1,275 @@ + subroutine sfcofa ( bilan, nbbasc, libasc, + > lenoeu, larete, + > nufade, nufafi, nbvoto, + > coonoe, + > somare, filare, np2are, + > facare, + > hettri, aretri, + > voltri, + > hetqua, arequa, filqua, + > volqua, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COntroles des FAces +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . bilan . s . 1 . bilan du controle de l'arete . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . nbbasc . s . 1 . nombre de bascule a faire . +c . libasc . s . * . liste des aretes a basculer . +c . lenoeu . e . 1 . noeud qui bouge . +c . larete . e . 1 . arete a controler . +c . nufade . e . 1 . numero face depart des voisines de larete . +c . nufafi . e . 1 . numero face fin des voisines de larete . +c . nbvoto . e . 1 . nombre de volumes total . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . facare . es . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer bilan, nbbasc, libasc(*) + integer lenoeu, larete + integer nufade, nufafi, nbvoto +c + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer volqua(2,nbquto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer laface +c + logical bascul +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''.. Examen du '',a,i10)' + texte(1,5) = '(''.. Probleme.'')' + texte(1,6) = '(''.. Bascule a faire.'')' +c + texte(2,4) = '(/,''.. Examination of '',a,'' # '',i10)' + texte(2,5) = '(''. Problem.'')' + texte(2,6) = '(''.. Swapping.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete + write (ulsort,texte(langue,4)) mess14(langue,1,-1), lenoeu +#endif +c + codret = 0 +c + bilan = 0 + nbbasc = 0 +c +c==== +c 2. boucle sur les faces s'appuyant sur l'arete +c On ne s'interesse qu'aux aretes qui viennent d'etre decoupees et +c qui font partie d'une frontiere reconnue +c On ne s'interesse qu'aux faces qui ne bordent aucun volume +c==== +c + do 21 , iaux = nufade, nufafi +c + if ( codret.eq.0 ) then +c + bascul = .false. +c + laface = facare(iaux) +c +c 2.1. ==> si la face voisine est un triangle +c + if ( laface.gt.0 ) then +cgn write (ulsort,*)'.. Face voisine : triangle ', laface +c + if ( nbvoto.eq.0 .or. voltri(1,laface).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFTQTR', nompro +#endif + call sftqtr ( bilan, bascul, + > lenoeu, larete, laface, + > coonoe, + > somare, filare, np2are, + > hettri, aretri, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> si la face voisine est un quadrangle +c + else +cgn write(ulsort,*)'.. Face voisine : quadrangle ',-laface +c + if ( nbvoto.eq.0 .or. volqua(1,-laface).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFTQQU', nompro +#endif + call sftqqu ( bilan, + > lenoeu, larete, -laface, + > coonoe, + > somare, filare, np2are, + > hetqua, arequa, filqua, + > ulsort, langue, codret) +c + endif +c + endif +c +c 2.3. ==> Memorisations +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 30 + endif +c + if ( bascul ) then + nbbasc = nbbasc + 1 + libasc(nbbasc) = laface + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. Bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Bilan ; codret = ', codret +#endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( bilan.ne.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete + write (ulsort,texte(langue,5)) + endif + if ( bascul ) then + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete + write (ulsort,texte(langue,6)) + endif + endif +#endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcoi1.F b/src/tool/Suivi_Frontiere/sfcoi1.F new file mode 100644 index 00000000..2b9f3ec7 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcoi1.F @@ -0,0 +1,303 @@ + subroutine sfcoi1 ( nbfran, casfre, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : COnversions Initiales - phase 1 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . casfre . es .13nbfran. caracteristiques des frontieres analytiques. +c . . . . 1 : 1., si cylindre . +c . . . . 2., si sphere . +c . . . . 3., si cone par origine, axe et angle . +c . . . . 4., si cone par 2 centres et 2 rayons . +c . . . . 5., si tore . +c . . . . de 2 a 13 : . +c . . . . . cylindre : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . . sphere : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . . cone : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 13 : angle en degre . +c . . . . . cone 2 : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . 9,10,11:xcent2, ycent2, zcent2. +c . . . . 12 : rayon2 . +c . . . . 13 : angle en degre/radian . +c . . . . . tore : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon de revolution . +c . . . . 12 : rayon primaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOI1' ) +c +#include "nblang.h" +#include "consta.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + integer nbfran +c + double precision casfre(13,nbfran) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer tyfran +c + double precision epsid2 + double precision daux + double precision xa, ya, za, ra + double precision xb, yb, zb, rb +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*24 messag(nblang,4) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de frontiere(s) analytique(s) :'',i8)' + texte(1,5) = '(''Type de la frontiere : '',a)' + texte(1,6) = '(''La definition de l''''axe est invalide.'')' +c + texte(2,4) = '(''Number of analytical boundarie(s):'',i8)' + texte(2,5) = '(''Type of boundary: '',a)' + texte(2,6) = '(''The definition of the axis is not valid.'')' +c +#include "impr03.h" +c 123456789012345678901234 + messag(1,1) = 'Cylindre ' + messag(1,2) = 'Sphere ' + messag(1,3) = 'Cone (origine-axe-angle)' + messag(1,4) = 'Cone (2 centres+rayons) ' +c + messag(2,1) = 'Cylindre ' + messag(2,2) = 'Sphere ' + messag(2,3) = 'Cone (o-axis-angle) ' + messag(2,4) = 'Cone (2 centres+radius) ' +c + codret = 0 +c + epsid2 = max(1.d-14,epsima) +c +c==== +c 2. boucle sur les frontieres enregistrees +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbfran +#endif +c + do 20 , iaux = 1 , nbfran +c + if ( codret.eq.0 ) then +c + tyfran = nint(casfre(1,iaux)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) messag(langue,tyfran) +#endif +c +c 2.1. ==> Creation de l'origine, de l'axe et de l'angle pour un cone +c defini par deux rayons. +c + if ( tyfran.eq.4 ) then +c +c +c o +c ! . +c ! . +c RA! . +c ! o +c ! RB! . +c ! ! . +c A----------------B----------O +c +c Thales : RA/RB = AO/BO ==> BO = AB*RB/(RA-RB) +c Angle : tg(alpha) = RA/AO +c +c 2.1.1. ==> Positionnement de A vers B, avec RA>RB +c + if ( casfre(8,iaux) .gt. casfre(12,iaux) ) then + xa = casfre( 2,iaux) + ya = casfre( 3,iaux) + za = casfre( 4,iaux) + ra = casfre( 8,iaux) + xb = casfre( 9,iaux) + yb = casfre(10,iaux) + zb = casfre(11,iaux) + rb = casfre(12,iaux) + else + xa = casfre( 9,iaux) + ya = casfre(10,iaux) + za = casfre(11,iaux) + ra = casfre(12,iaux) + xb = casfre( 2,iaux) + yb = casfre( 3,iaux) + zb = casfre( 4,iaux) + rb = casfre( 8,iaux) + endif +cgn write (ulsort,90004) 'A', xa, ya, za +cgn write (ulsort,90004) 'B', xb, yb, zb +c +c 2.1.2. ==> Axe : relie les deux centres, de A vers B +c L'axe est normalise +c + casfre(5,iaux) = xb - xa + casfre(6,iaux) = yb - ya + casfre(7,iaux) = zb - za + daux = sqrt(casfre(5,iaux)**2 + > + casfre(6,iaux)**2 + > + casfre(7,iaux)**2) + casfre(5,iaux) = casfre(5,iaux)/daux + casfre(6,iaux) = casfre(6,iaux)/daux + casfre(7,iaux) = casfre(7,iaux)/daux +c +c 2.1.3. ==> Origine : mise dans le centre +c +cgn write (ulsort,90004) 'AB', daux + daux = daux * rb / (ra-rb) +cgn write (ulsort,90004) 'AB* rb / (ra-rb)', daux + casfre(2,iaux) = xb + daux*casfre(5,iaux) + casfre(3,iaux) = yb + daux*casfre(6,iaux) + casfre(4,iaux) = zb + daux*casfre(7,iaux) +c +c 2.1.4. ==> Angle en radian +c +cgn write (ulsort,90004) 'AO',sqrt((casfre(2,iaux)-xa)**2 +cgn > + (casfre(3,iaux)-ya)**2 +cgn > + (casfre(4,iaux)-za)**2 ) + daux = ra / sqrt((casfre(2,iaux)-xa)**2 + > + (casfre(3,iaux)-ya)**2 + > + (casfre(4,iaux)-za)**2 ) + casfre(13,iaux) = atan(daux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'X centre', casfre( 2,iaux) + write (ulsort,90004) 'Y centre', casfre( 3,iaux) + write (ulsort,90004) 'Z centre', casfre( 4,iaux) + write (ulsort,90004) 'X axe ', casfre(5,iaux) + write (ulsort,90004) 'Y axe ', casfre(6,iaux) + write (ulsort,90004) 'Z axe ', casfre(7,iaux) + write (ulsort,90004) 'Angle ', casfre(13,iaux)*180.d0/pi +#endif +c + endif +c +c 2.2. ==> Normalisation de l'axe +c + if ( tyfran.eq.1 .or. tyfran.eq.3 ) then +c + daux = casfre(5,iaux)**2 + > + casfre(6,iaux)**2 + > + casfre(7,iaux)**2 + if ( daux.le.epsid2 ) then + write (ulsort,texte(langue,6)) + codret = 22 + else + daux = 1.d0/sqrt(daux) + casfre(5,iaux) = casfre(5,iaux)*daux + casfre(6,iaux) = casfre(6,iaux)*daux + casfre(7,iaux) = casfre(7,iaux)*daux + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'X axe ', casfre(5,iaux) + write (ulsort,90004) 'Y axe ', casfre(6,iaux) + write (ulsort,90004) 'Z axe ', casfre(7,iaux) +#endif +c + endif +c +c 2.3. ==> Angle en degre/radian +c + if ( tyfran.eq.3 ) then +c + casfre(13,iaux) = casfre(13,iaux)*pi/180.d0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Angle ', casfre(13,iaux)*180.d0/pi +#endif +c + endif +c + endif +c + 20 continue +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcoin.F b/src/tool/Suivi_Frontiere/sfcoin.F new file mode 100644 index 00000000..2bf95618 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcoin.F @@ -0,0 +1,687 @@ + subroutine sfcoin ( nomail, + > lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : COnversions INitiales +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOIN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "envca1.h" +#include "nombqu.h" +#include "impr02.h" +#include "precis.h" +#include "front0.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nretap, nrsset +c + integer nbarfr, nbqufr + integer nbfrdi + integer adnuno, adlino, adacno + integer adabsc, psomse, psegli, pgeoco + integer pcoono, adcocs + integer pareno + integer phetno + integer psomar, phetar, pfilar, pnp2ar + integer pcfaar, pfamar + integer parequ, phetqu + integer pcfaqu, pfamqu + integer adcafr + integer adfrgr, adnogr, nbfrgr, adulgr + integer cpt1d, cpt2d +c + integer codre0 + integer codre1, codre2, codre3, codre4 +c + double precision unst2x, epsid2 +c + character*2 saux02 + character*6 saux + character*7 saux07 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*8 ntrav1, ntrav2, ntrav3 + character*8 ncafdg, nocdfr, ncafan, ncfgnf, ncfgng, ncafar + character*80 saux80 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les initialisations +c==== +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' PRISE EN COMPTE DES FRONTIERES'')' + texte(1,5) = '(37(''=''),/)' + texte(1,6) = '(''Aucun '',a,''n''''est concerne.'')' + texte(1,7) = '(''Nombre de '',a,''concernes :'',i10)' + texte(1,8) = '(/,''. Conversion de la geometrie discrete'',/)' +c + texte(2,4) = '(/,a6,'' BOUNDARY EXAMINATION'')' + texte(2,5) = '(27(''=''),/)' + texte(2,6) = '(''No '',a,''is involved'')' + texte(2,7) = '(''Number of involved '',a,'':'',i10)' + texte(2,8) = '(/,''. Conversion of discrete geometry'',/)' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + if ( taopti(4).ne.2 ) then + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) + endif +c +c==== +c 2. recuperation des pointeurs +c==== +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2.==> tableaux du maillage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 30*19 + call utad01 ( iaux, nhnoeu, + > phetno, + > jaux, jaux, jaux, + > pcoono, pareno, jaux, adcocs, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 1554 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, jaux, + > pfamar, pcfaar, jaux, + > jaux , pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbquto.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 518 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > pfamqu, pcfaqu, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + epsid2 = max(1.d-14,epsima) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'epsid2', epsid2 +#endif +c + nrofro = 0 +c +c==== +c 3. Decompte des entites concernees par la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Decompte ; codret', codret +#endif +c +c 3.1. ==> Decompte des aretes concernees par la frontiere +c + if ( codret.eq.0 ) then +c + nbarfr = 0 + iaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONA', nompro +#endif + call sfcona ( iaux, nbarfr, imem(iaux), + > imem(phetar), imem(pcfaar), imem(pfamar), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( nbarfr.eq.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,1,1) + else + write (ulsort,texte(langue,7)) mess14(langue,3,1), nbarfr + endif + endif +#endif +c +c 3.2. ==> Decompte des quadrangles concernes par la frontiere +c Ne sert a rien ? +c +cgn if ( nbquto.lt.0 ) then +cgnc +cgn if ( codret.eq.0 ) then +cgnc +cgn nbqufr = 0 +cgn iaux = 0 +cgnc +cgn#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,3)) 'SFCONQ', nompro +cgn#endif +cgn call sfconq ( iaux, nbqufr, imem(iaux), +cgn > imem(phetqu), imem(pcfaqu), imem(pfamqu), +cgn > ulsort, langue, codret ) +cgnc +cgn endif +cgnc +cgn#ifdef _DEBUG_HOMARD_ +cgn if ( codret.eq.0 ) then +cgn if ( nbarfr.eq.0 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,4) +cgn else +cgn write (ulsort,texte(langue,7)) mess14(langue,3,4), nbqufr +cgn endif +cgn endif +cgn#endif +cgnc +cgn endif +c +c 3.3. ==> Nombre de frontieres discretes ou CAO +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3 ; codret', codret + write (ulsort,90002) 'nbarfr', nbarfr + write (ulsort,90002) 'taopti(29) (suifro)', taopti(29) + call gmprsx ( nompro, taopts(17) ) +#endif +c + if ( nbarfr.gt.0 .and. + > ( mod(taopti(29),2).eq.0 ) ) then +c +c 3.3.1. ==> Au premier passage +c + if ( taopti(10).eq.0 ) then +c + if ( codret.eq.0 ) then +c + ncafdg = taopts(17) + call gmliat ( ncafdg, 1, nbfrdi, codret ) +c + endif +c +c 3.3.2. ==> ensuite +c + else +c + if ( codret.eq.0 ) then +c + call gmliat ( nhsupe, 10, nbfrdi, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfrdi', nbfrdi +#endif +c + endif +c +c==== +c 4. Affichage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Affichage ; codret', codret + write (ulsort,90002) 'nbarfr', nbarfr +#endif +c + if ( nbarfr.gt.0 ) then +c + if ( codret.eq.0 ) then +c + ncfgnf = taopts(23) + ncfgng = taopts(24) + ncafan = taopts(25) + ncafar = taopts(26) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFAFF', nompro +#endif + call sffaff ( taopti(29), + > ncafdg, ncafan, ncfgnf, ncfgng, ncafar, + > nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. frontiere CAO : initialisations des fichiers +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. frontiere CAO ; codret', codret +#endif +c + if ( mod(taopti(29),5).eq.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nhsupe//'.Tab10' ) + call gmprsx ( nompro, nhsups//'.Tab10' ) +#endif +c + call gmadoj ( nhsupe//'.Tab10', adfrgr, iaux, codre1 ) + call gmadoj ( nhsups//'.Tab10', adnogr, iaux, codre2 ) + call gmliat ( nhsupe, 10, nbfrgr, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmalot ( taopts(27), 'entier', nbfrgr, adulgr, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + cpt1d = 0 + cpt2d = 0 + do 51 , iaux = 1, nbfrgr +c + if ( imem(adfrgr+iaux-1).gt.0 ) then + jaux = cpt1d + cpt1d = cpt1d + 1 + saux07 = 'fr1D. ' + elseif ( imem(adfrgr+iaux-1).lt.0 ) then + jaux = cpt2d + cpt2d = cpt2d + 1 + saux07 = 'fr2D. ' + else + jaux = -1 + endif +c + if ( jaux.ge.0 ) then +c + if ( codret.eq.0 ) then +c + call utench ( jaux, '0', kaux, saux02, + > ulsort, langue, codret ) +c + saux07(6:7) = saux02 + jaux = 7 + call guoufs ( saux07, jaux, kaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call uts8ch ( smem(adnogr+(iaux-1)*10), 80, saux80, + > ulsort, langue, codret ) + write (kaux,*) saux80 +c + endif +c + else +c + kaux = 0 +c + endif +c + imem(adulgr+iaux-1) = kaux +c + 51 continue +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, taopts(27) ) +#endif +c + endif +c +c==== +c 6. Conversion de la description de la geometrie analytique +c Il faut normaliser les axes ; on ne le fait pas avant pour +c avoir un affichage conforme a la donnee de l'utilisateur +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Conversion geometrie ; codret', codret +#endif +c + if ( nbarfr.gt.0 .and. mod(taopti(29),3).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncafar, adcafr, jaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + jaux = jaux/13 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOI1', nompro +#endif + call sfcoi1 ( jaux, rmem(adcafr), + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 7. Conversion de la description de la geometrie discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Conversion geometrie ; codret', codret + write (ulsort,90002) 'taopti(29)', taopti(29) + write (ulsort,90002) 'nbfrdi', nbfrdi + write (ulsort,90002) 'nbarfr', nbarfr +#endif +c + if ( taopti(29).lt.0 .and. mod(taopti(29),2).eq.0 .and. + > nbfrdi.gt.0 .and. nbarfr.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCONV', nompro +#endif + call sfconv ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + nocdfr = taopts(16) +c + call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 ) + call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre2 ) + call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre3 ) + call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + endif +c +c==== +c 8. Quand on est parti d'un macro-maillage : inhibition du suivi +c de frontiere sur les lignes droites +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. lignes droites ; codret', codret +#endif +c + if ( nbfrdi.gt.0 .and. nbarfr.gt.0 ) then +c + if ( taopti(10).eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFINDR', nompro +#endif + call sfindr ( imem(psegli), imem(pcfaar), imem(pfamar), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 9. Quand on est parti d'un macro-maillage : determination du +c comportement en degre 2 +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. degre 2 ; codret', codret +#endif +c + if ( taopti(10).eq.0 ) then +c + if ( codret.eq.0 ) then +c +c 9.1. ==> en degre 1, c'est simple +c + if ( degre.eq.1 ) then +c + typsfr = 1 +c +c 9.2. ==> en degre 2, tout depent de la position initiale des noeuds P2 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFPOP2', nompro +#endif + call sfpop2 ( typsfr, + > rmem(pcoono), + > imem(psomar), imem(pnp2ar), + > imem(pcfaar), imem(pfamar), + > lgetco, taetco, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then + call gmecat ( nomail, 10, typsfr, codret ) + endif +c + endif +c + endif +c +c==== +c 10. Noeuds initiaux et frontiere +c Attention : sfcaf1 et sfcoin doivent etre coherents +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. Noeuds ini / frontiere ; codret', codret +#endif +c + if ( taopti(10).eq.0 ) then +c + if ( taopti(29).lt.0 .and. nbfrdi.gt.0 ) then +c +cgn call gmprot(nompro,nhnoeu//'.Coor',115,115) +c + if ( codret.eq.0 ) then +c + unst2x = 1.d0 / rmem(adcocs+10)**2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFNOFL', nompro +#endif + call sfnofl ( ntrav1, ntrav2, ntrav3, + > adnuno, adlino, adacno, + > unst2x, epsid2, + > rmem(pcoono), + > imem(psomar), imem(phetar), imem(pfilar), + > imem(pnp2ar), + > imem(pcfaar), imem(pfamar), + > rmem(pgeoco), rmem(adabsc), + > imem(psomse), imem(psegli), + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +cgn call gmprot(nompro,nhnoeu//'.Coor',115,115) +c +c==== +c 11. La fin +c==== +c + if ( codret.eq.0 ) then +c + taopti(29) = abs(taopti(29)) +c + endif +c +c==== +c 12. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcon1.F b/src/tool/Suivi_Frontiere/sfcon1.F new file mode 100644 index 00000000..c714be54 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcon1.F @@ -0,0 +1,161 @@ + subroutine sfcon1 ( typcca, maextr, + > nohman, mafrmd, nocdfr, ncafdg, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - CONv de la geometrie frontiere - phase 1 +c - - --- - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typcca . e . 1 . type du code de calcul . +c . . . . 26 : SATURNE_2D (format MED) . +c . . . . 36 : SATURNE (format MED) . +c . . . . 46 : NEPTUNE_2D (format MED) . +c . . . . 56 : NEPTUNE (format MED) . +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non (defaut) . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . mafrmd . e . char*8 . maillage de la frontiere au format med . +c . nocdfr . s . char*8 . maillage de la frontiere a format C . +c . ncafdg . e . char*8 . nom de l'objet groupes/attributs frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCON1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer typcca + integer maextr +c + character*8 nohman + character*8 mafrmd, nocdfr, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. Prealable pour le cas extrude +c==== +c + if ( codret.eq.0 ) then +c + if ( maextr.ne.0 ) then +c +cgn call gmprsx (nompro,mafrmd) +cgn call gmprsx (nompro,mafrmd//'.Noeud') +cgn call gmprsx (nompro,mafrmd//'.ConnNoeu') +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCMS20', nompro +#endif +c + call vcms20 ( mafrmd, maextr, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro,mafrmd) +cgn call gmprsx (nompro,mafrmd//'.Noeud') +cgn call gmprsx (nompro,mafrmd//'.ConnNoeu') +cgn call dmflsh (iaux) +c + endif +c +c==== +c 3. Conversion +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCVGF', nompro +#endif + call sfcvgf ( nohman, mafrmd, nocdfr, ncafdg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcona.F b/src/tool/Suivi_Frontiere/sfcona.F new file mode 100644 index 00000000..579f3f55 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcona.F @@ -0,0 +1,263 @@ + subroutine sfcona ( option, nbarfr, arefro, + > hetare, cfaare, famare, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COntrole - Nombre d'Aretes +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . otpion . e . 1 . type de recherche : . +c . . . . 0 : toutes les aretes actives . +c . . . . 1 : les actives qui viennent d'etre coupees. +c . nbarfr . es . 1 . si 0 : on cherche le nombre, on le renvoie . +c . . . . sinon, on remplit . +c . arefro . s . nbarfr . numeros des aretes concernees . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCONA' ) +c +#include "nblang.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer nbarfr + integer arefro(nbarfr) + integer hetare(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer etat01, etat02 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Prealables +c==== +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de toutes les entites.'')' + texte(1,5) = '(''Examen des entites decoupees.'')' + texte(1,6) = '(''Option incorrecte :'',i10)' + texte(1,7) = '(''Aucun '',a,''n''''est concerne.'')' + texte(1,8) = '(''Nombre de '',a,''concernes :'',i10)' +c + texte(2,4) = '(''Examination of all the entities.'')' + texte(2,5) = '(''Examination of cut entities.'')' + texte(2,6) = '(''Non valid option :'',i10)' + texte(2,7) = '(''No '',a,''is involved'')' + texte(2,8) = '(''Number of involved '',a,'':'',i10)' +c +c 1.2. ==> Initialisations +c + codret = 0 +c + if ( option.eq.0 ) then + etat01 = 0 + etat02 = 2 + elseif ( option.eq.1 ) then + etat01 = 2 + etat02 = 2 + else + write (ulsort,texte(langue,6)) option + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4+option)) + endif +#endif +c +c==== +c 2. Decompte des aretes +c On ne s'interesse qu'aux aretes : +c . qui font partie d'une frontiere reconnue +c . qui viennent d'etre decoupees +c==== +c + if ( nbarfr.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Decompte aretes ; codret = ', codret +#endif +c + do 21 , iaux = 1 , nbarto +c + if ( codret.eq.0 ) then +c + if ( cfaare(cosfsa,famare(iaux)).gt.0 .or. + > cfaare(cosfli,famare(iaux)).gt.0 ) then +c + if ( hetare(iaux).eq.etat01 .or. + > hetare(iaux).eq.etat02 ) then +c +cgn write (ulsort,*) 'arete ',iaux,cfaare(cosfsa,famare(iaux)), +cgn > cfaare(cosfli,famare(iaux)) + nbarfr = nbarfr + 1 +c + endif +c + endif +c + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( nbarfr.eq.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,1,1) + else + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbarfr + endif + endif +#endif +c +c==== +c 3. Remplissage +c==== +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Remplissage ; codret = ', codret +#endif +c + jaux = 0 +c + do 31 , iaux = 1 , nbarto +c + if ( codret.eq.0 ) then +c + if ( cfaare(cosfsa,famare(iaux)).gt.0 .or. + > cfaare(cosfli,famare(iaux)).gt.0 ) then +c + if ( hetare(iaux).eq.etat01 .or. + > hetare(iaux).eq.etat02 ) then +c +cgn write (ulsort,*) 'arete ',iaux,cfaare(cosfsa,famare(iaux)), +cgn > cfaare(cosfli,famare(iaux)) +c + jaux = jaux + 1 + arefro(jaux) = iaux +c + endif +c + endif +c + endif +c + 31 continue +c +c reactualisation du nombre d'aretes concernees : certaines ont +c disparu car elles sont sur des lignes droites +c + nbarfr = jaux +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( nbarfr.eq.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,1,1) + else + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbarfr + endif + endif +#endif +c + endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfconq.F b/src/tool/Suivi_Frontiere/sfconq.F new file mode 100644 index 00000000..650d6a98 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfconq.F @@ -0,0 +1,260 @@ + subroutine sfconq ( option, nbqufr, quafro, + > hetqua, cfaqua, famqua, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COntrole - Nombre de Quadrangles +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . type de recherche : . +c . . . . 0 : tous les quadrangles actifs . +c . . . . 1 : les actifs qui viennent d'etre coupes . +c . nbqufr . es . 1 . si 0 : on cherche le nombre, on le renvoie . +c . . . . sinon, on remplit . +c . quafro . s . nbqufr . numeros des quadrangles concernes . +c . hetqua . e . nbquto . historique de l'etat des aretes . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCONQ' ) +c +#include "nblang.h" +#include "cofatq.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer nbqufr + integer quafro(nbqufr) + integer hetqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer etat01, etat02 + integer etan, etanp1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Prealables +c==== +c 1.1. ==> Les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de toutes les entites.'')' + texte(1,5) = '(''Examen des entites decoupees.'')' + texte(1,6) = '(''Option incorrecte :'',i10)' + texte(1,7) = '(''Aucun '',a,''n''''est concerne.'')' + texte(1,8) = '(''Nombre de '',a,''concernes :'',i10)' +c + texte(2,4) = '(''Examination of all the entities.'')' + texte(2,5) = '(''Examination of cut entities.'')' + texte(2,6) = '(''Non valid option :'',i10)' + texte(2,7) = '(''No '',a,''is involved'')' + texte(2,8) = '(''Number of involved '',a,'':'',i10)' +c +c 1.2. ==> Initialisations +c + codret = 0 +c + if ( option.eq.0 ) then + etat01 = 0 + etat02 = 4 + elseif ( option.eq.1 ) then + etat01 = 4 + etat02 = 4 + else + write (ulsort,texte(langue,6)) option + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4+option)) + endif +#endif +c +c==== +c 2. Decompte des quadrangles +c On ne s'interesse qu'aux quadrangles : +c . qui font partie d'une frontiere reconnue +c . qui viennent d'etre decoupes +c==== +c + if ( nbqufr.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Decompte quadrangles ; codret = ', codret +#endif +c + do 21 , iaux = 1 , nbquto +c + if ( codret.eq.0 ) then +c + if ( cfaqua(cosfsu,famqua(iaux)).gt.0 ) then +c + etanp1 = mod(hetqua(iaux),100) +c + if ( etanp1.eq.etat01 .or. etanp1.eq.etat02 ) then +c + etan = (hetqua(iaux)-etanp1) / 100 +c + if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then +c +cgn write (ulsort,*) 'quad ',iaux,cfaqua(cosfsu,famqua(iaux)) + nbqufr = nbqufr + 1 +c + endif +c + endif +c + endif +c + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( nbqufr.eq.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,1,4) + else + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbqufr + endif + endif +#endif +c +c==== +c 3. Remplissage +c==== +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Remplissage ; codret = ', codret +#endif +c + jaux = 0 +c + do 31 , iaux = 1 , nbquto +c + if ( codret.eq.0 ) then +c + if ( cfaqua(cosfsu,famqua(iaux)).gt.0 ) then +c + etanp1 = mod(hetqua(iaux),100) +c + if ( etanp1.eq.etat01 .or. etanp1.eq.etat02 ) then +c + etan = (hetqua(iaux)-etanp1) / 100 +c + if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then +c +cgn write (ulsort,*) 'quad ',iaux,cfaqua(cosfsu,famqua(iaux)) + jaux = jaux + 1 + quafro(jaux) = iaux +c + endif +c + endif +c + endif +c + endif +c + 31 continue +c +c reactualisation du nombre de quadrangles concernes : certains ont +c disparus car ils sont sur des surfaces planes +c + nbqufr = jaux +c + endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfconv.F b/src/tool/Suivi_Frontiere/sfconv.F new file mode 100644 index 00000000..7522cb7a --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfconv.F @@ -0,0 +1,179 @@ + subroutine sfconv ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - CONV de la geometrie du format MED au format C +c - - ---- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCONV' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux + character*6 saux + character*8 nohman + character*8 mafrmd, nocdfr, ncafdg +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONVERSION DE LA FRONTIERE DISCRETE'')' + texte(1,5) = '(42(''=''),/)' +c + texte(2,4) = '(/,a6,'' CONVERSION OF DISCRETE BOUNDARY'')' + texte(2,5) = '(38(''=''),/)' +c +c 1.2. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.3. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. les structures de base +c==== +c +c 2.1. ==> le maillage HOMARD +c + nohman = taopts(3) +c +c 2.2. ==> le maillage MED de la frontiere +c + mafrmd = taopts(16) +c +c 2.3. ==> les groupes definissant la frontiere +c + ncafdg = taopts(17) +c +c==== +c 3. traitement +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCON1', nompro +#endif + call sfcon1 ( taopti(11), taopti(39), + > nohman, mafrmd, nocdfr, ncafdg, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + taopts(16) = nocdfr +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcot1.F b/src/tool/Suivi_Frontiere/sfcot1.F new file mode 100644 index 00000000..0ab349c5 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcot1.F @@ -0,0 +1,624 @@ + subroutine sfcot1 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > tritet, cotrte, aretet, + > hettet, filtet, + > quahex, coquhe, arehex, + > hethex, filhex, + > voltri, pypetr, + > volqua, pypequ, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COnTroles - phase 1 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . s . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . s . 1 . nombre de corrections pour les aretes . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOT1' ) +c +#include "nblang.h" +#include "tbdim0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer filtet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer filhex(nbheto) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer larete, lequad, laface + integer nuarfr, nuqufr + integer nbexam, examno(2), examar(2) + integer nufade, nufafi, decafv + integer nbvoto + integer nbtetr, nbhexa, nbpyra, nbpent + integer lisvoi(tbdim) + integer bilan, nbbato + integer libasc(tbdim), nbbasc +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = '(/,''. Examen du '',a,i10)' + texte(1,8) = + >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'', + >i10)' + texte(1,9) = '(''==> Tout va bien.'')' + texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)' + texte(1,11) = '(''Nombre de '',a,'' a basculer :'',i10)' + texte(1,12) = '(''... Reprise du '',a,i10)' +c + texte(2,7) = '(/,''. Examination of '',a,'' # '',i10)' + texte(2,8) = + >'(''==> Number of corrections of nodes connected to '',a,'':'', + >i10)' + texte(2,9) = '(''==> Everything is OK.'')' + texte(2,10) = '(''Number of involved '',a,'':'',i10)' + texte(2,11) = '(''Number of '',a,'' to swap :'',i10)' + texte(2,12) = '(''... Correction of '',a,i10)' +c +#include "impr03.h" +c + codret = 0 +c + nbcoar = 0 + nbcoqu = 0 + nbbato = 0 +c + nbvoto = nbteto + nbheto + nbpyto + nbpeto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typsfr', typsfr +#endif +c +c==== +c 2. Boucle sur les quadrangles qui viennent d'etre decoupes et +c qui font partie d'une frontiere reconnue +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. boucle quadrangles ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqufr +#endif +c + nbtetr = 0 +c + do 21 , nuqufr = 1 , nbqufr +c +c 2.1. ==> Elimination des situations ou il est inutile +c de controler car le quadrangle a deja ete ramene +c + lequad = quafro(nuqufr) +c + if ( lequad.le.0 ) then + goto 21 + endif +c +c 2.2. ==> Reperage des situations a examiner : +c . le noeud central du quadrangle decoupe +c . les noeuds P2 courbes : a faire +c ce noeud central est la seconde extremite de la 2eme ou 3eme +c arete de l'un quelconque des quadrangles fils (cf. cmrdqu) +c + if ( codret.eq.0 ) then +c + if ( typsfr.le.2 ) then + nbexam = 1 + larete = arequa(filqua(lequad),2) + examno(1) = somare(2,larete) + else + codret = 22 + endif +c + endif +c +c 2.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,4), lequad +#endif +c + do 23 , iaux = 1 , nbexam +c + bilan = 0 +c +c 2.3.1. ==> Controle des volumes s'appuyant sur ce quadrangle +c + if ( nbvoto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVQ', nompro +#endif + call utvgvq ( lequad, + > volqua, pypequ, + > nbhexa, nbpyra, nbpent, + > lisvoi, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + decafv = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOVO', nompro +#endif + call sfcovo ( bilan, + > nbtetr, nbhexa, nbpyra, nbpent, + > decafv, lisvoi, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > hettet, filtet, + > quahex, coquhe, arehex, + > hethex, filhex, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 232 + endif +c + endif +c + endif +c +c 2.3.2. ==> Corrections eventuelles +c + 232 continue +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) mess14(langue,1,-1), examno(iaux) +#endif +c + nbcoqu = nbcoqu + 1 + quafro(nuqufr) = -lequad + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro +#endif + call utcorn ( examno(iaux), lequad, jaux, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 23 continue +c + endif +c + 21 continue +c +c==== +c 3. Boucle sur les aretes qui viennent d'etre decoupees et +c qui font partie d'une frontiere reconnue +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. boucle aretes ; codret', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,1), nbarfr +#endif +c + do 31 , nuarfr = 1 , nbarfr +c +c 3.1. ==> Elimination des situations ou il est inutile +c de controler car l'arete a deja ete ramenee +c + if ( codret.eq.0 ) then +c + larete = arefro(nuarfr) +c + if ( larete.le.0 ) then + goto 31 + endif +c + endif +c +c 3.2. ==> Reperage des situations a examiner : +c . le noeud milieu de l'arete decoupee ou +cgnc . les noeuds P2 courbes +c + if ( codret.eq.0 ) then +c +cgn if ( typsfr.le.2 ) then + nbexam = 1 + examar(1) = larete + examno(1) = somare(2,filare(examar(1))) +cgn else +cgn nbexam = 2 +cgn examar(1) = filare(larete) +cgn examno(1) = np2are(examar(1)) +cgn examar(2) = examar(1) + 1 +cgn examno(2) = np2are(examar(2)) +cgn endif +c + endif +c +c 3.3. ==> Examen +c + if ( codret.eq.0 ) then +c + do 33 , iaux = 1 , nbexam +c +c 3.3.1. ==> Faces s'appuyant sur l'arete : s'il n'y en a pas, on +c passe a la suite +c + nufade = posifa(examar(iaux)-1) + 1 + nufafi = posifa(examar(iaux)) +c + if ( nufafi.lt.nufade ) then + goto 33 + endif +c + bilan = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,1), examar(iaux) +#endif +c +c 3.3.2. ==> Controle des volumes s'appuyant sur cette arete +c + if ( nbvoto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVA', nompro +#endif + call utvgv1 ( nufade, nufafi, + > voltri, pypetr, + > volqua, pypequ, + > nbtetr, nbhexa, nbpyra, nbpent, + > lisvoi, facare, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + decafv = 2 * ( nufafi - nufade + 1 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOVO', nompro +#endif + call sfcovo ( bilan, + > nbtetr, nbhexa, nbpyra, nbpent, + > decafv, lisvoi, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > hettet, filtet, + > quahex, coquhe, arehex, + > hethex, filhex, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 334 + endif +c + endif +c + endif +c +c 3.3.3. ==> Controle des surfaces vraiment 2D s'appuyant sur l'arete +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOFA', nompro +#endif +c + call sfcofa ( bilan, nbbasc, libasc, + > examno(iaux), examar(iaux), + > nufade, nufafi, nbvoto, + > coonoe, + > somare, filare, np2are, + > facare, + > hettri, aretri, + > voltri, + > hetqua, arequa, filqua, + > volqua, + > ulsort, langue, codret) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,3,1), nbbasc + endif +#endif +c +c 3.3.4. ==> Corrections eventuelles +c + 334 continue +c +c 3.3.4.1. ==> Retour au milieu +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) mess14(langue,1,-1), examno(iaux) +#endif +c + nbcoar = nbcoar + 1 + arefro(nuarfr) = -larete + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro +#endif + call utcorn ( examno(iaux), jaux, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c +c 3.3.4.2. ==> On fait les basculements d'aretes necessaires +c + if ( codret.eq.0 ) then +c + nbbato = nbbato + nbbasc +c + do 3342 , jaux = 1 , nbbasc +c + laface = libasc(jaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFBATR', nompro +#endif + call sfbatr ( examno(iaux), examar(iaux), laface, + > somare, + > facare, posifa, + > hettri, aretri, filtri, + > ulsort, langue, codret) +c + 3342 continue +c + endif +c + 33 continue +c + endif +c + 31 continue +c +c==== +c 4. La fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( (nbcoqu+nbcoar).eq.0 ) then + write (ulsort,texte(langue,9)) + else + if ( nbcoqu.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoqu + endif + if ( nbcoar.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoar + endif + endif +#endif +c + if ( nbbato.gt.0 ) then + write (ulsort,texte(langue,11)) mess14(langue,3,1), nbbato + endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcot2.F b/src/tool/Suivi_Frontiere/sfcot2.F new file mode 100644 index 00000000..ae3390b1 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcot2.F @@ -0,0 +1,409 @@ + subroutine sfcot2 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > tritet, cotrte, aretet, hettet, + > filtet, + > quahex, coquhe, arehex, hethex, + > filhex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > voltri, pypetr, + > volqua, pypequ, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COnTroles - phase 2 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . s . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . s . 1 . nombre de corrections pour les aretes . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOT2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer filtet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer filhex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbcoa2, nbcoq2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''. Apres controle par interpenetration :'')' + texte(1,8) = + >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'', + >i10)' + texte(1,9) = '(''==> Tout va bien.'')' + texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)' +c + texte(2,5) = '(''. After checking of connections :'')' + texte(2,8) = + >'(''==> Number of corrections of nodes connected to '',a,'':'', + >i10)' + texte(2,9) = '(''==> Everything is OK.'')' + texte(2,10) = '(''Number of involved '',a,'':'',i10)' +c + codret = 0 +c +c==== +c 2. Controle des aretes et quadrangles qui viennent d'etre decoupes et +c qui font partie d'une frontiere reconnue +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. controle ; codret = ', codret +#endif +c + nbcoar = 0 + nbcoqu = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,1), nbarfr + write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqufr +cgn write (ulsort,*) quafro +#endif +c +c 2.1. ==> Les pyramides +cgn call gtdems (74) +c + if ( codret.eq.0 ) then +c + if ( nbpyto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3F1', nompro +#endif + call utb3f1 ( nbcoq2, nbcoa2, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > aretri, + > arequa, filqua, + > cfaqua, famqua, + > hetpyr, facpyr, cofapy, arepyr, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + nbcoqu = nbcoqu + nbcoq2 + nbcoar = nbcoar + nbcoa2 +c + endif +c + endif +c + endif +c +c 2.2. ==> Les pentaedres +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3G1', nompro +#endif + call utb3g1 ( nbcoq2, nbcoa2, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > hetpen, facpen, cofape, arepen, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + nbcoqu = nbcoqu + nbcoq2 + nbcoar = nbcoar + nbcoa2 +c + endif +c + endif +c + endif +cgn call gtfims (74) +c +c 2.3. ==> Les tetraaedres +cgn call gtdems (75) +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3D1', nompro +#endif + call utb3d1 ( nbcoq2, nbcoa2, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > aretri, + > hettet, tritet, cotrte, aretet, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + nbcoqu = nbcoqu + nbcoq2 + nbcoar = nbcoar + nbcoa2 +c + endif +c + endif +c + endif +cgn call gtfims (75) +c +c 2.4. ==> Les hexaedres +c +cgn call gtdems (76) + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3E1', nompro +#endif + call utb3e1 ( nbcoq2, nbcoa2, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > hethex, quahex, coquhe, arehex, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c + if ( codret.eq.0 ) then +c + nbcoqu = nbcoqu + nbcoq2 + nbcoar = nbcoar + nbcoa2 +c + endif +c + endif +c + endif +cgn call gtfims (76) +c +c==== +c 3. La fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) + if ( (nbcoqu+nbcoar).eq.0 ) then + write (ulsort,texte(langue,9)) + else + if ( nbcoqu.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoqu + endif + if ( nbcoar.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoar + endif + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcotl.F b/src/tool/Suivi_Frontiere/sfcotl.F new file mode 100644 index 00000000..95789716 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcotl.F @@ -0,0 +1,445 @@ + subroutine sfcotl ( coonoe, + > somare, filare, np2are, + > cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > tritet, cotrte, aretet, hettet, + > filtet, + > quahex, coquhe, arehex, hethex, + > filhex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > voltri, pypetr, + > volqua, pypequ, + > nbarfr, arefro, + > nbqufr, quafro, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COnTroLes +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . e . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . e . nbqufr . liste des quadrangles concernes . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOTL' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer filtet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer filhex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + double precision coonoe(nbnoto,sdim) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux, jaux +c + integer nbcoa1, nbcoq1, nuphas + integer nbcoa2, nbcoq2 + integer nbarf0, nbquf0 +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' CONTROLES'')' + texte(1,5) = '(16(''=''),/)' + texte(1,6) = '(/,''Phase de controle'',i10,/,27(''-''))' + texte(1,7) = '(/,''. Examen du '',a,i10)' + texte(1,8) = + >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'', + >i10)' + texte(1,9) = '(''==> Tout va bien.'')' + texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)' + texte(1,11) = '(''Nombre de '',a,'' a basculer :'',i10)' + texte(1,12) = '(''... Reprise du '',a,i10)' +c + texte(2,4) = '(/,a6,'' CHECK'')' + texte(2,5) = '(12(''=''),/)' + texte(2,6) = '(/,''Checking phase #'',i10,/,26(''-''))' + texte(2,7) = '(/,''. Examination of '',a,'' # '',i10)' + texte(2,8) = + >'(''==> Number of corrections of nodes connected to '',a,'':'', + >i10)' + texte(2,9) = '(''==> Everything is OK.'')' + texte(2,10) = '(''Number of involved '',a,'':'',i10)' + texte(2,11) = '(''Number of '',a,'' to swap :'',i10)' + texte(2,12) = '(''... Correction of '',a,i10)' +c +cgn 1001 format(a,' :',i10,', ',3g13.5) +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. Prealables +c==== +c + nuphas = 0 + nbarf0 = nbarfr + nbquf0 = nbqufr +cgn if ( nbarfr.gt.0 ) return +c + 20 continue +c +c==== +c 3. Controle des retournements pour les decoupages homogenes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Retournements ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + nuphas = nuphas + 1 + write (ulsort,texte(langue,6)) nuphas +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOT1', nompro +#endif + call sfcot1 ( nbcoq1, nbcoa1, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > tritet, cotrte, aretet, + > hettet, filtet, + > quahex, coquhe, arehex, + > hethex, filhex, + > voltri, pypetr, + > volqua, pypequ, + > nbarf0, arefro, + > nbquf0, quafro, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( (nbcoa1+nbcoq1).gt.0 ) then +c + if ( nbcoq1.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq1 + endif +c + if ( nbcoa1.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa1 + endif +c + else +c + write (ulsort,texte(langue,9)) +c + endif +c + endif +c +c==== +c 4. Controle des interpenetrations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Interpenetrations ; codret = ', codret +#endif +c + nbcoa2 = 0 + nbcoq2 = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + nuphas = nuphas + 1 + write (ulsort,texte(langue,6)) nuphas +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCOT2', nompro +#endif + call sfcot2 ( nbcoq2, nbcoa2, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > facare, posifa, + > hettri, aretri, filtri, + > hetqua, arequa, filqua, + > cfaqua, famqua, + > tritet, cotrte, aretet, hettet, + > filtet, + > quahex, coquhe, arehex, hethex, + > filhex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > voltri, pypetr, + > volqua, pypequ, + > nbarf0, arefro, + > nbquf0, quafro, + > ulsort, langue, codret) +c + endif +c +c + if ( codret.eq.0 ) then +c + if ( (nbcoa2+nbcoq2).gt.0 ) then +c + if ( nbcoq2.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq2 + endif +c + if ( nbcoa2.gt.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa2 + endif +c + else +c + write (ulsort,texte(langue,9)) +c + endif +c + endif +#endif +c +c==== +c 5. Tant qu'il y a eu une correction, on recommence les tests +c==== +c + if ( codret.eq.0 ) then +c + if ( (nbcoa1+nbcoq1+nbcoq2+nbcoa2).gt.0 ) then +c +c On raccourcit les listes des quadrangles et aretes a controler +c + jaux = nbarf0 + nbarf0 = 0 + do 51 , iaux = 1 , jaux + if ( arefro(iaux).gt.0 ) then + nbarf0 = nbarf0 + 1 + arefro(nbarf0) = arefro(iaux) + endif + 51 continue +c + jaux = nbquf0 + nbquf0 = 0 + do 52 , iaux = 1 , jaux + if ( quafro(iaux).gt.0 ) then + nbquf0 = nbquf0 + 1 + quafro(nbquf0) = quafro(iaux) + endif + 52 continue +c + goto 20 +c + endif +c + endif +c + 59 continue +c +c==== +c 6. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcovo.F b/src/tool/Suivi_Frontiere/sfcovo.F new file mode 100644 index 00000000..a8e54632 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcovo.F @@ -0,0 +1,350 @@ + subroutine sfcovo ( bilan, + > nbtetr, nbhexa, nbpyra, nbpent, + > decafv, volare, + > coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > hettet, filtet, + > quahex, coquhe, arehex, + > hethex, filhex, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - COntroles des VOlumes +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . bilan . s . 1 . bilan du controle de l'arete . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . nbtetr . e . 1 . nombre de tetraedres voisins . +c . nbhexa . e . 1 . nombre d'hexaedres voisins . +c . nbpyra . e . 1 . nombre de pyramides voisines . +c . nbpent . e . 1 . nombre de pentaedres voisins . +c . decafv . e . 1 . decalage dans le tableau volare . +c . volare . e . * . liste des voisins . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCOVO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer bilan + integer nbtetr, nbhexa, nbpyra, nbpent + integer decafv, volare(*) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto), filtet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto), filhex(nbheto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''.. Examen du '',a,i10)' + texte(1,5) = '(''.. Probleme.'')' + texte(1,6) = '(''.. Nombre de voisins de type '',a,'':'',i10)' +c + texte(2,4) = '(/,''.. Examination of '',a,'' # '',i10)' + texte(2,5) = '(''.. Problem.'')' + texte(2,6) = '(''.. Number of neighbours '',a,''type :'',i10)' +c +#include "impr03.h" +c +c==== +c 3. Controle des tetraedres +c==== + +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Controle tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,3), nbtetr +#endif +c + do 31 , iaux = 1 , nbtetr +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,3), volare(iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOTE', nompro +#endif + call utcote ( volare(iaux), bilan, + > coonoe, + > somare, + > aretri, + > tritet, cotrte, aretet, + > hettet, filtet, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 70 + endif +c + endif +c + 31 continue +c + endif +c +c==== +c 4. Controle des hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Controle hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,6), nbhexa +#endif +c + do 41 , iaux = 1 , nbhexa +c + if ( codret.eq.0 ) then +ccc if ( volare(decafv+iaux).ne.49 ) goto 41 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + > mess14(langue,1,6), volare(decafv+iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCOHE', nompro +#endif + call utcohe ( volare(decafv+iaux), bilan, + > coonoe, + > somare, + > arequa, + > quahex, coquhe, arehex, + > hethex, filhex, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 70 + endif +c + endif +c + 41 continue +c + endif +c +c==== +c 5. Controle des pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Controle pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,5), nbpyra +#endif +c + do 51 , iaux = 1 , nbpyra +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + > mess14(langue,1,5), volare(2*decafv+iaux) +#endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 70 + endif +c + endif +c + endif +c + 51 continue +c + endif +c +c==== +c 6. Controle des pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Controle pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,7), nbpent +#endif +c + do 61 , iaux = 1 , nbpent +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + > mess14(langue,1,7), volare(3*decafv+iaux) +#endif +c + if ( codret.eq.0 ) then +c + if ( bilan.ne.0 ) then + goto 70 + endif +c + endif +c + endif +c + 61 continue +c + endif +c +c==== +c 7. Bilan +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Bilan ; codret', codret +#endif +c + 70 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( bilan.ne.0 ) then + write (ulsort,texte(langue,5)) + endif + endif +#endif +c +c==== +c 8. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfctri.F b/src/tool/Suivi_Frontiere/sfctri.F new file mode 100644 index 00000000..34da2a84 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfctri.F @@ -0,0 +1,250 @@ + subroutine sfctri ( somseg, seglig, + > tbiaux, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - ConTRole des Intersections enter les lignes +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . tbiaux . e . sfnbso . tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . !=0 : nombre d'intersections . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCTRI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "front1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer somseg(sfnbse), seglig(0:sfnbli) + integer tbiaux(sfnbso) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer extred, extref +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Ligne numero'',i4)' + texte(1,5) = + > '(''.. Le noeud'',i10,'' appartient a'',i3,'' lignes.'')' + texte(1,6) = + > '(''.. Les lignes forment'',i3,'' intersection(s).'')' + texte(1,7) = + > '(''.. Le noeud'',i10,'' est une extremite de la ligne'',i4)' + texte(1,8) = '(''.. Il appartient aussi a la ligne'',i4,/)' +c + texte(2,4) = '(''. Line #"'',i4)' + texte(2,5) = + > '(''.. The vertex #'',i10,'' belongs to'',i3,'' lines.'')' + texte(2,6) = + > '(''.. The lines make'',i3,'' intersection(s).'')' + texte(2,7) = + > '(''.. The vertex #'',i10,'' is end of the line #'',i4)' + texte(2,8) = '(''.. It belongs to the line #'',i4,/)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Recherche des points communs qui ne sont pas des extremites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. points communs ; codret', codret +#endif +c +c 2.1. ==> Aucun noeud n'appartient a une ligne +c + do 21 , iaux = 1 , sfnbso +c + tbiaux(iaux) = 0 +c + 21 continue +c +c 2.2. ==> Parcours des lignes +c Pour chacun de ses noeuds, sauf les extremites, on +c cumule le nombre de ligne d'appartenance. +c + do 22 , iaux = 1 , sfnbli +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) iaux +#endif +c + jdeb = seglig(iaux-1)+2 + jfin = seglig(iaux)-2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'extremites', somseg(jdeb-1), somseg(jfin+1) + write (ulsort,90002) 'jdeb, jfin', jdeb, jfin +#endif + do 221 , jaux = jdeb, jfin +c + tbiaux(somseg(jaux)) = tbiaux(somseg(jaux)) + 1 +c + 221 continue +c + 22 continue +c +c 2.3. ==> Aucun noeud ne doit appartenir a plus d'une ligne +c + do 23 , iaux = 1 , sfnbso +c + if ( tbiaux(iaux).gt.1 ) then + write (ulsort,texte(langue,5)) iaux, tbiaux(iaux) + codret = codret + 1 + endif +c + 23 continue +c +c==== +c 3. Recherche des extremites qui sont des points interieurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. extremites ; codret', codret +#endif +c +c 3.1. ==> Parcours des lignes +c On repere les deux extremites et on +c cherche si elles appartiennent a une autre ligne +c + do 31 , iaux = 1 , sfnbli +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) iaux +#endif +c + jdeb = seglig(iaux-1)+1 + jfin = seglig(iaux)-1 + extred = somseg(jdeb) + extref = somseg(jfin) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'extremites', extred, extref +#endif +c + do 311 , kaux = 1 , sfnbli +c + if ( kaux.ne.iaux ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) kaux +#endif +c + jdeb = seglig(kaux-1)+2 + jfin = seglig(kaux)-2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'extremites', somseg(jdeb-1), somseg(jfin+1) + write (ulsort,90002) 'jdeb, jfin', jdeb, jfin +#endif + do 3111 , jaux = jdeb, jfin +c + if ( somseg(jaux).eq.extred .or. + > somseg(jaux).eq.extref ) then + codret = codret + 1 + write (ulsort,texte(langue,7)) somseg(jaux), iaux + write (ulsort,texte(langue,8)) kaux + endif +c + 3111 continue +c + endif +c + 311 continue +c + 31 continue +c +c==== +c 4. Bilan +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,6)) codret +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfcvco.F b/src/tool/Suivi_Frontiere/sfcvco.F new file mode 100644 index 00000000..f919d9d0 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcvco.F @@ -0,0 +1,167 @@ + subroutine sfcvco ( dimcst, nbnoto, sdim, + > coonca, geocoo, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - ConVersion des COordonnees +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dimcst . e . 1 . dimension de la coordonnee constante . +c . nbnoto . e . 1 . nombre total de noeuds . +c . sdim . e . 1 . dimension de l'espace de travail . +c . coonca . e . nbnoto . coordonnees des noeuds dans le calcul . +c . . . *sdimca. . +c . geocoo . e .nbnoto**. coordonnees des sommets de la frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCVCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer dimcst, nbnoto, sdim + double precision coonca(nbnoto,*), geocoo(nbnoto,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lenoeu +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Coordonnee constante incorrecte :'',i7)' +c + texte(2,4) = '(''Constant coordinate is wrong:'',i7)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'dimcst', dimcst + write (ulsort,90002) 'sdim', sdim +#endif +c==== +c 2. Transfert des coordonnees +c==== +c + if ( sdim.eq.2 ) then +c + if ( dimcst.eq.0 .or. dimcst.eq.3 ) then + iaux = 1 + jaux = 2 + elseif ( dimcst.eq.1 ) then + iaux = 2 + jaux = 3 + elseif ( dimcst.eq.2 ) then + iaux = 1 + jaux = 3 + else + write (ulsort,texte(langue,4)) dimcst + codret = 1 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'iaux, jaux', iaux, jaux +#endif +c + if ( codret.eq.0 ) then +c + do 21 , lenoeu = 1 , nbnoto + geocoo(lenoeu,1) = coonca(lenoeu,iaux) + geocoo(lenoeu,2) = coonca(lenoeu,jaux) + 21 continue +c + endif +c + else +c + do 22 , lenoeu = 1 , nbnoto + geocoo(lenoeu,1) = coonca(lenoeu,1) + geocoo(lenoeu,2) = coonca(lenoeu,2) + geocoo(lenoeu,3) = coonca(lenoeu,3) + 22 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + + diff --git a/src/tool/Suivi_Frontiere/sfcvgf.F b/src/tool/Suivi_Frontiere/sfcvgf.F new file mode 100644 index 00000000..54740844 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfcvgf.F @@ -0,0 +1,694 @@ + subroutine sfcvgf ( nohman, mafrmd, nocdfr, ncafdg, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - ConVersion de la Geometrie de la Frontiere +c - - - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohman . e . char*8 . nom de l'objet maillage homard iteration n . +c . mafrmd . e . char*8 . maillage de la frontiere au format med . +c . nocdfr . s . char*8 . maillage de la frontiere a format C . +c . ncafdg . es . char*8 . nom de l'objet groupes frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFCVGF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +#include "front1.h" +c +c 0.3. ==> arguments +c + character*8 nohman + character*8 mafrmd, nocdfr, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet + integer ptypel, pnoeel, nbnoto,nbelem, nvosom, pcoonc + integer sdimca, mdimca, dimcst + integer pgeoco, psomse, pnumli, ptypli, psegli, adabsc + integer pnumfa, pnomfa, pfamee + integer nbnomb + integer ptngrf, pointe, pligfa + integer pttgrl, ptngrl, pointl + integer ppovos, pvoiso + integer laligd, nbfd00, nblign, nbf + integer ptrav2 + integer lalign, noelig, arelig +c + integer iaux, jaux, nsomli + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + character*8 ntrav1, ntrav2 + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccocl, ncfami + character*8 ncequi, ncfron, ncnomb +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. recuperation des donnees du maillage HOMARD +c Le seul but est de recuperer dimcst. Il faut le dimcst du maillage +c de calcul et pas celui de la frontiere car ils peuvent etre +c differents : le maillage de calcul est 3D alors que la frontiere +c est dans un plan. +c +c==== +c 2.1. ==> nom interne des branches +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nohman, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> recuperation de la caracteristique des dimensions +c + if ( codret.eq.0 ) then +c + call gmliat ( nhnoeu, 2, dimcst, codre0 ) + codret = abs(codre0) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'dimcst', dimcst +#endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage de la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c +c 3.1. ==> nom interne des branches +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC - Frontiere', nompro +#endif + call utnomc ( mafrmd, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccocl, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, nccono ) +#endif +c +c 3.2. ==> recuperation des pointeurs +c + if ( codret.eq.0 ) then +c + call gmliat ( ncnoeu, 1, nbnoto, codre1 ) + call gmliat ( nccono, 1, nbelem, codre2 ) + call gmliat ( nccono, 2, nbmane, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 2002 + call utad11 ( iaux, ncnoeu, nccono, + > pcoonc, jaux, jaux, jaux, + > ptypel, pfamee, pnoeel, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( ncfami, 1, nbf, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD13', nompro +#endif + iaux = 30 + call utad13 ( iaux, ncfami, + > pnumfa, pnomfa, + > pointe, jaux, ptngrf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncfron, pligfa, iaux, codret ) +c + endif +c +c==== +c 4. correspondance entre les familles du maillage de calcul et +c les lignes dont on demande le suivi +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. correspondance ; codret', codret +#endif +c +c 4.1. ==> Enregistrement des groupes du suivi +c + if ( codret.eq.0 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafdg, iaux, + > nbfd00, jaux, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFLG', nompro +#endif + call vcsflg ( nbfd00, nbf, + > imem(pointl), imem(pttgrl), smem(ptngrl), + > imem(pointe), smem(ptngrf), + > imem(pnumfa), smem(pnomfa), + > imem(pligfa), iaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Allocation de la tete du maillage au format C +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. tete du maillage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( nocdfr, 'Cal_Fron', 0, iaux, codre1 ) + call gmaloj ( nocdfr//'.TypeLign', ' ', nbfd00, ptypli, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 50 , iaux = 1 , nbfd00 + imem(ptypli+iaux-1) = 0 + 50 continue +c + endif +c +c==== +c 6. Examen des lignes jusqu'a ne plus avoir de ligne fermee +c==== +c + laligd = 1 +c + 60 continue +c +c 6.1. ==> determination des elements voisins des sommets +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.1. elements voisins ; codret', codret +#endif +c +c 6.1.1. ==> comptage du nombre d'elements pour chaque sommet +c et determination des pointeurs par sommets sur "voisom", +c ranges dans la structure "povoso" +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'PtTabEnt', 0, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = nbnoto + 1 + call gmaloj ( ntrav1//'.Pointeur', ' ', iaux, ppovos, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVOS1', nompro +#endif + call vcvos1 ( imem(pnoeel), imem(ptypel), imem(ppovos), + > nvosom, nbelem, nbmane, nbnoto ) +c + endif +c +c 6.1.2. ==> reperage des voisins : la structure voisom contient la +c liste des elements 1d, 2d ou 3d voisins de chaque sommet +c (allocation du tableau des voisins a une taille egale +c au nombre cumule de voisins des sommets) +c + if ( codret.eq.0 ) then +c + call gmaloj ( ntrav1//'.Table', ' ', nvosom, pvoiso, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCVOS2', nompro +#endif + call vcvos2 ( imem(pnoeel), imem(ptypel), imem(ppovos), + > imem(pvoiso), nvosom, nbelem, nbmane, nbnoto ) +c + endif +c +c 6.2. ==> Recherche d'eventuelles lignes fermees +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. lignes fermees ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFL0', nompro +#endif + call vcsfl0 ( sdimca, nbelem, nvosom, nbnoto, nbf, + > rmem(pcoonc), + > imem(ptypel), imem(pfamee), + > imem(ppovos), imem(pvoiso), + > imem(pnumfa), smem(pnomfa), imem(pligfa), + > laligd, nbfd00, + > lalign, noelig, arelig, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lalign', lalign +#endif +c +c 6.3. ==> Si on a une ligne fermee, on l'ouvre par duplication du noeud +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. ligne fermee ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( lalign.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'noelig, arelig', noelig, arelig + write (ulsort,92010) + > (rmem(pcoonc+noelig-1+nbnoto*(iaux-1)), iaux=1,sdimca) +#endif +c + imem(ptypli+lalign-1) = 1 +c +c 6.3.1. ==> Ajout d'un noeud +c + if ( codret.eq.0 ) then +c + iaux = nbnoto+1 + call gmmod ( ncnoeu//'.Coor', + > pcoonc, nbnoto, iaux, sdimca, sdimca, codre0 ) + codret = abs(codre0) +c + endif +c + if ( codret.eq.0 ) then +c + nbnoto = nbnoto + 1 + do 631 , iaux = 1 , sdimca + rmem(pcoonc+nbnoto-1+nbnoto*(iaux-1)) = + > rmem(pcoonc+noelig-1+nbnoto*(iaux-1)) + 631 continue +c + endif +c +c 6.3.2. ==> Modification de la description de l'arete terminale +c + if ( codret.eq.0 ) then +c + if ( imem(pnoeel+arelig-1).eq.noelig ) then + imem(pnoeel+arelig-1) = nbnoto + elseif ( imem(pnoeel+arelig-1+nbelem).eq.noelig ) then + imem(pnoeel+arelig-1+nbelem) = nbnoto + else + codret = 632 + endif +c + endif +c +c 6.3.3. ==> Menage +c + if ( codret.eq.0 ) then +c + call gmsgoj ( ntrav1, codre0 ) + codret = abs(codre0) +c + endif +c +c 6.3.4. ==> Maintenant que la ligne est ouverte, on recommence. +c + laligd = lalign +c + goto 60 +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro, nocdfr//'.TypeLign') +#endif + 700 continue +c +c==== +c 7. Les coordonnees +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. coordonnees ; codret', codret +#endif +c 7.1. ==> La dimension +c + sfnbso = nbnoto + if ( dimcst.eq.0 ) then + sfsdim = sdimca + else + sfsdim = sdimca - 1 + endif + sfmdim = mdim +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'dimcst', dimcst + write (ulsort,90002) 'sdimca, sfsdim', sdimca, sfsdim + write (ulsort,90002) 'sfmdim', sfmdim +#endif +c +c 7.2. ==> Memoire +c + if ( codret.eq.0 ) then +c + call gmecat ( nocdfr, 1, sfsdim, codre1 ) + call gmecat ( nocdfr, 2, sfmdim, codre2 ) + call gmecat ( nocdfr, 3, sfnbso, codre3 ) + iaux = sfsdim*sfnbso + call gmaloj ( nocdfr//'.CoorNoeu', ' ', iaux, pgeoco, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 7.3. ==> Transfert +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCVCO', nompro +#endif + call sfcvco ( dimcst, nbnoto, sfsdim, + > rmem(pcoonc), rmem(pgeoco), + > ulsort, langue, codret ) +c + endif +c +c==== +c 8. conversion du format MED au format C +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. Conversion MED C ; codret', codret +#endif +c +c 8.1. ==> Allocation : on surdimensionne +c + sfnbli = nbfd00 + sfnbse = 2*(nbnoto+nbfd00) +c + if ( codret.eq.0 ) then +c + call gmecat ( nocdfr, 4, sfnbli, codre1 ) + call gmecat ( nocdfr, 5, sfnbse, codre2 ) + call gmaloj ( nocdfr//'.NumeLign', ' ', sfnbli, pnumli, codre3 ) + call gmaloj ( nocdfr//'.PtrSomLi', ' ', sfnbli+1, psegli, codre4 ) + call gmaloj ( nocdfr//'.SommSegm', ' ', sfnbse, psomse, codre5 ) + call gmaloj ( nocdfr//'.AbsCurvi', ' ', sfnbse, adabsc, codre6 ) + call gmalot ( ntrav2, 'entier', nbelem, ptrav2, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c 8.2. ==> Conversion +c + if ( codret.eq.0 ) then +c + imem(psegli) = 0 + imem(psegli+1) = nbnoto+1 +cgn print *,'appel de vcsfli' +cgn print *,'nbfd00 = ', nbfd00 +cgn print *,'nbelem, nbmane, nvosom, nbnoto, nbf = ', +cgn > nbelem, nbmane, nvosom, nbnoto, nbf +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'VCSFLI', nompro +#endif + call vcsfli ( sdimca, nbelem, nbmane, nvosom, nbnoto, nbf, + > rmem(pcoonc), + > imem(pnoeel), imem(ptypel), imem(pfamee), + > imem(ppovos), imem(pvoiso), + > imem(pnumfa), smem(pnomfa), imem(pligfa), + > nbfd00, nblign, nsomli, + > imem(pnumli), imem(psegli), imem(psomse), + > rmem(adabsc), imem(ptrav2), + > ulsort, langue, codret ) +c + endif +c +c 8.3. ==> Redimensionnement en tenant compte du vrai nombre de lignes +c et de sommets decrivant les lignes +c + if ( codret.eq.0 ) then +c + sfnbli = nblign +c + call gmmod ( nocdfr//'.NumeLign', + > pnumli, nbfd00, sfnbli, 1, 1, codre1 ) + call gmmod ( nocdfr//'.TypeLign', + > ptypli, nbfd00, sfnbli, 1, 1, codre2 ) + call gmmod ( nocdfr//'.PtrSomLi', + > pnumli, nbfd00+1, sfnbli+1, 1, 1, codre3 ) + call gmmod ( nocdfr//'.SommSegm', + > psomse, sfnbse, nsomli, 1, 1, codre4 ) + call gmmod ( nocdfr//'.AbsCurvi', + > adabsc, sfnbse, nsomli, 1, 1, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + sfnbse = nsomli +c + call gmecat ( nocdfr, 4, sfnbli, codre1 ) + call gmecat ( nocdfr, 5, sfnbse, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmsgoj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 8.4. ==> Enregistrement des groupes du suivi +c + if ( codret.eq.0 ) then +c + call gmatoj ( nocdfr//'.Groupes', ncafdg, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nocdfr ) + call gmprot (nompro, nocdfr//'.CoorNoeu', 1 , 20 ) + call gmprot (nompro, nocdfr//'.CoorNoeu', sfnbso-20 , sfnbso ) + call gmprsx (nompro, nocdfr//'.NumeLign' ) + call gmprsx (nompro, nocdfr//'.PtrSomLi' ) + call gmprot (nompro, nocdfr//'.SommSegm', 1 , 20 ) + call gmprot (nompro, nocdfr//'.SommSegm', sfnbse-20 , sfnbse ) + call gmprot (nompro, nocdfr//'.AbsCurvi', 1 , 20 ) + call gmprot (nompro, nocdfr//'.AbsCurvi', sfnbse-20 , sfnbse ) + call gmprsx (nompro, nocdfr//'.Groupes') + endif +#endif +c +c==== +c 9. controle des intersections +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. controle intersections ; codret', codret +#endif +c +c 9.1. ==> Allocation : on surdimensionne +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav2, 'entier', sfnbso, ptrav2, codre0 ) + codret = abs(codre0) +c + endif +c +c 9.2. ==> Controle +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFCTRI', nompro +#endif + call sfctri ( imem(psomse), imem(psegli), + > imem(ptrav2), + > ulsort, langue, codret) +c + endif +c +c 9.3. ==> menage +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav2, codre0 ) + codret = abs(codre0) +c + endif +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfdefg.F b/src/tool/Suivi_Frontiere/sfdefg.F new file mode 100644 index 00000000..bb181928 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfdefg.F @@ -0,0 +1,258 @@ + subroutine sfdefg ( suifro, + > nocman, nocmaf, ncafdg, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - DEFinition des Groupes +c - - --- - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . nocman . e . char*8 . nom de l'objet maillage calcul iteration n . +c . nocmaf . e . char*8 . nom de l'objet maillage frontiere discrete . +c . ncafdg . e . char*8 . nom de l'objet des frontieres discretes/CAO. +c . . . . nom des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFDEFG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "motcle.h" +c +c 0.3. ==> arguments +c + integer suifro +c + character*8 nocman, nocmaf, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbf, nblign, nbgrmx +c + character*8 ncfami + character*8 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro', suifro + if ( mod(suifro,2).eq.0 ) then + call gmprsx (nompro//' - maillage frontiere', nocmaf) + else + call gmprsx (nompro//' - maillage calcul', nocman) + endif + call gmprsx (nompro//' - groupes de la frontiere', ncafdg) + call gmprsx (nompro//' - groupes de la frontiere', + > ncafdg//'.Table') +#endif +c +#include "impr03.h" +c==== +c 2. les structures +c==== +c 2.1. ==> Allocation de la branche de la frontiere de taille egale au +c nombre de familles MED presentes +c + if ( mod(suifro,2).eq.0 ) then + saux08 = nocmaf + else + saux08 = nocman + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro//' - saux08', saux08 ) +#endif +c +c 2.3.1. ==> Caracteristiques des familles du maillage de la frontiere +c + if ( codret.eq.0 ) then +c + call gmnomc ( saux08//'.Famille' , ncfami, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( ncfami, 1, nbf, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbf', nbf +#endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmmod ( saux08//'.Frontier', + > iaux, 0, nbf, 1, 1, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, saux08//'.Frontier' ) +#endif +c +c==== +c 3. Les bords sont-ils definis par des groupes dans les donnees, +c ou par des groupes dans les familles du maillage de frontiere ? +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Bords ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGROU', nompro +#endif + call sfgrou ( ncfami, ncafdg, + > nblign, nbgrmx, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nblign', nblign + write (ulsort,90002) 'nbgrmx', nbgrmx + call gmprsx ( nompro, ncafdg ) +#endif +c + endif +c +c==== +c 4. Quand aucune ligne n'a ete definie dans le fichier de configuration +c on suivra toutes celles definies dans le maillage de la frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. ; codret', codret +#endif +c + if ( nblign.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. 0 ligne ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRFA', nompro +#endif + call sfgrfa ( saux08, ncafdg, + > nblign, nbf, nbgrmx, + > ulsort, langue, codret) +c + endif +c +c==== +c 5. Quand des lignes ont ete definies dans le fichier de configuration +c on eliminera toutes celles inconnues dans le maillage de la +c frontiere +c==== +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) '5.', nblign, 'lignes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRFB', nompro +#endif + call sfgrfb ( saux08, ncafdg, + > nblign, nbf, nbgrmx, + > ulsort, langue, codret) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx ( nompro, ncafdg ) + call gmprsx ( nompro, ncafdg//'.Pointeur' ) + call gmprsx ( nompro, ncafdg//'.Taille' ) + call gmprsx ( nompro, ncafdg//'.Table' ) +#endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffa01.F b/src/tool/Suivi_Frontiere/sffa01.F new file mode 100644 index 00000000..d7c59927 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffa01.F @@ -0,0 +1,238 @@ + subroutine sffa01 ( nouvno, coopro, + > lenoeu, + > coonoe, + > cencyl, axecyl, raycyl, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontiere Analytique - type 01 - cylindre +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nouvno . e . 1 . dernier numero de noeud cree . +c . coopro . s . sdim . nouvelles coordonnees du noeud . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . coonoe . e . nouvno . coordonnees des noeuds . +c . . . *sdim . . +c . cencyl . e . sdim . origine de l'axe du cylindre . +c . axecyl . e . sdim . axe du cylindre . +c . raycyl . e . 1 . rayon du cylindre . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFA01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer lenoeu + integer nouvno +c + double precision coonoe(nouvno,sdim) + double precision coopro(sdim) + double precision cencyl(sdim), axecyl(sdim), raycyl +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision vectca(3) + double precision daux1(3) + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Axe du cylindre :'',3g17.9)' + texte(1,5) = '(''Centre du cylindre :'',3g17.9)' + texte(1,6) = '(''Rayon du cylindre :'',g17.9)' + texte(1,7) = '(''Noeud '',i8,'' :'',3g17.9)' + texte(1,8) = '(''Coordonnees initiales :'',3g17.9)' + texte(1,9) = '(''Coordonnees projetees :'',3g17.9)' +c + texte(2,4) = '(''Axis of the cylindre :'',3g17.9)' + texte(2,5) = '(''Center of the cylindre:'',3g17.9)' + texte(2,6) = '(''Radius of the cylindre:'',g17.9)' + texte(2,7) = '(''Node '',i8,'' :'',3g17.9)' + texte(2,8) = '(''Initial coordonnates:'',3g17.9)' + texte(2,9) = '(''Moved coordonnates :'',3g17.9)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then + write (ulsort,texte(langue,4)) (axecyl(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,5)) (cencyl(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,6)) raycyl + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then + write (ulsort,texte(langue,7)) + > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) + endif +#endif +c +c 1.2. ==> Tout va bien a priori +c + codret = 0 +c +c==== +c 2. Projection +c==== +c 2.1. ==> daux = produit scalaire de CM avec l'axe +c daux = CM * axe = ( OmegaM - OmegaC ) * axe +c +c x M +c . . +c . . +c . . +c . . +c . . +c C . . A +c ---x--------------------x------------------ +c <--------------------> +c daux +c +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'vectcm', +cgn >((coonoe(lenoeu,iaux)-cencyl(iaux)),iaux=1,sdim) +cgn endif + daux = 0.d0 + do 21 , iaux = 1 , sdim + daux = daux + > + (coonoe(lenoeu,iaux)-cencyl(iaux)) * axecyl(iaux) + 21 continue +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'daux',daux +cgn endif +c +c 2.2. ==> Vecteur CA = daux * vect(axe) +c + do 22 , iaux = 1 , sdim + vectca(iaux) = daux * axecyl(iaux) + 22 continue +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'vectca',(vectca(iaux),iaux=1,sdim) +cgn endif +c +c 2.3. ==> Vecteur AM = CM - CA = ( OmegaM - OmegaC ) - CA +c + do 23 , iaux = 1 , sdim + daux1(iaux) = coonoe(lenoeu,iaux) + > - cencyl(iaux) + > - vectca(iaux) + 23 continue +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'vectAM',(daux1(iaux),iaux=1,sdim) +cgn endif +c +c 2.4. ==> Rayon pour le point M avant projection +c + daux = 0.d0 + do 24 , iaux = 1 , sdim + daux = daux + daux1(iaux)*daux1(iaux) + 24 continue + daux = sqrt(daux) +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'AM',daux +cgn endif +c +c 2.5. ==> Vecteur AP = (Rayon cylindre/dist(AM)) * Vecteur AM +c + daux = raycyl / daux + do 25 , iaux = 1 , sdim + daux1(iaux) = daux *daux1(iaux) + 25 continue +cgn if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then +cgn write (ulsort,90004) 'vectAP',(daux1(iaux),iaux=1,sdim) +cgn endif +c +c 2.6. ==> Coordonnees projetees : OmegaP = OmegaC + CD + DP +c + do 26 , iaux = 1 , sdim + coopro(iaux) = cencyl(iaux) + vectca(iaux) + daux1(iaux) + 26 continue +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-113 .or.lenoeu.eq.-13 ) then + write (ulsort,texte(langue,9)) (coopro(iaux), iaux = 1 , sdim) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffa02.F b/src/tool/Suivi_Frontiere/sffa02.F new file mode 100644 index 00000000..4eae7f0d --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffa02.F @@ -0,0 +1,192 @@ + subroutine sffa02 ( nouvno, coopro, + > lenoeu, + > coonoe, + > censph, raysph, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontiere Analytique - type 02 - sphere +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nouvno . e . 1 . dernier numero de noeud cree . +c . coopro . e . sdim . nouvelles coordonnees du noeud . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . coonoe . e . nouvno . coordonnees des noeuds . +c . . . *sdim . . +c . censph . e . sdim . centre de la sphere . +c . raycyl . e . 1 . rayon de la sphere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFA02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer lenoeu + integer nouvno +c + double precision coonoe(nouvno,sdim) + double precision coopro(sdim) + double precision censph(sdim), raysph +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision vectcm(3) + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Centre de la sphere :'',3g15.8)' + texte(1,5) = '(''Rayon de la sphere :'',g15.8)' + texte(1,7) = '(''Noeud '',i8,'' :'',3g15.8)' + texte(1,8) = '(''Coordonnees initiales :'',3g15.8)' + texte(1,9) = '(''Coordonnees projetees :'',3g15.8)' +c + texte(2,4) = '(''Centre of the sphere:'',3g15.8)' + texte(2,5) = '(''Radius of the sphere:'',g15.8)' + texte(2,7) = '(''Node '',i8,'' :'',3g15.8)' + texte(2,8) = '(''Initial coordonnates:'',3g15.8)' + texte(2,9) = '(''Moved coordonnates :'',3g15.8)' +c + 1001 format(a,' :',3g15.8) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) (censph(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,5)) raysph +#endif +c +c 1.2. ==> Tout va bien a priori +c + codret = 0 +c +c==== +c 2. Projection +c==== +c 2.1. ==> Vecteur CM +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + > lenoeu,(coonoe(lenoeu,iaux),iaux=1,sdim) +#endif +c + do 21 , iaux = 1 , sdim + vectcm(iaux) = coonoe(lenoeu,iaux) - censph(iaux) + 21 continue +cgn write (ulsort,1001) 'vectCM',(vectcm(iaux),iaux=1,sdim) +c +c 2.2. ==> Rayon pour le point M avant projection +c + daux = 0.d0 + do 22 , iaux = 1 , sdim + daux = daux + vectcm(iaux)*vectcm(iaux) + 22 continue + daux = sqrt(daux) +cgn write (ulsort,1001) 'DM',daux +c +c 2.3. ==> Vecteur CP = (Rayon cylindre/dist(CM)) * Vecteur CM +c + daux = raysph / daux + do 23 , iaux = 1 , sdim + vectcm(iaux) = daux *vectcm(iaux) + 23 continue +cgn write (ulsort,1001) 'vectCP',(vectcm(iaux),iaux=1,sdim) +c +c 2.4. ==> Coordonnees projetees : OmegaP = OmegaC + CP +c + do 24 , iaux = 1 , sdim + coopro(iaux) = censph(iaux) + vectcm(iaux) + 24 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) (coonoe(lenoeu,iaux),iaux=1,sdim) + write (ulsort,texte(langue,9)) (coopro(iaux), iaux = 1 , sdim) +#endif + daux = 0.d0 + do 222 , iaux = 1 , sdim + daux = daux + (coopro(iaux)-censph(iaux))**2 + 222 continue + daux = sqrt(daux) +cgn write (ulsort,1001) 'DM',daux +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffa03.F b/src/tool/Suivi_Frontiere/sffa03.F new file mode 100644 index 00000000..e368dc6a --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffa03.F @@ -0,0 +1,231 @@ + subroutine sffa03 ( nouvno, coopro, + > lenoeu, + > coonoe, + > oricon, axecon, angcon, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontiere Analytique - type 03 - cone +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nouvno . e . 1 . dernier numero de noeud cree . +c . coopro . s . sdim . nouvelles coordonnees du noeud . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . coonoe . e . nouvno . coordonnees des noeuds . +c . . . *sdim . . +c . oricon . e . sdim . origine de l'axe du cone . +c . axecon . e . sdim . axe du cone . +c . angcon . e . 1 . angle du cone en radian . +c . oricon . e . sdim . origine de l'axe du cone . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFA03' ) +c +#include "nblang.h" +#include "consta.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer lenoeu + integer nouvno +c + double precision coonoe(nouvno,sdim) + double precision coopro(sdim) + double precision oricon(sdim), axecon(sdim), angcon +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision vectoa(3) + double precision daux1(3) + double precision daux + double precision rayon +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Axe du cone :'',3g16.9)' + texte(1,5) = '(''Origine du cone :'',3g16.9)' + texte(1,6) = '(''Angle du cone :'',g16.9)' + texte(1,7) = '(''Noeud '',i8,'' :'',3g16.9)' + texte(1,8) = '(''Coordonnees initiales :'',3g16.9)' + texte(1,9) = '(''Coordonnees projetees :'',3g16.9)' +c + texte(2,4) = '(''Axis of the cone :'',3g16.9)' + texte(2,5) = '(''Origin of the cone:'',3g16.9)' + texte(2,6) = '(''Radius of the cone:'',g16.9)' + texte(2,7) = '(''Node '',i8,'' :'',3g16.9)' + texte(2,8) = '(''Initial coordonnates:'',3g16.9)' + texte(2,9) = '(''Moved coordonnates :'',3g16.9)' +c +cgn 1001 format(a,' :',3g16.9) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) (axecon(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,5)) (oricon(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,6)) angcon*180.d0/pi +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) +#endif +c +c 1.2. ==> Tout va bien a priori +c + codret = 0 +c +c==== +c 2. Projection +c==== +c 2.1. ==> daux = produit scalaire de OM avec l'axe +c daux = OM * axe = ( OmegaM - OmegaO ) * axe +c +c x M +c . . +c . . +c . . +c . . +c . . +c O . . A +c ---x--------------------x------------------ +c <--------------------> +c daux +c +cgn write (ulsort,1001) 'vectcm', +cgn >((coonoe(lenoeu,iaux)-oricon(iaux)),iaux=1,sdim) + daux = 0.d0 + do 21 , iaux = 1 , sdim + daux = daux + > + (coonoe(lenoeu,iaux)-oricon(iaux)) * axecon(iaux) + 21 continue +cgn write (ulsort,1001) 'daux',daux +c +c 2.2. ==> Vecteur OA = daux * vect(axe) +c + do 22 , iaux = 1 , sdim + vectoa(iaux) = daux * axecon(iaux) + 22 continue +cgn write (ulsort,1001) 'vectoa',(vectoa(iaux),iaux=1,sdim) +c +c 2.3. ==> Vecteur AM = OM - OA = ( OmegaM - OmegaO ) - OA +c + do 23 , iaux = 1 , sdim + daux1(iaux) = coonoe(lenoeu,iaux) + > - oricon(iaux) + > - vectoa(iaux) + 23 continue +cgn write (ulsort,1001) 'vectAM',(daux1(iaux),iaux=1,sdim) +c +c 2.4. ==> Rayon du cone = tangente(angle)*OA +c + daux = 0.d0 + do 24 , iaux = 1 , sdim + daux = daux + vectoa(iaux)**2 + 24 continue + rayon = tan(angcon)*sqrt(daux) +c +c 2.5. ==> Rayon pour le point M avant projection +c + daux = 0.d0 + do 25 , iaux = 1 , sdim + daux = daux + daux1(iaux)*daux1(iaux) + 25 continue + daux = sqrt(daux) +cgn write (ulsort,1001) 'AM',daux +c +c 2.6. ==> Vecteur AP = (Rayon cone/dist(AM)) * Vecteur AM +c + daux = rayon / daux + do 26 , iaux = 1 , sdim + daux1(iaux) = daux *daux1(iaux) + 26 continue +cgn write (ulsort,1001) 'vectAP',(daux1(iaux),iaux=1,sdim) +c +c 2.7. ==> Coordonnees projetees : OmegaP = OmegaC + CD + DP +c + do 27 , iaux = 1 , sdim + coopro(iaux) = oricon(iaux) + vectoa(iaux) + daux1(iaux) + 27 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) (coopro(iaux), iaux = 1 , sdim) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffa05.F b/src/tool/Suivi_Frontiere/sffa05.F new file mode 100644 index 00000000..16c19ac8 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffa05.F @@ -0,0 +1,244 @@ + subroutine sffa05 ( nouvno, coopro, + > lenoeu, + > coonoe, + > centor, axetor, rayrev, raypri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontiere Analytique - type 05 - tore +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nouvno . e . 1 . dernier numero de noeud cree . +c . coopro . s . sdim . nouvelles coordonnees du noeud . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . coonoe . e . nouvno . coordonnees des noeuds . +c . . . *sdim . . +c . centor . e . sdim . origine de l'axe du tore . +c . axetor . e . sdim . axe du tore . +c . rayrev . e . 1 . rayon de revolution du tore . +c . raypri . e . 1 . rayon primaire du tore . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFA05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer lenoeu + integer nouvno +c + double precision coonoe(nouvno,sdim) + double precision coopro(sdim) + double precision centor(sdim), axetor(sdim) + double precision rayrev, raypri +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision vectnp(3) + double precision vectca(3) + double precision daux1(3) + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Axe du tore :'',3g16.9)' + texte(1,5) = '(''Centre du tore :'',3g16.9)' + texte(1,6) = '(''Rayon de revolution :'',g16.9)' + texte(1,7) = '(''Rayon primaire :'',g16.9)' + texte(1,8) = '(''Noeud '',i8,'' :'',3g16.9)' + texte(1,9) = '(''Coordonnees initiales :'',3g16.9)' + texte(1,10) = '(''Coordonnees projetees :'',3g16.9)' +c + texte(2,4) = '(''Axis of the torus :'',3g16.9)' + texte(2,5) = '(''Center of the torus:'',3g16.9)' + texte(2,6) = '(''Revolution radius :'',g16.9)' + texte(2,7) = '(''Primary radius :'',g16.9)' + texte(2,8) = '(''Node '',i8,'' :'',3g16.9)' + texte(2,9) = '(''Initial coordonnates:'',3g16.9)' + texte(2,10) = '(''Moved coordonnates :'',3g16.9)' +c +cgn 1001 format(a,' :',3g16.9) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) (axetor(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,5)) (centor(iaux), iaux = 1 , sdim) + write (ulsort,texte(langue,6)) rayrev + write (ulsort,texte(langue,7)) raypri +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) + > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) +#endif +c +c 1.2. ==> Tout va bien a priori +c + codret = 0 +c +c==== +c 2. Projection +c==== +c La figure est dans le plan de l'axe et du point M. +c Le vecteur normal qui s'enfonce dans le plan est : u = axe x CM +c Le point A est l'intersection de ce plan avec le cercle de revolution +c Le vecteur CA est colineaire au produit vectoriel u x axe +c Axe +c | +c | +c | +c | +c | P +c | x +c | M . +c | x +c | . +c | . +c C |----------------------x-----------> +c A +c +c 2.1. ==> vectnp = vecteur normal au plan +c produit vectoriel de l'axe avec CM +c = axe x CM = axe x ( OmegaM - OmegaC ) +c + do 21 , iaux = 1 , sdim + daux1(iaux) = coonoe(lenoeu,iaux) - centor(iaux) + 21 continue +c + vectnp(1) = axetor(2)*daux1(3) - axetor(3)*daux1(2) + vectnp(2) = axetor(3)*daux1(1) - axetor(1)*daux1(3) + vectnp(3) = axetor(1)*daux1(2) - axetor(2)*daux1(1) +cgn write (ulsort,1001) 'vectnp',vectnp +c +c 2.2. ==> Vecteur CA = vectnp x vect(axe) +c + vectca(1) = vectnp(2)*axetor(3) - vectnp(3)*axetor(2) + vectca(2) = vectnp(3)*axetor(1) - vectnp(1)*axetor(3) + vectca(3) = vectnp(1)*axetor(2) - vectnp(2)*axetor(1) +c + daux = 0.d0 + do 221 , iaux = 1 , sdim + daux = daux + vectca(iaux)**2 + 221 continue + daux = rayrev / sqrt(daux) +c + do 222 , iaux = 1 , sdim + vectca(iaux) = vectca(iaux) * daux + 222 continue +cgn write (ulsort,1001) 'vectca',(vectca(iaux),iaux=1,sdim) +c +c 2.3. ==> Vecteur AM = CM - CA = ( OmegaM - OmegaC ) - CA +c + do 23 , iaux = 1 , sdim + daux1(iaux) = coonoe(lenoeu,iaux) + > - centor(iaux) + > - vectca(iaux) + 23 continue +cgn write (ulsort,1001) 'vectAM',(daux1(iaux),iaux=1,sdim) +c +c 2.4. ==> Rayon pour le point M avant projection +c + daux = 0.d0 + do 24 , iaux = 1 , sdim + daux = daux + daux1(iaux)*daux1(iaux) + 24 continue + daux = sqrt(daux) +cgn write (ulsort,1001) 'AM',daux +c +c 2.5. ==> Vecteur AP = (Rayon primaire/dist(AM)) * Vecteur AM +c + daux = raypri / daux + do 25 , iaux = 1 , sdim + daux1(iaux) = daux *daux1(iaux) + 25 continue +cgn write (ulsort,1001) 'vectAP',(daux1(iaux),iaux=1,sdim) +c +c 2.6. ==> Coordonnees projetees : OmegaP = OmegaC + CD + DP +c + do 26 , iaux = 1 , sdim + coopro(iaux) = centor(iaux) + vectca(iaux) + daux1(iaux) + 26 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) (coopro(iaux), iaux = 1 , sdim) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffaf1.F b/src/tool/Suivi_Frontiere/sffaf1.F new file mode 100644 index 00000000..44c74a0b --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffaf1.F @@ -0,0 +1,180 @@ + subroutine sffaf1 ( nbfron, pointa, taigra, nomgra, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontieres AFfichage - 1 +c - - - -- - +c remarque : sffaf1, sffaf2 et sffaf3 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfron . e . 1 . nombre de frontieres . +c . pointa . e .0:nbfron. pointeur sur le tableau nomgra . +c . taigra . e . * . taille des noms des groupes des frontieres . +c . nomgra . e . * . noms des groupes des frontieres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFAF1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfron + integer pointa(0:nbfron), taigra(*) +c + character*8 nomgra(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer numfro + integer lgngro +c + character*8 notyfr(2) + character*80 nomgro +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''*'',26x,''Groupe(s) frontiere '',a8,28x,''*'')' +c + texte(2,4) = + >'(''*'',28x,a8,'' boundary group(s)'',28x,''*'')' +c +#include "impr03.h" +c + 1000 format('* ',a80,' *') + 1001 format('*',10x,i10,14x,'*') + 1100 format(84('*')) +c +c==== +c 2. affichage +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. affichage ; codret', codret +#endif +c + notyfr(1) = 'discrete' + notyfr(2) = 'Discrete' +c + write (ulsort,1100) + write (ulsort,texte(langue,4)) notyfr(langue) + write (ulsort,1100) +c + do 21 , numfro = 1 , nbfron +c +c 2.1. ==> Reperage du nom du groupe +c + if ( codret.eq.0 ) then +c +c adresse du debut du groupe associe a la frontiere + jaux = pointa(numfro-1) + 1 +c +c longueur utile du nom du groupe + lgngro = 0 + do 221 , iaux = jaux , pointa(numfro) + lgngro = lgngro + taigra(iaux) + 221 continue +c + endif +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere fro + call uts8ch ( nomgra(jaux), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Affichage +c + if ( codret.eq.0 ) then +c + write (ulsort,1000) nomgro +c + endif +c + 21 continue +c + write (ulsort,1100) +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffaf2.F b/src/tool/Suivi_Frontiere/sffaf2.F new file mode 100644 index 00000000..2416193b --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffaf2.F @@ -0,0 +1,324 @@ + subroutine sffaf2 ( nbfrgr, nbfran, + > casfre, + > cacfpo, cacfta, cacfnm, + > calfpo, calfta, calfnm, + > calgpo, calgta, calgnm, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontieres AFfichage - 2 +c - - - -- - +c remarque : sffaf1, sffaf2 et sffaf3 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfrgr . e . 1 . nombre de liens frontiere/groupe . +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . casfre . e .13nbfran. caracteristiques des frontieres analytiques. +c . . . . 1 : 1., si cylindre . +c . . . . 2., si sphere . +c . . . . 3., si cone par origine, axe et angle . +c . . . . 4., si cone par 2 centres et 2 rayons . +c . . . . 5., si tore . +c . . . . de 2 a 13 : . +c . . . . . cylindre : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . . sphere : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . . cone : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 13 : angle en degre . +c . . . . . cone 2 : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . 9,10,11:xcent2, ycent2, zcent2. +c . . . . 12 : rayon2 . +c . . . . . tore : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon de revolution . +c . . . . 12 : rayon primaire . +c . cacfpo . e .0:nbfran. pointeurs sur le tableau du nom frontieres . +c . cacfta . e .10nbfran. taille du nom des frontieres . +c . cacfnm . e .10nbfran. nom des frontieres . +c . calfpo . e .0:nbfrgr. pointeurs sur le tableau du nom frontieres . +c . calfta . e .10nbfrgr. taille du nom des frontieres . +c . calfnm . e .10nbfrgr. nom des frontieres . +c . calgpo . e .0:nbfrgr. pointeurs sur le tableau du nom groupes . +c . calgta . e .10nbfrgr. taille du nom des groupes . +c . calgnm . e .10nbfrgr. nom des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFAF2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfrgr, nbfran + integer cacfpo(0:nbfran), cacfta(10*nbfran) + integer calfpo(0:nbfrgr), calfta(10*nbfrgr) + integer calgpo(0:nbfrgr), calgta(10*nbfrgr) +c + double precision casfre(13,nbfran) +c + character*8 cacfnm(10*nbfran) + character*8 calfnm(10*nbfrgr) + character*8 calgnm(10*nbfrgr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nufrgr, nufran, tyfran + integer lgnom, lgnomf +c + character*8 nomsur(0:5) + character*80 nom, nomf +c + integer nbmess + parameter ( nbmess = 12 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''*'',30x,''Liens groupe/frontiere'',30x,''*'')' + texte(1,5) = + >'(''*'',30x,''Frontieres analytiques'',30x,''*'')' + texte(1,6) = '(''* Rayon : '',g14.7,58x,''*'')' + texte(1,7) = '(''* Angle : '',g14.7,58x,''*'')' +c + texte(2,4) = + >'(''*'',31x,''Links boundary/group'',31x,''*'')' + texte(2,5) = + >'(''*'',31x,''Analytical boundaries'',30x,''*'')' + texte(2,6) = '(''* Radius: '',g14.7,58x,''*'')' + texte(2,7) = '(''* Angle: '',g14.7,58x,''*'')' +c +#include "impr03.h" +c + 1000 format('* ',a80,' *') + 1100 format(84('*')) + 1101 format(//,84('*')) + 1201 format('* Type : ',a8,66x,'*') + 1202 format('* ',a6,' : X =',g14.7,' Y =',g14.7,' Z =',g14.7,18x,'*') +c +c==== +c 2. Descriptions des frontieres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Descriptions frontieres ; codret', codret +#endif +c + if ( langue.eq.1 ) then + nomsur(0) = 'Inconnu ' + nomsur(1) = 'Cylindre' + nomsur(2) = 'Sphere ' + nomsur(3) = 'Cone ' + nomsur(4) = 'Cone ' + nomsur(5) = 'Tore ' + else + nomsur(0) = 'Unknwown' + nomsur(1) = 'Cylinder' + nomsur(2) = 'Sphere ' + nomsur(3) = 'Cone ' + nomsur(4) = 'Cone ' + nomsur(5) = 'Torus ' + endif +c + write (ulsort,1101) + write (ulsort,texte(langue,5)) + write (ulsort,1100) +c + do 21 , nufran = 1 , nbfran +c +c 2.1. ==> Nom de la frontiere +c + if ( codret.eq.0 ) then +c + jaux = cacfpo(nufran-1) + 1 +c + lgnom = 0 + do 211 , iaux = jaux , cacfpo(nufran) + lgnom = lgnom + cacfta(iaux) + 211 continue +c + endif +c + if ( codret.eq.0 ) then +c + call uts8ch ( cacfnm(jaux), lgnom, nom, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + write (ulsort,1000) nom + endif +c +c 2.2. ==> Type de la frontiere +c + tyfran = nint(casfre(1,nufran)) + if ( tyfran.le.-1 .or. tyfran.ge.6 ) then + tyfran = 0 + endif + write (ulsort,1201) nomsur(tyfran) +c + if ( tyfran.gt.0 ) then + write (ulsort,1202) 'Centre', + > (casfre(iaux,nufran), iaux = 2 , 4 ) + if ( tyfran.eq.1 .or. tyfran.eq.3 .or. tyfran.eq.5 ) then + write (ulsort,1202) 'Axe ', + > (casfre(iaux,nufran), iaux = 5 , 7 ) + endif + if ( tyfran.le.2 ) then + write (ulsort,texte(langue,6)) casfre(8,nufran) + elseif ( tyfran.eq.3 ) then + write (ulsort,texte(langue,7)) casfre(13,nufran) + elseif ( tyfran.eq.5 ) then + write (ulsort,texte(langue,6)) casfre(8,nufran) + write (ulsort,texte(langue,6)) casfre(12,nufran) + else + write (ulsort,texte(langue,6)) casfre(8,nufran) + write (ulsort,1202) 'Centre', + > (casfre(iaux,nufran), iaux = 9 , 11 ) + write (ulsort,texte(langue,6)) casfre(12,nufran) + endif + endif +c + write (ulsort,1100) +c + 21 continue +c +c==== +c 3. affichage des liens frontieres/groupe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. affichage liens ; codret', codret +#endif +c + write (ulsort,1100) + write (ulsort,texte(langue,4)) + write (ulsort,1100) +c + do 31 , nufrgr = 1 , nbfrgr +c +c 3.1. ==> Nom du groupe +c + if ( codret.eq.0 ) then +c + jaux = calgpo(nufrgr-1) + 1 +c + lgnom = 0 + do 311 , iaux = jaux , calgpo(nufrgr) + lgnom = lgnom + calgta(iaux) + 311 continue +c + call uts8ch ( calgnm(jaux), lgnom, nom, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + write (ulsort,1000) nom + endif +c +c 3.2. ==> Nom de la frontiere +c + if ( codret.eq.0 ) then +c + jaux = calfpo(nufrgr-1) + 1 +c + lgnomf = 0 + do 321 , iaux = jaux , calfpo(nufrgr) + lgnomf = lgnomf + calfta(iaux) + 321 continue +c + call uts8ch ( calfnm(jaux), lgnomf, nomf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then + write (ulsort,1000) nomf + endif +c + write (ulsort,1100) +c + 31 continue +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffaf3.F b/src/tool/Suivi_Frontiere/sffaf3.F new file mode 100644 index 00000000..4172894c --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffaf3.F @@ -0,0 +1,219 @@ + subroutine sffaf3 ( nbfron, typefr, nogrfr, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontieres AFfichage - 3 +c - - - -- - +c remarque : sffaf1, sffaf2 et sffaf3 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfron . e . 1 . nombre de frontieres . +c . typefr . e . nbfron . type de frontiere (1:ligne/-1:surface) . +c . nogrfr . e .10nbfron. noms des groupes des frontieres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFAF3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfron + integer typefr(nbfron) +c + character*8 nogrfr(10*nbfron) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer numfro + integer lgngro +c + character*80 nomgro +c + logical prem +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''*'',33x,''Ligne frontiere'',34x,''*'')' + texte(1,5) = '(''*'',32x,''Surface frontiere'',33x,''*'')' +c + texte(2,4) = '(''*'',35x,''1D boundary'',36x,''*'')' + texte(2,5) = '(''*'',35x,''2D boundary'',36x,''*'')' +c +#include "impr03.h" +c + 1000 format('* ',a80,' *') + 1001 format('*',10x,i10,14x,'*') + 1100 format(84('*')) + 1101 format(//,84('*')) +c + lgngro = 80 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfron', nbfron +#endif +c +c==== +c 2. affichage des lignes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. affichage des lignes ; codret', codret +#endif +c + prem = .true. +c + do 21 , numfro = 1 , nbfron +cgn write (ulsort,90112) 'typefr', numfro, typefr(numfro) +c + if ( typefr(numfro).gt.0 ) then +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere fro + call uts8ch ( nogrfr(10*(numfro-1)+1), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( prem ) then + write (ulsort,1101) + write (ulsort,texte(langue,4)) + write (ulsort,1100) + prem = .False. + endif + write (ulsort,1000) nomgro +c + endif +c + endif +c + 21 continue +c + if ( .not. prem ) then + write (ulsort,1100) + endif +c +c==== +c 3. affichage des surfaces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. affichage des surfaces ; codret', codret +#endif +c + prem = .true. +c + do 31 , numfro = 1 , nbfron +c + if ( typefr(numfro).lt.0 ) then +c + if ( codret.eq.0 ) then +c +c recuperation du nom du groupe associe a la frontiere fro + call uts8ch ( nogrfr(10*(numfro-1)+1), lgngro, nomgro, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( prem ) then + write (ulsort,1101) + write (ulsort,texte(langue,5)) + write (ulsort,1100) + prem = .False. + endif + write (ulsort,1000) nomgro +c + endif +c + endif +c + 31 continue +c + if ( .not. prem ) then + write (ulsort,1100) + endif +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sffaff.F b/src/tool/Suivi_Frontiere/sffaff.F new file mode 100644 index 00000000..f6d8f0fe --- /dev/null +++ b/src/tool/Suivi_Frontiere/sffaff.F @@ -0,0 +1,381 @@ + subroutine sffaff ( suifro, + > ncafdg, ncafan, ncfgnf, ncfgng, ncafar, + > nhsupe, nhsups, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Frontieres AFFichage +c - - - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . suifro . e . 1 . 1 : pas de suivi de frontiere . +c . . . . 2x : frontiere discrete . +c . . . . 3x : frontiere analytique . +c . . . . 5x : frontiere cao . +c . ncafdg . e . char*8 . nom de l'objet des frontieres discretes/CAO. +c . . . . nom des groupes . +c . ncafan . e . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . nom des groupes . +c . ncfgnf . es . char*8 . lien frontiere/groupe : nom des frontieres . +c . ncfgng . e . char*8 . lien frontiere/groupe : nom des groupes . +c . ncafar . e . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . valeurs reelles . +c . nhsupe . e . char*8 . informations supplementaires maillage . +c . nhsups . e . char*8 . informations supplementaires maillage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 2x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFFAFF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envada.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer suifro +c + character*8 ncafdg, ncafan, ncfgnf, ncfgng, ncafar + character*8 nhsupe, nhsups +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer adcafr, adfrgr, adnogr + integer pttgrd, ptngrd, pointd + integer adcpoi, adctai, adctab + integer adfpoi, adftai, adftab + integer adgpoi, adgtai, adgtab + integer nbfrdc, nbfrgr, nbfran +c + integer codre0 + integer codre1, codre2, codre3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(''Nombre de frontieres discretes :'',i8)' + texte(1,7) = '(''Nombre de liens frontiere/groupe :'',i8)' + texte(1,8) = '(''Nombre de frontieres analytiques :'',i8)' +c + texte(2,6) = '(''Number of discrete boundaries :'',i8)' + texte(2,7) = '(''Number of links boundary/group :'',i8)' + texte(2,8) = '(''Number of analytical boundaries:'',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'suifro', suifro +#endif +c +c==== +c 2. Les frontieres discretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Fr. discretes ; codret', codret +#endif +c + if ( ( mod(suifro,2).eq.0 ) .and. + > ( nbiter.eq.0 ) ) then +c +c 2.1. ==> Combien de frontieres discretes +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncafdg ) +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( ncafdg, 1, nbfrdc, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbfrdc +#endif +c +c 2.2. ==> Affichage des frontieres discretes +c + if ( nbfrdc.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,ncafdg//'.Pointeur') + call gmprsx(nompro,ncafdg//'.Taille') + call gmprsx(nompro,ncafdg//'.Table') +#endif + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafdg, iaux, + > jaux, jaux, + > pointd, pttgrd, ptngrd, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFAF1', nompro +#endif + call sffaf1 ( nbfrdc, + > imem(pointd), imem(pttgrd), smem(ptngrd), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 3. Les frontieres analytiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Fr. analytiques; codret', codret +#endif +c + if ( ( mod(suifro,3).eq.0 ) .and. + > ( nbiter.eq.0 ) ) then +c +c 3.1. ==> Combien de liens frontiere/groupe ? +c +cgn call gmprsx (nompro,ncfgng ) +c + if ( codret.eq.0 ) then +c + call gmliat ( ncfgnf, 1, nbfrgr, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbfrgr +#endif +c + if ( nbfrgr.gt.0 ) then +c +c 3.2. ==> Description des noms des frontieres dans les liens +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro,ncfgnf//'.Pointeur' ) +cgn call gmprsx (nompro,ncfgnf//'.Table' ) +cgn call gmprsx (nompro,ncfgnf//'.Taille' ) + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncfgnf, iaux, + > jaux, kaux, + > adfpoi, adftai, adftab, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Description des noms des groupes dans les liens +c + if ( codret.eq.0 ) then +cgn call gmprsx (nompro,ncfgng//'.Pointeur' ) +cgn call gmprsx (nompro,ncfgng//'.Table' ) +cgn call gmprsx (nompro,ncfgng//'.Taille' ) + iaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncfgng, iaux, + > jaux, kaux, + > adgpoi, adgtai, adgtab, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> Description des frontieres +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncafar ) +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncafar, adcafr, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,ncafan//'.Pointeur') + call gmprsx(nompro,ncafan//'.Taille') + call gmprsx(nompro,ncafan//'.Table') +#endif +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafan, iaux, + > nbfran, kaux, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbfran +#endif +c + endif +c +c 3.5. ==> Affichage des frontieres analytiques +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFAF2', nompro +#endif + call sffaf2 ( nbfrgr, nbfran, + > rmem(adcafr), + > imem(adcpoi), imem(adctai), smem(adctab), + > imem(adfpoi), imem(adftai), smem(adftab), + > imem(adgpoi), imem(adgtai), smem(adgtab), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. Les frontieres CAO +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. frontieres CAO ; codret', codret +#endif +c + if ( ( mod(suifro,5).eq.0 ) .or. + > ( nbiter.ge.1 ) ) then +c +c 4.1. ==> Combien de frontieres ? +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhsupe//'.Tab10' ) + call gmprsx (nompro, nhsups//'.Tab10' ) +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhsupe//'.Tab10', adfrgr, iaux, codre1 ) + call gmadoj ( nhsups//'.Tab10', adnogr, iaux, codre2 ) + call gmliat ( nhsupe, 10, nbfrgr, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbfrgr +#endif +c +c 4.2. ==> Affichage des frontieres +c + if ( nbfrgr.gt.0 ) then +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFFAF3', nompro +#endif + call sffaf3 ( nbfrgr, imem(adfrgr), smem(adnogr), + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrf0.F b/src/tool/Suivi_Frontiere/sfgrf0.F new file mode 100644 index 00000000..88b83aff --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrf0.F @@ -0,0 +1,215 @@ + subroutine sfgrf0 ( nocmaf, + > nbmail, + > adtyel, adfael, + > adnufa, adgrpo, adgrtb, + > nbfmed, lifami, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase 0 +c - - -- - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmaf . e . char*8 . nom de l'objet maillage de la frontiere . +c . nbmail . s . 1 . nombre de mailles . +c . adtyel . s . 1 . type des elements . +c . adfael . s . 1 . famille MED des elements . +c . adnufa . s . 1 . numero des familles . +c . adgrpo . s . 1 . pointeurs des groupes . +c . adgrtb . s . 1 . table des groupes . +c . nbfmed . s . 1 . nombre de familles de mailles de frontiere . +c . lifami . s . * . liste des familles a explorer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRF0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer nbfmed, nbmail + integer adtyel, adfael + integer adnufa, adgrpo, adgrtb + integer lifami(*) +c + character*8 nocmaf +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbnomb +c + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. recuperation des adresses +c==== +c 2.1. ==> les informations generales +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nocmaf ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmaf, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, ncnoeu ) + call gmprsx (nompro, nccono ) + call gmprsx (nompro, ncfami ) +#endif +c + endif +c +c 2.2. ==> caracteristiques des mailles frontiere +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD11', nompro +#endif + iaux = 77 + call utad11 ( iaux, ncnoeu, nccono, + > jaux, jaux, jaux, jaux, + > adtyel, adfael, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nccono, 1, nbmail, codret ) +c + endif +c +c 2.3. ==> adresses des tableaux des groupes dans les familles +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD13', nompro +#endif + iaux = 10 + call utad13 ( iaux, ncfami, + > adnufa, jaux, + > adgrpo, jaux, adgrtb, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. reperage des numeros des familles de segments +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. reperage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRF1', nompro +#endif + call sfgrf1 ( nbfmed, lifami, + > nbmail, imem(adtyel), imem(adfael), + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrf1.F b/src/tool/Suivi_Frontiere/sfgrf1.F new file mode 100644 index 00000000..4ae36051 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrf1.F @@ -0,0 +1,179 @@ + subroutine sfgrf1 ( nbfmed, lifami, + > nbmail, typmai, fammai, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase 1 +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfmed . s . 1 . nombre de familles de mailles de frontiere . +c . lifami . s . * . liste des familles a explorer . +c . nbmail . e . 1 . nombre de mailles . +c . typmai . e . nbmail . type des mailles . +c . fammai . e . nbmail . famille MED des mailles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRF1' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "envca1.h" +#include "meddc0.h" +c +c 0.3. ==> arguments +c + integer nbfmed, nbmail + integer lifami(*) + integer typmai(nbmail), fammai(nbmail) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lamail + integer typseg, typtri, typqua +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de mailles :'',i11)' + texte(1,5) = '(''Nombre de familles de '',a,'' :'',i11)' +c + texte(2,4) = '(''Number of meshes :'',i11)' + texte(2,5) = '(''Number of families of '',a,'' :'',i11)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbmail +#endif +c + codret = 0 +c + nbfmed = 0 +c +c==== +c 2. on parcourt toutes les mailles +c On repere les mailles de bords et on memorise leur familles MED +c==== +c + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typqua = edqua4 + else + typseg = edseg3 + typtri = edtri6 + typqua = edqua8 + endif +c + do 2 , lamail = 1, nbmail +c + if ( typmai(lamail).eq.typseg .or. + > typmai(lamail).eq.typtri .or. + > typmai(lamail).eq.typqua ) then +c +c on cherche si sa famille MED est deja enregistree +c si oui, on passe a la maille suivante +c si non, on l'ajoute a la liste +c + do 21 , iaux = 1, nbfmed +c + if ( fammai(lamail).eq.lifami(iaux) ) then + goto 2 + endif +c + 21 continue +c + nbfmed = nbfmed + 1 + lifami(nbfmed) = fammai(lamail) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ajout de la famille', fammai(lamail) +#endif +c + endif +c + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbfmed +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrf2.F b/src/tool/Suivi_Frontiere/sfgrf2.F new file mode 100644 index 00000000..8bb45ddf --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrf2.F @@ -0,0 +1,281 @@ + subroutine sfgrf2 ( nbfmed, + > nbf, nbgrmx, nblign, lgtabl, + > pointl, taigrl, nomgrl, + > pointf, nomgrf, numfam, + > lifami, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase 2 +c - - -- - - +c remarque : sfgrf2 et sfgrf3 sont des clones +c Creation de la liste des groupes de segments du maillage frontiere +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfmed . e . 1 . nombre de familles de mailles de frontiere . +c . nbf . e . 1 . nombre de familles du maillage frontiere . +c . nbgrmx . e . 1 . nombre maxi de groupes dans les familles . +c . nblign . s . 1 . nombre de lignes decrites . +c . lgtabl . s . 1 . longueur des tables . +c . pointl . s .0:nbgrmx. pointeur sur le tableau nomgrl . +c . taigrl . s . * . taille des noms des groupes des lignes . +c . nomgrl . s . * . noms des groupes des lignes . +c . pointf . e . 0:nbf . pointeur sur le tableau nomgrf . +c . numfam . e . nbf . numero des familles au sens MED . +c . nomgrf . e . * . noms des groupes des familles . +c . lifami . e . nbfmed . liste des familles a explorer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRF2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbfmed + integer nbf, nbgrmx, nblign, lgtabl + integer lifami(nbfmed) + integer pointl(0:nbgrmx), pointf(0:nbf), numfam(nbf) + integer taigrl(*) +c + character*8 nomgrl(*), nomgrf(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, lig, fam + integer nbgr, gr + integer lgngrl, lgngrf +c + character*80 groupl,groupf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de familles de '',a,'' :'',i8)' + texte(1,5) = '(/,''Ligne numero '',i5,/,18(''=''))' + texte(1,6) = '(''. Elle est definie par le groupe : '',a,/)' +c + texte(2,4) = '(''Number of families of '',a,'' :'',i8)' + texte(2,5) = '(/,''Line # '',i5,/,12(''=''))' + texte(2,6) = '(''. It is defined by group : '',a,/)' +c +#include "impr03.h" +c + codret = 0 +c + nblign = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbfmed +#endif +c +c==== +c 2. on parcourt toutes les familles de mailles du maillage frontiere +c pour enregistrer les groupes du maillage frontiere +c==== +c +cgn write (ulsort,93080) (nomgrf(iaux),iaux=1,20) + do 20 , fam = 1, nbf +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Famille ', fam, ', de numero', numfam(fam) +#endif +c +c 2.1. ==> la famille est-elle a traiter ? +c + do 21 , iaux = 1, nbfmed +c +cgn write (ulsort,90112) 'lifami', iaux, lifami(iaux) + if ( numfam(fam).eq.lifami(iaux) ) then + goto 221 + endif +c + 21 continue +c + goto 20 +c +c 2.2. ==> on parcourt tous les groupes entrant dans la +c definition de cette famille +c + 221 continue +c + nbgr = (pointf(fam)-pointf(fam-1))/10 +c + do 22 , gr = 1, nbgr +c +c 2.2.1. ==> nom du groupe associe +c adresse du debut du groupe numero gr de la famille fam +c + if ( codret.eq.0 ) then +c + iaux = pointf(fam-1)+1+10*(gr-1) +c +c recuperation du nom du groupe numero gr dans la famille +c numero fam + call uts8ch ( nomgrf(iaux), 80, groupf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrf, groupf, ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.. groupf = ', groupf + write (ulsort,*) '.. lgngrf = ', lgngrf +#endif +c +c 2.2.2. ==> on cherche si le groupe est deja present dans la liste +c + do 222 , lig = 1 , nblign +c + if ( codret.eq.0 ) then +c adresse du debut du groupe associe a la ligne lig + iaux = pointl(lig-1) + 1 +c +c recuperation du nom du groupe associe a la ligne lig + call uts8ch ( nomgrl(iaux), 80, groupl, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrl, groupl, ulsort, langue, codret ) +c + endif +c +c ......... si le groupe de la ligne et le groupe dans la liste +c ......... coincident, on passe au groupe suivant dans la famille +c + if ( lgngrl.eq.lgngrf ) then +c + if ( groupl(1:lgngrl).eq.groupf(1:lgngrf) ) then + goto 22 + endif +c + endif +c + 222 continue +c +c 2.2.3. ==> le groupe est absent de la liste ; on allonge la liste +c + nblign = nblign + 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nblign + write (ulsort,texte(langue,6)) groupf(1:lgngrf) +#endif +c + iaux = pointl(nblign-1) + 1 +c + call utchs8 ( groupf, lgngrf, nomgrl(iaux), + > ulsort, langue, codret ) +c + kaux = (lgngrf-mod(lgngrf,8)) / 8 + do 223 , jaux = 1 , kaux + taigrl(iaux+jaux-1) = 8 + 223 continue +c + if ( mod(lgngrf,8).ne.0 ) then + taigrl(iaux+kaux) = mod(lgngrf,8) + kaux = kaux + 1 + endif +c + pointl(nblign) = pointl(nblign-1) + kaux + lgtabl = iaux+kaux-1 +c + 22 continue +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrf3.F b/src/tool/Suivi_Frontiere/sfgrf3.F new file mode 100644 index 00000000..c4559572 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrf3.F @@ -0,0 +1,442 @@ + subroutine sfgrf3 ( nbfseg, + > nbf, nbgrmx, nblign, lgtabl, + > pointl, taigrl, nomgrl, + > pointf, nomgrf, numfam, + > lifami, linugr, ncafdg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase 3 +c - - -- - - +c remarque : sfgrf2 et sfgrf3 sont des clones +c Mise a jour de la liste des groupes de segments voulus +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfseg . e . 1 . nombre de familles de segments . +c . nbf . e . 1 . nombre de familles du maillage frontiere . +c . nbgrmx . e . 1 . nombre maxi de groupes dans les familles . +c . nblign . es . 1 . nombre de lignes decrites . +c . lgtabl . es . 1 . longueur des tables . +c . pointl . e .0:nblign. pointeur sur le tableau nomgrl . +c . taigrl . e . * . taille des noms des groupes des lignes . +c . nomgrl . e . * . noms des groupes des lignes . +c . pointf . e . 0:nbf . pointeur sur le tableau nomgrf . +c . numfam . e . nbf . numero des familles au sens MED . +c . nomgrf . e . * . noms des groupes des familles . +c . lifami . e . nbfseg . liste des familles a explorer . +c . linugr . s . nblign . numeros des groupes acceptables . +c . ncafdg . es . char*8 . nom de l'objet groupes/attributs frontiere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRF3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbfseg + integer nbf, nbgrmx, nblign, lgtabl + integer pointl(0:nbgrmx), pointf(0:nbf), numfam(nbf) + integer taigrl(*) + integer lifami(nbfseg), linugr(nblign) +c + character*8 nomgrl(*), nomgrf(*) + character*8 ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, lig, fam + integer nbgr, gr + integer lgngrl, lgngrf + integer nblnew, lgtnew + integer pointn, pttgrn, ptngrn +c + character*80 groupl,groupf + character*8 ntrava +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de familles de '',a,'' :'',i8)' + texte(1,5) = + >'(''*'',20x,''Elimination de groupe(s) frontiere discrete'', + >19x,''*'')' + texte(1,6) = + >'(''*'',20x,''Tous les groupes sont elimines'',32x,''*'')' +c + texte(2,4) = '(''Number of families of '',a,'' :'',i8)' + texte(2,5) = + >'(''*'',20x,''Elimination of discrete boundary group(s)'', + >21x,''*'')' + texte(2,6) = + >'(''*'',20x,''All the groups are taken off'',34x,''*'')' +c +#include "impr03.h" +c + 1000 format(/) + 1001 format(84('*')) + 1002 format('* ',a80,' *') +c + codret = 0 +c +c 1.2. ==> A priori, aucune ligne voulue n'est acceptable +c + do 12 , iaux = 1 , nblign + linugr(iaux) = 0 + 12 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbfseg + write (ulsort,90002) 'lgtabl', lgtabl + write (ulsort,93080) (nomgrl(iaux),iaux=1,lgtabl) +#endif +c +c==== +c 2. on parcourt toutes les familles de mailles du maillage frontiere +c pour reperer les groupes de la liste qui sont effectivement dans +c le maillage frontiere +c==== +c +cgn write (ulsort,93080) (nomgrf(iaux),iaux=1,20) + do 20 , fam = 1, nbf +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Famille ', fam, ', de numero', numfam(fam) +#endif +c +c 2.1. ==> la famille est-elle a traiter ? +c + do 21 , iaux = 1, nbfseg +c +cgn write (ulsort,90112) 'lifami', iaux, lifami(iaux) + if ( numfam(fam).eq.lifami(iaux) ) then + goto 221 + endif +c + 21 continue +c + goto 20 +c +c 2.2. ==> on parcourt tous les groupes entrant dans la +c definition de cette famille +c + 221 continue +c + nbgr = (pointf(fam)-pointf(fam-1))/10 +c + do 22 , gr = 1, nbgr +c +c 2.2.1. ==> nom du groupe associe +c adresse du debut du groupe numero gr de la famille fam +c + if ( codret.eq.0 ) then +c + iaux = pointf(fam-1)+1+10*(gr-1) +c +c recuperation du nom du groupe numero gr dans la famille +c numero fam + call uts8ch ( nomgrf(iaux), 80, groupf, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrf, groupf, ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,93020) 'groupf', groupf + write (ulsort,90002) 'lgngrf', lgngrf +#endif +c +c 2.2.2. ==> on cherche si le groupe est deja present dans la liste +c + do 222 , lig = 1 , nblign +c + if ( codret.eq.0 ) then +c adresse du debut du groupe associe a la ligne lig + iaux = pointl(lig-1) + 1 +c +c recuperation du nom du groupe associe a la ligne lig + call uts8ch ( nomgrl(iaux), 80, groupl, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +c longueur utile du nom du groupe + call utlgut ( lgngrl, groupl, ulsort, langue, codret ) +c + endif +c +c ......... si le groupe de la ligne et le groupe dans la liste +c ......... coincident, on passe au groupe suivant dans la famille +c ......... on note ce groupe +c + if ( lgngrl.eq.lgngrf ) then +c + if ( groupl(1:lgngrl).eq.groupf(1:lgngrf) ) then + linugr(lig) = 1 + goto 22 + endif +c + endif +c + 222 continue +c + 22 continue +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'linugr' + write (ulsort,91020) (linugr(iaux),iaux=1,nblign) +#endif +c +c==== +c 3. Si au moins un groupe de la liste n'est pas dans le maillage +c frontiere, il faut recreer cette liste en eliminant ces groupes. +c==== +c 3.1. ==> Decompte du nombre de groupes absents +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. Decompte ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nblnew = nblign + do 31 , iaux = 1 , nblign + if ( linugr(iaux).eq.0 ) then + nblnew = nblnew - 1 + endif + 31 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nblnew', nblnew +#endif +c + if ( nblnew.lt.nblign ) then +c +c 3.2. ==> Allocation de la nouvelle structure +c + if ( codret.eq.0 ) then +c + iaux = 0 + jaux = 0 + kaux = nblign - jaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTATPC', nompro +#endif + call utaptc ( ntrava, iaux, jaux, + > kaux, lgtabl, + > pointn, pttgrn, ptngrn, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ntrava ) +cgn call gmprsx (nompro,ntrava//'.Pointeur' ) +cgn call gmprsx (nompro,ntrava//'.Table' ) +cgn call gmprsx (nompro,ntrava//'.Taille' ) +#endif +c +c 3.3. ==> Remplissage de la nouvelle structure +c + write (ulsort,1000) + write (ulsort,1001) + write (ulsort,texte(langue,5)) + write (ulsort,1001) +c + lgtnew = 0 +c +c 3.3.1. ==> Tous les groupes sont absents +c + if ( nblnew.eq.0 ) then +c + write (ulsort,texte(langue,6)) + +c 3.3.2. ==> Au moins un groupe est absent, mais pas tous +c On transfere les valeurs +c + else +c + nblnew = 0 +c + if ( codret.eq.0 ) then +c + do 33 , lig = 1 , nblign +c + if ( codret.eq.0 ) then +c + if ( linugr(lig).ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Transfert ligne', lig +#endif +c + kaux = pointl(lig) - pointl(lig-1) +cgn write(ulsort,*) 'kaux', kaux +c + nblnew = nblnew + 1 + lgtnew = lgtnew + kaux + jaux = imem(pointn+nblnew-1) + imem(pointn+nblnew) = jaux + kaux +c + do 331 , iaux = 1, kaux + imem(pttgrn+jaux-1+iaux) = taigrl(pointl(lig-1)+iaux) + smem(ptngrn+jaux-1+iaux) = nomgrl(pointl(lig-1)+iaux) + 331 continue +c + else +c +c adresse du debut du groupe associe a la ligne lig + iaux = pointl(lig-1) + 1 +c +c recuperation du nom du groupe associe a la ligne lig + call uts8ch ( nomgrl(iaux), 80, groupl, + > ulsort, langue, codret ) +c + write (ulsort,1002) groupl +c + endif +c + endif +c + 33 continue +c + endif +c + endif +c + write (ulsort,1001) +c +c 3.4. ==> Ajustement des tailles de la structure +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. Ajustement ; codret', codret +#endif +c 3.4.1. ==> Ajustement de la structure +c + if ( codret.eq.0 ) then +c + jaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTATPC', nompro +#endif + call utaptc ( ntrava, iaux, jaux, + > nblnew, lgtnew, + > pointn, pttgrn, ptngrn, + > ulsort, langue, codret ) +c + endif +c +c 3.4.2. ==> Transfert +c + if ( codret.eq.0 ) then +c + call gmlboj ( ncafdg, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + ncafdg = ntrava +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncafdg ) + call gmprsx (nompro,ncafdg//'.Pointeur' ) + call gmprsx (nompro,ncafdg//'.Table' ) + call gmprsx (nompro,ncafdg//'.Taille' ) +#endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrfa.F b/src/tool/Suivi_Frontiere/sfgrfa.F new file mode 100644 index 00000000..6ca6c190 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrfa.F @@ -0,0 +1,266 @@ + subroutine sfgrfa ( nocmaf, ncafdg, + > nblign, nbf, nbgrmx, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase A +c - - -- - - +c remarque : sfgrfa et sfgrfb sont des clones +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmaf . e . char*8 . nom de l'objet maillage de la frontiere . +c . ncafdg . es . char*8 . nom de l'objet groupes pour la frontiere . +c . nblign . s . 1 . nombre de lignes a considerer . +c . nbf . e . 1 . nombre de familles du maillage frontiere . +c . nbgrmx . e . 1 . nombre maxi de groupes dans les familles . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nblign, nbf, nbgrmx +c + character*8 nocmaf, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lgtabl + integer adtyel, adfael + integer pointl, pttgrl, ptngrl + integer adgrtb, adgrpo, adnufa + integer nbmail, nbfmed + integer ptrav1 +c + character*8 ntrav1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbgrmx', nbgrmx +#endif +c + codret = 0 +c +c==== +c 2. recuperation des adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. adresses et reperage ; codret', codret +#endif +c +c 2.1. ==> le tableau trav1 contiendra la liste des familles du maillage +c frontiere qui contiennent au moins un groupe. Il est alloue +c au maximum theorique qui vaut le nombre total de groupes +c constituant les familles + 1 pour la famille nulle +c + if ( codret.eq.0 ) then +c + iaux = nbgrmx + 1 + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codret ) +c + endif +c +c 2.2. ==> adresses et filtrage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - maillage frontiere',nocmaf ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRF0', nompro +#endif + call sfgrf0 ( nocmaf, + > nbmail, + > adtyel, adfael, + > adnufa, adgrpo, adgrtb, + > nbfmed, imem(ptrav1), + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro//' - ntrav1 (lifami)',ntrav1 ) +#endif +c + endif +c +c==== +c 3. on alloue les tableaux decrivant les groupes a suivre +c au maximum theorique qui est le nombre total de groupes +c constituant les familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Allocation ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'ncafdg ', ncafdg + call gmprsx (nompro,ncafdg ) +#endif +c + if ( codret.eq.0 ) then +c + jaux = 3 + kaux = 10*nbgrmx +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTATPC', nompro +#endif + call utaptc ( ncafdg, iaux, jaux, + > nbgrmx, kaux, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. on remplit les tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. remplissage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro, nocmaf//'.Famille.Groupe.Pointeur' ) +cgn call gmprsx (nompro, nocmaf//'.Famille.Groupe.Table' ) +cgn call gmprsx (nompro, nocmaf//'.Famille.Numero' ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRF2', nompro +#endif + call sfgrf2 ( nbfmed, + > nbf, nbgrmx, nblign, lgtabl, + > imem(pointl), imem(pttgrl), smem(ptngrl), + > imem(adgrpo), smem(adgrtb), imem(adnufa), + > imem(ptrav1), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncafdg ) + call gmprsx (nompro,ncafdg//'.Pointeur' ) + call gmprsx (nompro,ncafdg//'.Table' ) + call gmprsx (nompro,ncafdg//'.Taille' ) +#endif +c + endif +c +c==== +c 5. ajustement des longueurs des tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. Ajustement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + jaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTATPC', nompro +#endif + call utaptc ( ncafdg, iaux, jaux, + > nblign, lgtabl, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncafdg ) + call gmprsx (nompro,ncafdg//'.Pointeur' ) + call gmprsx (nompro,ncafdg//'.Table' ) + call gmprsx (nompro,ncafdg//'.Taille' ) +#endif +c + endif +c +c==== +c 6. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codret ) +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrfb.F b/src/tool/Suivi_Frontiere/sfgrfb.F new file mode 100644 index 00000000..7feeb374 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrfb.F @@ -0,0 +1,250 @@ + subroutine sfgrfb ( nocmaf, ncafdg, + > nblign, nbf, nbgrmx, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GRoupes de la Frontiere - phase B +c - - -- - - +c remarque : sfgrfa et sfgrfb sont des clones +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmaf . e . char*8 . nom de l'objet maillage de la frontiere . +c . ncafdg . es . char*8 . nom de l'objet groupes/attributs frontiere . +c . nblign . s . 1 . nombre de lignes a considerer . +c . nbf . e . 1 . nombre de familles du maillage frontiere . +c . nbgrmx . e . 1 . nombre maxi de groupes dans les familles . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGRFB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nblign, nbf, nbgrmx +c + character*8 nocmaf, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lgtabl + integer adtyel, adfael + integer pointl, pttgrl, ptngrl + integer adgrtb, adgrpo, adnufa + integer nbmail, nbfseg + integer ptrav1, ptrav2 + integer codre1, codre2 + integer codre0 +c + character*8 ntrav1, ntrav2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. recuperation des adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. adresses et reperage ; codret', codret +#endif +c +c 2.1. ==> le tableau trav1 contiendra la liste des familles du maillage +c frontiere qui contiennent au moins un groupe. Il est alloue +c au maximum theorique qui vaut le nombre total de groupes +c constituant les familles + 1 pour la famille nulle +c le tableau trav2 contiendra la liste des numeros des groupes +c voulus et qui sont effectivement un groupe frontiere +c + if ( codret.eq.0 ) then +c + iaux = nbgrmx + 1 + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + call gmalot ( ntrav2, 'entier ', nblign, ptrav2, codre2) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.2. ==> adresses et filtrage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nocmaf ) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRF0', nompro +#endif + call sfgrf0 ( nocmaf, + > nbmail, + > adtyel, adfael, + > adnufa, adgrpo, adgrtb, + > nbfseg, imem(ptrav1), + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ntrav1 ) + call gmprsx (nompro,ntrav2 ) +#endif +c + endif +c +c==== +c 3. recuperation des caracteristiques de la liste +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncafdg ) + call gmprsx (nompro,ncafdg//'.Pointeur' ) + call gmprsx (nompro,ncafdg//'.Table' ) + call gmprsx (nompro,ncafdg//'.Taille' ) +#endif + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTADPT', nompro +#endif + call utadpt ( ncafdg, iaux, + > jaux, lgtabl, + > pointl, pttgrl, ptngrl, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. on verifie les tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. remplissage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro, ncfami//'.Groupe.Pointeur' ) +cgn call gmprsx (nompro, ncfami//'.Groupe.Table' ) +cgn call gmprsx (nompro, ncfami//'.Numero' ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFGRF3', nompro +#endif + call sfgrf3 ( nbfseg, + > nbf, nbgrmx, nblign, lgtabl, + > imem(pointl), imem(pttgrl), smem(ptngrl), + > imem(adgrpo), smem(adgrtb), imem(adnufa), + > imem(ptrav1), imem(ptrav2), ncafdg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,ncafdg ) + call gmprsx (nompro,ncafdg//'.Pointeur' ) + call gmprsx (nompro,ncafdg//'.Table' ) + call gmprsx (nompro,ncafdg//'.Taille' ) +#endif +c + endif +c +c==== +c 5. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfgrou.F b/src/tool/Suivi_Frontiere/sfgrou.F new file mode 100644 index 00000000..a30cb538 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfgrou.F @@ -0,0 +1,170 @@ + subroutine sfgrou ( ncfami, ncafdg, + > nblign, nbgrmx, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - GROUpes pour la frontiere +c - - ---- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncfami . e . char*8 . nom de l'objet famille du maillage . +c . ncafdg . es . char*8 . nom de l'objet groupes frontiere . +c . nblign . s . 1 . nombre de lignes dans les donnees . +c . nbgrmx . s . 1 . nombre maximal de groupes de la frontiere . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFGROU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nblign, nbgrmx +c + character*8 ncfami, ncafdg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de groupes demandes pour la frontiere :'',i8)' + texte(1,5) = + > '(''Pas de groupe dans le maillage de la frontiere.'')' + texte(1,6) = '(''Impossible de la suivre.'')' + texte(1,7) = '(''Nombre de groupes dans les familles :'',i8)' +c + texte(2,4) = '(''Number of groups requested for boundary:'',i8)' + texte(2,5) = '(''No group in boundary mesh.'')' + texte(2,6) = '(''It cannot be followed.'')' + texte(2,7) = '(''Number of groups in families:'',i8)' +c +#include "impr03.h" +c +c==== +c 2. Nombre de groupes designes dans le fichier de configuration +c==== +c + call gmliat ( ncafdg, 1, nblign, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx ( nompro, ncafdg ) +cgn call gmprsx ( nompro, ncafdg//'.Table' ) + write (ulsort,texte(langue,4)) nblign +#endif +c +c==== +c 3. Nombre de groupes presents dans les familles du maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. On compte ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( ncfami//'.Groupe', 2, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) iaux/10 +#endif +c + if ( codret.eq.0 ) then +c + nbgrmx = iaux/10 +c + if ( nbgrmx.eq.0 ) then + write (ulsort,texte(langue,5)) + write (ulsort,texte(langue,6)) + codret = 3 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbgrmx', nbgrmx +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfindr.F b/src/tool/Suivi_Frontiere/sfindr.F new file mode 100644 index 00000000..6ab601b5 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfindr.F @@ -0,0 +1,234 @@ + subroutine sfindr ( seglig, cfaare, famare, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - INhibition du suivi sur les lignes DRoites +c - - -- -- +c ______________________________________________________________________ +c +c but : inhiber le suivi de frontiere pour les aretes pour des +c aretes pointant vers des droites +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nbarto . famille des aretes . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFINDR' ) +c +#include "nblang.h" +#include "cofina.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "front1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombar.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer seglig(0:sfnbli) + integer cfaare(nctfar,nbfare), famare(nbarto) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux +c + integer are + logical yadroi +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 789012345678901234567890123 + texte(1,4) = '(/,a6,'' INHIBITION SUR LES DROITES'')' + texte(1,5) = '(33(''=''),/)' + texte(1,6) = '(''La ligne '',i4,'' est une droite.'')' +c +c 7890123456789012345678901234567 + texte(2,4) = '(/,a6,'' CANCELLATION ON STRAIGHT LINES'')' + texte(2,5) = '(37(''=''),/)' + texte(2,6) = '(''Line # '',i4,'' is a straight line.'')' +c +#include "impr03.h" +c +c 1.2. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.3. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c=== +c 2. Impression des numeros des lignes qui sont droites (2 points) +c On le memorise temporairement en negativant le numero du premier +c segment decrivant cette ligne +c=== +c +cgn write (ulsort,90002) 'seglig', (seglig(iaux), iaux = 0, sfnbli) + yadroi = .false. +c + do 21 , iaux = 1, sfnbli +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90012) 'Nombre de segments de la ligne', iaux, + > abs(seglig(iaux))-abs(seglig(iaux-1))-2 +#endif + if ( abs(seglig(iaux))-abs(seglig(iaux-1)).eq.3 ) then +c + write (ulsort,texte(langue,6)) iaux + seglig(iaux) = -seglig(iaux) + yadroi = .true. +c + endif +c + 21 continue +c +c=== +c 3. S'il y a des droites : les aretes qui sont situees sur de telles +c lignes doivent etre retirees du suivi de frontiere : inutile de +c faire des calculs pour rien ! +c=== +c + if ( yadroi ) then +c +c 3.1 ==> Pour cela, il suffit de changer leur famille : on remplace +c leur famille actuelle par celle qui a toutes les memes +c caracteristiques, sauf celle du suivi de frontiere, stockee +c dans cosfin (cf. vccfam) +c + do 31 , are = 1, nbarto +c + iaux = cfaare(cosfli,famare(are)) +c +c 3.1 ==> l'arete est active pour le SF : elle est sur la ligne iaux +c + if ( iaux.gt.0 ) then +c +c 3.1.1 ==> la ligne iaux est une droite +c + if ( seglig(iaux).lt.0 ) then +c + famare(are) = cfaare(cosfin,famare(are)) +c + endif +c + endif +c + 31 continue +c +c 3.2. ==> On remet les numeros positifs +c + do 32 , iaux = 1, sfnbli +c + seglig(iaux) = abs(seglig(iaux)) +c + 32 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sflgeo.F b/src/tool/Suivi_Frontiere/sflgeo.F new file mode 100644 index 00000000..4a176bc1 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sflgeo.F @@ -0,0 +1,212 @@ + subroutine sflgeo ( lgopti, taopti, lgopts, taopts, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Lecture de la GEOmetrie +c - - - --- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgopti . e . 1 . longueur du tableau des options . +c . taopti . e . lgopti . tableau des options . +c . lgopts . e . 1 . longueur du tableau des options caracteres . +c . taopts . e . lgopts . tableau des options caracteres . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme avec la memoire . +c . . . . 3 : probleme avec le fichier . +c . . . . 5 : contenu incorrect . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFLGEO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "motcle.h" +c 0.3. ==> arguments +c + integer lgopti + integer taopti(lgopti) +c + integer lgopts + character*8 taopts(lgopts) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nrosec + integer nretap, nrsset + integer iaux +c + character*6 saux + character*8 nofich, nomail +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c 1.1. ==> le debut des mesures de temps +c + nrosec = taetco(4) + call gtdems (nrosec) +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' LECTURE DE LA FRONTIERE DISCRETE'')' + texte(1,5) = '(39(''=''),/)' + texte(1,6) = '(''Le maillage fourni est de degre'',i3)' + texte(1,7) = '(''Il doit etre de degre 1.'')' +c + texte(2,4) = '(/,a6,'' READINGS OF DISCRETE BOUNDARY'')' + texte(2,5) = '(36(''=''),/)' + texte(2,6) = '(''Degree of the mesh is :'',i3)' + texte(2,7) = '(''It should be linear.'')' +c +#include "impr03.h" +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. lecture de la frontiere discrete depuis le fichier MED +c==== +c + if ( codret.eq.0 ) then +c + nofich = mccdfr + nomail = mccnmf + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'ESLMMD', nompro +#endif + call eslmmd ( nofich, nomail, + > taopti(11), taopts(16), + > iaux, taopti(9), + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Controle du degre +c==== +c + if ( codret.eq.0 ) then +c + call gmliat ( taopts(16), 3, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( iaux.ne.1 ) then +c + write (ulsort,texte(langue,6)) iaux + write (ulsort,texte(langue,7)) + codret = 1 +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +c 4.1. ==> message si erreur +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +c 4.2. ==> fin des mesures de temps de la section +c + call gtfims (nrosec) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Suivi_Frontiere/sflise.F b/src/tool/Suivi_Frontiere/sflise.F new file mode 100644 index 00000000..1027ea2e --- /dev/null +++ b/src/tool/Suivi_Frontiere/sflise.F @@ -0,0 +1,175 @@ + subroutine sflise ( numlig, seg, seglig, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - LIgne d'appartenance d'un SEgment +c - - -- -- +c ______________________________________________________________________ +c +c but : retourner le numero de la ligne d'apres le numero du segment +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numlig . s . 1 . numero de la ligne du segment . +c . seg . e . 1 . numero du segment . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : le numero de segment est negatif ou nul. +c . . . . 2 : le numero de segment est trop grand . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFLISE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "front1.h" +c +c 0.3. ==> arguments +c + integer numlig, seg, seglig(0:sfnbli) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de lignes :'',i5)' + texte(1,5) = '(''Premier segment :'',i5)' + texte(1,6) = '(''Dernier segment :'',i5)' + texte(1,7) = '(''Segment recherche :'',i5)' + texte(1,8) = + > '(''Le numero du segment recherche est negatif ou nul.'')' + texte(1,9) = + > '(''Le numero du segment recherche est trop grand.'')' +c + texte(2,4) = '(''Number of lines :'',i5)' + texte(2,5) = '(''First segment :'',i5)' + texte(2,6) = '(''Last segment :'',i5)' + texte(2,7) = '(''Requested segment :'',i5)' + texte(2,8) = '(''Requested segment # is negative or null.'')' + texte(2,9) = '(''Requested segment # is too high.'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) sfnbli + write (ulsort,texte(langue,5)) seglig(0) + write (ulsort,texte(langue,6)) seglig(sfnbli) + write (ulsort,texte(langue,7)) seg + write (ulsort,1789) ( seglig(iaux) , iaux = 1 , sfnbli) + 1789 format(10i8) +#endif +c +c==== +c 2. recherche +c==== +c +c 2.1. ==> controle preliminaire +c + if ( seg.le.0 ) then +c + codret = 1 +c + elseif ( seg.gt.seglig(sfnbli) ) then +c + codret = 2 +c + else +c +c 2.2. ==> recherche +c + do 22 , iaux = 1 , sfnbli +c + if ( seg.le.seglig(iaux) ) then + numlig = iaux + goto 221 + endif +c + 22 continue +c + 221 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,4)) sfnbli + write (ulsort,texte(langue,5)) seglig(0)+1 + write (ulsort,texte(langue,6)) seglig(sfnbli) + write (ulsort,texte(langue,7)) seg + write (ulsort,texte(langue,7+codret)) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfliso.F b/src/tool/Suivi_Frontiere/sfliso.F new file mode 100644 index 00000000..232908b1 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfliso.F @@ -0,0 +1,517 @@ + subroutine sfliso ( numnoe, lignoe, abscno, + > unst2x, epsid2, + > coonoe, + > somare, hetare, filare, np2are, + > cfaare, famare, + > geocoo, abscur, + > somseg, seglig, segnoe, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - LIen des SOmmets +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numnoe . s . mcnvnf . liste des noeuds de calcul de frontiere . +c . lignoe . s . mcnvnf . liste lignes pour ces noeuds . +c . abscno . s . mcnvnf . abscisse curviligne de ces noeuds . +c . unst2x . e . 1 . inverse de la taille maximale au carre . +c . epsid2 . e . 1 . precision relative pour carre de distance . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nbarto . famille des aretes . +c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . +c . abscur . e . sfnbse . abscisse curviligne des somm des segments . +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . segnoe . aux . nbnoto . segments lies aux noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFLISO' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofina.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "front1.h" +#include "front2.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision unst2x, epsid2 + double precision coonoe(nbnoto,sdim), geocoo(sfnbso,*) + double precision abscno(mcnxnf) + double precision abscur(sfnbse) +c + integer numnoe(mcnxnf), lignoe(mcnxnf) + integer seglig(0:sfnbli), somseg(sfnbse) + integer segnoe(nbnoto) + integer somare(2,nbarto), hetare(nbarto), filare(nbarto) + integer np2are(nbarto) + integer famare(nbarto), cfaare(nctfar,nbfare) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lenoeu, larete + integer seg, segm(3) + integer lig, ligv + integer nbsomm + integer nbar00 +#ifdef _DEBUG_HOMARD_ + integer glop + common / tutu / glop +#endif +c + double precision coop(3), acnoeu +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Nombre de '',a,'' du maillage :'',i10)' + texte(1,5) = '(''Boucle sur les aretes'')' + texte(1,6) = '(/,''Arete'',i10,'', sur la ligne'',i10)' + texte(1,7) = + >'(/,'' .. Examen du noeud du cote'',i2,'' :'',i10,'', seg ='',i5)' + texte(1,9) = '(6x,''Une arete est de longueur'')' + texte(1,10) = '(i5,'' aretes sont de longueur'')' + texte(1,11) = + > '(6x,''inferieure a la discretisation de la frontiere'')' + texte(1,12) = '(a,'' Inhibition du sf sur l''''arete'',i10)' + texte(1,20) = + >'(5x,''Examen des noeuds situes sur des extremites de ligne'')' +c + texte(2,4) = '(''. Number of '',a,'' in mesh :'',i10)' + texte(2,5) = '(''Loop over edges'')' + texte(2,6) = '(/,''Edge #'',i10,'', on line'',i10)' + texte(2,7) = + > '(/,'' .. Examination of node #'',i2,'' #'',i10,'', seg ='',i5)' + texte(2,9) = '(6x,''One edge is with length'')' + texte(2,10) = '(i5,'' edges are with length'')' + texte(2,11) = + > '(6x,''lower than the discretization of the boundary'')' + texte(2,12) = '(a,'' Inhibition of bf for the edge #'',i10)' + texte(2,20) = '(5x,''Examination of nodes located on lines'')' +c +#include "impr03.h" +c +c 1.2. ==> a priori, aucun segment n'est attache a un noeud +c + do 12 , lenoeu = 1 , nbnoto + segnoe(lenoeu) = 0 + 12 continue +c + if ( typsfr.le.2 ) then + nbsomm = 2 + else + nbsomm = 3 + endif +c + nbar00 = 0 +c + mcnvnf = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarto +#endif +c +cgn write(ulsort,90002) 'somseg', somseg +#ifdef _DEBUG_HOMARD_ + do 13 , iaux = 1, sfnbli + write(ulsort,90002) 'somseg pour la ligne numero', iaux + jaux = 0 + do 131 , seg = seglig(iaux-1)+1, seglig(iaux)-1 + jaux = jaux + 1 + write(ulsort,90012) '.. sommet numero', jaux, somseg(seg) + 131 continue + 13 continue +#endif +c +c==== +c 2. Boucle sur les aretes qui sont actives et positionnees sur +c une ligne de frontiere +c On va situer les sommets sur la ligne +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. boucle sur les aretes ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) +#endif +c + do 20 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ +c if ( larete.le.0 .or. +c > ( larete.eq.1 .or. larete.eq.8 .or. +c > larete.eq.9 ) ) then + if ( larete.le.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + lig = cfaare(cosfli,famare(larete)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,6)) larete, lig + endif +#endif +c + if ( lig.gt.0 ) then +c + if ( hetare(larete).ne.50 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + iaux = seglig(lig-1) + 1 + jaux = seglig(lig) + write (ulsort,90002) 'Sommets extremites de cette ligne', + >somseg(iaux), somseg(jaux-1) + endif +#endif +c +c On parcourt les noeuds de l'arete +c + do 200 , jaux = 1 , nbsomm +c +c 2.1. ==> Le noeud et son segment initial +c + if ( codret.eq.0 ) then +c + if ( jaux.le.2 ) then + lenoeu = somare(jaux,larete) + else + lenoeu = np2are(larete) + endif + seg = segnoe(lenoeu) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,7)) jaux, lenoeu, seg + if ( seg.lt.0 ) then + write (ulsort,90002) + > 'Le noeud est une extremite de la ligne', lig + elseif ( seg.eq.0 ) then + write (ulsort,*) '... Ce noeud n''est pas encore place.' + else + write (ulsort,90002) + > 'Le noeud a deja ete place sur le segment', seg + endif + endif +#endif +c +c 2.2. ==> Le noeud est une extremite de ligne ou n'a pas ete place +c + if ( seg.le.0 ) then +c + do 221 , iaux = 1 , sdim + coop(iaux) = coonoe(lenoeu,iaux) + 221 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90024) 'apres 221, coop du noeud', + > lenoeu, (coop(iaux),iaux=1,sdim) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFSENO', nompro +#endif + call sfseno ( coop, lig, unst2x, epsid2, + > seglig, somseg, geocoo, abscur, + > seg, acnoeu ) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90024) 'apres appel a sfseno, coop du noeud', + > lenoeu, (coop(iaux),iaux=1,sdim) + write (ulsort,90004) '==> acnoeu', acnoeu + write (ulsort,90002) 'Ce noeud a ete mis sur le segment', seg + endif +#endif + segm(jaux) = seg +c + if ( seg.ne.0 ) then +c + do 222 , iaux = 1 , mcnvnf + if ( numnoe(iaux).eq.lenoeu ) then + if ( lignoe(iaux).eq.lig ) then +cgn write (ulsort,*) ' enregistrement deja fait' + goto 200 + endif + endif + 222 continue +c + segnoe(lenoeu) = seg +c + mcnvnf = mcnvnf + 1 +cgn write (ulsort,90002) ' enregistrement a la position', mcnvnf + numnoe(mcnvnf) = lenoeu + lignoe(mcnvnf) = lig + abscno(mcnvnf) = acnoeu +c les noeuds sont forces sur la frontiere +cgn acnoeu=0.d0 +cgn do 2222 , iaux = 1 , sdim +cgn acnoeu = acnoeu+(coonoe(lenoeu,iaux)-coop(iaux))**2 +cgn 2222 continue +cgn write (ulsort,*) 223, lenoeu,acnoeu +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .or. lenoeu.eq.-102 ) then + write (ulsort,90024) 'avant 222, coonoe du noeud', + > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) + endif +#endif + do 223 , iaux = 1 , sdim +cgn write (ulsort,*) iaux,coonoe(lenoeu,iaux),coop(iaux) + coonoe(lenoeu,iaux) = coop(iaux) + 223 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .or. lenoeu.eq.-102 ) then + write (ulsort,90024) 'apres 223, coonoe du noeud', + > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) + endif +#endif +#ifdef _DEBUG_HOMARD_ +c + else +c + codret = codret + 1 +#endif +c + endif +c +c 2.3. ==> Le noeud est deja situe sur un segment interieur +c De quelle ligne ? +c + else +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .or. lenoeu.eq.-102 ) then + write (ulsort,90024) ' .... Noeud', + > lenoeu,(coonoe(lenoeu,iaux),iaux=1,sdim) + write (ulsort,*) 'deja sur le segment ',seg + endif +#endif +c + call sflise( ligv, seg, seglig, + > ulsort, langue, codret) +c + if ( codret.eq.0 ) then +c + if ( ligv.eq.lig ) then +c +c 2.3.1 ==> meme ligne : pas de probleme +c + segm(jaux) = seg +c + else +c +c 2.3.2 ==> autre ligne : on le retire +c + segm(jaux) = 0 +c + endif +c + endif +c + endif +c + endif +c + 200 continue +c +c 2.4. ==> Combien de noeuds de l'arete pointent sur la ligne ? +c + if ( codret.eq.0 ) then +c + if ( segm(1).eq.0 .and. segm(2).eq.0 ) then +c +c 2.4.1. ==> Aucun : impression, et prohibition du sf +c +20100 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ', + > 'un sommet n''est pas situe') + write(ulsort,20100) + > larete,(somare(iaux,larete),iaux=1,2),lig + iaux = cfaare(cosfin,famare(larete)) + famare(larete) = iaux +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,texte(langue,12)) '2.4.1', larete + endif +#endif + if ( mod(hetare(larete),10).eq.2 ) then + do 241 , iaux = 0 , 1 + jaux = cfaare(cosfin,famare(filare(larete)+iaux)) + famare(filare(larete)+iaux) = jaux +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,texte(langue,12)) '2.4.1',filare(larete)+iaux + endif +#endif + 241 continue + endif +c + elseif ( abs(segm(1)).eq.abs(segm(2)) ) then +c +c 2.4.2. ==> Les deux ; et ils pointent vers le meme segment +c Il ne sert plus a rien de suivre la frontiere pour +c cette arete : on a atteint la discretisation minimale +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +20200 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ', + > 'meme segment',i10) + write(ulsort,20200) + > larete,(somare(iaux,larete),iaux=1,2),lig,abs(segm(1)) + write(ulsort,texte(langue,12)) '2.4.2', larete + endif +#endif + nbar00 = nbar00 + 1 + iaux = cfaare(cosfin,famare(larete)) + famare(larete) = iaux + if ( mod(hetare(larete),10).eq.2 ) then + do 242 , iaux = 0 , 1 + jaux = cfaare(cosfin,famare(filare(larete)+iaux)) + famare(filare(larete)+iaux) = jaux +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,texte(langue,12)) '2.4.2',filare(larete)+iaux + endif +#endif + 242 continue + endif +c + endif +c + endif +c + endif +c + endif +c + 20 continue +c + endif +c +c==== +c 3. impressions +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) '3. impressions, codret =', codret +#endif +c + if ( nbar00.ne.0 ) then + if ( nbar00.eq.1 ) then + write (ulsort,texte(langue,9)) + else + write (ulsort,texte(langue,10)) nbar00 + endif + write (ulsort,texte(langue,11)) + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + + diff --git a/src/tool/Suivi_Frontiere/sfmop2.F b/src/tool/Suivi_Frontiere/sfmop2.F new file mode 100644 index 00000000..472d5675 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfmop2.F @@ -0,0 +1,195 @@ + subroutine sfmop2 ( coonoe, hetnoe, arenoe, + > somare, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - MOdification des noeuds P2 +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . arenoe . e . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFMOP2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto), arenoe(nbnoto) + integer somare(2,nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c + integer lenoeu, lenoe1, lenoe2 + integer larete +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/5x,''Retouche des coordonnees des noeuds P2'')' + texte(1,5) = '(7x,''Nombre de noeuds modifies : '',i10)' + texte(1,6) = '(7x,''==> Arete '',i10)' + texte(1,7) = '(7x,''==> Repositionnement du noeud '',i10)' +c + texte(2,4) = '(/5x,''Updating of P2 node coordinates'')' + texte(2,5) = '(7x,''Number of modified nodes : '',i10)' + texte(2,6) = '(7x,''==> Edge # '',i10)' + texte(2,7) = '(7x,''==> Relocalization of node # '',i10,)' +c + codret = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro +#endif +c +c==== +c 2. retouche des coordonnees des noeuds P2 +c remarque : on repositionne tous les nouveaux noeuds P2 +c on pourrait faire plus malin en ne bougeant que ceux +c qui doivent l'etre mais c'est assez complique. Il faut +c tous ceux sur une arete dont l'extremite a bouge par +c suite de raffinement, et tous ceux qui etaient des P1 +c et qui redeviennent P2 par deraffinement. +c Au final, cela suppose de reperer des voisinages et +c donc assez complique et pas forcement economique en CPU +c remarque : on en fait pas assez. il faudrait faire les noeuds +c au milieu des quadrangles. +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. noeuds P2 ; codret = ', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + jaux = 0 +#endif +c + do 21 , lenoeu = 1 , nbnoto +c + if ( mod(hetnoe(lenoeu),10).eq.2 ) then +c +c 2.1. ==> Reperage +c + larete = arenoe(lenoeu) + lenoe1 = somare(1,larete) + lenoe2 = somare(2,larete) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) larete + write(ulsort,texte(langue,7)) lenoeu +#endif +c +c 2.2. ==> Calcul des coordonnees milieu +c + do 221 , iaux = 1 , sdim + coonoe(lenoeu,iaux) = + > (coonoe(lenoe1,iaux)+coonoe(lenoe2,iaux))*0.5d0 + 221 continue +#ifdef _DEBUG_HOMARD_ + jaux = jaux + 1 +#endif +c + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) jaux + write (ulsort,*) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfnnfl.F b/src/tool/Suivi_Frontiere/sfnnfl.F new file mode 100644 index 00000000..c0681c2f --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfnnfl.F @@ -0,0 +1,183 @@ + subroutine sfnnfl ( hetare, + > cfaare, famare, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : compter le nombre de noeuds du maillage de calcul qui sont sur +c la frontiere +c ______________________________________________________________________ +c +c Suivi de Frontiere - Nombre de Noeuds sur la Frontiere - Lignes +c - - - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFNNFL' ) +c +#include "nblang.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "front2.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto) + integer famare(nbarto), cfaare(nctfar,nbfare) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lig + integer nbarfr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''. Max du nombre de noeuds sur la frontiere :'',i10)' + texte(1,5) = '(''Arete '',i10,'' de ligne'',i10)' +c + texte(2,4) = '(''. Max of number of nodes over boundary :'',i10)' + texte(2,5) = '(''Edge '',i10,'' in line'',i10)' +c +c==== +c 2. boucle sur les aretes : situer les sommets sur la ligne +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. boucle sur les aretes ; codret = ', codret +#endif +c + nbarfr = 0 +c + if ( codret.eq.0 ) then +c + do 21 , iaux = 1 , nbarto +c + lig = cfaare(cosfli,famare(iaux)) +#ifdef _DEBUG_HOMARD_ + if ( lig.gt.0 ) then + write (ulsort,texte(langue,5)) iaux, lig + endif +#endif +c + if ( lig.gt.0 ) then +c + if ( hetare(iaux).ne.50 ) then +c + nbarfr = nbarfr + 1 +c + endif +c + endif +c + 21 continue +c + endif +c + if ( degre.eq.1 ) then + mcnxnf = 2*nbarfr + else + mcnxnf = 3*nbarfr + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mcnxnf +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + + diff --git a/src/tool/Suivi_Frontiere/sfnofl.F b/src/tool/Suivi_Frontiere/sfnofl.F new file mode 100644 index 00000000..b4165178 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfnofl.F @@ -0,0 +1,311 @@ + subroutine sfnofl ( ntrav1, ntrav2, ntrav3, + > adnuno, adlino, adacno, + > unst2x, epsid2, + > coonoe, + > somare, hetare, filare, np2are, + > cfaare, famare, + > geocoo, abscur, + > somseg, seglig, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - NOeuds du maillage de calcul +c - - -- +c sur la Frontiere - Lignes +c - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ntrav1 . s . 1 . tableau de numnoe = imem(adnuno) . +c . ntra2v . s . 1 . tableau de lignoe = imem(adlino) . +c . ntrav3 . s . 1 . tableau de abscno = rmem(adacno) . +c . adnuno . s . 1 . liste des noeuds de calcul sur le bord . +c . adlino . s . 1 . liste lignes pour ces noeuds . +c . adacno . s . 1 . abscisse curviligne de ces noeuds . +c . unst2x . e . 1 . inverse de la taille maximale au carre . +c . epsid2 . e . 1 . precision relative pour carre de distance . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . +c . abscur . e . sfnbse . abscisse curviligne des somm des segments . +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFNOFL' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +c +#include "envca1.h" +#include "front1.h" +#include "front2.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision unst2x, epsid2 + double precision coonoe(nbnoto,sdim), geocoo(sfnbso,sdim) + double precision abscur(sfnbse) +c + integer adnuno, adlino, adacno + integer seglig(0:sfnbli), somseg(sfnbse) + integer famare(nbarto), cfaare(nctfar,nbfare) + integer somare(2,nbarto), hetare(nbarto), filare(nbarto) + integer np2are(nbarto) +c + character*8 ntrav1, ntrav2, ntrav3 +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux +c + integer adsegn + integer codre0 + integer codre1, codre2, codre3, codre4 +c + character*6 saux + character*8 ntrava +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' NOEUDS INITIAUX SUR LA FRONTIERE'')' + texte(1,5) = '(39(''=''),/)' + texte(1,6) = '(''. Nombre de '',a,'' :'',i10)' + texte(1,7) = '(''. Inverse du carre de la taille :'',g15.7)' + texte(1,8) = '(''. Precision relative :'',g15.7)' +c + texte(2,4) = '(/,a6,'' INITIAL NODES AND BOUNDARY'')' + texte(2,5) = '(33(''=''),/)' + texte(2,6) = '(''. Number of '',a,'' :'',i10)' + texte(2,7) = '(''. 1./max distance ** 2 :'',g15.7)' + texte(2,8) = '(''. Relative precision for equality :'',g15.7)' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,-1), nbnoto + write (ulsort,texte(langue,6)) mess14(langue,3,1), nbarto + write (ulsort,texte(langue,7)) unst2x + write (ulsort,texte(langue,8)) epsid2 +#endif +c +c==== +c 2. Estimation du nombre de noeuds du maillage de calcul qui sont +c sur une ligne de frontiere +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Estimation ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFNNFL', nompro +#endif + call sfnnfl ( hetare, + > cfaare, famare, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. Allocations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocations ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', mcnxnf, adnuno, codre1 ) + call gmalot ( ntrav2, 'entier ', mcnxnf, adlino, codre2 ) + call gmalot ( ntrav3, 'reel ', mcnxnf, adacno, codre3 ) + call gmalot ( ntrava, 'entier ', nbnoto, adsegn, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 4. Etablissement du lien des sommets +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Liens sommets/lignes ; codret = ', codret +#endif +cgn 1001 format(a,' :',i10,', ',3g13.5) +cgn do 41 ,codre0=1,nbnoto +cgn write (ulsort,1001) 'n', codre0, +cgn >(coonoe(codre0,iaux),iaux = 1 , sdim) +cgn 41 continue +c + if ( codret.eq.0 ) then +c +cgn 1001 format('Noeud ',i8,' :',3g16.9) +cgn codre1=115 +cgn write (ulsort,1001) +cgn > codre1,(coonoe(codre1,iaux),iaux=1,sdim) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFLISO', nompro +#endif + call sfliso ( imem(adnuno), imem(adlino), rmem(adacno), + > unst2x, epsid2, + > coonoe, + > somare, hetare, filare, np2are, + > cfaare, famare, + > geocoo, abscur, + > somseg, seglig, imem(adsegn), + > ulsort, langue, codret ) +c + endif +cgn codre1=115 +cgn write (ulsort,1001) +cgn > codre1,(coonoe(codre1,iaux),iaux=1,sdim) +cgn do 42 ,codre0=1,nbnoto +cgn write (ulsort,1001) 'n', codre0, +cgn >(coonoe(codre0,iaux),iaux = 1 , sdim) +cgn 42 continue +c +cgn call gmprot ( nompro//' apres SFLISO', ntrav1, 1, mcnvnf ) +cgn call gmprot ( nompro//' apres SFLISO', ntrav2, 1, mcnvnf ) +cgn call gmprot ( nompro//' apres SFLISO', ntrav3, 1, mcnvnf ) +c +c==== +c 5. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Menage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrava, codret ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end + + diff --git a/src/tool/Suivi_Frontiere/sfnuli.F b/src/tool/Suivi_Frontiere/sfnuli.F new file mode 100644 index 00000000..5e43ebd7 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfnuli.F @@ -0,0 +1,218 @@ + subroutine sfnuli ( cfaare, numlig, option, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - NUmeros de LIgne +c - - -- -- +c ______________________________________________________________________ +c +c but : compactage ou retablissement des numeros de ligne des familles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . numlig . e . sfnbli . numero des lignes . +c . option . e . 1 . 0 pour compactage, sinon retablissement . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFNULI' ) +c +#include "nblang.h" +#include "cofaar.h" +#include "cofina.h" +c +c 0.2. ==> communs +c +#include "front1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option + integer numlig(sfnbli) + integer cfaare(nctfar,nbfare) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux +c + integer lig, ligv +c + character*6 saux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' COMPACTAGE DES NUMEROS DE LIGNE'')' + texte(1,5) = '(38(''=''),/)' + texte(1,6) = '(/,a6,'' RESTITUTION DE NUMEROS DE LIGNE'')' + texte(1,7) = + > '(5x,''La ligne'',i10,'' ne figure pas dans la liste :'')' +c + texte(2,4) = '(/,a6,'' LINE NUMBERS COMPACTING'')' + texte(2,5) = '(30(''=''),/)' + texte(2,6) = '(/,a6,'' LINE NUMBERS RETRIEVING'')' + texte(2,7) = + > '(5x,''Line #'',i10,'' does not belong to list:'')' +c +#include "impr03.h" +c +c 1.2. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.3. ==> le titre +c + if ( option.eq.0 ) then + write (ulsort,texte(langue,4)) saux + else + write (ulsort,texte(langue,6)) saux + endif + write (ulsort,texte(langue,5)) +c +c==== +c 2. boucle sur les familles d'aretes : compacter les numeros +c==== +c + if ( option.eq.0 ) then +c + do 21 iaux = 1 , nbfare +c + if ( codret.eq.0 ) then +c + lig = cfaare(cosfli,iaux) + if ( lig.gt.0 ) then +c + do 211 , ligv = 1 , sfnbli + if ( lig.eq.numlig(ligv) ) then + cfaare(cosfli,iaux) = ligv + cfaare(cosfli,cfaare(cosfin,iaux)) = -ligv + goto 21 + endif + 211 continue +c + codret = 1 +c + endif +c + endif +c + 21 continue +c +c==== +c 3. boucle sur les familles d'aretes : redonner les numeros d'origine +c==== +c + else +c + do 31 , iaux = 1, nbfare +c + lig = cfaare(cosfli,iaux) + if ( lig.gt.0 ) then + cfaare(cosfli,iaux) = numlig( lig) + else if (lig.lt.0) then + cfaare(cosfli,iaux) = -numlig(-lig) + endif +c + 31 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,7)) lig + write (ulsort,91020) (numlig(ligv),ligv=1,sfnbli) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfpop2.F b/src/tool/Suivi_Frontiere/sfpop2.F new file mode 100644 index 00000000..0ff4f198 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfpop2.F @@ -0,0 +1,264 @@ + subroutine sfpop2 ( typsfr, + > coonoe, + > somare, np2are, + > cfaare, famare, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - POsition des noeuds P2 +c - - -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typsfr . s . 1 . type du suivi de frontiere . +c . . . . 0 : aucun . +c . . . . 1 : maillage de degre 1, avec projection . +c . . . . des nouveaux sommets . +c . . . . 2 : maillage de degre 2, seuls les noeuds . +c . . . . P1 sont sur la frontiere ; les noeuds . +c . . . . P2 restent au milieu des P1 . +c . . . . 3 : maillage de degre 2, les noeuds P2 . +c . . . . etant sur la frontiere . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nbarto . famille des aretes . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFPOP2' ) +c +#include "nblang.h" +#include "cofaar.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "fracta.h" +c +c 0.3. ==> arguments +c + integer typsfr + integer somare(2,nbarto), np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) +c + double precision coonoe(nbnoto,2) +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset + integer iaux +c + integer larete, noeud1, noeud2 + integer numlig +c + character*6 saux +c + double precision daux, daux1, daux2 + double precision xmil, ymil +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' REPERAGE DES POSITIONS DE NOEUDS P2'')' + texte(1,5) = '(42(''=''),/)' + texte(1,6) = + >'(''. Examen de l''''arete '',i10,'' (ligne '',i8,'')'')' + texte(1,7) ='(''Ecart au carre :'',g12.5)' + texte(1,8) ='(''1/2 arete au carre :'',g12.5)' + texte(1,9) ='(''Ecart maximal :'',g12.5)' + texte(1,10) ='(''1/2 arete maximale :'',g12.5)' + texte(1,11) ='(''Millieme de la 1/2 arete maximale :'',g12.5)' + texte(1,12) ='(''Les noeuds P2 sont au milieu des aretes.'')' + texte(1,13) ='(''Les noeuds P2 sont sur la frontiere.'')' +c + texte(2,4) = '(/,a6,'' LOCALIZATION OF P2 NODES'')' + texte(2,5) = '(31(''=''),/)' + texte(2,6) = + >'(''. Examination of edge #'',i10,'' (line #'',i8,'')'')' + texte(2,7) ='(''Squared distance :'',g12.5)' + texte(2,8) ='(''Squared half edge :'',g12.5)' + texte(2,9) ='(''Maximum distance :'',g12.5)' + texte(2,10) ='(''Maximum half edge :'',g12.5)' + texte(2,11) ='(''1.e-3 maximum half edge :'',g12.5)' + texte(2,12) ='(''P2 nodes are centers of edges.'')' + texte(2,13) ='(''P2 nodes are located over border.'')' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5. ==> le titre +c + write (ulsort,texte(langue,4)) saux + write (ulsort,texte(langue,5)) +c +c==== +c 2. On ne s'interesse qu'aux aretes qui font partie d'une frontiere +c reconnue +c Il suffit de le faire sur les aretes du macro-maillage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. ; codret = ', codret +#endif +c +c 2.1. ==> Recherche de l'ecart maximum entre le noeud central et le +c milieu des 2 extremites, pour chacune des aretes de frontiere +c + daux1 = 0.d0 + daux2 = 0.d0 +c + do 21 , larete = 1 , nbarma +c + if ( codret.eq.0 ) then +c + numlig = cfaare(cosfli,famare(larete)) +c + if ( numlig.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6)) larete, numlig +#endif + noeud1 = somare(1,larete) + noeud2 = somare(2,larete) +c + xmil = unsde * ( coonoe(noeud1,1) + coonoe(noeud2,1) ) + ymil = unsde * ( coonoe(noeud1,2) + coonoe(noeud2,2) ) +c + daux = ( coonoe(np2are(larete),1) - xmil ) **2 + + > ( coonoe(np2are(larete),2) - ymil ) **2 + daux1 = max(daux1, daux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,7)) daux +#endif +c + daux = ( coonoe(noeud1,1) - xmil ) **2 + + > ( coonoe(noeud1,2) - ymil ) **2 + daux2 = max(daux2, daux) +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,8)) daux +#endif +c + endif +c + endif +c + 21 continue +c +c 2.2. ==> diagnostic : si l'ecart est superieur au millieme de la +c demi-arete, on considere que les noeuds P2 ont ete mis sur +c la frontiere +c C'est un pari ... +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,9)) sqrt(daux1) + write(ulsort,texte(langue,10)) sqrt(daux2) + write(ulsort,texte(langue,11)) 1.d-3*sqrt(daux2) +#endif + if ( daux1.gt.1.d-6*daux2 ) then + typsfr = 3 + else + typsfr = 2 + endif +c + write(ulsort,texte(langue,10+typsfr)) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfprep.F b/src/tool/Suivi_Frontiere/sfprep.F new file mode 100644 index 00000000..ebb2ebc7 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfprep.F @@ -0,0 +1,272 @@ + subroutine sfprep ( nomail, nocdfr, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere : PREParation +c -- --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard iter. n+1 . +c . nocdfr . e . char8 . nom de l'objet description de la frontiere . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . en entree = celui du module d'avant . +c . . . . en sortie = celui du module en cours . +c . . . . 0 : pas de probleme . +c . . . . 1 : manque de temps cpu . +c . . . . 2x : probleme dans les memoires . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : mauvaises options . +c . . . . 6 : problemes dans les noms d'objet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFPREP' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nocdfr +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer pcoono + integer psomar, phetar, pnp2ar + integer pcfaar, pfamar + integer psegli, pnumli +c + integer codre0, codre1, codre2 +c +#ifdef _DEBUG_HOMARD_ + character*8 action + parameter ( action = 'sufr ' ) +#endif + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c +#ifdef _DEBUG_HOMARD_ + character*6 nompra +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 0 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2.==> tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 3 + call utad01 ( iaux, nhnoeu, + > jaux, + > jaux, jaux, jaux, + > pcoono, jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 518 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux, jaux, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Particularites de la frontiere discrete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. frontiere discrete ; codret', codret +#endif +c +c 3.1.==> Description de la frontiere discrete +c + if ( codret.eq.0 ) then +c + call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre1 ) + call gmadoj ( nocdfr//'.NumeLign', pnumli, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 3.2. ==> Compactage des numeros de ligne +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2 compactage nros ligne ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'SFNULI', nompro +#endif + call sfnuli ( imem(pcfaar), imem(pnumli), iaux, + > lgetco, taetco, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + nompra = 'sfnuli' + iaux = 2 + call utveri ( action, nomail, nompra, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + iaux = 2 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfseno.F b/src/tool/Suivi_Frontiere/sfseno.F new file mode 100644 index 00000000..a34447fd --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfseno.F @@ -0,0 +1,449 @@ + subroutine sfseno ( cono, numlig, unst2x, epsid2, + > seglig, somseg, geocoo, abscur, + > seg, acnoeu ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - SEgment - NOeud +c - - -- -- +c ______________________________________________________________________ +c +c but : recherche du segment de la ligne auquel appartient le noeud +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . cono . es . sdim . coordonnees du noeud . +c . numlig . e . 1 . numero de ligne sur laquelle on cherche . +c . unst2x . e . 1 . inverse de la taille maximale au carre . +c . epsid2 . e . 1 . precision relative pour carre de distance . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . +c . seg . s . 1 . numero de segment trouve . +c - : noeud sur extremite de ligne . +c + : noeud hors extremites . +c . acnoeu . s . 1 . abscisse curviligne du noeud sur la ligne . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "front1.h" +#include "infini.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision unst2x, epsid2 + double precision geocoo(sfnbso,*), cono(sdim) + integer seglig(0:sfnbli), somseg(sfnbse) + integer numlig, seg + double precision acnoeu + double precision abscur(sfnbse) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer seg1, seg2, segmin +c + double precision cooa(3), coob(3) + double precision daux, daux1, daux2 +c +#ifdef _DEBUG_HOMARD_ + integer ulsort + parameter (ulsort=1) + integer glop + common / tutu / glop +#endif +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. initialisation +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,*) 'Entree dans SFSENO' + write(ulsort,90004) 'unst2x',unst2x + write(ulsort,90004) 'epsid2',epsid2 + write(ulsort,90004) 'cono', (cono(iaux),iaux = 1 , sdim) + write(ulsort,90002) 'numlig', numlig + endif +#endif +c +c 1.1. ==> segment pas encore trouve +c + seg = 0 +c +c 1.2. ==> bornes de la ligne dans la numerotation des segments +c + seg1 = seglig(numlig-1) + 1 + seg2 = seglig(numlig ) - 2 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90006) 'Pointeurs seglig pour la ligne', numlig, + >' de',seg1,' a ',seg2+2 + write(ulsort,90002) '==> Segments extremites',seg1,seg2 + write(ulsort,90002) '==> Sommets extremites ', + > somseg(seg1),somseg(seg2+1) + endif +#endif +c +c==== +c 2. Le noeud est-il une extremite de la ligne ? +c Remarque : on commence par la fin de la ligne pour pouvoir +c initialiser correctement l'etape suivante en cas de +c non coincidence +c Remarque : comme ce sont les coordonnees du debut du segment qui +c sont stockees, il faut examiner le segment fictif +c (dernier+1) pour trouver les coordonnees de sa fin +c==== +c + do 20 , jaux = 1 , 2 +c + if ( jaux.eq.1 ) then + kaux = seg2+1 + else + kaux = seg1 + endif +c + daux = 0.d0 + do 21 , iaux = 1 , sdim + coob(iaux) = geocoo(somseg(kaux),iaux) + daux = daux + (coob(iaux)-cono(iaux))**2 + 21 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( jaux.eq.1 ) then + write(ulsort,90002) 'segment (jaux=1)', seg2 + else + write(ulsort,90002) 'segment (jaux=2)', seg1 + endif + write(ulsort,90024) 'Noeud', somseg(kaux), + > (geocoo(somseg(kaux),iaux),iaux=1,sdim) + write(ulsort,90024) '==> carre distance a l''extremite', + > 1+mod(jaux,2),daux + endif +#endif + if ( daux*unst2x.le.epsid2 ) then + seg = -kaux + acnoeu = abscur(kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90015) '==> Le noeud est l''extremite', + > 1+mod(jaux,2),' de la ligne', numlig + endif +#endif + goto 50 +c + endif +c + 20 continue +c +c==== +c 3. Le noeud n'est pas une extremite de la ligne +c On va chercher le segment dont la premiere extremite est +c la plus proche du noeud courant. +c Si une de ces extremites est le noeud courant, on le note +c et on sort. +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90002) 'Le noeud n''est pas extremite de la ligne', + > numlig + endif +#endif +c + daux1 = vinfpo +c + do 30 , kaux = seg1 , seg2 +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( kaux.eq.seg1 .or. kaux.le.-1 ) then + write(ulsort,90006) ' Segment [', + > somseg(kaux),' ',somseg(kaux+1),'] ' + endif + endif +#endif +c +c 3.1. ==> Calcul de la distance au point A, debut du segment +c + daux = 0.d0 + do 31 , iaux = 1 , sdim + daux = daux + (geocoo(somseg(kaux),iaux)-cono(iaux))**2 + 31 continue +cgn if ( kaux.eq.seg1 .or. kaux.le.-1 ) then +cgn write(ulsort,90004) ' Carre de la distance', daux +cgn endif +c + if ( daux*unst2x.le.epsid2 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) 'Carre de la distance', daux + write(ulsort,90002) + > '==> Le noeud est au debut du segment', kaux + endif +#endif + seg = kaux + acnoeu = abscur(kaux) + goto 50 +c + endif +c +c 3.2. ==> Memorisation du minimum +c +cgn write(ulsort,90004) ' Distance ', daux + if ( daux.le.daux1 ) then +c + daux1 = daux + segmin = kaux +cgn write(ulsort,*) ' Minimum pour le segment ',segmin, +cgn > ' : [',somseg(segmin),',',somseg(segmin+1),'] ' +c + endif +c + 30 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) 'Distance minimale', daux1 + write(ulsort,90006) ' atteinte sur le segment ',segmin, + > '[',somseg(segmin),' ',somseg(segmin+1),'] ' + endif +#endif +c +c==== +c 4. Le noeud n'est pas une extremite d'un segment +c On precise les points A et B +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90002) 'Le premier segment est seg1', seg1 + write(ulsort,90002) 'Le dernier segment est seg2', seg2 + write(ulsort,90002) + > 'Le segment le plus proche du noeud est segmin', segmin + endif +#endif +c +c 4.1. ==> On a trouve le segment dont le debut, A, est le sommet le +c plus proche de N. +c Si c'est le premier segment, il n'y a pas d'equivoque : +c N sera place entre A et B +c Sinon, il faut preciser entre les deux segments concernes, +c segmin-1 et segmin. On postule que le segment le plus proche +c est celui dont la deuxieme extremite est la plus proche de N. +c +c N +c A +c . +c segmin-1 . . segmin +c . . +c C . . B +c + if ( segmin.ne.seg1 ) then +c + daux = 0.d0 + daux2 = 0.d0 + do 41 , iaux = 1 , sdim + daux = daux + + > (geocoo(somseg(segmin-1),iaux)-cono(iaux))**2 + daux2 = daux2 + + > (geocoo(somseg(segmin+1),iaux)-cono(iaux))**2 + 41 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90024) '(C-A) Carre de la distance au debut de', + > segmin-1, daux + write(ulsort,90024) '(A-B) Carre de la distance au debut de', + > segmin , daux1 + write(ulsort,90024) '(B- ) Carre de la distance au debut de', + > segmin+1, daux2 + write(ulsort,90004) ' N',(cono(iaux),iaux=1,sdim) + write(ulsort,90004) ' C', + > (geocoo(somseg(segmin-1),iaux),iaux=1,sdim), abscur(segmin-1) + write(ulsort,90004) ' A', + > (geocoo(somseg(segmin),iaux),iaux=1,sdim), abscur(segmin) + write(ulsort,90004) ' B', + > (geocoo(somseg(segmin+1),iaux),iaux=1,sdim), abscur(segmin+1) + endif +#endif +c + if ( daux.lt.daux2 ) then + seg = segmin - 1 + else + seg = segmin + endif +c + else +c + seg = segmin +c + endif +c +c 4.2. ==> Definition des points A et B +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90002) '... ==> Le noeud est lie au segment', seg + endif +#endif +c + do 42 , iaux = 1 , sdim + cooa(iaux) = geocoo(somseg(seg ),iaux) + coob(iaux) = geocoo(somseg(seg+1),iaux) + 42 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) ' de A', (cooa(iaux),iaux=1,sdim), + > abscur(seg) + write(ulsort,90004) ' a B', (coob(iaux),iaux=1,sdim), + > abscur(seg+1) + endif +#endif +c +c 4.3. ==> Il faut recoller N sur la frontiere le cas echeant, +c puis redefinir son abscisse curviligne. +c +c 4.3.1. ==> Calcul du produit scalaire AB.AN +c + daux = 0.d0 + do 431 , iaux = 1 , sdim + daux = daux + + > ( coob(iaux) - cooa(iaux) ) * + > ( cono(iaux) - cooa(iaux) ) + 431 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) 'Produit scalaire AB.AN', daux + endif +#endif +c +c 4.3.2. ==> Positionnement +c 4.3.2.1. ==> Si le produit scalaire est negatif, c'est que P est +c "en arriere" de A. On ramene P sur A. +c + if ( daux.le.0 ) then +c + do 4321 , iaux = 1 , sdim + cono(iaux) = cooa(iaux) + 4321 continue + acnoeu = abscur(seg) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) '.. ==> Le noeud a ete replace sur A' + endif +#endif +c + else +c +c daux1 : distance AB + daux1 = abscur(seg+1)-abscur(seg) + daux = daux / (daux1**2) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) 'Distance AB', daux1 + write(ulsort,90004) 'Carre de la distance AB ', daux1**2 + endif +#endif +c +c 4.3.2.2. ==> Si le produit scalaire est superieur au carre de la +c distance AB, c'est que P est "en avant" de B. +c On ramenera P sur B. +c + if ( daux.ge.1.d0 ) then +c + do 4322 , iaux = 1 , sdim + cono(iaux) = coob(iaux) + 4322 continue + acnoeu = abscur(seg+1) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) '.. ==> Le noeud a ete replace sur B' + endif +#endif +c +c 4.3.2.3. ==> N est "entre" A et B. +c On decompose le vecteur AN en une partie le long du +c segment, alpha.AB, et une partie orthogonale. +c Cela revient a projeter N orthogonalement au segment. +c + else +c + do 4323 , iaux = 1 , sdim + cono(iaux) = cooa(iaux) + daux*(coob(iaux)-cooa(iaux)) + 4323 continue + acnoeu = abscur(seg) + daux*daux1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) '.. ==> Le noeud a ete place entre A et B' + endif +#endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,90004) '. Nouveau noeud', (cono(iaux),iaux=1,sdim) + endif +#endif +c +c==== +c 5. Sortie +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) '5. sortie' +#endif +c + 50 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write(ulsort,*) 'Bilan :' + write(ulsort,90002) '==> Segment ', seg + write(ulsort,90004) '==> Abcisse curviligne', acnoeu + write(ulsort,*) 'Sortie de SFSENO' + endif +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sfslin.F b/src/tool/Suivi_Frontiere/sfslin.F new file mode 100644 index 00000000..714d95e5 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sfslin.F @@ -0,0 +1,444 @@ + subroutine sfslin ( lenoeu, noeud1, noeud2, + > numlig, unst2x, epsid2, + > geocoo, abscur, + > numnoe, lignoe, abscno, + > typlig, somseg, seglig, + > coop, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Suivi des LIgnes - placement d'un Noeud +c - - - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lenoeu . e . 1 . noeud a bouger . +c . noeud1 . e . 1 . noeud voisin 1 de lenoeu sur l'arete . +c . noeud2 . e . 1 . noeud voisin 2 de lenoeu sur l'arete . +c . numlig . e . 1 . numero de la ligne de la frontiere . +c . unst2x . e . 1 . inverse de la taille maximale au carre . +c . epsid2 . e . 1 . precision relative pour carre de distance . +c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere . +c . abscur . e . sfnbse . abscisse curviligne des somm des segments . +c . numnoe . e . mcnvnf . liste des noeuds de calcul sur le bord . +c . lignoe . e . mcnvnf . liste lignes pour ces noeuds . +c . abscno . e . mcnvnf . abscisse curviligne de ces noeuds . +c . typlig . e . sfnbli . type de la ligne . +c . . . . 0 : ligne ouverte, a 2 extremites . +c . . . . 1 : ligne fermee . +c . somseg . e . sfnbse . liste des sommets des lignes separees par . +c des 0 . +c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les . +c . . . . segments de la ligne i sont aux places de . +c . . . . seglig(i-1)+1 a seglig(i)-1 inclus . +c . coop . es . sdim . nouvelles coordonnees de lenoeu . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : impossible de retrouver les noeuds . +c . . . . voisins . +c . . . . 2 : impossible de trouver le segment . +c . . . . contenant le noeud . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFSLIN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "front1.h" +#include "front2.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lenoeu, noeud1, noeud2 + integer numlig + integer numnoe(mcnvnf), lignoe(mcnvnf) + integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli) +c + double precision unst2x, epsid2 + double precision geocoo(sfnbso,sdim) + double precision abscur(sfnbse) + double precision abscno(mcnvnf) + double precision coop(sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer seg, seg1, seg2 + integer nupass, nbpass +c + double precision abscnn(2), abscn1, abscn2, abscnm + double precision daux, lgdeb, lgfin + double precision cooa(3) + double precision cooini(3), coopst(3), dist +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +cgn ulsort = lenoeu +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. '',a,i10,'' a deplacer'')' + texte(1,5) = '(''... Coordonnees :'',3g17.9)' + texte(1,6) = '(''.. Il est entre les '',a,i10,'' et'',i10)' + texte(1,7) = + > '(''.... Abscisse curviligne du noeud'',i10,'' :'',g17.9)' + texte(1,8) = '(''.... Abscisse curviligne '',a,'' :'',g17.9)' + texte(1,9) = + >'(''.. Impossible de trouver le '',a,i10,'' sur la frontiere.'')' + texte(1,10) = '(''.. Impossible de trouver le segment associe.'')' +c + texte(2,4) = '(''... '',a,'' # '',i10,'' to move'')' + texte(2,5) = '(''... Coordinates :'',3g17.9)' + texte(2,6) = + > '(''... It is between '',a,'' # '',i10,'' and #'',i10)' + texte(2,7) = + > '(''.... Current absciss of the node'',i10,'' :'',g17.9)' + texte(2,8) = '(''.... Current absciss '',a,'' :'',g17.9)' + texte(2,9) = + > '(''.. The '',a,i10,'' cannot be found on boundary.'')' + texte(2,10) = '(''.. The edge of boundary cannot be found.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu + write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim) + write (ulsort,texte(langue,6)) mess14(langue,3,-1), + > noeud1, noeud2 +#endif +c + codret = 0 +c +c==== +c 2. Recherche des abscisses curvilignes associes aux noeuds voisins +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Recherche abscisse ; codret', codret +#endif +c + do 21 , iaux = 1 , 2 +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + kaux = noeud1 + else + kaux = noeud2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '.... '//mess14(langue,2,-1), kaux +#endif +c + do 211 , jaux = 1 , mcnvnf +c + if ( numnoe(jaux).eq.kaux ) then + if ( lignoe(jaux).eq.numlig ) then + daux = abs(abscno(jaux)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) jaux, daux +#endif + goto 212 + endif + endif +c + 211 continue +c + codret = 1 +c + endif +c + 212 continue +c + if ( codret.eq.0 ) then +c + abscnn(iaux) = daux +c + endif +c + 21 continue +c +c==== +c 3. Positionnement du noeud a bouger +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Positionnement ; codret', codret +#endif +c +c 3.1. ==> Caracteristique de la ligne +c + if ( codret.eq.0 ) then +c + if ( typlig(numlig).eq.0 ) then + nbpass = 1 + else + nbpass = 2 + endif +c + seg1 = seglig(numlig-1)+1 + seg2 = seglig(numlig )-2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90006) 'Pointeurs ligne', numlig, + > ' de', seg1,' a ', seg2 + write (ulsort,90012) '==> Sommets extremites de la ligne', + > numlig, somseg(seg1), somseg(seg2+1) + write (ulsort,90004) 'abscisse debut', abscur(seg1) + write (ulsort,90004) 'abscisse fin ', abscur(seg2+1) + write (ulsort,90002) 'nbpass', nbpass +#endif +c + if ( nbpass.gt.0 ) then +c + do 31 , iaux = 1 , sdim + cooini(iaux) = coop(iaux) + 31 continue +c + endif +c + endif +c + abscn1 = abscnn(1) + abscn2 = abscnn(2) +c + do 30 , nupass = 1 , nbpass +cgn write (ulsort,*) ' ' +cgn write (ulsort,90002) 'Passage numero', nupass +c +c 3.2. ==> La nouvelle abscisse curviligne +c . Au premier passage, on calcule entre les deux noeuds +c . A l'eventuel second, c'est que l'on a une extremite ; on +c doit tester le chemin reciproque pour les cas ou la ligne +c serait fermee. +c + if ( codret.eq.0 ) then +c +c + if ( nupass.eq.1 ) then +c + abscnm = 0.5d0 * (abscn1+abscn2) +c + else +c + if ( abscn2.gt.abscn1 ) then + lgfin = abscur(seg2+1) - abscn2 + lgdeb = abscn1 - abscur(seg1) +cgn write (ulsort,90004) 'de n2 a la fin', lgfin +cgn write (ulsort,90004) 'du debut a n1 ', lgdeb + else + lgfin = abscur(seg2+1) - abscn1 + lgdeb = abscn2 - abscur(seg1) +cgn write (ulsort,90004) 'de n1 a la fin', lgfin +cgn write (ulsort,90004) 'du debut a n2 ', lgdeb + daux = (abscn2-abscur(seg1)) - (abscur(seg2+1)-abscn1) + endif + if ( lgfin.gt.lgdeb ) then + abscnm = abscur(seg2+1) - 0.5d0*(lgfin-lgdeb) + else + abscnm = abscur(seg1) + 0.5d0*(lgdeb-lgfin) + endif +c + do 32 , iaux = 1 , sdim + coopst(iaux) = coop(iaux) + 32 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,2,-1), lenoeu + write (ulsort,texte(langue,8)) 'noeud', abscnm +#endif +c + endif +c +c 3.3. ==> Recherche du segment +c Remarque : le noeud a bouger ne peut pas etre une des +c extremites de la ligne car il est situe entre +c noeud1 et noeud2, eux-memes sur cette ligne +c + if ( codret.eq.0 ) then +c + seg = 0 +c + do 33 , kaux = seg1 , seg2 +c + if ( abscnm.ge.abscur(kaux) .and. + > abscnm.le.abscur(kaux+1) ) then +c + seg = kaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,90006) '.... Appartiendra au segment', seg + write (ulsort,texte(langue,8)) 'debut', abscur(seg) + write (ulsort,texte(langue,8)) 'fin ', abscur(seg+1) +#endif +c +c 3.3.2. ==> Le noeud est-il le premier point du segment ? +c + daux = 0.d0 + do 332 , iaux = 1 , sdim + cooa(iaux) = geocoo(somseg(kaux),iaux) + daux = daux + (cooa(iaux)-coop(iaux))**2 + 332 continue +c +c 3.3.3. ==> Si non, on doit bouger le noeud +c Si oui, c'est parfait : le noeud est deja sur la frontiere +c + if ( daux*unst2x.gt.epsid2 ) then +c +c A M B +c x--------------------------o------------x +c +c On procede par proportionnalite : +c AM = AB *(d(A,M)/d(A,B)) +c + daux = ( abscnm - abscur(kaux) ) / + > ( abscur(kaux+1) - abscur(kaux) ) +c + do 333 , iaux = 1 , sdim + coop(iaux) = cooa(iaux) + + > daux * ( geocoo(somseg(kaux+1),iaux)-cooa(iaux)) + 333 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim) +#endif +c +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,90006) '.. Le noeud est extremite du segment', kaux +#endif +c + endif +c + goto 30 +c + endif +c + 33 continue +c + if ( seg.eq.0 ) then + codret = 2 + endif +c + endif +c + 30 continue +c +c 3.4. ==> Si l'arete est sur une ligne fermee, on compare les deux +c solutions. L'idee est que la bonne est celle ou on va +c le moins loin ! +c + if ( codret.eq.0 ) then +c + if ( nbpass.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,90004) 'cooini', (cooini(iaux),iaux=1,sdim) + write (ulsort,90004) 'coopst', (coopst(iaux),iaux=1,sdim) + write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim) +#endif +c + dist = 0.d0 + daux = 0.d0 + do 341 , iaux = 1 , sdim + dist = dist + (cooini(iaux) - coopst(iaux))**2 + daux = daux + (cooini(iaux) - coop(iaux))**2 + 341 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'dist', dist + write (ulsort,90004) 'daux', daux +#endif +c + if ( dist.lt.daux ) then + do 342 , iaux = 1 , sdim + coop(iaux) = coopst(iaux) + 342 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'On reprend la premiere projection :' + write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim) +#endif + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu + write (ulsort,texte(langue,6)) mess14(langue,3,-1), + > noeud1, noeud2 + if ( codret.eq.1 ) then + write (ulsort,texte(langue,9)) mess14(langue,1,-1), kaux + elseif ( codret.eq.2 ) then + write (ulsort,texte(langue,10)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +cgn ulsort=1 +c + end diff --git a/src/tool/Suivi_Frontiere/sftqqu.F b/src/tool/Suivi_Frontiere/sftqqu.F new file mode 100644 index 00000000..1bfe5152 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sftqqu.F @@ -0,0 +1,578 @@ + subroutine sftqqu ( bilan, + > lenoeu, larete, lequad, + > coonoe, + > somare, filare, np2are, + > hetqua, arequa, filqua, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Test Qualite - QUadrangle +c - - - - -- +c______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . bilan . s . 1 . bilan du controle de l'arete . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . larete . e . 1 . arete en cours d'examen . +c . lequad . e . 1 . quadrangle en cours d'examen . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFTQQU' ) +c + double precision rapqmx + parameter ( rapqmx = 5.0d0 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "impr02.h" +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer bilan +c + integer lenoeu, larete, lequad +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer a1, a2, a3, a4 + integer sp, sq, spn, sqn + integer s0, sp0, sq0 + integer inloc, inloc1, inloc2, inloc3 + integer etat + integer som(4) +c + double precision coopro(3) + double precision coocen(3) + double precision conoqu(4,3) + double precision conotr(3,3) + double precision v1(3), v2(3), v3(3) + double precision quaper + double precision quafi1, quafi2, quafi3 + double precision daux1 +c + logical memeco +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Aretes du quadrangle'',i10'' :'',4i10)' + texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)' +c + texte(2,4) = '(''Edges of quadrangle #'',i10'' :'',4i10)' + texte(2,5) = '(''Cancellation of BF for node # : '',i10)' +c + 1001 format('... ',a,' :',i10,', ',3g13.5) +#ifdef _DEBUG_HOMARD_ +cgn 1000 format('... ',a,' :',3g13.5) + 1002 format('... Test du ',a,' :',4i10) + write (ulsort,1002) mess14(langue,1,-1), lenoeu + write (ulsort,1001) 'n', lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) + write (ulsort,1002) mess14(langue,1, 1), larete + write (ulsort,1002) mess14(langue,1, 4), lequad +#endif +c +c 1.2. ==> Tout va bien a priori +c + bilan = 0 +c + codret = 0 +c +c==== +c 2. Reperage des caracteristiques du quadrangle pere +c==== +c 2.1. ==> Reperage local des aretes +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) lequad, a1, a2, a3, a4 +#endif +c +c 2.2. ==> Recherche des sommets +c +c som(4) = sa4a1 a4 sa3a4 = som(3) +c ._________. +c . . +c . . +c a1. .a3 +c . . +c ._________. +c som(1) = sa1a2 a2 sa2a3 = som(2) +c +cgn print *,larete +cgn print *,a1, a2, a3, a4 +c + call utsoqu ( somare, a1, a2, a3, a4, + > som(1), som(2), som(3), som(4) ) +cgn write (ulsort,*) 'Sommets : ', som +c + codret = 22 + do 22 , iaux = 1 , 4 + if ( larete.eq.arequa(lequad,iaux) ) then + inloc = iaux + codret = 0 + endif + 22 continue +cgn print *,inloc +c + if ( codret.eq.0 ) then +c + sp = som(inloc) +c + inloc1 = per1a4(1,inloc) + spn = som(inloc1) +c + inloc2 = per1a4(2,inloc) + sqn = som(inloc2) +c + inloc3 = per1a4(3,inloc) + sq = som(inloc3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) 'sp ', sp, (coonoe(sp ,iaux),iaux=1,sdim) + write (ulsort,1001) 'spn', spn, (coonoe(spn,iaux),iaux=1,sdim) + write (ulsort,1001) 'sq ', sq, (coonoe(sq ,iaux),iaux=1,sdim) + write (ulsort,1001) 'sqn', sqn, (coonoe(sqn,iaux),iaux=1,sdim) +#endif +c +c 2.3. ==> Autres caracteristiques +c . Qualite du quadrangle de depart +c . Coordonnees du noeud sur la frontiere +c . Etat +c + do 23 , iaux = 1 , sdim + conoqu(1,iaux) = coonoe(sp,iaux) + conoqu(2,iaux) = coonoe(spn,iaux) + conoqu(3,iaux) = coonoe(sqn,iaux) + conoqu(4,iaux) = coonoe(sq,iaux) + coopro(iaux) = coonoe(lenoeu,iaux) + 23 continue +cgn write (ulsort,1001) 'n ', lenoeu, (coopro(iaux),iaux = 1 ,sdim) +cgn write (ulsort,1002) 'quadrangle pere', sp, spn, sqn, sq + call utqqu0 ( quaper, daux1, sdim, conoqu ) +cgn write (ulsort,1000) 'Qualite pere ', quaper +cgn write (ulsort,1000) 'Surface pere ', daux1 +c + etat = mod(hetqua(lequad),100) +c + endif +c +c==== +c 3. Test de qualite du decoupage standard +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret +#endif +c + if ( etat.eq.4 .or. typsfr.gt.2 ) then +c + if ( codret.eq.0 ) then +c +c larete/inloc +c sp lenoeu sq +c .-----------------------.-----------------------. +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c inloc1 . .s0 .inloc3 +c sp0 .-----------------------.-----------------------.sq0 +c . . . +c . . . +c . . . +c . Fils1 . Fils2 . +c . . . +c . . . +c . . . +c .-----------------------.-----------------------. +c spn sqn +c inloc2 +c +c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sp0/s0 +c + if ( typsfr.le.2 ) then + sp0 = somare(2,filare(arequa(lequad,inloc1))) + sq0 = somare(2,filare(arequa(lequad,inloc3))) + s0 = somare(2,arequa(filqua(lequad),2)) + do 311 , iaux = 1 , sdim + coocen(iaux) = coonoe(s0,iaux) + 311 continue + else + sp0 = np2are(arequa(lequad,inloc1)) + sq0 = np2are(arequa(lequad,inloc3)) + do 312 , iaux = 1 , sdim + coocen(iaux) = 0.5d0*(coonoe(sp0,iaux)+coonoe(sq0,iaux)) + 312 continue + endif +cgn write (ulsort,1001) 'sp0', sp0, (coonoe(sp0,iaux),iaux=1,sdim) +cgn write (ulsort,1001) 'sq0', sq0, (coonoe(sq0,iaux),iaux=1,sdim) +cgn write (ulsort,1001) 's0 ', s0, (coocen(iaux),iaux=1,sdim) +c + do 31 , iaux = 1 , sdim + v1(iaux) = coonoe(sp0,iaux) + v2(iaux) = coocen(iaux) + v3(iaux) = conoqu(1,iaux) + 31 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sp0 s0 sp N +cgn write (ulsort,*) 'Du bon cote de sp0/s0 :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sq0/s0 +c + do 32 , iaux = 1 , sdim + v1(iaux) = coonoe(sq0,iaux) + 32 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sq0 s0 sp N +cgn write (ulsort,*) 'Du bon cote de sq0/s0 :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sq0/sq +c + do 33 , iaux = 1 , sdim + v2(iaux) = coonoe(sq,iaux) + 33 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sq0 sq sp N +cgn write (ulsort,*) 'Du bon cote de sq0/sq :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.4. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sp0/sp +c + do 34 , iaux = 1 , sdim + v1(iaux) = coonoe(sp0,iaux) + 34 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v3, v2, coopro, iaux ) + else + call utsen3 ( memeco, v1, v3, v2, coopro, iaux ) + endif +c sp0 sp sq N +cgn write (ulsort,*) 'Du bon cote de sp0/sp :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.5. ==> Qualites des fils avec le noeud deplace +c + do 351 , iaux = 1 , sdim + conoqu(2,iaux) = coonoe(sp0,iaux) + conoqu(3,iaux) = coocen(iaux) + conoqu(4,iaux) = coopro(iaux) + 351 continue +cgn write (ulsort,1002) 'quadrangle', sp, sp0, s0, lenoeu + call utqqu0 ( quafi1, daux1, sdim, conoqu ) +cgn write (ulsort,1000) 'Qualite fils 1', quafi1 +c + do 352 , iaux = 1 , sdim + conoqu(1,iaux) = coonoe(sq,iaux) + conoqu(2,iaux) = coonoe(sq0,iaux) + 352 continue +cgn write (ulsort,1002) 'quadrangle', sq, sq0, s0, lenoeu + call utqqu0 ( quafi2, daux1, sdim, conoqu ) +cgn write (ulsort,1000) 'Qualite fils 2', quafi2 +c +c On limite le facteur d'accroissement +c +cgn write (ulsort,1000) 'max 1 2', max(quafi1,quafi2) +cgn write (ulsort,1000) 'seuil ', quaper*rapqmx + if ( max(quafi1,quafi2).gt.quaper*rapqmx ) then + bilan = 1 + goto 50 + endif +c + endif +c + endif +c +c==== +c 4. Test de qualite du decoupage de conformite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. test decoupage en 3 ; codret = ', codret +#endif +c + if ( ( etat.ge.31 .and. etat.le.34 ) .or. typsfr.gt.2 ) then +c + if ( codret.eq.0 ) then +c +c larete/inloc +c sp lenoeu sq +c .---------------.----------------. +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c .. .. +c .--------------------------------. +c spn sqn +c +c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sp/spn +c + do 41 , iaux = 1 , sdim + v1(iaux) = coonoe(sp,iaux) + v2(iaux) = coonoe(spn,iaux) + v3(iaux) = coonoe(sq,iaux) + 41 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sp spn sq N +cgn write (ulsort,*) 'Du bon cote de sp/spn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 4.2. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sq/sqn +c + do 42 , iaux = 1 , sdim + v2(iaux) = coonoe(sqn,iaux) + 42 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v3, v2, v1, coopro, iaux ) + else + call utsen3 ( memeco, v3, v2, v1, coopro, iaux ) + endif +c sq sqn sp N +cgn write (ulsort,*) 'Du bon cote de sq/sqn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 4.3. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment spn/sqn +c + do 43 , iaux = 1 , sdim + v1(iaux) = coonoe(spn,iaux) + 43 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c spn sqn sq N +cgn write (ulsort,*) 'Du bon cote de spn/sqn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 4.4. ==> Qualite future des triangles issus du decoupage +c + do 441 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(sp,iaux) + conotr(2,iaux) = coonoe(spn,iaux) + conotr(3,iaux) = coopro(iaux) + 441 continue +cgn write (ulsort,1002) 'triangle', sp, spn, lenoeu + call utqtr0 ( quafi1, daux1, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 1', quafi1 +c + do 442 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(sqn,iaux) + 442 continue +cgn write (ulsort,1002) 'triangle', sqn, spn, lenoeu + call utqtr0 ( quafi2, daux1, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 2', quafi2 +c + do 443 , iaux = 1 , sdim + conotr(2,iaux) = coonoe(sq,iaux) + 443 continue +cgn write (ulsort,1002) 'triangle', sqn, sq, lenoeu + call utqtr0 ( quafi3, daux1, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 3', quafi3 +c +c On limite le facteur d'accroissement +c +cgn write (ulsort,1000) 'max 1 2 3', max(quafi1,quafi2,quafi3) +cgn write (ulsort,1000) 'seuil ', quaper*rapqmx*2.d0 + if ( max(quafi1,quafi2,quafi3).gt.quaper*rapqmx*2.d0 ) then + bilan = 1 + goto 50 + endif +c + endif +c + endif +c +c==== +c 5.La fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. la fin ; codret = ', codret +#endif +c + 50 continue +c +#ifdef _DEBUG_HOMARD_ + if ( bilan.ne.0 ) then + write(ulsort,texte(langue,5)) lenoeu + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,1001) mess14(langue,2,-1), lenoeu, + > (coopro(iaux),iaux=1,sdim) + write (ulsort,1001) mess14(langue,2, 1), larete + write (ulsort,1001) mess14(langue,2, 4), lequad +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Suivi_Frontiere/sftqtr.F b/src/tool/Suivi_Frontiere/sftqtr.F new file mode 100644 index 00000000..dec429c8 --- /dev/null +++ b/src/tool/Suivi_Frontiere/sftqtr.F @@ -0,0 +1,583 @@ + subroutine sftqtr ( bilan, bascul, + > lenoeu, larete, letria, + > coonoe, + > somare, filare, np2are, + > hettri, aretri, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Suivi de Frontiere - Test Qualite - TRiangle +c - - - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . bilan . s . 1 . bilan du controle de l'arete . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c . bascul . s . 1 . vrai pour une bascule d'arete . +c . lenoeu . e . 1 . noeud en cours d'examen . +c . larete . e . 1 . arete en cours d'examen . +c . letria . e . 1 . triangle en cours d'examen . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'SFTQTR' ) +c + double precision rapqmx + parameter ( rapqmx = 5.0d0 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer bilan +c + logical bascul +c + integer lenoeu, larete, letria +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer a1, a2, a3 + integer sa1a2, sa2a3, sa3a1 + integer sn, sp, sq + integer np, nq + integer arep, areq + integer etat +c + double precision coopro(3) + double precision conotr(3,3) + double precision v1(3), v2(3), v3(3) + double precision quaper + double precision quafi1, quafi2, quafi3, quafi5, quafi6 + double precision daux1, daux2 +c + logical memeco +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Aretes du triangle'',i10'' :'',3i10)' + texte(1,5) = '(''Annulation du SF pour le noeud : '',i10)' +c + texte(2,4) = '(''Edges of triangle #'',i10'' :'',3i10)' + texte(2,5) = '(''Cancellation of BF for node # : '',i10)' +c + 1000 format('... ',a,' :',3g13.5) + 1001 format('... ',a,' :',i10,', ',3g13.5) + 1002 format('... Test du ',a,' :',4i10) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1002) mess14(langue,1,-1), lenoeu + write (ulsort,1001) 'n', lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim) + write (ulsort,1002) mess14(langue,1, 1), larete + write (ulsort,1002) mess14(langue,1, 2), letria +#endif +c +c 1.2. ==> Tout va bien a priori +c + bilan = 0 +c + codret = 0 +c +c==== +c 2. Reperage des caracteristiques du triangle pere +c==== +c 2.1. ==> Reperage local des aretes +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) letria, a1, a2, a3 +#endif +c +c 2.2. ==> Recherche des sommets +c sa2a3 +c * +c . . +c . . +c . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1*---------------*sa1a2 +c a1 +c + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + if ( larete.eq.a1 ) then + sp = sa1a2 + sq = sa3a1 + sn = sa2a3 + arep = a3 + areq = a2 + elseif ( larete.eq.a2 ) then + sp = sa2a3 + sq = sa1a2 + sn = sa3a1 + arep = a1 + areq = a3 + elseif ( larete.eq.a3 ) then + sp = sa3a1 + sq = sa2a3 + sn = sa1a2 + arep = a2 + areq = a1 + else + codret = 12 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) 'sp', sp, (coonoe(sp,iaux),iaux=1,sdim) + write (ulsort,1001) 'sq', sq, (coonoe(sq,iaux),iaux=1,sdim) + write (ulsort,1001) 'sn', sn, (coonoe(sn,iaux),iaux=1,sdim) + write (ulsort,1001) 'arep', arep + write (ulsort,1001) 'areq', areq +#endif +c +c 2.3. ==> Autres caracteristiques +c . Qualite du triangle de depart +c . Coordonnees du noeud sur la frontiere +c . Etat +c + if ( codret.eq.0 ) then +c + do 23 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(sp,iaux) + conotr(2,iaux) = coonoe(sq,iaux) + conotr(3,iaux) = coonoe(sn,iaux) + coopro(iaux) = coonoe(lenoeu,iaux) + 23 continue +cgn write (ulsort,1001) 'n ', lenoeu, (coopro(iaux),iaux = 1 ,sdim) +cgn write (ulsort,1002) 'triangle pere', sp, sq, sn + call utqtr0 ( quaper, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite pere ', quaper +cgn write (ulsort,1000) 'Surface pere ', daux2 +c + etat = mod(hettri(letria),10) +c + endif +c +c==== +c 3. Test de qualite du decoupage standard +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. test decoupage en 4 ; codret = ', codret +#endif +c + if ( etat.eq.4 .or. typsfr.gt.2 ) then +c + if ( codret.eq.0 ) then +c +c larete +c sp lenoeu sq +c .-----------------------.-----------------------. +c . . . . +c . . . . +c . . . . +c . Fils1 . . Fils3 . +c . . . . +c . . . . +c . . . . +c . . Fils2 . . +c . . . . +c . . . . +c areq . . . . arep +c .-----------------------. +c nq . . np +c . . +c . . +c . Fils4 . +c . . +c . . +c . . +c . . +c . . +c . . +c . . +c . +c sn +c +c 3.1. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment np/nq +c + if ( typsfr.le.2 ) then + np = somare(2,filare(arep)) + nq = somare(2,filare(areq)) + else + np = np2are(arep) + nq = np2are(areq) + endif +cgn write (ulsort,1001) 'np', np, (coonoe(np,iaux),iaux = 1 ,sdim) +cgn write (ulsort,1001) 'nq', nq, (coonoe(nq,iaux),iaux = 1 ,sdim) +c + do 31 , iaux = 1 , sdim + v1(iaux) = coonoe(np,iaux) + v2(iaux) = coonoe(nq,iaux) + v3(iaux) = conotr(1,iaux) + 31 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) +c np nq sp N + endif +cgn write (ulsort,*) 'Du bon cote de np/nq :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.2. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sp/nq +c + do 32 , iaux = 1 , sdim + v1(iaux) = conotr(2,iaux) + 32 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v3, v2, v1, coopro, iaux ) + else + call utsen3 ( memeco, v3, v2, v1, coopro, iaux ) + endif +c sp nq sq N +cgn write (ulsort,*) 'Du bon cote de sp/sn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.3. ==> On verifie que le noeud lenoeu ne traverse pas +c le segment sq/np +c + do 33 , iaux = 1 , sdim + v2(iaux) = coonoe(np,iaux) + 33 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sq np sp N +cgn write (ulsort,*) 'Du bon cote de sq/sn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 3.4. ==> Qualites des fils avec le noeud deplace +c 3.4.1. ==> Les triangles de cote +c + do 3411 , iaux = 1 , sdim + conotr(2,iaux) = coonoe(nq,iaux) + conotr(3,iaux) = coopro(iaux) + 3411 continue +cgn write (ulsort,1002) 'triangle fils 1', sp, nq, lenoeu + call utqtr0 ( quafi1, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 1', quafi1 +cgn write (ulsort,1000) 'Surface fils 1', daux1 +c + do 3412 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(sq,iaux) + conotr(2,iaux) = coonoe(np,iaux) + 3412 continue +cgn write (ulsort,1002) 'triangle fils 3', sq, np, lenoeu + call utqtr0 ( quafi3, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 3', quafi3 +cgn write (ulsort,1000) 'Surface fils 3', daux1 +c +cgn write (ulsort,1000) 'max 1 3', max(quafi1,quafi3) +cgn write (ulsort,1000) 'seuil ', quaper*rapqmx + if ( max(quafi1,quafi3).gt.quaper*rapqmx ) then + bilan = 1 + goto 50 + endif +c +c 3.4.2. ==> Les triangles centraux +c . Decoupage standard ou avec bascule d'aretes +c + do 3421 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(nq,iaux) + 3421 continue +cgn write (ulsort,1002) 'triangle fils 2', nq, np, lenoeu + call utqtr0 ( quafi2, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 2', quafi2 +cgn write (ulsort,1000) 'Surface fils 2', daux1 +c + daux1 = max(quaper,quafi2) +c +c Test de la bascule d'arete : np-nq est remplace par sn-lenoeu +c les triangles Fils2 et Fils4 sont remplaces +c + if ( typsfr.le.2 ) then +c + do 3422 , iaux = 1 , sdim + conotr(2,iaux) = coonoe(sn,iaux) + 3422 continue +cgn write (ulsort,1002) 'triangle fils 5', nq, sn, lenoeu + call utqtr0 ( quafi5, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 5', quafi5 +cgn write (ulsort,1000) 'Surface fils 5', daux1 +c + do 3423 , iaux = 1 , sdim + conotr(1,iaux) = coonoe(np,iaux) + 3423 continue +cgn write (ulsort,1002) 'triangle fils 6', np, sn, lenoeu + call utqtr0 ( quafi6, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 6', quafi6 +cgn write (ulsort,1000) 'Surface fils 6', daux1 +c + daux2 = max(quafi6,quafi5) +c +cgn write (ulsort,1000) 'max 5 6', daux2 +cgn write (ulsort,1000) 'max p 2', daux1 +c + if ( daux1.lt.daux2 ) then + bascul = .false. + else +cgn write (ulsort,*) '- On bascule -' + bascul = .true. + daux1 = daux2 + endif +c + endif +c +cgn write (ulsort,1000) 'max 2 4', daux1 +cgn write (ulsort,1000) 'seuil ', quaper*rapqmx + if ( daux1.gt.quaper*rapqmx ) then + bilan = 1 + goto 50 + endif +c + endif +c + endif +c +c==== +c 4. Test de qualite du decoupage de conformite +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. test decoupage en 2 ; codret = ', codret +#endif +c + if ( etat.eq.2 .or. typsfr.gt.2 ) then +c + if ( codret.eq.0 ) then +c +c larete +c sp lenoeu sq +c .-----------------------.-----------------------. +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c areq . . . arep +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c ... +c . +c sn +c +c 4.1. ==> On verifie que le noeud lenoeu ne traverse pas +c les segments sp/sn ou sq/sn +c + do 41 , iaux = 1 , sdim + v1(iaux) = coonoe(sp,iaux) + v2(iaux) = coonoe(sn,iaux) + v3(iaux) = coonoe(sq,iaux) + 41 continue +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v1, v2, v3, coopro, iaux ) + else + call utsen3 ( memeco, v1, v2, v3, coopro, iaux ) + endif +c sp sn sq N +cgn write (ulsort,*) 'Du bon cote de sp/sn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c + iaux = 0 + if ( sdim.eq.2 ) then + call utsen2 ( memeco, v3, v2, v1, coopro, iaux ) + else + call utsen3 ( memeco, v3, v2, v1, coopro, iaux ) + endif +c sq sn sp N +cgn write (ulsort,*) 'Du bon cote de sq/sn :', memeco +c + if ( .not. memeco ) then + bilan = 1 + goto 50 + endif +c +c 4.2. ==> Qualite future des triangles issus du decoupage +c + do 421 , iaux = 1 , sdim + conotr(1,iaux) = coopro(iaux) + conotr(2,iaux) = coonoe(sq,iaux) + conotr(3,iaux) = coonoe(sn,iaux) + 421 continue +cgn write (ulsort,1002) 'triangle', lenoeu, sq, sn + call utqtr0 ( quafi1, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 1', quafi1 +c + do 422 , iaux = 1 , sdim + conotr(2,iaux) = coonoe(sp,iaux) + 422 continue +cgn write (ulsort,1002) 'triangle', lenoeu, sp, sn + call utqtr0 ( quafi2, daux2, sdim, conotr ) +cgn write (ulsort,1000) 'Qualite fils 2', quafi2 +c +c On limite le facteur d'accroissement +c +cgn write (ulsort,1000) 'max 1 2', max(quafi1,quafi2) +cgn write (ulsort,1000) 'seuil ', quaper*rapqmx*2.d0 + if ( max(quafi1,quafi2).gt.quaper*rapqmx*2.d0 ) then + bilan = 1 + goto 50 + endif +c + endif +c + endif +c +c==== +c 5. La fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. la fin ; codret = ', codret +#endif +c + 50 continue +c +#ifdef _DEBUG_HOMARD_ + if ( bilan.ne.0 ) then + write(ulsort,texte(langue,5)) lenoeu + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,1001) mess14(langue,2,-1), lenoeu, + > (coopro(iaux),iaux=1,sdim) + write (ulsort,1001) mess14(langue,2, 1), larete + write (ulsort,1001) mess14(langue,2, 2), letria +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/CMakeLists.txt b/src/tool/Utilitaire/CMakeLists.txt new file mode 100644 index 00000000..62ddaeef --- /dev/null +++ b/src/tool/Utilitaire/CMakeLists.txt @@ -0,0 +1,406 @@ +# Copyright (C) 2016-2020 CEA/DEN, EDF R&D +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# See http://www.salome-platform.org/ or email : webmaster.salome@opencascade.com +# +# Compilation de Utilitaire + +SET(Utilitaire_SOURCES + ./utacma.F + ./utacme.F + ./utad01.F + ./utad02.F + ./utad03.F + ./utad04.F + ./utad05.F + ./utad06.F + ./utad07.F + ./utad08.F + ./utad11.F + ./utad12.F + ./utad13.F + ./utad21.F + ./utad22.F + ./utad31.F + ./utad41.F + ./utad80.F + ./utad97.F + ./utad98.F + ./utad99.F + ./utadpt.F + ./utafqu.F + ./utaftr.F + ./utahma.F + ./utaipe.F + ./utal00.F + ./utal02.F + ./utal41.F + ./utalfe.F + ./utalfo.F + ./utalih.F + ./utalpf.F + ./utalpg.F + ./utalpr.F + ./utalso.F + ./utaptc.F + ./utapte.F + ./utarhe.F + ./utarpe.F + ./utarpy.F + ./utarro.F + ./utarte.F + ./utashe.F + ./utaspe.F + ./utaspy.F + ./utaste.F + ./utaurq.F + ./utb02a.F + ./utb03a.F + ./utb05a.F + ./utb05b.F + ./utb05c.F + ./utb07a.F + ./utb07b.F + ./utb11a.F + ./utb11b.F + ./utb11c.F + ./utb11d.F + ./utb11e.F + ./utb11f.F + ./utb13a.F + ./utb13b.F + ./utb13c.F + ./utb13d.F + ./utb13e.F + ./utb17a.F + ./utb17b.F + ./utb17c.F + ./utb17d.F + ./utb17e.F + ./utb19a.F + ./utb19c.F + ./utb3a0.F + ./utb3b0.F + ./utb3c0.F + ./utb3d0.F + ./utb3d1.F + ./utb3e0.F + ./utb3e1.F + ./utb3f0.F + ./utb3f1.F + ./utb3g0.F + ./utb3g1.F + ./utb3n0.F + ./utb3n1.F + ./utb3n2.F + ./utb3n3.F + ./utb3n4.F + ./utb3n5.F + ./utbica.F + ./utbide.F + ./utbil1.F + ./utbilm.F + ./utboar.F + ./utbofa.F + ./utbono.F + ./utboqu.F + ./utbotr.F + ./utcach.F + ./utcafo.F + ./utcapf.F + ./utcapg.F + ./utcapr.F + ./utcaso.F + ./utchen.F + ./utchnu.F + ./utchre.F + ./utchs8.F + ./utcnar.F + ./utcnhe.F + ./utcnno.F + ./utcnpe.F + ./utcnqu.F + ./utcnte.F + ./utcntr.F + ./utcohe.F + ./utcoma.F + ./utcomp.F + ./utconf.F + ./utcoq2.F + ./utcoq3.F + ./utcoq5.F + ./utcorn.F + ./utcote.F + ./utcrhi.F + ./utcrpg.F + ./utcte1.F + ./utcte2.F + ./utcte3.F + ./utcte4.F + ./utcvne.F + ./utdhcl.F + ./utdhco.F + ./utdhcu.F + ./utdhex.F + ./utdhfc.F + ./utdhlc.F + ./utdhlg.F + ./utdhuc.F + ./utdhus.F + ./utdiag.F + ./utdich.F + ./utdpen.F + ./utdpyr.F + ./utdqua.F + ./utdtet.F + ./utdtri.F + ./uteare.F + ./utecf0.F + ./utecfe.F + ./utehex.F + ./utench.F + ./utepen.F + ./utepyr.F + ./utequa.F + ./utetet.F + ./utetri.F + ./utfaa1.F + ./utfaa2.F + ./utfam1.F + ./utfam2.F + ./utfia1.F + ./utfia2.F + ./utfiac.F + ./utfihe.F + ./utfin1.F + ./utfin2.F + ./utfino.F + ./utflt0.F + ./utfltr.F + ./utfmgr.F + ./utfmlg.F + ./uthcac.F + ./uthcai.F + ./uthcnb.F + ./uthequ.F + ./uthonh.F + ./utimpg.F + ./utinca.F + ./utincg.F + ./utinci.F + ./utindh.F + ./utinei.F + ./utinfm.F + ./utinit.F + ./utinla.F + ./utinma.F + ./utlgar.F + ./utlgut.F + ./utlo00.F + ./utlo01.F + ./utlo02.F + ./utlo03.F + ./utlo04.F + ./utlo05.F + ./utlo06.F + ./utlo07.F + ./utlo08.F + ./utlo09.F + ./utlo10.F + ./utlo11.F + ./utloea.F + ./utmcc0.F + ./utmcch.F + ./utmcen.F + ./utmcf0.F + ./utmcf1.F + ./utmcf2.F + ./utmcfa.F + ./utmclc.F + ./utmcls.F + ./utmcre.F + ./utmcz0.F + ./utmczr.F + ./utmemh.F + ./utmess.F + ./utmfar.F + ./utmfen.F + ./utmffa.F + ./utmfv1.F + ./utmfvo.F + ./utmmc1.F + ./utmmco.F + ./utmnmj.F + ./utmoch.F + ./utmopf.F + ./utmoso.F + ./utnbmc.F + ./utnbmh.F + ./utnc01.F + ./utnc02.F + ./utnc03.F + ./utnc04.F + ./utnc05.F + ./utnc06.F + ./utnc07.F + ./utnc08.F + ./utnc09.F + ./utnc11.F + ./utnc12.F + ./utnc13.F + ./utnc14.F + ./utnc15.F + ./utnc16.F + ./utnhex.F + ./utniqu.F + ./utnitr.F + ./utnmhe.F + ./utnmpe.F + ./utnmqu.F + ./utnoad.F + ./utnomc.F + ./utnomh.F + ./utnpen.F + ./utnpyr.F + ./utnqua.F + ./utntet.F + ./utntri.F + ./utnvaf.F + ./utora3.F + ./utora4.F + ./utoraq.F + ./utorat.F + ./utosde.F + ./utosme.F + ./utosno.F + ./utpd10.F + ./utplco.F + ./utplra.F + ./utpmhe.F + ./utpmte.F + ./utppqt.F + ./utpr01.F + ./utpr02.F + ./utpr03.F + ./utpr04.F + ./utpr05.F + ./utpr06.F + ./utprma.F + ./utprmi.F + ./utprve.F + ./utqco2.F + ./utqhex.F + ./utqjno.F + ./utqpen.F + ./utqpyr.F + ./utqqu0.F + ./utqqua.F + ./utqte2.F + ./utqtet.F + ./utqtr0.F + ./utqtri.F + ./utqun2.F + ./utqure.F + ./utre01.F + ./utre02.F + ./utre03.F + ./utre04.F + ./utrech.F + ./utrptc.F + ./uts8ch.F + ./utsen2.F + ./utsen3.F + ./utsex0.F + ./utsex1.F + ./utsex2.F + ./utsex3.F + ./utsext.F + ./utsohe.F + ./utsope.F + ./utsopy.F + ./utsoqu.F + ./utsote.F + ./utsotr.F + ./utsrc1.F + ./utsrc2.F + ./utsrc3.F + ./utsrc4.F + ./utsuar.F + ./utsuex.F + ./utsuhe.F + ./utsuno.F + ./utsupe.F + ./utsuqu.F + ./utsute.F + ./utsutr.F + ./utsvm0.F + ./utsvmn.F + ./utsynt.F + ./uttbrc.F + ./uttetr.F + ./uttfi1.F + ./uttfi2.F + ./utthex.F + ./uttoqu.F + ./uttpen.F + ./uttpyr.F + ./uttqua.F + ./uttrii.F + ./uttrir.F + ./uttris.F + ./uttrn2.F + ./utulbi.F + ./utulfd.F + ./utulls.F + ./ututso.F + ./utvar0.F + ./utvar1.F + ./utvars.F + ./utveri.F + ./utvga1.F + ./utvga2.F + ./utvgan.F + ./utvgfa.F + ./utvgv1.F + ./utvgv2.F + ./utvgv3.F + ./utvgva.F + ./utvgvf.F + ./utvgvq.F + ./utvhex.F + ./utvoh0.F + ./utvohe.F + ./utvois.F + ./utvop0.F + ./utvope.F + ./utvopy.F + ./utvot0.F + ./utvote.F + ./utvoy0.F + ./utvpen.F + ./utvpyr.F + ./utvte0.F + ./utvtet.F + ./utwipg.F + ) + +INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/src/tool/Utilitaire ../Includes_Generaux) + +SET ( CMAKE_Fortran_FLAGS "-ffixed-line-length-0 -fdefault-double-8 -fdefault-real-8 -fdefault-integer-8 -fimplicit-none -O2" ) + +ADD_LIBRARY (Utilitaire ${Utilitaire_SOURCES}) + +INSTALL(TARGETS Utilitaire EXPORT ${PROJECT_NAME}TargetGroup DESTINATION ${SALOME_INSTALL_LIBS}) diff --git a/src/tool/Utilitaire/utacma.F b/src/tool/Utilitaire/utacma.F new file mode 100644 index 00000000..aa31f348 --- /dev/null +++ b/src/tool/Utilitaire/utacma.F @@ -0,0 +1,355 @@ + subroutine utacma ( nocmai, typnom, typcca, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnoto, nctfno, nbelem, nbmane, attrib, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Allocation pour le Calcul - MAillage +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmai . es . char8 . nom de l'objet maillage homard . +c . typnom . e . 1 . type du nom de l'objet maillage . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . typcca . e . 1 . type du code de calcul . +c . sdim . e . 1 . dimension de l'espace . +c . mdim . e . 1 . dimension du maillage . +c . degre . e . 1 . degre du maillage . +c . mailet . e . 1 . presence de mailles etendues . +c . . . . 1 : aucune . +c . . . . 2x : TRIA7 . +c . . . . 3x : QUAD9 . +c . . . . 5x : HEXA27 . +c . maconf . e . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . homolo . e . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . hierar . e . 1 . maillage hierarchique . +c . . . . 0 : non . +c . . . . 1 : oui . +c . nbnoto . e . 1 . nombre de noeuds total . +c . nctfno . e . 1 . nombre de carac. des familles de noeuds . +c . nbelem . e . 1 . nombre d'elements . +c . nbmane . e . 1 . nombre maximum de noeuds par element . +c . attrib . e . 1 . attribut auxiliaire . +c . ncinfo . s . char8 . nom de la branche InfoGene . +c . ncnoeu . s . char8 . nom de la branche Noeud . +c . nccono . s . char8 . nom de la branche ConnNoeu . +c . nccode . s . char8 . nom de la branche ConnDesc . +c . nccoex . s . char8 . nom de la branche CodeExte . +c . ncfami . s . char8 . nom de la branche Famille . +c . ncequi . s . char8 . nom de la branche Equivalt . +c . ncfron . s . char8 . nom de la branche Frontier . +c . ncnomb . s . char8 . nom de la branche Nombres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTACMA' ) +c + integer nbnomb + parameter ( nbnomb = 50 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nocmai +c + integer typnom, typcca + integer sdim, mdim + integer degre, mailet, maconf, homolo, hierar + integer nbnoto, nctfno, nbelem, nbmane, attrib +c + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Allocation d''''un objet maillage de calcul'',/)' + texte(1,5) = '(''Mauvaise demande de type de nom :'',i6)' + texte(1,6) = '(''Probleme pour allouer l''''objet '',a8)' + texte(1,7) = '(''Probleme pour allouer un objet temporaire.'')' +c + texte(2,4) = + > '(5x,''Allocation of an object calculation mesh'',/)' + texte(2,5) = '(''Bad request for the type of name :'',i6)' + texte(2,6) = '(''Problem while allocating object '',a8)' + texte(2,7) = '(''Problem while allocating a temporary object.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. allocation de la structure du maillage de calcul +c on n'alloue que les objets structures du graphe +c==== +c +c 2.1. ==> allocation de la tete du maillage de calcul +c + if ( typnom.eq.0 ) then +c + call gmalot ( nocmai, 'Cal_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nocmai, 'Cal_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + else +c + codret = -1 +c + endif +c +c 2.2. ==> Allocation des branches principales +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. branches ppales ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nocmai, 1, sdim, codre1 ) + call gmecat ( nocmai, 2, mdim, codre2 ) + call gmecat ( nocmai, 3, degre, codre3 ) + call gmecat ( nocmai, 4, maconf, codre4 ) + call gmecat ( nocmai, 5, homolo, codre5 ) + call gmecat ( nocmai, 6, hierar, codre6 ) + call gmecat ( nocmai, 7, nbnomb, codre7 ) + call gmecat ( nocmai, 8, mailet, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'codes',codre1, codre2, codre3, + > codre4, codre5,codre6, codre7, codre8 + call gmprsx(nompro, nocmai) +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. avant nocmai 1 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nocmai//'.InfoGene', ' ', 0, iaux, codre1 ) + call gmaloj ( nocmai//'.Noeud' , ' ', 0, iaux, codre2 ) + call gmaloj ( nocmai//'.ConnNoeu', ' ', 0, iaux, codre3 ) + call gmaloj ( nocmai//'.ConnDesc', ' ', 0, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. avant nocmai 2 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nocmai//'.CodeExte' , ' ', 0, iaux, codre1 ) + call gmaloj ( nocmai//'.Famille' , ' ', 0, iaux, codre2 ) + call gmaloj ( nocmai//'.Equivalt' , ' ', 0, iaux, codre3 ) + call gmaloj ( nocmai//'.Nombres' , ' ', nbnomb, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + call gmaloj ( nocmai//'.Frontier', ' ', iaux, jaux, codret ) +c + endif +c +c 2.3. ==> nom interne de ces branches +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. nom interne ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmai, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > iaux, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'ncnoeu', ncnoeu + write (ulsort,90003) 'nccono', nccono +#endif +c + endif +c +c 2.4. ==> attributs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. attributs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( ncnoeu, 1, nbnoto, codre1 ) + call gmecat ( ncnoeu, 2, nctfno, codre2 ) + call gmecat ( ncnoeu, 3, 0 , codre2 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmecat ( nccono, 1, nbelem, codre1 ) + call gmecat ( nccono, 2, nbmane, codre2 ) + call gmecat ( nccono, 3, attrib, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx(nompro, nocmai) + call gmprsx(nompro, nocmai//'.Nombres') + call gmprsx(nompro//' - ncnoeu', ncnoeu) + call gmprsx(nompro//' - nccono', nccono) + endif +#endif +c +c==== +c 3. la fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. la fin ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,5)) typnom + else + if ( typnom.eq.1 ) then + write (ulsort,texte(langue,6)) nocmai + else + write (ulsort,texte(langue,7)) + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utacme.F b/src/tool/Utilitaire/utacme.F new file mode 100644 index 00000000..1132091e --- /dev/null +++ b/src/tool/Utilitaire/utacme.F @@ -0,0 +1,233 @@ + subroutine utacme ( ncequi, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqte, nbeqhe, + > adeqpo, adeqin, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Allocation pour le Calcul - Maillage - Equivalence +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncequi . e . char8 . nom de la branche Equivalt maillage calcul . +c . nbequi . e . 1 . nombre d'equivalences . +c . nbeqno . e . 1 . nombre total de noeuds dans les equivalen. . +c . nbeqmp . e . 1 . nombre total de mailles-points dans les eq.. +c . nbeqar . e . 1 . nombre total d'aretes dans les eq. . +c . nbeqtr . e . 1 . nombre total de triangles dans les eq. . +c . nbeqqu . e . 1 . nombre total de quadrangles dans les eq. . +c . nbeqte . e . 1 . nombre total de tetraedres dans les eq. . +c . nbeqhe . e . 1 . nombre total d'hexaedres dans les eq. . +c . adeqpo . s . 1 . adresse de la branche Pointeur . +c . adeqin . s . 1 . adresse de la branche InfoGene . +c . adeqno . s . 1 . adresse de la branche Noeud . +c . adeqmp . s . 1 . adresse de la branche Point . +c . adeqar . s . 1 . adresse de la branche Arete . +c . adeqtr . s . 1 . adresse de la branche Trian . +c . adeqqu . s . 1 . adresse de la branche Quadr . +c . adeqte . s . 1 . adresse de la branche Tetra . +c . adeqhe . s . 1 . adresse de la branche Hexae . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTACME' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 ncequi +c + integer nbequi + integer nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + integer nbeqte, nbeqhe + integer adeqpo, adeqin + integer adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Allocation des equivalences du maillage de calcul'')' + texte(1,5) = '(''Nombre d''''equivalences : '',i4)' + texte(1,6) = '(''Nombre de paires de '',a14,'' : '',i4)' + texte(1,7) = '(''Impossible d''''ecrire les attributs de '',a)' + texte(1,8) = '(''Impossible d''''allouer les branches de '',a)' + texte(1,9) = '(''Codes : '',7i3)' +c + texte(2,4) = + > '(''Allocation of equivalences of calculation mesh'')' + texte(2,5) = '(''Number of equivalences: '',i4)' + texte(2,6) = '(''Number of pairs of '',a14,'': '',i4)' + texte(2,7) = '(''Attributes of '',a,'' cannot be written.'')' + texte(2,8) = '(''Branches of '',a,'' cannot be allocated.'')' + texte(2,9) = '(''Codes: '',7i3)' +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) + write(ulsort,texte(langue,5)) nbequi + write(ulsort,texte(langue,6)) mess14(langue,3,-1), nbeqno + write(ulsort,texte(langue,6)) mess14(langue,3,0), nbeqmp + write(ulsort,texte(langue,6)) mess14(langue,3,1), nbeqar + write(ulsort,texte(langue,6)) mess14(langue,3,2), nbeqtr + write(ulsort,texte(langue,6)) mess14(langue,3,4), nbeqqu + write(ulsort,texte(langue,6)) mess14(langue,3,3), nbeqte + write(ulsort,texte(langue,6)) mess14(langue,3,6), nbeqhe +#endif +c +c==== +c 2. attributs +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( ncequi, 1, nbequi, codre1 ) + call gmecat ( ncequi, 2, nbeqno, codre2 ) + call gmecat ( ncequi, 3, nbeqmp, codre3 ) + call gmecat ( ncequi, 4, nbeqar, codre4 ) + call gmecat ( ncequi, 5, nbeqtr, codre5 ) + call gmecat ( ncequi, 6, nbeqqu, codre6 ) + call gmecat ( ncequi, 7, nbeqte, codre7 ) + call gmecat ( ncequi, 8, nbeqhe, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,7)) ncequi + endif +c + endif +c +c==== +c 3. allocation +c==== +c + if ( codret.eq.0 ) then +c + if ( nbequi.ne.0 ) then +c + iaux = 5*nbequi + call gmaloj ( ncequi//'.Pointeur', ' ', iaux, adeqpo, codre1 ) + iaux = 33*nbequi + call gmaloj ( ncequi//'.InfoGene', ' ', iaux, adeqin, codre2 ) + call gmaloj ( ncequi//'.Noeud' , ' ', 2*nbeqno, adeqno, codre3 ) + call gmaloj ( ncequi//'.Point' , ' ', 2*nbeqmp, adeqmp, codre4 ) + call gmaloj ( ncequi//'.Arete' , ' ', 2*nbeqar, adeqar, codre5 ) + call gmaloj ( ncequi//'.Trian' , ' ', 2*nbeqtr, adeqtr, codre6 ) + call gmaloj ( ncequi//'.Quadr' , ' ', 2*nbeqqu, adeqqu, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,8)) ncequi + write(ulsort,texte(langue,9)) + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 + endif +c + call gmaloj ( ncequi//'.Tetra' , ' ', 2*nbeqte, adeqte, codre1 ) + call gmaloj ( ncequi//'.Hexae' , ' ', 2*nbeqhe, adeqhe, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad01.F b/src/tool/Utilitaire/utad01.F new file mode 100644 index 00000000..be62829c --- /dev/null +++ b/src/tool/Utilitaire/utad01.F @@ -0,0 +1,255 @@ + subroutine utad01 ( option, nhnoeu, + > adhist, + > adfami, adcofa, bidon, + > adcoor, adarno, adhono, adcocs, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 01 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour les noeuds HOM_Noeu +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utad01 et utad05 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : historique . +c . . . . 3 : coordonnees . +c . . . . 5 : arete support du noeud . +c . . . . 7 : fami, cofa . +c . . . . 11 : noho . +c . . . . 19 : constantes des coordonnees . +c . nhnoeu . e . char8 . nom de l'objet decrivant l'entite . +c . adhist . s . 1 . historique de l'etat . +c . adfami . s . 1 . famille des noeuds . +c . adcofa . s . 1 . codes des familles des noeuds . +c . bidon . s . 1 . en attente si evolution . +c . adcoor . s . 1 . coordonnees . +c . adarno . s . 1 . arete supportant le noeud . +c . adhono . s . 1 . homologue du noeud . +c . adcocs . s . 1 . constantes des coordonnees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "indefi.h" +c +c 0.3. ==> arguments +c + character*8 nhnoeu +c + integer option + integer adhist + integer adfami, adcofa, bidon + integer adcoor, adarno, adhono, adcocs +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer codre1, codre2 + integer tabcod(7) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux noeuds'')' + texte(1,5) = '(''Option :'',i10)' + texte(1,8) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Adresses for nodes'')' + texte(2,5) = '(''Option :'',i10)' + texte(2,8) = '(''Error codes'',20i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + call dmflsh (iaux) +#endif +c + do 10 , iaux = 1 , 7 + tabcod(iaux) = 0 + 10 continue +c + bidon = iindef +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Historique des etats +c + if ( mod(option,2).eq.0 ) then +c + call gmadoj ( nhnoeu//'.HistEtat', adhist, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 1 + tabcod(1) = codre0 + endif +c + endif +c +c 2.2. ==> Les coordonnees +c + if ( mod(option,3).eq.0 ) then +c + call gmadoj ( nhnoeu//'.Coor', adcoor, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(2) = codre0 + endif +c + endif +c +c 2.3. ==> L'arete supportant le noeud +c + if ( mod(option,5).eq.0 ) then +c + call gmadoj ( nhnoeu//'.AretSupp', adarno, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(3) = codre0 + endif +c + endif +c +c 2.4. ==> Les familles +c + if ( mod(option,7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhnoeu//'.Famille.EntiFamm', adfami, iaux, codre1) + call gmadoj ( nhnoeu//'.Famille.Codes' , adcofa, iaux, codre2) +c + if ( codre1.ne.0 ) then + codret = 41 + tabcod(4) = codre1 + endif + if ( codre2.ne.0 ) then + codret = 42 + tabcod(5) = codre2 + endif +c + endif +c + endif +c +c 2.5. ==> L'homologue du noeud +c + if ( mod(option,11).eq.0 ) then +c + call gmadoj ( nhnoeu//'.Homologu', adhono, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 5 + tabcod(6) = codre0 + endif +c + endif +c +c 2.6. ==> Constantes liees aux coordonnees +c + if ( mod(option,19).eq.0 ) then +c + call gmadoj ( nhnoeu//'.CoorCons', adcocs, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 6 + tabcod(7) = codre0 + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,8)) tabcod + call gmprsx ( nompro, nhnoeu ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad02.F b/src/tool/Utilitaire/utad02.F new file mode 100644 index 00000000..c8e9bf90 --- /dev/null +++ b/src/tool/Utilitaire/utad02.F @@ -0,0 +1,395 @@ + subroutine utad02 ( option, nhenti, + > adhist, adcode, adfill, admere, + > adfami, adcofa, bidon, + > adnivo, adinsu, adins2, + > adnoim, adhomo, adcoar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 02 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour une entite HOM_Enti +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : historique, connectivite descendante . +c . . . . 3 : fille . +c . . . . 5 : mere . +c . . . . 7 : fami . +c . . . . 11 : nivo . +c . . . . 13 : isup . +c . . . . 17 : isup2 . +c . . . . 19 : noeud interne a la maille . +c . . . . 29 : homologue . +c . . . . 31 : connectivite par arete . +c . . . . 37 : cofa . +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . adhist . s . 1 . historique de l'etat . +c . adcode . s . 1 . connectivite descendante . +c . adfill . s . 1 . fille des entites . +c . admere . s . 1 . mere des entites . +c . adfami . s . 1 . famille des entites . +c . adcofa . s . 1 . code des familles des entites . +c . bidon . s . 1 . en attente si evolution . +c . adnivo . s . 1 . niveau des entites . +c . adinsu. s . 1 . informations supplementaires . +c . adins2. s . 1 . informations supplementaires numero 2 . +c . adnoim . s . 1 . noeud interne a la maille . +c . adhomo . s . 1 . homologue . +c . adcoar . s . 1 . connectivite par arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "indefi.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer option + integer adhist, adcode, adfill, admere + integer adfami, adcofa, bidon + integer adnivo + integer adinsu + integer adins2 + integer adnoim + integer adhomo + integer adcoar +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codava + integer codre0 + integer codre1, codre2 + integer tabcod(12) +c + integer nbmess + parameter ( nbmess = 11 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux entites'')' + texte(1,8) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Adresses for entities'')' + texte(2,8) = '(''Error codes'',20i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'option' ,option + call dmflsh (iaux) +#endif +c + do 10 , iaux = 1 , 12 + tabcod(iaux) = 0 + 10 continue +c + adcofa = iindef + adhist = iindef + adcode = iindef + adfill = iindef + admere = iindef + adfami = iindef + adcofa = iindef + adnivo = iindef + adinsu = iindef + adins2 = iindef + adnoim = iindef + adhomo = iindef + adcoar = iindef + bidon = iindef +c + codava = codret + codret = 0 +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Historique des etats et connectivite descendante +c + if ( mod(option,2).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.HistEtat', adhist, iaux, codre1 ) + call gmadoj ( nhenti//'.ConnDesc', adcode, iaux, codre2 ) +c + if ( codre1.ne.0 ) then + codret = 21 + tabcod(1) = codre1 + endif + if ( codre2.ne.0 ) then + codret = 22 + tabcod(2) = codre2 + endif +c + endif +c + endif +c +c 2.2. ==> Fille +c + if ( mod(option,3).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Fille', adfill, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(3) = codre0 + endif +c + endif +c + endif +c +c 2.3. ==> Mere +c + if ( mod(option,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Mere', admere, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 5 + tabcod(4) = codre0 + endif +c + endif +c + endif +c +c 2.4. ==> Les familles +c + if ( mod(option,7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Famille.EntiFamm', adfami, iaux, codre0) +c + if ( codre0.ne.0 ) then + codret = 7 + tabcod(5) = codre0 + endif +c + endif +c + endif +c + if ( mod(option,37).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Famille.Codes' , adcofa, iaux, codre0) +c + if ( codre0.ne.0 ) then + codret = 37 + tabcod(6) = codre0 + endif +c + endif +c + endif +c +c 2.5. ==> Le niveau +c + if ( mod(option,11).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Niveau', adnivo, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 11 + tabcod(7) = codre0 + endif +c + endif +c + endif +c +c 2.6. ==> Les informations supplementaires +c + if ( mod(option,13).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.InfoSupp', adinsu, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 13 + tabcod(8) = codre0 + endif +c + endif +c + endif +c +c 2.7. ==> Les informations supplementaires numero 2 +c + if ( mod(option,17).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.InfoSup2', adins2, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 17 + tabcod(9) = codre0 + endif +c + endif +c + endif +c +c 2.8. ==> Le noeud supplementaire +c + if ( mod(option,19).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.NoeuInMa', adnoim, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 19 + tabcod(10) = codre0 + endif +c + endif +c + endif +c +c 2.9. ==> Les homologues +c + if ( mod(option,29).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.Homologu', adhomo, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 29 + tabcod(11) = codre0 + endif +c + endif +c + endif +c +c 2.10. ==> La connectivite par aretes +c + if ( mod(option,31).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenti//'.ConnAret', adcoar, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 31 + tabcod(12) = codre0 + endif +c + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'option' ,option + write (ulsort,90003) 'structure', nhenti + write (ulsort,texte(langue,8)) tabcod + call gmprsx ( nompro, nhenti ) + call gmprsx ( nompro, nhenti//'.Famille' ) +c + else +c + codret = codava +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad03.F b/src/tool/Utilitaire/utad03.F new file mode 100644 index 00000000..455dbbc2 --- /dev/null +++ b/src/tool/Utilitaire/utad03.F @@ -0,0 +1,292 @@ + subroutine utad03 ( option, nhenti, + > nbenci, nbenrc, numead, + > adenra, adenrb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 03 +c -- -- -- +c ______________________________________________________________________ +c Recuperation d'informations pour le recollement non conforme +c d'une entite HOM_Enti +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des infos. a recuperer . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : nombre de non conformites initiales . +c . . . . 3 : nbre d'entites / recollement unitaire . +c . . . . 5 : numero de la mere adoptive . +c . . . . 7 : aretes recouvrant une autre . +c . . . . 11 : aretes recouvertes par une autre . +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . nbenci . s . 1 . nombre de non conformites initiales . +c . nbenrc . s . 1 . nombre d'entites par recollement unitaire . +c . numead . s . 1 . numero de la mere adoptive . +c . adenra . s . 1 . liste des entites recouvrant une autre . +c . adenrb . s . 1 . liste des entites recouvertes par une autre. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer option + integer nbenci, nbenrc, numead + integer adenra, adenrb +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codava + integer codre0 + integer codre1, codre2, codre3, codre4, codre5 + logical existe +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux recollements'')' + texte(1,5) = '(''Option :'',i10)' + texte(1,6) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Adresses for glue'')' + texte(2,5) = '(''Option :'',i10)' + texte(2,6) = '(''Error codes'',20i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + call gmprsx (nompro,nhenti//'.Recollem') + call dmflsh (iaux) +#endif +c + codava = codret + codret = 0 +c +c==== +c 2. Structure generale +c==== +c + call gmobal ( nhenti//'.Recollem', codre0 ) + if ( codre0.eq.0 ) then + nbenci = 0 + nbenrc = -1 + numead = 0 + existe = .false. + elseif ( codre0.eq.1 ) then + existe = .true. + else + nbenci = -1 + existe = .false. + codret = max ( abs(codre0), codret ) + endif +c +c==== +c 3. Nombre de non conformites initiales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Nbr non conformites init ; codret = ', codret +#endif +c + if ( option.gt.0 ) then +c + if ( mod(option,2).eq.0 ) then +c + if ( existe ) then +c + call gmliat ( nhenti//'.Recollem', 1, nbenci, codre1 ) +c + codret = max ( abs(codre1), codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. Recherche des informations +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Recherche informations ; codret = ', codret +#endif +c + if ( option.gt.0 ) then +c +c 4.1. ==> Nombre d'entites par recollement unitaire +c + if ( mod(option,3).eq.0 ) then +c + if ( existe ) then +c + call gmliat ( nhenti//'.Recollem', 2, nbenrc, codre2 ) +c + codret = max ( abs(codre2), codret ) +c + else +c + if ( mod(option,2).ne.0 ) then + codret = max ( 41, codret ) + endif +c + endif +c + endif +c +c 4.2. ==> Numero de la mere adoptive +c Remarque : si la structure n'existe pas, on renvoie 0 pour +c ne pas perturber le reste +c + if ( mod(option,5).eq.0 ) then +c + if ( existe ) then +c + call gmliat ( nhenti//'.Recollem', 3, numead, codre3 ) +c + codret = max ( abs(codre3), codret ) +c + else +c + numead = 0 +c + endif +c + endif +c +c 4.3. ==> liste des entites recouvrant une autre +c + if ( mod(option,7).eq.0 ) then +c + if ( existe ) then +c + call gmadoj ( nhenti//'.Recollem.ListeA', + > adenra, iaux, codre4 ) +c + codret = max ( abs(codre4), codret ) +c + else +c + if ( mod(option,2).ne.0 ) then + codret = max ( 43, codret ) + endif +c + endif +c + endif +c +c 4.4. ==> Liste des entites recouvertes par une autre +c + if ( mod(option,11).eq.0 ) then +c + if ( existe ) then +c + call gmadoj ( nhenti//'.Recollem.ListeB', + > adenrb, iaux, codre5 ) +c + codret = max ( abs(codre5), codret ) +c + else +c + if ( mod(option,2).ne.0 ) then + codret = max ( 44, codret ) + endif +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,2)) codret + if ( existe ) then + write (ulsort,texte(langue,6)) codre0, + > codre1, codre2, codre3, codre4, codre5 +c + else +c + codret = codava +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad04.F b/src/tool/Utilitaire/utad04.F new file mode 100644 index 00000000..eb556468 --- /dev/null +++ b/src/tool/Utilitaire/utad04.F @@ -0,0 +1,364 @@ + subroutine utad04 ( option, nhvois, + > ppovos, pvoiso, pposif, pfacar, + > advotr, advoqu, + > lgpptr, lgppqu, adpptr, adppqu, + > lgtate, adptte, adtate, + > lgtahe, adpthe, adtahe, + > lgtapy, adptpy, adtapy, + > lgtape, adptpe, adtape, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 04 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour une entite Voisins +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : ppovos, pvoiso . +c . . . . 3 : pposif, pfacar . +c . . . . 5 : voltri . +c . . . . 7 : volqua . +c . . . . 11 : lgpptr, lgppqu . +c . . . . 13 : pypetr . +c . . . . 17 : pypequ . +c . . . . 19 : lgtate, adptte, adtate . +c . . . . 23 : lgtahe, adpthe, adtahe . +c . . . . 29 : lgtapy, adptpy, adtapy . +c . . . . 31 : lgtape, adptpe, adtape . +c . nhvois . e . char8 . nom de la branche Voisins . +c . ppovos . s . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . s . 1 . adresse des voisins des sommets . +c . pposif . s . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . s . 1 . adresse des voisins des aretes . +c . advotr . s . 1 . numeros des 2 volumes par triangle . +c . advoqu . s . 1 . numeros des 2 volumes par quadrangle . +c . lgpptr . s . 1 . longueur du tableau PyPe/Tri . +c . lgppqu . s . 1 . longueur du tableau PyPe/Qua . +c . adpptr . s . 1 . adresse du tableau PyPe/Tri . +c . adppqu . s . 1 . adresse du tableau PyPe/Qua . +c . lgtate . s . 1 . longueur du tableau Tet/Are.Table . +c . adptte . s . 1 . adresse du pointeur des tetras/aretes . +c . adtate . s . 1 . adresse de la table des tetras/aretes . +c . lgtahe . s . 1 . longueur du tableau Hex/Are.Table . +c . adpthe . s . 1 . adresse du pointeur des hexas/aretes . +c . adtahe . s . 1 . adresse de la table des hexas/aretes . +c . lgtapy . s . 1 . longueur du tableau Pyr/Are.Table . +c . adptpy . s . 1 . adresse du pointeur des pyras/aretes . +c . adtapy . s . 1 . adresse de la table des pyras/aretes . +c . lgtape . s . 1 . longueur du tableau Pen/Are.Table . +c . adptpe . s . 1 . adresse du pointeur des pentas/aretes . +c . adtape . s . 1 . adresse de la table des pentas/aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nhvois +c + integer option + integer ppovos, pvoiso + integer pposif, pfacar + integer advotr, advoqu + integer lgpptr, lgppqu, adpptr, adppqu + integer lgtate, adptte, adtate + integer lgtahe, adpthe, adtahe + integer lgtapy, adptpy, adtapy + integer lgtape, adptpe, adtape +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer codre1, codre2, codre3 +c + character*8 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux voisins'')' +c + texte(2,4) = '(''Adresses for neighbours'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'Option', option + call dmflsh (iaux) +#endif +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Aretes voisines des noeuds +c + if ( mod(option,2).eq.0 ) then +c + call gmadoj ( nhvois//'.0D/1D.Pointeur', ppovos, iaux, codre1 ) + call gmadoj ( nhvois//'.0D/1D.Table', pvoiso, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. aretes/noeuds ; codret', codret +#endif +c + endif +c +c 2.2. ==> Faces voisines des aretes +c + if ( mod(option,3).eq.0 ) then +c + call gmadoj ( nhvois//'.1D/2D.Pointeur', pposif, iaux, codre1 ) + call gmadoj ( nhvois//'.1D/2D.Table', pfacar, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. faces/aretes ; codret', codret +#endif +c + endif +c +c 2.3. ==> Volumes voisins des triangles +c + if ( mod(option,5).eq.0 ) then +c + call gmadoj ( nhvois//'.Vol/Tri', advotr, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. volumes/triangles ; codret', codret +#endif +c + endif +c +c 2.4. ==> Volumes voisins des quadrangles +c + if ( mod(option,7).eq.0 ) then +c + call gmadoj ( nhvois//'.Vol/Qua', advoqu, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.4. volumes/quadrangles ; codret', codret +#endif +c + endif +c +c 2.5. ==> Longueurs des PyPe +c + if ( mod(option,11).eq.0 ) then +c + call gmliat ( nhvois , 1, lgpptr, codre1 ) + call gmliat ( nhvois , 2, lgppqu, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.5. Longueurs des PyPe ; codret', codret +#endif +c + endif +c +c 2.6. ==> Pyramides/Pentaedres voisins des triangles +c + if ( mod(option,13).eq.0 ) then +c + call gmadoj ( nhvois//'.PyPe/Tri', adpptr, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.6. Pyra+Pent/Tria ; codret', codret +#endif +c + endif +c +c 2.7. ==> Pyramides/Pentaedres voisins des quadrangles +c + if ( mod(option,17).eq.0 ) then +c + call gmadoj ( nhvois//'.PyPe/Qua', adppqu, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.7. Pyra+Pent/Quad ; codret', codret +#endif +c + endif +c +c 2.8. ==> Tetraedres voisins des aretes +c + if ( mod(option,19).eq.0 ) then +c + saux08 = '.Tet/Are' + call gmliat ( nhvois//saux08 , 2, lgtate, codre1 ) + call gmadoj ( nhvois//saux08//'.Pointeur', + > adptte, iaux, codre2 ) + call gmadoj ( nhvois//saux08//'.Table', + > adtate, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.8. Tetraedres/Aretes ; codret', codret +#endif +c + endif +c +c 2.9. ==> Hexaedres voisins des aretes +c + if ( mod(option,23).eq.0 ) then +c + saux08 = '.Hex/Are' + call gmliat ( nhvois//saux08 , 2, lgtahe, codre1 ) + call gmadoj ( nhvois//saux08//'.Pointeur', + > adpthe, iaux, codre2 ) + call gmadoj ( nhvois//saux08//'.Table', + > adtahe, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.9. Hexaedres/Aretes ; codret', codret +#endif +c + endif +c +c 2.10. ==> Pyramides voisines des aretes +c + if ( mod(option,29).eq.0 ) then +c + saux08 = '.Pyr/Are' + call gmliat ( nhvois//saux08 , 2, lgtapy, codre1 ) + call gmadoj ( nhvois//saux08//'.Pointeur', + > adptpy, iaux, codre2 ) + call gmadoj ( nhvois//saux08//'.Table', + > adtapy, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.10. Pyramides/Aretes ; codret', codret +#endif +c + endif +c +c 2.11. ==> Pentaedres voisins des aretes +c + if ( mod(option,31).eq.0 ) then +c + saux08 = '.Pen/Are' + call gmliat ( nhvois//saux08 , 2, lgtape, codre1 ) + call gmadoj ( nhvois//saux08//'.Pointeur', + > adptpe, iaux, codre2 ) + call gmadoj ( nhvois//saux08//'.Table', + > adtape, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.11. Pentaedres/Aretes ; codret', codret +#endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'Option', option + call gmprsx ( nompro, nhvois ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad05.F b/src/tool/Utilitaire/utad05.F new file mode 100644 index 00000000..8eecea44 --- /dev/null +++ b/src/tool/Utilitaire/utad05.F @@ -0,0 +1,319 @@ + subroutine utad05 ( option, optio2, nhnoeu, + > nbeold, nbenew, sdim, + > adhist, + > adfami, + > adcoor, adarno, adhono, adanci, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 05 +c -- -- -- +c ______________________________________________________________________ +c Modification des longueurs des tableaux pour une entite HOM_Noeu +c et recuperation de leurs adresses +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utad01 et utad05 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : historique . +c . . . . 3 : coordonnees . +c . . . . 5 : arete support du noeud . +c . . . . 7 : fami . +c . . . . 11 : noho . +c . . . . 13 : dera . +c . optio2 . e . 1 . 0 : on detruit les objets de taille nulle . +c . . . . 1 : on garde les objets de taille nulle . +c . nhnoeu . e . char8 . nom de l'objet decrivant l'entite . +c . nbeold . e . 1 . nombre d'entites ancien . +c . nbenew . e . 1 . nombre d'entites nouveau . +c . sdim . e . 1 . dimension . +c . adhist . s . 1 . historique de l'etat . +c . adfami . s . 1 . famille des noeuds . +c . adcoor . s . 1 . coordonnees . +c . adarno . s . 1 . arete supportant le noeud . +c . adhono . s . 1 . homologue du noeud . +c . adanci . s . 1 . deraffinement . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nhnoeu +c + integer option, optio2 + integer nbeold, nbenew, sdim + integer adhist + integer adfami + integer adcoor, adarno, adhono, adanci +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer un + parameter ( un = 1 ) +c + integer iaux + integer codre0 + integer tabcod(7) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux noeuds'')' + texte(1,8) = '(''Codes de retour'',20i3)' + texte(1,9) = '(''Ancien nombre de noeuds : '',i10)' + texte(1,10) = '(''Nouveau nombre de noeuds : '',i10)' +c + texte(2,4) = '(''Adresses for nodes'')' + texte(2,6) = '(''Error codes'',20i3)' + texte(2,9) = '(''Old number of nodes : '',i10)' + texte(2,10) = '(''New number of nodes : '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'option' ,option + write (ulsort,texte(langue,9)) nbeold + write (ulsort,texte(langue,10)) nbenew + call gmprsx ( nompro, nhnoeu ) + call dmflsh (iaux) +#endif +c + do 10 , iaux = 1 , 7 + tabcod(iaux) = 0 + 10 continue +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Historique des etats +c + if ( mod(option,2).eq.0 ) then +c +cgn call gmprsx ( nompro, nhnoeu//'.HistEtat' ) + call gmmod ( nhnoeu//'.HistEtat', + > adhist, nbeold, nbenew, un, un, codre0 ) +c + if ( codre0.ne.0 ) then + tabcod(1) = 1 + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 2 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c +c 2.2. ==> Les coordonnees +c + if ( mod(option,3).eq.0 ) then +c + call gmmod ( nhnoeu//'.Coor', + > adcoor, nbeold, nbenew, sdim, sdim, codre0 ) +c + if ( codre0.ne.0 ) then + tabcod(2) = 2 + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 3 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c +c 2.3. ==> L'arete supportant le noeud +c + if ( mod(option,5).eq.0 ) then +c + call gmmod ( nhnoeu//'.AretSupp', + > adarno, nbeold, nbenew, un, un, codre0 ) +c + if ( codre0.ne.0 ) then + tabcod(3) = 3 + codret = 3 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 5 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c +c 2.4. ==> Les familles +c + if ( mod(option,7).eq.0 ) then +c + call gmmod ( nhnoeu//'.Famille.EntiFamm', + > adfami, nbeold, nbenew, un, un, codre0 ) +c + if ( codre0.ne.0 ) then + tabcod(4) = 4 + codret = 4 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 7 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c +c 2.5. ==> L'homologue du noeud +c + if ( mod(option,11).eq.0 ) then +c + call gmmod ( nhnoeu//'.Homologu', + > adhono, nbeold, nbenew, un, un, codre0 ) +c + if ( codre0.ne.0 ) then + tabcod(5) = 5 + codret = 5 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 11 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c +c 2.6. ==> La memorisation du deraffinement +c + if ( mod(option,13).eq.0 ) then +c + call gmobal ( nhnoeu//'.Deraffin', codre0 ) +c + if ( codre0.eq.2 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhnoeu//'.Deraffin' , codre0 ) +c + else +c + call gmmod ( nhnoeu//'.Deraffin', + > adanci, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 13 + tabcod(6) = 13 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Choix', 13 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c + endif +c +c==== +c 3. Attribut +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( nhnoeu, 1, nbenew, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 30 + tabcod(7) = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,8)) tabcod +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad06.F b/src/tool/Utilitaire/utad06.F new file mode 100644 index 00000000..78df38db --- /dev/null +++ b/src/tool/Utilitaire/utad06.F @@ -0,0 +1,650 @@ + subroutine utad06 ( typenh, option, optio2, nhenti, + > nbeold, nbenew, nbaold, nbanew, + > adhist, adcode, adfill, admere, + > adfami, + > adnivo, adinsu, adins2, + > adnoim, adanci, adhomo, adcoar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 06 +c -- -- -- +c ______________________________________________________________________ +c Modification des longueurs des tableaux pour une entite HOM_Enti +c et recuperation de leurs adresses +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : historique, connectivite descendante . +c . . . . 3 : fille . +c . . . . 5 : mere . +c . . . . 7 : fami . +c . . . . 11 : nivo . +c . . . . 13 : isup . +c . . . . 17 : isup2 . +c . . . . 19 : noeud interne a la maille . +c . . . . 23 : Deraffin . +c . . . . 29 : homologue . +c . . . . 31 : connectivite par arete . +c . optio2 . e . 1 . 0 : on detruit les objets de taille nulle . +c . . . . 1 : on garde les objets de taille nulle . +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . nbeold . e . 1 . nombre d'entites ancien . +c . nbenew . e . 1 . nombre d'entites nouveau . +c . nbaold . e . 1 . nombre d'entites decrites par arete ancien . +c . nbanew . e . 1 . nombre d'entites decrites par arete nouveau. +c . adhist . s . 1 . historique de l'etat . +c . adcode . s . 1 . connectivite descendante . +c . adfill . s . 1 . fille des entites . +c . admere . s . 1 . mere des entites . +c . adfami . s . 1 . famille des entites . +c . adnivo . s . 1 . niveau des entites . +c . adinsu . s . 1 . informations supplementaires . +c . adins2 . s . 1 . informations supplementaires numero 2 . +c . adnoim . s . 1 . noeud interne a la maille . +c . adanci . s . 1 . memorisation du deraffinement . +c . adhomo . s . 1 . homologue . +c . adcoar . s . 1 . connectivite par arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer typenh + integer option, optio2 + integer nbeold, nbenew, nbaold, nbanew + integer adhist, adcode, adfill, admere + integer adfami + integer adnivo + integer adinsu + integer adins2 + integer adnoim + integer adanci + integer adhomo + integer adcoar +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer un + parameter ( un = 1 ) +c + integer iaux, jaux, kaux, laux + integer dimaux + integer codava + integer codre0 + integer codre1, codre2 + integer tabcod(0:13) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Reallocations pour les '',a)' + texte(1,6) = '(''On detruit les objets de taille nulle.'')' + texte(1,7) = '(''On garde les objets de taille nulle.'')' + texte(1,8) = '(''Codes de retour'',20i3)' + texte(1,9) = '(''Ancien nombre d''''entites : '',i10)' + texte(1,10) = '(''Nouveau nombre d''''entites : '',i10)' +c + texte(2,4) = '(''Reallocation for the '',a)' + texte(2,6) = '(''Null size objects are destroyed.'')' + texte(2,7) = '(''Null size objetcs are kept.'')' + texte(2,8) = '(''Error codes'',20i3)' + texte(2,9) = '(''Old number of entities : '',i10)' + texte(2,10) = '(''New number of entities : '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option', option + write (ulsort,texte(langue,6+optio2)) + write (ulsort,texte(langue,9)) nbeold + write (ulsort,texte(langue,10)) nbenew +cgn call gmprsx ( nompro, nhenti ) + call dmflsh (iaux) +#endif +c + do 10 , iaux = 0 , 13 + tabcod(iaux) = 0 + 10 continue +c + codava = codret + codret = 0 +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Historique des etats et connectivite descendante +c + if ( mod(option,2).eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.HistEtat' , codre1 ) + call gmlboj ( nhenti//'.ConnDesc' , codre2 ) +c + else +c + call gmmod ( nhenti//'.HistEtat', + > adhist, nbeold, nbenew, un, un, codre1 ) +c + if ( typenh.eq.0 ) then + dimaux = 1 + elseif ( typenh.eq.1 ) then + dimaux = -2 + elseif ( typenh.eq.2 ) then + dimaux = 3 + elseif ( typenh.eq.3 ) then + dimaux = 4 + elseif ( typenh.eq.4 ) then + dimaux = 4 + elseif ( typenh.eq.5 ) then + dimaux = 5 + elseif ( typenh.eq.6 ) then + dimaux = 6 + elseif ( typenh.eq.7 ) then + dimaux = 5 + else + codret = 120 + tabcod(2) = 1 + endif +c + if ( codret.eq.0 ) then +c + if ( dimaux.lt.0 ) then + iaux = -dimaux + jaux = -dimaux + kaux = nbeold + laux = nbenew + else + iaux = (nbeold-nbaold) + jaux = (nbenew-nbanew) + kaux = dimaux + laux = dimaux + endif + call gmmod ( nhenti//'.ConnDesc', + > adcode, iaux, jaux, kaux, laux, codre2 ) +c + endif +c + endif +c + if ( codre1.ne.0 ) then + codret = 11 + tabcod(1) = 1 + endif +c + if ( codre2.ne.0 ) then + codret = 12 + tabcod(2) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 2 + write (ulsort,texte(langue,8)) codre1, codre2 +#endif +c + endif +c +c 2.2. ==> Fille +c + if ( mod(option,3).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.Fille' , codre0 ) +c + else +c + call gmmod ( nhenti//'.Fille', + > adfill, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(3) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 3 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.3. ==> Mere +c + if ( mod(option,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.Mere' , codre0 ) +c + else +c + call gmmod ( nhenti//'.Mere', + > admere, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(4) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 5 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.4. ==> Les familles +c Attention : ne jamais tuer EntiFamm si taille nulle +c + if ( mod(option,7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmmod ( nhenti//'.Famille.EntiFamm', + > adfami, nbeold, nbenew, un, un, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 4 + tabcod(5) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 7 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.5. ==> Le niveau +c + if ( mod(option,11).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.Niveau' , codre0 ) +c + else +c + call gmmod ( nhenti//'.Niveau', + > adnivo, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 5 + tabcod(7) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 11 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.6. ==> Les informations supplementaires +c + if ( mod(option,13).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.InfoSupp' , codre0 ) +c + else +c + if ( typenh.eq.0 ) then + dimaux = 1 + elseif ( typenh.eq.1 ) then + dimaux = 1 + elseif ( typenh.eq.2 ) then + dimaux = 1 + elseif ( typenh.eq.3 ) then + dimaux = 4 + elseif ( typenh.eq.4 ) then + dimaux = 1 + elseif ( typenh.eq.5 ) then + dimaux = 5 + elseif ( typenh.eq.6 ) then + dimaux = 6 + elseif ( typenh.eq.7 ) then + dimaux = 5 + else + codret = 6 + tabcod(8) = 1 + endif + iaux = (nbeold-nbaold) + jaux = (nbenew-nbanew) + kaux = dimaux + laux = dimaux + call gmmod ( nhenti//'.InfoSupp', + > adinsu, iaux, jaux, kaux, laux, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 6 + tabcod(8) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 13 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.7. ==> Les informations supplementaires numero 2 +c + if ( mod(option,17).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.InfoSup2' , codre0 ) +c + else +c + call gmmod ( nhenti//'.InfoSup2', + > adins2, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 7 + tabcod(9) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 17 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.8. ==> Le noeud supplementaire +c + if ( mod(option,19).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.NoeuInMa' , codre0 ) +c + else +c + call gmmod ( nhenti//'.NoeuInMa', + > adnoim, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 8 + tabcod(10) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 19 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.9. ==> La memorisation du deraffinement +c + if ( mod(option,23).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmobal ( nhenti//'.Deraffin', codre0 ) +c + if ( codre0.eq.2 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.Deraffin' , codre0 ) +c + else +c + call gmmod ( nhenti//'.Deraffin', + > adanci, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 9 + tabcod(11) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 23 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c + endif +c +c 2.10. ==> Les homologues +c + if ( mod(option,29).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbenew.eq.0 ) then +c + call gmlboj ( nhenti//'.Homologu' , codre0 ) +c + else +c + call gmmod ( nhenti//'.Homologu', + > adhomo, nbeold, nbenew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 10 + tabcod(12) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 29 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c +c 2.11. ==> Connectivites par aretes +c + if ( mod(option,31).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( optio2.eq.0 .and. nbanew.eq.0 ) then +c + call gmlboj ( nhenti//'.ConnAret' , codre0 ) +c + else +c + call gmmod ( nhenti//'.ConnAret', + > adcoar, nbaold, nbanew, un, un, codre0 ) +c + endif +c + if ( codre0.ne.0 ) then + codret = 11 + tabcod(13) = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'traitement', 31 + write (ulsort,texte(langue,8)) codre0 +#endif +c + endif +c + endif +c + endif +c +c==== +c 3. Attributs +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( nhenti, 1, nbenew, codre1 ) + call gmecat ( nhenti, 2, nbanew, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + codret = 30 + tabcod(0) = 1 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option', option + write (ulsort,texte(langue,8)) tabcod + write (ulsort,texte(langue,9)) nbeold + write (ulsort,texte(langue,10)) nbenew + call gmprsx(nompro,nhenti) +c + else +c + codret = codava +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad07.F b/src/tool/Utilitaire/utad07.F new file mode 100644 index 00000000..300a8c26 --- /dev/null +++ b/src/tool/Utilitaire/utad07.F @@ -0,0 +1,272 @@ + subroutine utad07 ( ncequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn, + > adeqno, adeqmp, adeqar, adeqtr, adeqqu, + > adeqte, adeqhe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 07 +c -- -- -- +c ______________________________________________________________________ +c Modification des longueurs des tableaux pour une entite MC_Equ +c et recuperation de leurs adresses +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utacme et utad07 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncequi . e . char8 . nom de la branche Equivalt maillage calcul . +c . nbeqno . e . 1 . nombre total de noeuds dans les equivalen. . +c . nbeqmp . e . 1 . nombre total de mailles-points dans les eq.. +c . nbeqar . e . 1 . nombre total d'aretes dans les eq. . +c . nbeqtr . e . 1 . nombre total de triangles dans les eq. . +c . nbeqqu . e . 1 . nombre total de quadrangles dans les eq. . +c . nbeqnn . e . 1 . nouveau nbeqno . +c . nbeqmn . e . 1 . nouveau nbeqmp . +c . nbeqan . e . 1 . nouveau nbeqar . +c . nbeqtn . e . 1 . nouveau nbeqtr . +c . nbeqqn . e . 1 . nouveau nbeqqu . +c . adeqno . s . 1 . adresse de la branche Noeud . +c . adeqmp . s . 1 . adresse de la branche Point . +c . adeqar . s . 1 . adresse de la branche Arete . +c . adeqtr . s . 1 . adresse de la branche Trian . +c . adeqqu . s . 1 . adresse de la branche Quadr . +c . adeqte . s . 1 . adresse de la branche Tetra . +c . adeqhe . s . 1 . adresse de la branche Hexae . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD07' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 ncequi +c + integer nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu + integer nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn + integer adeqno, adeqmp, adeqar, adeqtr, adeqqu + integer adeqte, adeqhe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer un + parameter ( un = 1 ) +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer nbeqte, nbeqhe +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Rellocation des equivalences du maillage de calcul'')' + texte(1,5) = '(''Nombre d''''equivalences : '',i4)' + texte(1,6) = '(''Nombre de paires de '',a14,'' : '',i4)' + texte(1,7) = '(''Impossible d''''ecrire les attributs de '',a)' + texte(1,8) = '(''Impossible de reallouer les branches de '',a)' + texte(1,9) = '(''Codes : '',7i3)' +c + texte(2,4) = + > '(''Re-allocation of equivalences of calculation mesh'')' + texte(2,5) = '(''Number of equivalences: '',i4)' + texte(2,6) = '(''Number of pairs of '',a14,'': '',i4)' + texte(2,7) = '(''Attributes of '',a,'' cannot be written.'')' + texte(2,8) = '(''Branches of '',a,'' cannot be re-allocated.'')' + texte(2,9) = '(''Codes: '',7i3)' +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) + write(ulsort,texte(langue,6)) mess14(langue,3,-1), nbeqno + write(ulsort,texte(langue,6)) mess14(langue,3,0), nbeqmp + write(ulsort,texte(langue,6)) mess14(langue,3,1), nbeqar + write(ulsort,texte(langue,6)) mess14(langue,3,2), nbeqtr + write(ulsort,texte(langue,6)) mess14(langue,3,4), nbeqqu + write(ulsort,texte(langue,6)) mess14(langue,3,-1), nbeqnn + write(ulsort,texte(langue,6)) mess14(langue,3,0), nbeqmn + write(ulsort,texte(langue,6)) mess14(langue,3,1), nbeqan + write(ulsort,texte(langue,6)) mess14(langue,3,2), nbeqtn + write(ulsort,texte(langue,6)) mess14(langue,3,4), nbeqqn +#endif +c +c==== +c 2. attributs +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( ncequi, 2, nbeqnn, codre1 ) + call gmecat ( ncequi, 3, nbeqmn, codre2 ) + call gmecat ( ncequi, 4, nbeqan, codre3 ) + call gmecat ( ncequi, 5, nbeqtn, codre4 ) + call gmecat ( ncequi, 6, nbeqqn, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,7)) ncequi + endif +c + endif +c +c==== +c 3. redimensionnement +c==== +c 3.1. ==> Noeuds, mailles-point, aretes et faces +c + if ( codret.eq.0 ) then +c + call gmmod ( ncequi//'.Noeud', + > adeqno, 2*nbeqno, 2*nbeqnn, un, un, codre1 ) + call gmmod ( ncequi//'.Point', + > adeqmp, 2*nbeqmp, 2*nbeqmn, un, un, codre2 ) + call gmmod ( ncequi//'.Arete', + > adeqar, 2*nbeqar, 2*nbeqan, un, un, codre3 ) + call gmmod ( ncequi//'.Trian', + > adeqtr, 2*nbeqtr, 2*nbeqtn, un, un, codre4 ) + call gmmod ( ncequi//'.Quadr', + > adeqqu, 2*nbeqqu, 2*nbeqqn, un, un, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + if ( codret.ne.0 ) then + write(ulsort,texte(langue,8)) ncequi + write(ulsort,texte(langue,9)) + > codre1, codre2, codre3, codre4, codre5 + endif +c + endif +c + if ( codret.eq.0 ) then +c + nbeqno = nbeqnn + nbeqmp = nbeqmn + nbeqar = nbeqan + nbeqtr = nbeqtn + nbeqqu = nbeqqn +c + endif +c +c 3.2. ==> Volumes dans le cas du recollement +c + if ( codret.eq.0 ) then +c + call gmliat ( ncequi, 7, nbeqte, codre1 ) + call gmliat ( ncequi, 8, nbeqhe, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbeqte.gt.0 ) then + call gmecat ( ncequi, 6, nbeqtr+nbeqqu, codre1 ) + call gmmod ( ncequi//'.Tetra', adeqte, + > 2, 2, nbeqte, nbeqtr+nbeqqu, codre2 ) + else + codre1 = 0 + codre2 = 0 + endif + if ( nbeqhe.gt.0 ) then + call gmecat ( ncequi, 7, nbeqtr+nbeqqu, codre3 ) + call gmmod ( ncequi//'.Hexae', adeqhe, + > 2, 2, nbeqhe, nbeqtr+nbeqqu, codre4 ) + else + codre3 = 0 + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad08.F b/src/tool/Utilitaire/utad08.F new file mode 100644 index 00000000..da8dd2c8 --- /dev/null +++ b/src/tool/Utilitaire/utad08.F @@ -0,0 +1,249 @@ + subroutine utad08 ( typenh, option, nhenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 08 +c -- -- -- +c ______________________________________________________________________ +c Suppression des tableaux des familles pour une entite HOM_Enti +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des destructions . +c . . . . 1 : la branche Famille complete . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : fami . +c . . . . 3 : cofa . +c . . . . si negatif, on ramene a une longueur nulle. +c . . . . si positif, on supprime le tableau . +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD08' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer typenh + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codava + integer codre0 + integer tabcod(12) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Suppressions des tableaux liees aux familles des '',a)' + texte(1,8) = '(''Codes de retour'',20i3)' +c + texte(2,4) = + > '(''Destruction of the arrays for the families of the '',a)' + texte(2,8) = '(''Error codes'',20i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option', option + call dmflsh (iaux) +#endif +c + do 10 , iaux = 1 , 3 + tabcod(iaux) = 0 + 10 continue +c + codava = codret + codret = 0 +c +c==== +c 2. Destruction totale +c==== +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + call gmsgoj ( nhenti//'.Famille' , codre0 ) +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(1) = codre0 + endif +c + endif +c +c==== +c 3. Destruction partielle +c==== +c + elseif ( option.gt.0 ) then +c +c 3.1. ==> Familles des entites +c + if ( mod(option,2).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( option.gt.0 ) then +c + call gmlboj ( nhenti//'.Famille.EntiFamm' , codre0 ) +c + else +c + call gmadoj ( nhenti//'.Famille.EntiFamm', + > iaux, jaux, codre0 ) +c + if ( codre0.eq.0 ) then + call gmmod ( nhenti//'.Famille.EntiFamm', iaux, + > jaux, 0, 1, 1, codre0 ) + endif +c + endif +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(1) = codre0 + endif +c + endif +c + endif +c +c 3.2. ==> Code des Familles +c + if ( mod(option,3).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( option.gt.0 ) then +c + call gmlboj ( nhenti//'.Famille.Codes' , codre0 ) +c + else +c + call gmadoj ( nhenti//'.Famille.Codes', + > iaux, jaux, codre0 ) +c + if ( codre0.eq.0 ) then + call gmmod ( nhenti//'.Famille.Codes', iaux, + > jaux, 0, 1, 1, codre0 ) + endif +c + endif +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(3) = codre0 + endif +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option' ,option + write (ulsort,90003) 'structure', nhenti + write (ulsort,texte(langue,8)) tabcod + call gmprsx ( nompro, nhenti ) + call gmprsx ( nompro, nhenti//'.Famille' ) +c + else +c + codret = codava +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad11.F b/src/tool/Utilitaire/utad11.F new file mode 100644 index 00000000..c5dcc9ee --- /dev/null +++ b/src/tool/Utilitaire/utad11.F @@ -0,0 +1,269 @@ + subroutine utad11 ( option, ncnoeu, nccono, + > adcoor, adfano, adneno, adcocs, + > adtyel, adfael, adnoel, adneel, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 11 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour MC_Noe et MC_CNo +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : coordonnees des noeuds . +c . . . . 3 : famille MED des noeuds . +c . . . . 5 : numerotation externe des noeuds . +c . . . . 7 : type des elements . +c . . . . 11 : famille MED des elements . +c . . . . 13 : noeuds des elements . +c . . . . 17 : numerotation externe des elements . +c . . . . 19 : constantes des coordonnees . +c . ncnoeu . e . char8 . nom de la branche Noeud . +c . nccono . e . char8 . nom de la branche ConnNoeu . +c . adcoor . s . 1 . coordonnees des noeuds . +c . adfano . s . 1 . famille MED des noeuds . +c . adneno . s . 1 . numerotation externe des noeuds . +c . adcocs . s . 1 . constantes des coordonnees . +c . adtyel . s . 1 . type des elements . +c . adfael . s . 1 . famille MED des elements . +c . adnoel . s . 1 . noeuds des elements . +c . adneel . s . 1 . numerotation externe des elements . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD11' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 ncnoeu, nccono +c + integer option + integer adcoor, adfano, adneno, adcocs + integer adtyel, adfael, adnoel, adneel +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer tabcod(8) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux entites'')' + texte(1,5) = '(''Option :'',i10)' + texte(1,8) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Adresses for entities'')' + texte(2,5) = '(''Option :'',i10)' + texte(2,6) = '(''Error codes'',20i3)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + call dmflsh (iaux) +#endif +c + do 10 , iaux = 1 , 8 + tabcod(iaux) = 0 + 10 continue +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Coordonnees des noeuds +c + if ( mod(option,2).eq.0 ) then +c + call gmadoj ( ncnoeu//'.Coor', adcoor, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 1 + tabcod(1) = codre0 + endif +c + endif +c +c 2.2. ==> Famille MED des noeuds +c + if ( mod(option,3).eq.0 ) then +c + call gmadoj ( ncnoeu//'.FamilMED', adfano, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(2) = codre0 + endif +c + endif +c +c 2.3. ==> Numerotation externe des noeuds +c + if ( mod(option,5).eq.0 ) then +c + call gmadoj ( ncnoeu//'.NumeExte', adneno, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(3) = codre0 + endif +c + endif +c +c 2.4. ==> Type des elements +c + if ( mod(option,7).eq.0 ) then +c + call gmadoj ( nccono//'.Type', adtyel, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 4 + tabcod(4) = codre0 + endif +c + endif +c +c 2.5. ==> Famille MED des elements +c + if ( mod(option,11).eq.0 ) then +c + call gmadoj ( nccono//'.FamilMED', adfael, iaux, codre0) +c + if ( codre0.ne.0 ) then + codret = 5 + tabcod(5) = codre0 + endif +c + endif +c +c 2.6. ==> Noeuds des elements +c + if ( mod(option,13).eq.0 ) then +c + call gmadoj ( nccono//'.Noeuds', adnoel, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 6 + tabcod(6) = codre0 + endif +c + endif +c +c 2.7. ==> Numerotation externe des elements +c + if ( mod(option,17).eq.0 ) then +c + call gmadoj ( nccono//'.NumeExte', adneel, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 7 + tabcod(7) = codre0 + endif +c + endif +c +c 2.8. ==> Constantes liees aux coordonnees +c + if ( mod(option,19).eq.0 ) then +c + call gmadoj ( ncnoeu//'.CoorCons', adcocs, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 8 + tabcod(8) = codre0 + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,8)) tabcod + call gmprsx ( nompro, nccono ) + call gmprsx ( nompro, ncnoeu ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad12.F b/src/tool/Utilitaire/utad12.F new file mode 100644 index 00000000..ed7120a5 --- /dev/null +++ b/src/tool/Utilitaire/utad12.F @@ -0,0 +1,170 @@ + subroutine utad12 ( option, typenh, + > nccoex, adcoex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 12 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour MC_Gr_En et MC_CEx +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 7 : code externe . +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nccoex . e . char8 . nom de la branche CodeExte . +c . adcoex . s . 1 . code externe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD12' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nccoex +c + integer option, typenh + integer adcoex +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + character*6 saux06 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux '',a)' + texte(1,5) = '(''Option :'',i10)' + texte(1,9) = '(''Erreur dans l''''adresse de code externe'')' +c + texte(2,4) = '(''Adresses for '',a)' + texte(2,5) = '(''Option :'',i10)' + texte(2,9) = '(''Error in address of external code'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> types d'entites +c + saux06 = '.'//suffix(1,typenh)(1:5) +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Code externe +c + if ( mod(option,7).eq.0 ) then +c + call gmadoj ( nccoex//saux06, adcoex, iaux, codret ) +c + if ( codret.ne.0 ) then + codret = 4 + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,5+codret)) + call gmprsx (nompro,nccoex//saux06) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad13.F b/src/tool/Utilitaire/utad13.F new file mode 100644 index 00000000..cd039186 --- /dev/null +++ b/src/tool/Utilitaire/utad13.F @@ -0,0 +1,179 @@ + subroutine utad13 ( option, ncfami, + > adnufa, adnofa, + > adgrpo, adgrtl, adgrtb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 13 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour MC_Fam +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : numero des familles . +c . . . . 3 : nom des familles . +c . . . . 5 : groupes . +c . ncfami . e . char8 . nom de la branche MC_Fam . +c . adnufa . s . 1 . numero des familles . +c . adnofa . s . 1 . nom des familles . +c . adgrpo . s . 1 . pointeurs des groupes . +c . adgrtl . s . 1 . taille des groupes . +c . adgrtb . s . 1 . table des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD13' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 ncfami +c + integer option + integer adnufa, adnofa + integer adgrpo, adgrtl, adgrtb +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer codre1, codre2, codre3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux entites'')' + texte(1,5) = '(''Option :'',i10)' +c + texte(2,4) = '(''Adresses for entities'')' + texte(2,5) = '(''Option :'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + call dmflsh (iaux) +#endif +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Numero des familles +c + if ( mod(option,2).eq.0 ) then +c + call gmadoj ( ncfami//'.Numero', adnufa, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.2. ==> Nom des familles +c + if ( mod(option,3).eq.0 ) then +c + call gmadoj ( ncfami//'.Nom', adnofa, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.3. ==> Groupes +c + if ( mod(option,5).eq.0 ) then +c + call gmadoj ( ncfami//'.Groupe.Pointeur', adgrpo, iaux, codre1 ) + call gmadoj ( ncfami//'.Groupe.Taille', adgrtl, iaux, codre2 ) + call gmadoj ( ncfami//'.Groupe.Table', adgrtb, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad21.F b/src/tool/Utilitaire/utad21.F new file mode 100644 index 00000000..d18169f4 --- /dev/null +++ b/src/tool/Utilitaire/utad21.F @@ -0,0 +1,240 @@ + subroutine utad21 ( nhnoeu, + > adcoor, adhist, adarno, + > adhono, addera, + > adcoco, adinfg, + > adreco, + > adfami, adcofa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 21 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour les noeuds HOM_Noeu +c Attention : Si le tableau est absent ou de longueur nulle, on +c retourne une adresse valant 0. C'est une valeur +c impossible car cela voudrait dire que malloc a reserve +c une place exactement la ou est le common. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhnoeu . e . char8 . nom de l'objet decrivant l'entite . +c . adhist . s . 1 . historique de l'etat . +c . adfami . s . 1 . famille des noeuds . +c . adcofa . s . 1 . codes des familles des noeuds . +c . adcoor . s . 1 . coordonnees . +c . adarno . s . 1 . arete supportant le noeud . +c . adhono . s . 1 . homologue du noeud . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD21' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nhnoeu +c + integer adcoor, adhist, adarno + integer adhono, addera + integer adcoco, adinfg + integer adreco + integer adfami, adcofa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre0 +c + character*16 saux16 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.3. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux noeuds'')' +c + texte(2,4) = '(''Adresses for nodes'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +ccc call gmprsx(nompro,nhnoeu) +#endif +c + codret = 0 +c +c==== +c 2. Reperage des tableaux +c On explore tous ceux possibles dans HOM_Noeu (cf. typobj.stu) +c==== +c + do 21 , iaux = 1 , 10 +c +c 2.1. ==> Le nom de la iaux-ieme branche +c + if ( codret.eq.0 ) then +c +c 1234567890123456 + if ( iaux.eq.1 ) then + saux16 = 'Coor ' + elseif ( iaux.eq.2 ) then + saux16 = 'HistEtat ' + elseif ( iaux.eq.3 ) then + saux16 = 'AretSupp ' + elseif ( iaux.eq.4 ) then + saux16 = 'Homologu ' + elseif ( iaux.eq.5 ) then + saux16 = 'Deraffin ' + elseif ( iaux.eq.6 ) then + saux16 = 'CoorCons ' + elseif ( iaux.eq.7 ) then + saux16 = 'InfoGene ' + elseif ( iaux.eq.8 ) then + saux16 = 'Recollem ' + elseif ( iaux.eq.9 ) then + saux16 = 'Famille.EntiFamm' + elseif ( iaux.eq.10 ) then + saux16 = 'Famille.Codes ' + endif +c + endif +c +c 2.2. ==> Recherche du tableau +c + if ( codret.eq.0 ) then +c +c 2.2.1. ==> Existence du tableau +c + call gmobal ( nhnoeu//'.'//saux16, codre0 ) +c +c 2.2.1. ==> Le tableau existe : quelles adresse et longueur ? +c + if ( codre0.eq.2 ) then +c + call gmadoj ( nhnoeu//'.'//saux16, jaux, kaux, codre0 ) +c + if ( codre0.eq.0 ) then + if ( kaux.eq.0 ) then + jaux = 0 + endif + else + codret = codret + 1 + endif +c +c 2.2.2. ==> Probleme +c + elseif ( codre0.ne.0 ) then + codret = codret + 1 +c +c 2.2.3. ==> Le tableau n'existe pas +c + else + jaux = 0 + endif +c + endif +c +c 2.3. ==> Stockage de l'adresse et eventuellement de la longueur +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + adcoor = jaux + elseif ( iaux.eq.2 ) then + adhist = jaux + elseif ( iaux.eq.3 ) then + adarno = jaux + elseif ( iaux.eq.4 ) then + adhono = jaux + elseif ( iaux.eq.5 ) then + addera = jaux + elseif ( iaux.eq.6 ) then + adcoco = jaux + elseif ( iaux.eq.7 ) then + adinfg = jaux + elseif ( iaux.eq.8 ) then + adreco = jaux + elseif ( iaux.eq.9 ) then + adfami = jaux + elseif ( iaux.eq.10 ) then + adcofa = jaux + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad22.F b/src/tool/Utilitaire/utad22.F new file mode 100644 index 00000000..fa503d85 --- /dev/null +++ b/src/tool/Utilitaire/utad22.F @@ -0,0 +1,283 @@ + subroutine utad22 ( nhenti, + > adcode, adcoar, adhist, + > adnivo, admere, adfill, + > adenho, + > adinsu, lginsu, + > adins2, lgins2, + > adnoim, + > addera, adinfg, + > adfami, adcofa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 22 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour une entite HOM_Enti +c Attention : Si le tableau est absent ou de longueur nulle, on +c retourne une adresse valant 0. C'est une valeur +c impossible car cela voudrait dire que malloc a reserve +c une place exactement la ou est le common. +c Remarque : utal02, utad02, utad22 et utad06 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . adcode . s . 1 . connectivite descendante . +c . adcoar . s . 1 . connectivite par aretes . +c . adhist . s . 1 . historique de l'etat . +c . adnivo . s . 1 . niveau des entites . +c . admere . s . 1 . mere des entites . +c . adfill . s . 1 . fille des entites . +c . adenho . s . 1 . homologues . +c . adinsu. s . 1 . informations supplementaires . +c . lginsu. s . 1 . longueur des informations supplementaires . +c . adins2. s . 1 . informations supplementaires numero 2 . +c . lgins2. s . 1 . longueur des informations supplementaires 2. +c . adnoim . s . 1 . noeud interne a la maille . +c . addera . s . 1 . deraffinement . +c . adinfg . s . 1 . informations generales . +c . adfami . s . 1 . famille des entites . +c . adcofa . s . 1 . code des familles des entites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD22' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer adcode, adcoar, adhist + integer adnivo, admere, adfill + integer adenho + integer adinsu, lginsu + integer adins2, lgins2 + integer adnoim + integer addera, adinfg + integer adfami, adcofa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre0 +c + character*16 saux16 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux entites'')' +c + texte(2,4) = '(''Adresses for entities'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +ccc call gmprsx(nompro,nhenti) +#endif +c + codret = 0 +c +c==== +c 2. Reperage des tableaux +c On explore tous ceux possibles dans HOM_Enti (cf. typobj.stu) +c==== +c + do 21 , iaux = 1 , 15 +c +c 2.1. ==> Le nom de la iaux-ieme branche +c + if ( codret.eq.0 ) then +c +c 1234567890123456 + if ( iaux.eq.1 ) then + saux16 = 'ConnDesc ' + elseif ( iaux.eq.2 ) then + saux16 = 'ConnAret ' + elseif ( iaux.eq.3 ) then + saux16 = 'HistEtat ' + elseif ( iaux.eq.4 ) then + saux16 = 'Niveau ' + elseif ( iaux.eq.5 ) then + saux16 = 'Mere ' + elseif ( iaux.eq.6 ) then + saux16 = 'Fille ' + elseif ( iaux.eq.7 ) then + saux16 = 'Homologu ' + elseif ( iaux.eq.8 ) then + saux16 = 'InfoSupp ' + elseif ( iaux.eq.9 ) then + saux16 = 'InfoSup2 ' + elseif ( iaux.eq.10 ) then + saux16 = 'NoeuInMa ' + elseif ( iaux.eq.11 ) then + saux16 = 'Deraffin ' + elseif ( iaux.eq.12 ) then + saux16 = 'InfoGene ' + elseif ( iaux.eq.13 ) then + saux16 = 'Recollem ' + goto 21 + elseif ( iaux.eq.14 ) then + saux16 = 'Famille.EntiFamm' + elseif ( iaux.eq.15 ) then + saux16 = 'Famille.Codes ' + endif +c + endif +c +c 2.2. ==> Recherche du tableau +c + if ( codret.eq.0 ) then +c +c 2.2.1. ==> Existence du tableau +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'tableau', saux16 +#endif +c + call gmobal ( nhenti//'.'//saux16, codre0 ) +c +c 2.2.1. ==> Le tableau existe : quelles adresse et longueur ? +c + if ( codre0.eq.2 ) then +c + call gmadoj ( nhenti//'.'//saux16, jaux, kaux, codre0 ) +c + if ( codre0.eq.0 ) then + if ( kaux.eq.0 ) then + jaux = 0 + endif + else + codret = codret + 1 + endif +c +c 2.2.2. ==> Probleme +c + elseif ( codre0.ne.0 ) then + codret = codret + 1 +c +c 2.2.3. ==> Le tableau n'existe pas : adresse fictive et longueur nulle +c + else + jaux = 0 + kaux = 0 + endif +c + endif +c +c 2.3. ==> Stockage de l'adresse et eventuellement de la longueur +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + adcode = jaux + elseif ( iaux.eq.2 ) then + adcoar = jaux + elseif ( iaux.eq.3 ) then + adhist = jaux + elseif ( iaux.eq.4 ) then + adnivo = jaux + elseif ( iaux.eq.5 ) then + admere = jaux + elseif ( iaux.eq.6 ) then + adfill = jaux + elseif ( iaux.eq.7 ) then + adenho = jaux + elseif ( iaux.eq.8 ) then + adinsu = jaux + lginsu = kaux + elseif ( iaux.eq.9 ) then + adins2 = jaux + lgins2 = kaux + elseif ( iaux.eq.10 ) then + adnoim = jaux + elseif ( iaux.eq.11 ) then + addera = jaux + elseif ( iaux.eq.12 ) then + adinfg = jaux + elseif ( iaux.eq.14 ) then + adfami = jaux + elseif ( iaux.eq.15 ) then + adcofa = jaux + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad31.F b/src/tool/Utilitaire/utad31.F new file mode 100644 index 00000000..1e6033a2 --- /dev/null +++ b/src/tool/Utilitaire/utad31.F @@ -0,0 +1,252 @@ + subroutine utad31 ( option, nohind, typenh, + > nbval, nbcomp, + > adsupp, advale, advalr, typind, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 31 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour une entite Indicate +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des adresses a recuperer. +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : attributs . +c . . . . 3 : adresse du support . +c . . . . 5 : adresses des valeurs . +c . . . . si negatif, on n'arrete pas quand la . +c . . . . structure n'est pas allouee . +c . nohind . e . char8 . nom de l'objet decrivant l'indicateur . +c . typenh . e . 1 . code des entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbval . s . 1 . nombre de valeurs par composante . +c . nbcomp . s . 1 . nombre de composantes . +c . adsupp . s . 1 . support . +c . advale . s . 1 . valeurs entieres, -1 si inexistante . +c . advalr . s . 1 . valeurs reelles, -1 si inexistante . +c . typind . s . 1 . type de valeurs . +c . . . . 2 : entieres . +c . . . . 3 : reelles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD31' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "enti01.h" +c +c 0.3. ==> arguments +c + character*8 nohind +c + integer option + integer typenh + integer nbval, nbcomp + integer adsupp, advale, advalr + integer typind +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer codre1, codre2 +c + character*14 saux14 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Adresses relatives a l''''indicateur HOMARD pour les '',a)' + texte(1,5) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Adresses for HOMARD indicator for '',a)' + texte(2,5) = '(''Error codes'',20i3)' +c + 1001 format ('Structure :',a) + 1002 format ('Option :',i10) +c +c==== +c 2. recuperation des adresses +c==== +c + if ( option.ne.0 ) then +c +c 2.1. ==> nom de la structure +c + saux14 = nohind//'.'//suffix(1,typenh)(1:5) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,1001) saux14 + write (ulsort,1002) option + call dmflsh (iaux) +#endif +cgn call gmprsx(nompro,saux14) +c +c 2.2. ==> la structure est-elle alloue ? +c + call gmobal ( saux14, codre0 ) +c + if ( codre0.eq.0 ) then + if ( option.lt.0 ) then + goto 29 + else + codret = max ( abs(codre0), codret ) + endif + elseif ( codre0.ne.1 ) then + codret = max ( abs(codre0), codret ) + endif +c +c 2.3. ==> attributs +c + if ( mod(option,2).eq.0 ) then +c + call gmliat ( saux14, 1, nbval, codre1 ) + call gmliat ( saux14, 2, nbcomp, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.4. ==> Support +c + if ( mod(option,3).eq.0 ) then +c + call gmadoj ( saux14//'.Support', adsupp, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.5. ==> Adresses des valeurs +c + if ( mod(option,5).eq.0 ) then +c + advale = -1 + advalr = -1 + typind = 0 +c + codre0 = 0 +c + call gmobal ( saux14//'.ValeursE', codre1 ) +c + if ( codre1.eq.2 ) then + typind = 2 + call gmadoj ( saux14//'.ValeursE', advale, iaux, codre2 ) + if ( codre2.ne.0 ) then + codre0 = 2 + endif +c + elseif ( codre1.eq.0 ) then + typind = 3 + call gmadoj ( saux14//'.ValeursR', advalr, iaux, codre2 ) + if ( codre2.ne.0 ) then + codre0 = 2 + endif +c + else + codre0 = 2 + endif +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 2.9. ==> sortie anticipee +c + 29 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,5)) codre1, codre2 + call gmprsx ( nompro, nohind ) + call gmprsx ( nompro, saux14 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad41.F b/src/tool/Utilitaire/utad41.F new file mode 100644 index 00000000..8505b5b3 --- /dev/null +++ b/src/tool/Utilitaire/utad41.F @@ -0,0 +1,200 @@ + subroutine utad41 ( nospec, + > nparrc, nptrrc, npqurc, + > npterc, npherc, npperc, nppyrc, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright 2016 EDF +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 41 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux pour les recollements +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nospec . e . char8 . nom de l'objet memorisant les specificites . +c . nparrc . s . 1 . nombre de paires d'aretes recollees . +c . nptrrc . s . 1 . nombre de paires de triangles recolles . +c . npqurc . s . 1 . nombre de paires de quadrangles recolles . +c . npterc . s . 1 . nombre de paires de tetraedres recolles . +c . npherc . s . 1 . nombre de paires d'hexaedres recolles . +c . npperc . s . 1 . nombre de paires de pentaedres recolles . +c . nppyrc . s . 1 . nombre de paires de pyramides recollees . +c . adarrc . s . 1 . paires d'aretes recollees . +c . adtrrc . s . 1 . paires de triangles recolles . +c . adqurc . s . 1 . paires de quadrangles recolles . +c . adterc . s . 1 . paires des tetra. voisins faces a recoller . +c . adherc . s . 1 . paires des hexa. voisins faces a recoller . +c . adperc . s . 1 . paires des penta. voisins faces a recoller . +c . adpyrc . s . 1 . paires des pyram. voisines faces a recoller. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD41' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nospec +c + integer nparrc, nptrrc, npqurc + integer npterc, npherc, npperc, nppyrc + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux recollements'')' +c + texte(2,4) = '(''Adresses for entities'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des nombres et des adresses +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nospec) +#endif +c +c 2.1. ==> Nombre de paires +c + call gmliat ( nospec, 1, nparrc, codre1 ) + call gmliat ( nospec, 2, nptrrc, codre2 ) + call gmliat ( nospec, 3, npqurc, codre3 ) + call gmliat ( nospec, 4, npterc, codre4 ) + call gmliat ( nospec, 5, npherc, codre5 ) + call gmliat ( nospec, 6, npperc, codre6 ) + call gmliat ( nospec, 7, nppyrc, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + if ( codret.ne.0 ) then + write (ulsort,90002) 'codre1-7', + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 + endif +c +c 2.2. ==> Adresses +c + if ( codret.eq.0 ) then +c + call gmadoj ( nospec//'.Tab1', adarrc, iaux, codre1 ) + call gmadoj ( nospec//'.Tab2', adtrrc, iaux, codre2 ) + call gmadoj ( nospec//'.Tab3', adqurc, iaux, codre3 ) + call gmadoj ( nospec//'.Tab4', adterc, iaux, codre4 ) + call gmadoj ( nospec//'.Tab5', adherc, iaux, codre5 ) + call gmadoj ( nospec//'.Tab6', adperc, iaux, codre6 ) + call gmadoj ( nospec//'.Tab7', adpyrc, iaux, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + if ( codret.ne.0 ) then + write (ulsort,90002) 'codre1-7', + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprot (nompro,nospec//'.Tab1',1,2*nparrc) + call gmprot (nompro,nospec//'.Tab2',1,2*nptrrc) + call gmprot (nompro,nospec//'.Tab3',1,2*npqurc) + call gmprot (nompro,nospec//'.Tab4',1,(nptrrc+npqurc)*3/2) + call gmprot (nompro,nospec//'.Tab5',1,(nptrrc+npqurc)*3/2) + call gmprot (nompro,nospec//'.Tab6',1,(nptrrc+npqurc)*3/2) + call gmprot (nompro,nospec//'.Tab7',1,(nptrrc+npqurc)*3/2) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad80.F b/src/tool/Utilitaire/utad80.F new file mode 100644 index 00000000..72334cc4 --- /dev/null +++ b/src/tool/Utilitaire/utad80.F @@ -0,0 +1,144 @@ + subroutine utad80 ( nbfich, + > adnore, adlono, adpono, adnofi, adnoos, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 80 +c -- -- -- +c ______________________________________________________________________ +c Recuperation des adresses des tableaux decrivant le fichier de +c configuration +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfich . s . 1 . nombre d'objets dans le fichier . +c . adnore . s . 1 . adresse . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD80' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfich + integer adnore, adlono, adpono, adnofi, adnoos +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6 + integer iaux +c + character*8 nomaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. recherche des adresses des objets GM lies aux noms des fichiers +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Recherche ; codret = ', codret +#endif +c + nomaux = osliob +c + call gmliat ( nomaux, 1, nbfich, codre1 ) + call gmadoj ( nomaux//'.NomRefer', adnore, iaux, codre2) + call gmadoj ( nomaux//'.LongNomF', adlono, iaux, codre3 ) + call gmadoj ( nomaux//'.PosiNomF', adpono, iaux, codre4 ) + call gmadoj ( nomaux//'.NomUFich', adnofi, iaux, codre5 ) + call gmadoj ( nomaux//'.NomObjSt', adnoos, iaux, codre6 ) +c + codret = min ( codre1, codre2, codre3, codre4, codre5, + > codre6 ) + codret = max ( abs(codret), + > codre1, codre2, codre3, codre4, codre5, + > codre6 ) +c + if ( codret.ne.0 ) then + codret = 1 + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad97.F b/src/tool/Utilitaire/utad97.F new file mode 100644 index 00000000..13f5a6ff --- /dev/null +++ b/src/tool/Utilitaire/utad97.F @@ -0,0 +1,365 @@ + subroutine utad97 ( typenh, option, deraff, extrus, + > nhenti, norenu, norenn, nosvmn, + > adhist, adcode, adcoar, adfill, admere, + > adfami, adcofa, adinsu, adins2, + > nbanen, pancen, + > adafen, adaeen, adafae, adaien, + > rsento, adencp, + > nbenac, nbento, adenho, adenca, + > lgenin, adenin, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 97 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . 1 : rien de special . +c . . . . 2 : recherche des fils py/te des hexa/penta. +c . deraff . e . logic . vrai/faux selon deraffinement . +c . extrus . e . 1 . prise en compte d'extrusion . +c . nhenti . e . char*8 . nom de l'objet de l'entite . +c . norenu . e . char*8 . nom de l'objet renumerotation iteration n+1. +c . norenn . e . char8 . nom de l'objet renumerotation iteration n . +c . nosvmn . e . char8 . nom de l'objet contenant les sauvegardes . +c . . . . du maillage n . +c . adhist . s . 1 . historique de l'etat . +c . adcode . s . 1 . connectivite descendante . +c . adcoar . s . 1 . connectivite par aretes . +c . adfill . s . 1 . fille des entites . +c . admere . s . 1 . mere des entites . +c . adfami . s . 1 . famille des entites . +c . adcofa . s . 1 . code des familles des entites . +c . adinsu. s . 1 . informations supplementaires . +c . adins2. s . 1 . informations supplementaires numero 2 . +c . adnoim . s . 1 . noeud interne a la maille . +c . nbanen . s . 1 . nombre ancien d'entites . +c . pancen . s . 1 . adresse des anciens numeros . +c . adafen . s . 1 . adresse des anciennes filles . +c . adaeen . s . 1 . adresse des anciens historiques d'etat . +c . adafae . s . 1 . adresse des anciennes familles . +c . adaien . s . 1 . adresse des anciennes informations . +c . rsento . s . 1 . nombre d'entites . +c . adencp . s . 1 . adresse de la numerotation dans le calcul . +c . nbenac . s . 1 . nombre d'entites actives iteration n . +c . nbento . s . 1 . nombre d'entites iteration n . +c . adenho . s . 1 . adresse de la numerotation dans HOMARD it n. +c . adenca . s . 1 . adresse de la numerotation dans le calcul n. +c . lgenin . s . 1 . longueur de la numer. init dans le calcul n. +c . adenin . s . 1 . adresse de la numer. init dans le calcul n . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD97' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "enti01.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer typenh, option + integer adhist, adcode, adcoar, adfill, admere + integer adfami, adcofa, adinsu, adins2 + integer adnoim, adhomo + integer nbanen, pancen + integer adafen, adaeen, adafae, adaien + integer rsento, adencp + integer nbenac, nbento, adenho, adenca + integer lgenin, adenin +c + character*8 nhenti, norenu, norenn, nosvmn +c + logical deraff + logical extrus +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre1, codre2 + integer codre0 +c + character*2 saux02 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Adresses relatives aux '',a)' +c + texte(2,4) = '(''Adresses for '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c + saux02 = suffix(3,typenh)(1:2) +c +c==== +c 2. structure generale +c==== +c 2.1. ==> Grandeurs generales +c + if ( typenh.eq.1 ) then + iaux = 6 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + else + iaux = 7770 + if ( typenh.eq.2 .or. typenh.eq.4 ) then + if ( extrus ) then + iaux = iaux*13 + endif + else + iaux = iaux*13 + if ( typenh.ge.6 ) then + if ( mod(option,2).eq.0 ) then + iaux = iaux*17 + endif + endif + endif + endif +c +c 2.2. ==> Pour les volumes, a-t-on des descriptions par aretes ? +c + if ( typenh.eq.3 .or. typenh.ge.5 ) then +c + call gmliat ( nhenti, 2, jaux, codret ) +c + if ( codret.eq.0 ) then +c + if ( jaux.gt.0 ) then + iaux = iaux*31 + endif +c + endif +c + endif +c +c 2.3. ==> Les adresses +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_'//saux02, nompro +#endif + call utad02 ( iaux, nhenti, + > adhist, adcode, adfill, admere, + > adfami, adcofa, jaux, + > jaux, adinsu, adins2, + > adnoim, adhomo, adcoar, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. ancienne structure si deraffinement +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'3. ancienne structure ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( deraff ) then +c + if ( codret.eq.0 ) then +cgn call gmprsx ( nompro,nhenti) +cgn call gmprsx ( nompro,nhenti//'.Deraffin') + call gmadoj ( nhenti//'.Deraffin', pancen, iaux, codret ) + endif +c + endif +c + endif +c +c==== +c 4. caracteristiques de l'etape precedente +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'4. precedente ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nosvmn, typenh, nbanen, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbanen.gt.0 ) then +c + call gmadoj ( nosvmn//'.Fille_'//saux02, adafen, iaux, codre1 ) + call gmadoj ( nosvmn//'.HEtat_'//saux02, adaeen, iaux, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( typenh.eq.2 ) then + call gmadoj ( nosvmn//'.Famil_'//saux02, adafae, iaux, codre0) + codret = max ( abs(codre0), codret ) + endif +c + if ( ( typenh.eq.6 .or. typenh.eq.7 ) .and. + > mod(option,2).eq.0) then +c + call gmobal ( nosvmn//'.Insu2_'//saux02, codre1 ) +c + if ( codre1.eq.0 ) then + codre0 = 0 + elseif ( codre1.eq.2 ) then + call gmadoj ( nosvmn//'.Insu2_'//saux02, + > adaien, iaux, codre0 ) + else + codre0 = 1 + endif +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. Renumerotations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002)'5. Renumerotations ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_'//saux02//'_new', nompro +#endif + iaux = -21 + call utre03 ( typenh, iaux, norenu, + > jaux, rsento, jaux, adencp, + > ulsort, langue, codret) +c + endif +c + if ( nbanen.gt.0 .or. extrus ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE03_'//saux02//'_anc', nompro +#endif + iaux = -2310 + call utre03 ( typenh, iaux, norenn, + > nbenac, nbento, adenho, adenca, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTRE04_'//saux02//'_anc', nompro +#endif + iaux = -11 + call utre04 ( typenh, iaux, norenn, + > lgenin, adenin, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad98.F b/src/tool/Utilitaire/utad98.F new file mode 100644 index 00000000..437f461c --- /dev/null +++ b/src/tool/Utilitaire/utad98.F @@ -0,0 +1,517 @@ + subroutine utad98 ( nomail, option, optio2, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, nbtaan, nbtano, + > nbhean, nbheno, nbhaan, nbhano, + > nbpyan, nbpyno, nbyaan, nbyano, + > nbpean, nbpeno, nbpaan, nbpano, + > phetar, psomar, pfilar, pmerar, pancar, + > pnp2ar, adhoar, + > phettr, paretr, pfiltr, ppertr, panctr, + > pnivtr, adpetr, adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pancqu, + > pnivqu, adhequ, adnmqu, adhoqu, + > phette, ptrite, pcotrt, parete, + > pfilte, pperte, pancte, + > phethe, pquahe, pcoquh, parehe, + > pfilhe, pperhe, panche, adnmhe, + > phetpy, pfacpy, pcofay, parepy, + > pfilpy, pperpy, pancpy, + > phetpe, pfacpe, pcofap, parepe, + > pfilpe, pperpe, pancpe, + > pfamar, pfamtr, pfamqu, + > pfamte, pfamhe, pfampy, pfampe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 98 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . option . e . 1 . 0 : on detruit les objets de taille nulle . +c . . . . 1 : on garde les objets de taille nulle . +c . optio2 . e . 1 . 1 : on raccourcit les volu/face des extrus.. +c . . . . 0 : on ne fait rien . +c . nbenan . e . 1 . si < 0 : on ne modifie rien pour l'entite . +c . . . . si >= 0 : ancien nombre d'entite . +c . nbenno . e . 1 . nouveau nombre d'entite . +c . nbeaan . e . 1 . ancien nombre d'entite decrits par aretes . +c . nbeano . e . 1 . nouveau nombre d'entite decrits par aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD98' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer option, optio2 + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno, nbtaan, nbtano + integer nbhean, nbheno, nbhaan, nbhano + integer nbpyan, nbpyno, nbyaan, nbyano + integer nbpean, nbpeno, nbpaan, nbpano + integer phetar, psomar, pfilar, pmerar, pancar, pnp2ar + integer adhoar + integer phettr, paretr, pfiltr, ppertr, panctr, pnivtr + integer adpetr, adnmtr + integer adhotr + integer phetqu, parequ, pfilqu, pperqu, pancqu, pnivqu + integer adhequ, adnmqu + integer adhoqu + integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte + integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche + integer adnmhe + integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy + integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe + integer pfamar + integer pfamtr + integer pfamqu + integer pfamte + integer pfamhe + integer pfampy + integer pfampe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer typenh +c + integer codre0 +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(''Modification de taille des tableaux des '',a)' + texte(1,7) = '(5x,''==> code de retour :'',i8)' +c + texte(2,6) = '(''Size modification of arrays for '',a)' + texte(2,7) = '(5x,''==> error code :'',i8)' +c +#include "impr03.h" +c +c==== +c 2. structure generale +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c +c==== +c 3. tableaux +c==== +c 3.1. ==> Les aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. ==> aretes, codret', codret + write (ulsort,90002) 'nbaran', nbaran + write (ulsort,90002) 'nbarno', nbarno +#endif +c + if ( ( nbaran.ne.nbarno ) .and. ( nbaran.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 1 + iaux = 210 + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call gmobal ( nharet//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_ar', nompro +#endif + call utad06 ( typenh, iaux, option, nharet, + > nbaran, nbarno, 0, 0, + > phetar, psomar, pfilar, pmerar, + > pfamar, + > jaux, pnp2ar, jaux, + > jaux, pancar, adhoar, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,1) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.2. ==> Les triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. triangles, codret', codret + write (ulsort,90002) 'nbtran', nbtran + write (ulsort,90002) 'nbtrno', nbtrno +#endif +c + if ( ( nbtran.ne.nbtrno ) .and. ( nbtran.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 2 + iaux = 7 + if ( nbtran.gt.0 ) then + iaux = iaux*330 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( optio2.eq.1 ) then + iaux = iaux*13 + endif + endif + call gmobal ( nhtria//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_tr', nompro +#endif + call utad06 ( typenh, iaux, option, nhtria, + > nbtran, nbtrno, 0, 0, + > phettr, paretr, pfiltr, ppertr, + > pfamtr, + > pnivtr, adpetr, jaux, + > adnmtr, panctr, adhotr, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,2) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.3. ==> Les quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. quadrangles, codret', codret + write (ulsort,90002) 'nbquan', nbquan + write (ulsort,90002) 'nbquno', nbquno +#endif +c + if ( ( nbquan.ne.nbquno ) .and. ( nbquan.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 4 + iaux = 2310 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + call gmobal ( nhquad//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif + if ( optio2.eq.1 ) then + iaux = iaux*13 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_qu', nompro +#endif + call utad06 ( typenh, iaux, option, nhquad, + > nbquan, nbquno, 0, 0, + > phetqu, parequ, pfilqu, pperqu, + > pfamqu, + > pnivqu, adhequ, jaux, + > adnmqu, pancqu, adhoqu, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,4) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.4. ==> Les tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. tetraedres, codret', codret + write (ulsort,90002) 'nbtean', nbtean + write (ulsort,90002) 'nbteno', nbteno + write (ulsort,90002) 'nbtaan, nbtano,', nbtaan, nbtano +#endif +c + if ( ( nbtean.ne.nbteno ) .and. ( nbtean.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 3 + iaux = 7 + if ( nbtean.gt.0 ) then + iaux = iaux*390 + endif + call gmobal ( nhtetr//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( ( nbtaan.ne.nbtano ) .and. ( nbtaan.gt.0 ) ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_te', nompro +#endif + call utad06 ( typenh, iaux, option, nhtetr, + > nbtean, nbteno, nbtaan, nbtano, + > phette, ptrite, pfilte, pperte, + > pfamte, + > jaux, pcotrt, jaux, + > jaux, pancte, jaux, parete, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,3) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.5. ==> Les pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.5. pyramides, codret', codret + write (ulsort,90002) 'nbpyan', nbpyan + write (ulsort,90002) 'nbpyno', nbpyno + write (ulsort,90002) 'nbyaan, nbyano,', nbyaan, nbyano +#endif +c + if ( ( nbpyan.ne.nbpyno ) .and. ( nbpyan.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 5 + iaux = 7 + if ( nbpyan.gt.0 ) then + iaux = iaux*390 + endif + call gmobal ( nhpyra//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( ( nbyaan.ne.nbyano ) .and. ( nbyaan.gt.0 ) ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_py', nompro +#endif + call utad06 ( typenh, iaux, option, nhpyra, + > nbpyan, nbpyno, nbyaan, nbyano, + > phetpy, pfacpy, pfilpy, pperpy, + > pfampy, + > jaux, pcofay, jaux, + > jaux, pancpy, jaux, parepy, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,5) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.6. ==> Les hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.6. ==> hexaedres, codret', codret + write (ulsort,90002) 'nbhean', nbhean + write (ulsort,90002) 'nbheno', nbheno + write (ulsort,90002) 'nbhaan, nbhano,', nbhaan, nbhano +#endif +c + if ( ( nbhean.ne.nbheno ) .and. ( nbhean.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 6 + iaux = 210*13 + if ( mod(mailet,5).eq.0 ) then + iaux = iaux*19 + endif + call gmobal ( nhhexa//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( ( nbhaan.ne.nbhano ) .and. ( nbhaan.gt.0 ) ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_he', nompro +#endif + call utad06 ( typenh, iaux, option, nhhexa, + > nbhean, nbheno, nbhaan, nbhano, + > phethe, pquahe, pfilhe, pperhe, + > pfamhe, + > jaux, pcoquh, jaux, + > adnmhe, panche, jaux, parehe, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,6) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c 3.7. ==> Les pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.7. ==> pentaedres, codret', codret + write (ulsort,90002) 'nbpean', nbpean + write (ulsort,90002) 'nbpeno', nbpeno + write (ulsort,90002) 'nbpaan, nbpano,', nbpaan, nbpano +#endif +c + if ( ( nbpean.ne.nbpeno ) .and. ( nbpean.ge.0 ) ) then +c + if ( codret.eq.0 ) then +c + typenh = 7 + iaux = 2730 + call gmobal ( nhpent//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + iaux = iaux*23 + endif + if ( ( nbpaan.ne.nbpano ) .and. ( nbpaan.gt.0 ) ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD06_pe', nompro +#endif + call utad06 ( typenh, iaux, option, nhpent, + > nbpean, nbpeno, nbpaan, nbpano, + > phetpe, pfacpe, pfilpe, pperpe, + > pfampe, + > jaux, pcofap, jaux, + > jaux, pancpe, jaux, parepe, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,5) + write (ulsort,texte(langue,7)) codret +#endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utad99.F b/src/tool/Utilitaire/utad99.F new file mode 100644 index 00000000..5c753b2d --- /dev/null +++ b/src/tool/Utilitaire/utad99.F @@ -0,0 +1,284 @@ + subroutine utad99 ( nomail, + > phetar, psomar, pfilar, pmerar, adhoar, + > phettr, paretr, pfiltr, ppertr, pnivtr, + > adnmtr, adhotr, + > phetqu, parequ, pfilqu, pperqu, pnivqu, + > adnmqu, adhoqu, + > phette, ptrite, + > phethe, pquahe, pcoquh, + > phetpy, pfacpy, pcofay, + > phetpe, pfacpe, pcofap, + > nhvois, nharet, nhtria, nhquad, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ADresses - phase 99 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAD99' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer phetar, psomar, pfilar, pmerar, adhoar + integer phettr, paretr, pfiltr, ppertr, pnivtr + integer adnmtr, adhotr + integer phetqu, parequ, pfilqu, pperqu, pnivqu + integer adnmqu, adhoqu + integer phette, ptrite + integer phethe, pquahe, pcoquh + integer phetpy, pfacpy, pcofay + integer phetpe, pfacpe, pcofap +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. structure generale +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c +c==== +c 3. tableaux +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. tableaux ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 30 + if ( homolo.ge.2 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, pfilar, pmerar, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, adhoar, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 330 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, pfiltr, ppertr, + > jaux, jaux, jaux, + > pnivtr, jaux, jaux, + > adnmtr, adhotr, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 330 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*19 + endif + if ( homolo.ge.3 ) then + iaux = iaux*29 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, pfilqu, pperqu, + > jaux, jaux, jaux, + > pnivqu, jaux, jaux, + > adnmqu, adhoqu, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 26 + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 26 + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 26 + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utadpt.F b/src/tool/Utilitaire/utadpt.F new file mode 100644 index 00000000..7e280330 --- /dev/null +++ b/src/tool/Utilitaire/utadpt.F @@ -0,0 +1,207 @@ + subroutine utadpt ( nobjet, choix, + > nombre, lgtabl, + > adpoin, adtail, adtabl, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ADresses d'un objet de type PtTabxxx +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nobjet . e . char8 . nom de l'objet PtTabxxx . +c . choix . e . 1 . option de la recherche : . +c . . . . 2 : les attributs . +c . . . . 3 : les adresses . +c . nombre . s . 1 . le tableau Pointeur est (0:nombre) . +c . lgtabl . s . 1 . longueur commune a Taille et Table . +c . adpoin . s . 1 . adresse de Pointeur . +c . adtail . s . 1 . adresse de Taille . +c . adtabl . s . 1 . adresse de Table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTADPT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) nobjet +c + integer choix + integer nombre, lgtabl + integer adpoin, adtail, adtabl +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2 + integer codre0 + integer iaux +c + character*8 nomobj +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'choix', choix +#endif +c +c 1.2. ==> Nom court de l'objet +c + call gmnomc ( nobjet, nomobj, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Taille' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c +c==== +c 2. Attributs +c==== +c + if ( mod(choix,2).eq.0 ) then +c + call gmliat ( nomobj, 1, nombre, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nombre', nombre +#endif +c + if ( codret.eq.0 ) then +c + if ( nombre.gt.0 ) then + call gmliat ( nomobj, 2, lgtabl, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgtabl', lgtabl +#endif + endif +c + endif +c + endif +c +c==== +c 3. Adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Adresses ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nomobj, 1, nombre, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nombre', nombre +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( mod(choix,3).eq.0 .and. nombre.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nomobj//'.Pointeur', adpoin, iaux, codre1 ) + call gmadoj ( nomobj//'.Table' , adtabl, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmobal ( nomobj//'.Taille', codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( nomobj//'.Taille', adtail, iaux, codret ) + elseif ( codre0.ne.0 ) then + codret = 2 + endif +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utafqu.F b/src/tool/Utilitaire/utafqu.F new file mode 100644 index 00000000..5f40b591 --- /dev/null +++ b/src/tool/Utilitaire/utafqu.F @@ -0,0 +1,133 @@ + subroutine utafqu ( somare, filare, a1, a2, a3, a4, + > as1n1, as2n1, + > as2n2, as3n2, + > as3n3, as4n3, + > as4n4, as1n4 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Aretes Filles - QUadrangle +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . filare . e . nbaret . premiere fille des aretes . +c .a1,..,a4. e . 1 . les numeros des aretes du quadrangle . +c . asinj . s . 1 . arete entre le sommet i et le milieu de . +c . . . . l'arete j du triangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), filare(*) + integer a1, a2, a3, a4 + integer as1n1, as2n1 + integer as2n2, as3n2 + integer as3n3, as4n3 + integer as4n4, as1n4 +c +c 0.4. ==> variables locales +c + integer s1, s2, s3, s4 + integer iaux +c +c==== +c 1. on cherche les numeros des sommets du quadrangle defini par ses +c==== +c +cgn10000 format('arete a',i1,' :',i2,' de',i3,' a',i3) +cgn20000 format('sommet S',i1,' :',i3) +cgn write(1,10000) 1, a1, somare(1,a1), somare(2,a1) +cgn write(1,10000) 2, a2, somare(1,a2), somare(2,a2) +cgn write(1,10000) 3, a3, somare(1,a3), somare(2,a3) +cgn write(1,10000) 4, a4, somare(1,a4), somare(2,a4) + call utsoqu ( somare, a1, a2, a3, a4, + > s2, s3, s4, s1 ) +cgn write(1,20000) 1, s1 +cgn write(1,20000) 2, s2 +cgn write(1,20000) 3, s3 +cgn write(1,20000) 4, s4 +c +c==== +c 2. Filles des aretes +c On s'appuie sur le fait que le second noeud des aretes filles +c de ak est, par construction, le noeud au milieu de ak. +c Donc le premier est l'un des 2 noeuds de ak. +c==== +c +cgn30000 format('arete ',a5,' :',i3,' de',i3,' a',i3) + iaux = filare(a1) + if ( somare(1,iaux).eq.s1 ) then + as1n1 = iaux + as2n1 = iaux + 1 + else + as1n1 = iaux + 1 + as2n1 = iaux + endif +cgn write(1,30000) 'as2n1', as2n1, somare(1,as2n1), somare(2,as2n1) +cgn write(1,30000) 'as3n1', as3n1, somare(1,as3n1), somare(2,as3n1) +c + iaux = filare(a2) + if ( somare(1,iaux).eq.s2 ) then + as2n2 = iaux + as3n2 = iaux + 1 + else + as2n2 = iaux + 1 + as3n2 = iaux + endif +cgn write(1,30000) 'as1n2', as1n2, somare(1,as1n2), somare(2,as1n2) +cgn write(1,30000) 'as3n2', as3n2, somare(1,as3n2), somare(2,as3n2) +c + iaux = filare(a3) + if ( somare(1,iaux).eq.s3 ) then + as3n3 = iaux + as4n3 = iaux + 1 + else + as3n3 = iaux + 1 + as4n3 = iaux + endif +cgn write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3) +cgn write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3) +c + iaux = filare(a4) + if ( somare(1,iaux).eq.s4 ) then + as4n4 = iaux + as1n4 = iaux + 1 + else + as4n4 = iaux + 1 + as1n4 = iaux + endif +cgn write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3) +cgn write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3) +c + end diff --git a/src/tool/Utilitaire/utaftr.F b/src/tool/Utilitaire/utaftr.F new file mode 100644 index 00000000..a9f7f631 --- /dev/null +++ b/src/tool/Utilitaire/utaftr.F @@ -0,0 +1,137 @@ + subroutine utaftr ( somare, filare, a1, a2, a3, + > as2n1, as3n1, + > as3n2, as1n2, + > as1n3, as2n3 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Aretes Filles - TRiangle +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . filare . e . nbaret . premiere fille des aretes . +c .a1,a2,a3. e . 1 . les numeros des aretes du triangle . +c . asinj . s . 1 . arete entre le sommet i et le milieu de . +c . . . . l'arete j du triangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), filare(*) + integer a1, a2, a3 + integer as2n1, as3n1 + integer as3n2, as1n2 + integer as1n3, as2n3 +c +c 0.4. ==> variables locales +c + integer s1, s2, s3 + integer iaux +c +c==== +c 1. on cherche les numeros des sommets du triangle defini par ses +c aretes a1, a2 et a3 avec la convention : +c le sommet si est en face de l'arete ai +c remarque : utsotr et utaftr sont semblables +c==== +c +cgn10000 format('arete a',i1,' :',i2,' de',i3,' a',i3) +cgn20000 format('sommet S',i1,' :',i3) +cgn write(1,10000) 1, a1, somare(1,a1), somare(2,a1) +cgn write(1,10000) 2, a2, somare(1,a2), somare(2,a2) +cgn write(1,10000) 3, a3, somare(1,a3), somare(2,a3) + s1 = 0 + if ( somare(1,a1).eq.somare(1,a3) ) then + s2 = somare(1,a1) + s1 = somare(2,a3) + elseif ( somare(1,a1).eq.somare(2,a3) ) then + s2 = somare(1,a1) + s1 = somare(1,a3) + endif +c + if ( s1.eq.0 ) then + if ( somare(2,a1).eq.somare(1,a3) ) then + s2 = somare(2,a1) + s1 = somare(2,a3) + elseif ( somare(2,a1).eq.somare(2,a3) ) then + s2 = somare(2,a1) + s1 = somare(1,a3) + endif + s3 = somare(1,a1) + else + s3 = somare(2,a1) + endif +cgn write(1,20000) 1, s1 +cgn write(1,20000) 2, s2 +cgn write(1,20000) 3, s3 +c +c==== +c 2. Filles des aretes +c==== +c +cgn30000 format('arete ',a5,' :',i3,' de',i3,' a',i3) + iaux = filare(a1) + if ( somare(1,iaux).eq.s2 ) then + as2n1 = iaux + as3n1 = iaux + 1 + else + as2n1 = iaux + 1 + as3n1 = iaux + endif +cgn write(1,30000) 'as2n1', as2n1, somare(1,as2n1), somare(2,as2n1) +cgn write(1,30000) 'as3n1', as3n1, somare(1,as3n1), somare(2,as3n1) +c + iaux = filare(a2) + if ( somare(1,iaux).eq.s1 ) then + as1n2 = iaux + as3n2 = iaux + 1 + else + as1n2 = iaux + 1 + as3n2 = iaux + endif +cgn write(1,30000) 'as1n2', as1n2, somare(1,as1n2), somare(2,as1n2) +cgn write(1,30000) 'as3n2', as3n2, somare(1,as3n2), somare(2,as3n2) +c + iaux = filare(a3) + if ( somare(1,iaux).eq.s1 ) then + as1n3 = iaux + as2n3 = iaux + 1 + else + as1n3 = iaux + 1 + as2n3 = iaux + endif +cgn write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3) +cgn write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3) +c + end diff --git a/src/tool/Utilitaire/utahma.F b/src/tool/Utilitaire/utahma.F new file mode 100644 index 00000000..e3309cb2 --- /dev/null +++ b/src/tool/Utilitaire/utahma.F @@ -0,0 +1,597 @@ + subroutine utahma ( nomail, typnom, option, + > sdim, mdim, degre, mailet, maconf, + > homolo, hierar, rafdef, + > nbmane, typcca, typsfr, maextr, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Allocation pour HOMARD - MAillage +c -- - - -- +c +c Branche InfoSupE : +c Tab1 : communs entiers +c Tab2 : type des elements +c Si le format externe est le format MED : +c Tab3 : tableau de la branche Famille.Attribut.Pointeur +c Tab4 : tableau de la branche Famille.Attribut +c Tab5 : tableau de la branche Famille.Groupe.Pointeur +c Tab6 : tableau de la branche Famille.Groupe.Taille +c Tab7 : tableau de la branche InfoGene.Pointeur +c Tab8 : tableau de la branche InfoGene.Taille +c Tab9 : tableau de la branche Famille.Numero +c Branche InfoSupS : +c Tab1 : commun de la date +c Si le format externe est le format MED : +c Tab2 : tableau de la branche Famille.Groupe.Table +c Tab3 : tableau de la branche InfoGene.Table +c Tab4 : tableau de la branche Famille.Nom +c Tab5 : tableau de la branche Equivalt.InfoGene +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . es . char8 . nom de l'objet maillage homard . +c . typnom . e . 1 . type du nom de l'objet maillage . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . option . e . 1 . option de creation de l'objet maillage . +c . . . . 1 : toutes les branches sont a creer . +c . . . . 2x : sauf la branche RenuMail . +c . sdim . e . 1 . dimension de l'espace . +c . mdim . e . 1 . dimension du maillage . +c . degre . e . 1 . degre du maillage . +c . maconf . e . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . homolo . e . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . hierar . e . 1 . maillage hierarchique . +c . . . . 0 : non . +c . . . . 1 : oui . +c . rafdef . e . 1 . 0 : macro-maillage . +c . . . . 1 : le maillage est inchange . +c . . . . 2 : le maillage est issu du raffinement pur. +c . . . . d'un autre maillage . +c . . . . 3 : le maillage est issu du deraffinement . +c . . . . pur d'un autre maillage . +c . . . . 4 : le maillage est issu de raffinement et . +c . . . . de deraffinement d'un autre maillage . +c . . . . 12 : le maillage est un maillage passe de . +c . . . . degre 1 a 2 . +c . . . . 21 : le maillage est un maillage passe de . +c . . . . degre 2 a 1 . +c . nbmane . e . 1 . nombre maximum de noeuds par element . +c . typcca . e . 1 . type du code de calcul . +c . typsfr . e . 1 . type du suivi de frontiere . +c . . . . 0 : aucun . +c . . . . 1 : maillage de degre 1, avec projection . +c . . . . des nouveaux sommets . +c . . . . 2 : maillage de degre 2, seuls les noeuds . +c . . . . P1 sont sur la frontiere ; les noeuds . +c . . . . P2 restent au milieu des P1 . +c . . . . 3 : maillage de degre 2, les noeuds P2 . +c . . . . etant sur la frontiere . +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . mailet . e . 1 . presence de mailles etendues . +c . . . . 1 : aucune . +c . . . . 2x : TRIA7 . +c . . . . 3x : QUAD9 . +c . . . . 5x : HEXA27 . +c . norenu . s . char8 . nom de la branche RenuMail . +c . nhnoeu . s . char8 . nom de la branche Noeud . +c . nhmapo . s . char8 . nom de la branche Ma_Point . +c . nharet . s . char8 . nom de la branche Arete . +c . nhtria . s . char8 . nom de l'objet decrivant les triangles . +c . nhquad . s . char8 . nom de l'objet decrivant les quadrangles . +c . nhtetr . s . char8 . nom de l'objet decrivant les tetraedres . +c . nhhexa . s . char8 . nom de l'objet decrivant les hexaedres . +c . nhpyra . s . char8 . nom de l'objet decrivant les pyramides . +c . nhpent . s . char8 . nom de l'objet decrivant les pentaedres . +c . nhvois . s . char8 . nom de la branche Voisins . +c . nhsupe . s . char8 . informations supplementaires entieres . +c . nhsups . s . char8 . informations supplementaires caracteres 8 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAHMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer typnom, option +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8, codre9 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Allocation d''''un objet maillage HOMARD'',/)' + texte(1,5) = '(''Mauvaise demande de type de nom :'',i6)' + texte(1,6) = '(''Probleme pour allouer l''''objet '',a8)' + texte(1,7) = '(''Probleme pour allouer un objet temporaire.'')' +c + texte(2,4) = '(''Allocation of an object HOMARD mesh'',/)' + texte(2,5) = '(''Bad request for the type of the name :'',i6)' + texte(2,6) = '(''Problem while allocating object '',a8)' + texte(2,7) = '(''Problem while allocating a temporary object.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'sdim ', sdim + write (ulsort,90002) 'mdim ', mdim + write (ulsort,90002) 'degre ', degre + write (ulsort,90002) 'mailet', mailet + write (ulsort,90002) 'maconf', maconf + write (ulsort,90002) 'homolo', homolo + write (ulsort,90002) 'hierar', hierar + write (ulsort,90002) 'rafdef', rafdef + write (ulsort,90002) 'nbmane', nbmane + write (ulsort,90002) 'typcca', typcca + write (ulsort,90002) 'typsfr', typsfr + write (ulsort,90002) 'maextr', maextr +#endif +c +c==== +c 2. allocation de la structure du maillage HOMARD +c==== +c 2.1. ==> allocation de la tete du maillage HOMARD +c + if ( typnom.eq.0 ) then +c + call gmalot ( nomail, 'HOM_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nomail, 'HOM_Mail', 0, iaux, codre1 ) + codret = abs(codre1) +c + else +c + codret = -1 +c + endif +c +c 2.2. ==> Attributs +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2.2. attributs ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nomail, 1, sdim, codre1 ) + call gmecat ( nomail, 2, mdim, codre2 ) + call gmecat ( nomail, 3, degre, codre3 ) + call gmecat ( nomail, 4, maconf, codre4 ) + call gmecat ( nomail, 5, homolo, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmecat ( nomail, 6, hierar, codre1 ) + call gmecat ( nomail, 7, rafdef, codre2 ) + call gmecat ( nomail, 8, nbmane, codre3 ) + call gmecat ( nomail, 9, typcca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmecat ( nomail,10, typsfr, codre1 ) + call gmecat ( nomail,11, maextr, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. Allocation des branches principales +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. branches principales ; codret = ', codret +#endif +c +c 3.1. ==> Allocation des branches principales +c + if ( codret.eq.0 ) then +c + call gmaloj ( nomail//'.Noeud' , ' ', 0, iaux, codre1 ) + call gmaloj ( nomail//'.Ma_Point', ' ', 0, iaux, codre2 ) + call gmaloj ( nomail//'.Arete' , ' ', 0, iaux, codre3 ) + call gmaloj ( nomail//'.Face' , ' ', 0, iaux, codre4 ) + call gmaloj ( nomail//'.Volume' , ' ', 0, iaux, codre5 ) + call gmaloj ( nomail//'.ElemIgno', ' ', 0, iaux, codre6 ) + call gmaloj ( nomail//'.Voisins' , ' ', 0, iaux, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + call gmaloj ( nomail//'.InfoSupE', ' ', 0, iaux, codre1 ) + call gmaloj ( nomail//'.InfoSupS', ' ', 0, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 3.2. ==> Allocation des branches optionnelles +c + if ( codret.eq.0 ) then +c + if ( mod(option,2).ne.0 ) then +c + call gmaloj ( nomail//'.RenuMail', ' ', 0, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + if ( codret.eq.0 ) then +c + call gmaloj ( nomail//'.RenuMail.InfoSupE', + > ' ', 0, iaux, codre1 ) + codre2 = 0 + do 32 , iaux = 1 , 10 + call gmecat ( nomail//'.RenuMail.InfoSupE', iaux, 0, codre0 ) + codre2 = max ( abs(codre2), codre0 ) + 32 continue +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + endif +c +c==== +c 4. branches decrivant les elements +c on le fait pour un nombre nul d'elements +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. branches des elements ; codret = ', codret +#endif +c 4.1. ==> allocation +c + jaux = 0 +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then + call gmaloj (nomail//'.Arete.HOM_Se02' , ' ', jaux, iaux,codre1) + call gmaloj (nomail//'.Face.HOM_Tr03' , ' ', jaux, iaux,codre2) + call gmaloj (nomail//'.Face.HOM_Qu04' , ' ', jaux, iaux,codre3) + call gmaloj (nomail//'.Volume.HOM_Te04', ' ', jaux, iaux,codre4) + call gmaloj (nomail//'.Volume.HOM_He08', ' ', jaux, iaux,codre5) + call gmaloj (nomail//'.Volume.HOM_Py05', ' ', jaux, iaux,codre6) + call gmaloj (nomail//'.Volume.HOM_Pe06', ' ', jaux, iaux,codre7) + else + call gmaloj (nomail//'.Arete.HOM_Se03' , ' ', jaux, iaux,codre1) + if ( mod(mailet,2).eq.0 .or. mod(mailet,3).eq.0 ) then + call gmaloj (nomail//'.Face.HOM_Tr07', ' ', jaux, iaux,codre2) + else + call gmaloj (nomail//'.Face.HOM_Tr06', ' ', jaux, iaux,codre2) + endif + if ( mod(mailet,3).eq.0 ) then + call gmaloj (nomail//'.Face.HOM_Qu09', ' ', jaux, iaux,codre3) + else + call gmaloj (nomail//'.Face.HOM_Qu08', ' ', jaux, iaux,codre3) + endif + call gmaloj (nomail//'.Volume.HOM_Te10', ' ', jaux, iaux,codre4) + if ( mod(mailet,5).eq.0 ) then + call gmaloj (nomail//'.Volume.HOM_He27', + > ' ', jaux, iaux, codre5) + else + call gmaloj (nomail//'.Volume.HOM_He20', + > ' ', jaux, iaux, codre5) + endif + call gmaloj (nomail//'.Volume.HOM_Py13', ' ', jaux, iaux,codre6) + call gmaloj (nomail//'.Volume.HOM_Pe15', ' ', jaux, iaux,codre7) + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c 4.2. ==> nom interne de ces branches +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.2. nom interne ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 4.3. ==> on met un nombre nul de mailles a priori +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.3 ; codret = ', codret +#endif +c + jaux = 0 +c + do 43 , iaux = 1 , 2 +c + if ( codret.eq.0 ) then +c + call gmecat ( nhmapo, iaux, jaux, codre1 ) + call gmecat ( nharet, iaux, jaux, codre2 ) + call gmecat ( nhtria, iaux, jaux, codre3 ) + call gmecat ( nhtetr, iaux, jaux, codre4 ) + call gmecat ( nhquad, iaux, jaux, codre5 ) + call gmecat ( nhpyra, iaux, jaux, codre6 ) + call gmecat ( nhhexa, iaux, jaux, codre7 ) + call gmecat ( nhpent, iaux, jaux, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + endif +c + 43 continue +c + call gmecat ( nhelig, 1, jaux, codre0 ) + codret = max ( abs(codre0), codret ) +c +c 4.4. ==> idem en renumerotation +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.4 ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(option,2).ne.0 ) then +c + do 44 , iaux = 1 , 19 +c + jaux = iaux + kaux = 0 + call gmecat ( norenu, jaux, kaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + 44 continue +c + endif +c + endif +c +c==== +c 5. allocation de la branche des familles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. familles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhnoeu//'.Famille', ' ', 0, iaux, codre1 ) + call gmaloj ( nhmapo//'.Famille', ' ', 0, iaux, codre2 ) + call gmaloj ( nharet//'.Famille', ' ', 0, iaux, codre3 ) + call gmaloj ( nhtria//'.Famille', ' ', 0, iaux, codre4 ) + call gmaloj ( nhtetr//'.Famille', ' ', 0, iaux, codre5 ) + call gmaloj ( nhquad//'.Famille', ' ', 0, iaux, codre6 ) + call gmaloj ( nhpyra//'.Famille', ' ', 0, iaux, codre7 ) + call gmaloj ( nhhexa//'.Famille', ' ', 0, iaux, codre8 ) + call gmaloj ( nhpent//'.Famille', ' ', 0, iaux, codre9 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8, codre9 ) +c + endif +c +c==== +c 6. allocation des branches decrivant les voisinages +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. voisinages ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhvois//'.0D/1D' , ' ', 0, iaux, codre1 ) + call gmaloj ( nhvois//'.1D/2D' , ' ', 0, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 7. attributs nuls pour les informations supplementaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. infos supplementaires ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + do 71 , iaux = 1 , 10 + call gmecat ( nomail//'.InfoSupE' , iaux, 0, codre1 ) + call gmecat ( nomail//'.InfoSupS' , iaux, 0, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + 71 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +c +c==== +c 8. impression du graphe +c==== +c + call gmprsx (nompro, nomail ) + call gmprsx (nompro, nomail//'.Arete' ) + call gmprsx (nompro, nomail//'.Face' ) + call gmprsx (nompro, nomail//'.Volume' ) + call gmprsx (nompro, nomail//'.Voisins' ) + call gmprsx (nompro, nomail//'.InfoSupE' ) + call gmprsx (nompro, nomail//'.InfoSupS' ) +#endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,5)) typnom + else + if ( typnom.eq.1 ) then + write (ulsort,texte(langue,6)) nomail + else + write (ulsort,texte(langue,7)) + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utaipe.F b/src/tool/Utilitaire/utaipe.F new file mode 100644 index 00000000..27795e07 --- /dev/null +++ b/src/tool/Utilitaire/utaipe.F @@ -0,0 +1,382 @@ + subroutine utaipe ( lepent, option, + > hetpen, facpen, filpen, fppyte, + > aretri, + > tritet, cotrte, + > nbaint, nuaret, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Aretes Internes d'un PEntaedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . pentaedre a traiter . +c . option . e . 1 . produit de : . +c . . . . 1 : toutes . +c . . . . 2 : du noeud central aux sommets . +c . . . . 3 : du noeud central aux milieux . +c . . . . 5 : autres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e . 2** . fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . nbaint . s . 1 . nombre d'aretes internes . +c . nuaret . s . nbaint . numero des aretes internes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAIPE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombpe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lepent, option + integer aretri(nbtrto,3) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer filpen(nbpeto), fppyte(2,nbpeco) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer nbaint + integer nuaret(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer etapen, letria + integer listar(6), lista3(6) + integer f1hp, numtet +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Recherche des aretes internes au '',a,i10)' + texte(1,5) = '(''Etat :'',i10)' + texte(1,6) = '(''Option :'',i2)' + texte(1,7) = '(''Impossible.'')' +c + texte(2,4) = '(''Search of he internal edges of the '',a,i10)' + texte(2,5) = '(''Status:'',i10)' + texte(2,6) = '(''Option:'',i2)' + texte(2,7) = '(''Impossible.'')' +c +#include "impr03.h" +c + codret = 0 +c + etapen = mod(hetpen(lepent),100) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,7), lepent + write (ulsort,texte(langue,5)) etapen + write (ulsort,texte(langue,6)) option +#endif +c +c==== +c 2. Reperage des fils +c==== +c + f1hp = filpen(lepent) +cgn write(1,90002) 'f1hp',f1hp + if ( f1hp.lt.0 ) then + numtet = fppyte(2,-f1hp) +cgn write(1,90002) 'tetraedre numtet', numtet + endif +c + nbaint = 0 +c +c==== +c 3. Decoupage selon 1 arete +c Arete interne entre le milieu de l'arete coupee et le sommet oppose +c==== +c + if ( etapen.ge.1 .and. etapen.le.6 ) then +c + call utarte ( numtet, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + nuaret(nbaint+1) = listar(1) + nbaint = nbaint + 1 +c +c==== +c 4. Decoupage selon 2 aretes des faces triangulaire et quadrangulaires +c Arete interne entre les milieux des 2 aretes coupees +c==== +c + elseif ( etapen.ge.21 .and. etapen.le.26 ) then +c + iaux = numtet + 1 + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + nuaret(nbaint+1) = listar(3) + nbaint = nbaint + 1 +c +c==== +c 5. Decoupage selon 2 aretes des faces triangulaires +c==== +c + elseif ( etapen.ge.31 .and. etapen.le.36 ) then +c +c 5.1. ==> Aretes du 1er et du 3eme fils +c + call utarte ( numtet, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + iaux = numtet + 2 + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > lista3 ) +c +c 5.2. ==> Aretes internes entre noeud central et sommets +c + if ( mod(option,2).eq.0 .or. option.eq.1 ) then +c +c 5.2.1. ==> Sommets de la face quadrangulaire coupee +c . Les deux premiers sommets sont ceux qui appartiennent +c a la face triangulaire F1 +c . Les 4 sommets tournent dans le sens positif, vus +c de l'exterieur +c + nuaret(nbaint+1) = listar(3) + nuaret(nbaint+2) = listar(2) + nuaret(nbaint+3) = lista3(3) + nuaret(nbaint+4) = lista3(2) +c +c 5.2.2. ==> Autres sommets +c . Le premier sommet appartient a la face triangulaire F1 +c + iaux = numtet + 6 + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + nuaret(nbaint+5) = listar(3) + nuaret(nbaint+6) = listar(2) +c + nbaint = nbaint + 6 +c + endif +c +c 5.3. ==> Aretes internes entre noeud central et noeuds milieux +c . Le premier noeud appartient a la face triangulaire F1 +c + if ( mod(option,3).eq.0 .or. option.eq.1 ) then +c +c 5.3.1. ==> Cote de la face F1 +c + nbaint = nbaint + 1 + nuaret(nbaint) = listar(1) +c +c 5.3.2. ==> Cote de la face F2 +c + nbaint = nbaint + 1 + nuaret(nbaint) = lista3(1) +c + endif +c +c==== +c 6. Decoupage selon 1 face quadrangulaire +c Aretes internes entre le milieu de la face et les sommets opposes +c==== +c + elseif ( etapen.ge.43 .and. etapen.le.45 ) then +c + call utarte ( numtet, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c +c 6.1. ==> Cote de la face F1 +c + nbaint = nbaint + 1 + nuaret(nbaint) = listar(3) +c +c 6.2. ==> Cote de la face F2 +c + nbaint = nbaint + 1 + nuaret(nbaint) = listar(2) +c +c==== +c 7. Decoupage selon 1 face triangulaire +c==== +c + elseif ( etapen.ge.51 .and. etapen.le.52 ) then +c +c 7.1. ==> Aretes internes entre noeud central et sommets +c . Les 3 sommets tournent dans le sens positif, vus +c de l'exterieur +c + if ( mod(option,2).eq.0 .or. option.eq.1 ) then +c + iaux = numtet + 10 + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c +c . Decoupage de la face triangulaire F1 : le 1er sommet est S4 + if ( etapen.eq.51 ) then + nuaret(nbaint+1) = listar(3) + nuaret(nbaint+2) = listar(2) + nuaret(nbaint+3) = listar(1) +c +c . Decoupage de la face triangulaire F2 : le 1er sommet est S1 + elseif ( etapen.eq.52 ) then + nuaret(nbaint+1) = listar(1) + nuaret(nbaint+2) = listar(2) + nuaret(nbaint+3) = listar(3) + endif + nbaint = nbaint + 3 +c + endif +c +c 7.2. ==> Aretes internes entre noeud central et noeuds milieux +c . Les 3 noeuds tournent dans le sens positif, vus +c de l'exterieur +c + if ( mod(option,3).eq.0 .or. option.eq.1 ) then +c + iaux = numtet + 9 + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c +c . Decoupage de la face triangulaire F1 : le 1er noeud est N1 + if ( etapen.eq.51 ) then + nuaret(nbaint+1) = listar(1) + nuaret(nbaint+2) = listar(2) + nuaret(nbaint+3) = listar(3) +c +c . Decoupage de la face triangulaire F2 : le 1er noeud est N4 + elseif ( etapen.eq.52 ) then + nuaret(nbaint+1) = listar(3) + nuaret(nbaint+2) = listar(1) + nuaret(nbaint+3) = listar(2) + endif + nbaint = nbaint + 3 +c + endif +c +c==== +c 8. Decoupage standard en 8 +c Aretes internes entre les centres des faces dans l'ordre : +c NF2NF4, NF4NF5, NF5NF3 +c==== +c + elseif ( etapen.eq.80 ) then +c + letria = facpen(f1hp+7,1) +cgn write(1,90002) 'letria',letria +c + do 81 , iaux = 1 , 3 + nuaret(iaux) = aretri(letria,iaux) + 81 continue + nbaint = nbaint + 3 +c +c==== +c 9. Etat inconnu +c==== +c + else + codret = 2 + endif +c +cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbaint) +c +c==== +c 10. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,1,7), lepent + write (ulsort,texte(langue,5)) etapen + write (ulsort,texte(langue,7)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utal00.F b/src/tool/Utilitaire/utal00.F new file mode 100644 index 00000000..9129a8fb --- /dev/null +++ b/src/tool/Utilitaire/utal00.F @@ -0,0 +1,382 @@ + subroutine utal00 ( option, optimp, + > nomail, ndecar, ndecfa, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, + > indtet, indhex, indpen, + > nbsoan, nbsono, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, + > nbhean, nbheno, + > nbpean, nbpeno, + > nbpyan, nbpyno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ALlocations - 00 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . type de traitement . +c . . . . 0 : raffinement . +c . . . . 1 : deraffinement . +c . . . . 2 : conformite . +c . optimp . e . 1 . impressions 0:non, 1:oui . +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . ndecar . e . ch8 . nom de l'objet des decisions sur les aretes. +c . ndecfa . e . ch8 . nom de l'objet des decisions sur les faces . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . indnp2 . es . 1 . nombre de noeuds p2 en vigueur . +c . indnim . es . 1 . nombre de noeuds internes en vigueur . +c . indare . es . 1 . indice de la derniere arete creee . +c . indtri . es . 1 . indice du dernier triangle cree . +c . indqua . es . 1 . indice du dernier quadrangle cree . +c . indtet . es . 1 . indice du dernier tetraedre cree . +c . indhex . es . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . nbsoan . s . 1 . nombre de sommets - ancien . +c . nbsono . s . 1 . nombre de sommets - nouveau . +c . nbnoan . e . 1 . nombre de noeuds - ancien . +c . nbnono . e . 1 . nombre de noeuds - nouveau . +c . nbaran . e . 1 . nombre d'aretes - ancien . +c . nbarno . e . 1 . nombre d'aretes - nouveau . +c . nbtran . e . 1 . nombre de triangles - ancien . +c . nbtrno . e . 1 . nombre de triangles - nouveau . +c . nbquan . e . 1 . nombre de quadrangles - ancien . +c . nbquno . e . 1 . nombre de quadrangles - nouveau . +c . nbtean . e . 1 . nombre de tetraedres - ancien . +c . nbteno . e . 1 . nombre de tetraedres - nouveau . +c . nbhean . e . 1 . nombre d'hexaedres - ancien . +c . nbheno . e . 1 . nombre d'hexaedres - nouveau . +c . nbpean . e . 1 . nombre de pentaedres - ancien . +c . nbpeno . e . 1 . nombre de pentaedres - nouveau . +c . nbpyan . e . 1 . nombre de pyramides - ancien . +c . nbpyno . e . 1 . nombre de pyramides - nouveau . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . e/s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAL00' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer option + integer optimp +c + character*8 nomail + character*8 ndecar, ndecfa +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen + integer nbsoan, nbsono + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpean, nbpeno + integer nbpyan, nbpyno +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre0 + integer codre1, codre2, codre3 + integer pdecfa, pdecar + integer phettr, paretr + integer phetqu, parequ + integer phette, ptrite + integer phethe, pquahe + integer phetpe, pfacpe +cgn integer phetpy, pfacpy +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. recuperation des adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c + if ( option.eq.0 ) then +c +c 3.1. ==> Quelques nombres +c + if ( codret.eq.0 ) then +c + call gmliat ( nhtetr, 1, nbtean, codre1 ) + call gmliat ( nhhexa, 1, nbhean, codre2 ) + call gmliat ( nhpent, 1, nbpean, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtean', nbtean + write (ulsort,90002) 'nbhean', nbhean + write (ulsort,90002) 'nbpean', nbpean +#endif +c + endif +c +c 3.2. ==> Adresses +c + if ( codret.eq.0 ) then +c + if ( nbtean.ne.0 .or. nbpean.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbhean.ne.0 .or. nbpean.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbtean.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbhean.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbpean.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 2 + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.3. ==> Decisions +c + if ( codret.eq.0 ) then +c + call gmadoj ( ndecar, pdecar, iaux, codre1 ) + call gmadoj ( ndecfa, pdecfa, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + else +c + write (ulsort,*) 'Arret dans ', nompro + stop +c + endif +c +c==== +c 4. decompte des nouvelles entites a creer +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. decompte ; codret', codret +#endif +c + if ( option.eq.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPLRA', nompro +#endif +c + call utplra ( optimp, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, indtet, indhex, indpen, + > imem(pdecar), imem(pdecfa), + > imem(phettr), + > imem(phetqu), + > imem(ptrite), imem(phette), + > imem(pquahe), imem(phethe), + > imem(pfacpe), imem(phetpe), + > nbsoan, nbsono, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, + > nbhean, nbheno, + > nbpean, nbpeno, + > nbpyan, nbpyno, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utal02.F b/src/tool/Utilitaire/utal02.F new file mode 100644 index 00000000..4ed5cfb4 --- /dev/null +++ b/src/tool/Utilitaire/utal02.F @@ -0,0 +1,465 @@ + subroutine utal02 ( typenh, option, + > nhenti, nbento, nbenca, + > adhist, adcode, adfill, admere, + > adfami, adcofa, + > adnivo, adinsu, adins2, + > adnoim, adhomo, adcoar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocations - phase 02 +c -- -- -- +c ______________________________________________________________________ +c Allocations des tableaux pour une entite HOM_Enti +c Remarque : le code de retour en entree ne doit pas etre ecrase +c brutalement ; il doit etre cumule avec les operations +c de ce programme +c Remarque : utal02, utad02, utad06, utad08 et utad22 sont similaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des allocations a faire . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : historique, connectivite descendante . +c . . . . 3 : fille . +c . . . . 5 : mere . +c . . . . 7 : fami . +c . . . . 11 : nivo . +c . . . . 13 : isup . +c . . . . 17 : isup2 . +c . . . . 19 : noeud interne a la maille . +c . . . . 29 : homologue . +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . nbento . e . 1 . nombre d'entites . +c . nbenca . e . 1 . nombre d'entites en connectivite par arete . +c . adhist . s . 1 . historique de l'etat . +c . adcode . s . 1 . connectivite descendante . +c . adfill . s . 1 . fille des entites . +c . admere . s . 1 . mere des entites . +c . adfami . s . 1 . famille des entites . +c . adcofa . s . 1 . code des familles des entites . +c . adnivo . s . 1 . niveau des entites . +c . adinsu . s . 1 . informations supplementaires . +c . adins2 . s . 1 . informations supplementaires numero 2 . +c . adnoim . s . 1 . noeud interne a la maille . +c . adhomo . s . 1 . homologue . +c . adcoar . s . 1 . connectivite par arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAL02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "indefi.h" +c +c 0.3. ==> arguments +c + character*8 nhenti +c + integer typenh, option + integer nbento, nbenca + integer adhist, adcode, adfill, admere + integer adfami, adcofa + integer adnivo + integer adinsu + integer adins2 + integer adnoim + integer adhomo + integer adcoar +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codava + integer codre0 + integer codre1, codre2 + integer tabcod(0:12) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Allocations pour les '',a)' + texte(1,6) = '(''Structure : '',a)' + texte(1,8) = '(''Codes de retour'',20i3)' +c + texte(2,4) = '(''Allocations for '',a)' + texte(2,6) = '(''Structure: '',a)' + texte(2,8) = '(''Error codes'',20i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option', option + write (ulsort,90002) 'nbento', nbento + write (ulsort,90002) 'nbenca', nbenca +cgn call gmprsx(nompro,nhenti) +cgn call gmprsx(nompro,nhenti//'.Famille') + call dmflsh (iaux) +#endif +c + do 10 , iaux = 0 , 12 + tabcod(iaux) = 0 + 10 continue +c + adcofa = iindef + adhist = iindef + adcode = iindef + adfill = iindef + admere = iindef + adfami = iindef + adcofa = iindef + adnivo = iindef + adinsu = iindef + adins2 = iindef + adnoim = iindef + adhomo = iindef + adcoar = iindef +c + codava = codret + codret = 0 +c +c==== +c 2. Allocation et recuperation des adresses +c==== +c + if ( option.gt.0 ) then +c +c 2.1. ==> Historique des etats et connectivite descendante +c + if ( mod(option,2).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.HistEtat', ' ', nbento, adhist, codre1 ) + if ( codre1.ne.0 ) then + codret = 11 + tabcod(1) = codre1 + endif +c + if ( typenh.eq.0 ) then + jaux = 1 + elseif ( typenh.eq.1 ) then + jaux = 2 + elseif ( typenh.eq.2 ) then + jaux = 3 + elseif ( typenh.eq.3 ) then + jaux = 4 + elseif ( typenh.eq.4 ) then + jaux = 4 + elseif ( typenh.eq.5 ) then + jaux = 5 + elseif ( typenh.eq.6 ) then + jaux = 6 + elseif ( typenh.eq.7 ) then + jaux = 5 + else + codret = 120 + tabcod(2) = 1 + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = (nbento-nbenca)*jaux + call gmaloj ( nhenti//'.ConnDesc', ' ', iaux, adcode, codre2 ) +c + if ( codre2.ne.0 ) then + codret = 12 + tabcod(2) = codre2 + endif +c + endif +c + endif +c +c 2.2. ==> Fille +c + if ( mod(option,3).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Fille', ' ', nbento, adfill, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 2 + tabcod(3) = codre0 + endif +c + endif +c + endif +c +c 2.3. ==> Mere +c + if ( mod(option,5).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Mere', ' ', nbento, admere, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 3 + tabcod(4) = codre0 + endif +c + endif +c + endif +c +c 2.4. ==> Les familles +c + if ( mod(option,7).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Famille.EntiFamm', ' ', + > nbento, adfami, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 4 + tabcod(5) = codre0 + endif +c + endif +c + endif +c +c 2.5. ==> Le niveau +c + if ( mod(option,11).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Niveau', ' ', nbento, adnivo, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 5 + tabcod(7) = codre0 + endif +c + endif +c + endif +c +c 2.6. ==> Les informations supplementaires +c + if ( mod(option,13).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.3 ) then + iaux = (nbento-nbenca)*4 + elseif ( typenh.eq.5 ) then + iaux = (nbento-nbenca)*5 + elseif ( typenh.eq.6 ) then + iaux = (nbento-nbenca)*6 + elseif ( typenh.eq.7 ) then + iaux = (nbento-nbenca)*5 + else + iaux = nbento + endif + call gmaloj ( nhenti//'.InfoSupp', ' ', iaux, adinsu, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 6 + tabcod(8) = codre0 + endif +c + endif +c + endif +c +c 2.7. ==> Les informations supplementaires numero 2 +c + if ( mod(option,17).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.InfoSup2', ' ', nbento, adins2, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 7 + tabcod(9) = codre0 + endif +c + endif +c + endif +c +c 2.8. ==> Le noeud supplementaire +c + if ( mod(option,19).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.NoeuInMa', ' ', nbento, adnoim, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 8 + tabcod(10) = codre0 + endif +c + endif +c + endif +c +c 2.9. ==> Les homologues +c + if ( mod(option,29).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenti//'.Homologu', ' ', nbento, adhomo, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 9 + tabcod(11) = codre0 + endif +c + endif +c + endif +c +c 2.10. ==> La connectivite par aretes +c + if ( mod(option,31).eq.0 ) then +c + if ( codret.eq.0 ) then +c + if ( typenh.eq.3 ) then + iaux = nbenca*6 + elseif ( typenh.eq.5 ) then + iaux = nbenca*8 + elseif ( typenh.eq.6 ) then + iaux = nbenca*12 + elseif ( typenh.eq.7 ) then + iaux = nbenca*9 + else + iaux = 0 + endif + call gmaloj ( nhenti//'.ConnAret', ' ', iaux, adcoar, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 10 + tabcod(12) = codre0 + endif +c + endif +c + endif +c + endif +c +c==== +c 3. Attributs +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( nhenti, 1, nbento, codre1 ) + call gmecat ( nhenti, 2, nbenca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + tabcod(0) = codret + codret = 30 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'option', option + write (ulsort,texte(langue,6)) nhenti + write (ulsort,texte(langue,8)) tabcod +c + else +c + codret = codava +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utal41.F b/src/tool/Utilitaire/utal41.F new file mode 100644 index 00000000..5ae964f8 --- /dev/null +++ b/src/tool/Utilitaire/utal41.F @@ -0,0 +1,282 @@ + subroutine utal41 ( typcca, nonexm, nbanci, nbenrc, + > nbarto, nbarde, + > nbtrri, nbtrde, + > nbquri, nbqude, + > nbpeac, nbpyac, + > nospec, + > adarrc, adtrrc, adqurc, + > adterc, adherc, adperc, adpyrc, + > lgtrc1, lgtrc2, lgtrc3, + > lgtrc4, lgtrc5, lgtrc6, lgtrc7, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright 2016 EDF +c ______________________________________________________________________ +c +c UTilitaire - ALocations - phase 41 +c -- -- -- +c ______________________________________________________________________ +c Allocation des tableaux pour les recollements +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typcca . e . 1 . type du code de calcul . +c . nonexm . e . 1 . non exportation de mailles . +c . . . . 1 : on exporte toutes les mailles . +c . . . . 2x : les segments ne sont pas exportes . +c . nbenci . e . 1 . nombre de non conformites initiales . +c . nbenrc . e . 1 . nombre d'entites par recollement unitaire . +c . nbpeac . e . 1 . nombre de pentaedres actifs . +c . nbpyac . e . 1 . nombre de pyramides actives . +c . nospec . s . char8 . nom de l'objet memorisant les specificites . +c . adarrc . s . 1 . paires d'aretes recollees . +c . adtrrc . s . 1 . paires de triangles recolles . +c . adqurc . s . 1 . paires de quadrangles recolles . +c . adterc . s . 1 . paires des tetra. voisins faces a recoller . +c . adherc . s . 1 . paires des hexa. voisins faces a recoller . +c . adperc . s . 1 . paires des penta. voisins faces a recoller . +c . adpyrc . s . 1 . paires des pyram. voisines faces a recoller. +c . lgtrc1 . s . 1 . longueur des paires d'aretes . +c . lgtrc2 . s . 1 . longueur des paires de triangles . +c . lgtrc3 . s . 1 . longueur des paires de quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAL41' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer typcca, nonexm + integer nbanci, nbenrc + integer nbarto, nbarde + integer nbtrri, nbtrde + integer nbquri, nbqude + integer nbpeac, nbpyac +c + integer adarrc, adtrrc, adqurc + integer adterc, adherc, adperc, adpyrc + integer lgtrc1, lgtrc2, lgtrc3 + integer lgtrc4, lgtrc5, lgtrc6, lgtrc7 +c + character*8 nospec +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Allocations relatives aux recollements'')' +c + texte(2,4) = '(''Allocations for entities'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. La structure principale +c==== +c + call gmalot ( nospec, '10TabEnt', 0, iaux, codret ) +c +c==== +c 3. Les entites recollees +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Aretes +c + if ( mod(nonexm,2).ne.0 ) then +cgn write (ulsort,90002) 'nbanci', nbanci +cgn write (ulsort,90002) 'nbenrc', nbenrc + lgtrc1 = 2*nbarto + if ( typcca.eq.26 .or. + > typcca.eq.46 ) then + lgtrc1 = lgtrc1 + 2*nbanci*nbenrc + endif + else + lgtrc1 = 0 + endif +c + call gmaloj ( nospec//'.Tab1', ' ', lgtrc1, adarrc, codre1 ) +c +c 3.2. ==> Triangles +c +cgn write (ulsort,90002) 'nbtrri = ',nbtrri +cgn write (ulsort,90002) 'nbtrde = ',nbtrde + if ( typcca.eq.26 .or. + > typcca.eq.46 ) then + lgtrc2 = 0 + else + lgtrc2 = 2*(nbtrde+nbtrri) + endif +c + call gmaloj ( nospec//'.Tab2', ' ', lgtrc2, adtrrc, codre2 ) +c +c 3.3. ==> Quadrangles +c +cgn write (ulsort,90002) 'nbquri = ',nbquri +cgn write (ulsort,90002) 'nbqude = ',nbqude + if ( typcca.eq.26 .or. + > typcca.eq.46 ) then + lgtrc3 = 2*(nbarde+nbanci*nbenrc) + else + lgtrc3 = 2*(nbqude+nbquri) + endif + call gmaloj ( nospec//'.Tab3', ' ', lgtrc3, adqurc, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c +c==== +c 4. Les voisins des entites recollees +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. voisins ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + lgtrc4 = lgtrc2*3/2 + call gmaloj ( nospec//'.Tab4', ' ', lgtrc4, adterc, codre1 ) + lgtrc5 = lgtrc3*3/2 + call gmaloj ( nospec//'.Tab5', ' ', lgtrc5, adherc, codre2 ) + if ( nbpeac.gt.0 ) then + lgtrc6 = (lgtrc2+lgtrc3)*3/2 + else + lgtrc6 = 0 + endif + call gmaloj ( nospec//'.Tab6', ' ', lgtrc6, adperc, codre3 ) + if ( nbpyac.gt.0 ) then + lgtrc7 = (lgtrc2+lgtrc3)*3/2 + else + lgtrc7 = 0 + endif + call gmaloj ( nospec//'.Tab7', ' ', lgtrc7, adpyrc, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 5. les attributes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. les attributes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + lgtrc1 = lgtrc1/2 + lgtrc2 = lgtrc2/2 + lgtrc3 = lgtrc3/2 + lgtrc4 = lgtrc4/3 + lgtrc5 = lgtrc5/3 + lgtrc6 = lgtrc6/3 + lgtrc7 = lgtrc7/3 +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nospec, 1, lgtrc1, codre1 ) + call gmecat ( nospec, 2, lgtrc2, codre2 ) + call gmecat ( nospec, 3, lgtrc3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmecat ( nospec, 4, lgtrc4, codre1 ) + call gmecat ( nospec, 5, lgtrc5, codre2 ) + call gmecat ( nospec, 6, lgtrc6, codre3 ) + call gmecat ( nospec, 7, lgtrc7, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +cgn call gmprsx ( nompro, nospec ) +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalfe.F b/src/tool/Utilitaire/utalfe.F new file mode 100644 index 00000000..8c7f6740 --- /dev/null +++ b/src/tool/Utilitaire/utalfe.F @@ -0,0 +1,181 @@ + subroutine utalfe ( typenh, nhenti, + > nbento, nctfen, nbfenm, + > nhenfa, pfamen, pcfaen, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation pour HOMARD - Famille pour une Entite +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenti . e . char*8 . nom de l'objet de l'entite . +c . nbento . e . 1 . nombre d'entites . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfenm . e . 1 . nombre maximum de familles . +c . nhenfa . s . char*8 . nom de l'objet de la famille de l'entite . +c . pfamen . s . 1 . adresses des numeros des familles . +c . pcfaen . s . 1 . adresses des codes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALFE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh + integer nbento, nctfen, nbfenm + integer pfamen, pcfaen +c + character*8 nhenti, nhenfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Allocations des structures des familles des '',a)' +c + texte(2,4) = '(''Allocation of structures for family of '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c==== +c 2. allocation des structures +c==== +c 2.1. ==> le receptacle des familles +c + call gmnomc ( nhenti//'.Famille', nhenfa, codret ) +c +c 2.2. ==> le numero de famille pour chaque entite +c les codes des attributs associes a chaque famille +c les noms des groupes associes a chaque famille +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. numero de famille ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( nhenfa//'.EntiFamm', ' ', nbento, pfamen, codre1 ) + iaux = nctfen * nbfenm + call gmaloj ( nhenfa//'.Codes', ' ', iaux , pcfaen, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3. ==> les attributs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. attributs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nhenfa, 1, nbfenm, codre1 ) + call gmecat ( nhenfa, 2, nctfen, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalfo.F b/src/tool/Utilitaire/utalfo.F new file mode 100644 index 00000000..7de337fc --- /dev/null +++ b/src/tool/Utilitaire/utalfo.F @@ -0,0 +1,214 @@ + subroutine utalfo ( nofonc, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation d'une FOnction +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nofonc . s . char8 . nom de l'objet fonction . +c . typcha . e . 1 . edin64/edfl64 selon entier/reel . +c . typgeo . e . 1 . type geometrique au sens MED . +c . ngauss . e . 1 . nombre de points de Gauss . +c . nbenmx . e . 1 . nombre d'entites maximum . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . nbtyas . e . 1 . nombre de types de support associes . +c . carsup . e . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . typint . e . . type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . advale . s . 1 . adresse du tableau de valeurs entieres . +c . advalr . s . 1 . adresse du tableau de valeurs reelles . +c . adobch . s . 1 . adresse des noms des objets 'Champ' . +c . adprpg . s . 1 . adresse des noms des objets 'Profil', . +c . . . . 'LocaPG' et fonction aux noeuds par . +c . . . . elements eventuellement associes . +c . adtyas . s . 1 . adresse des types associes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALFO' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nofonc +c + integer typcha + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + write (ulsort,90002) 'typcha', typcha + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbenmx', nbenmx + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'typint', typint + call dmflsh (iaux) +#endif +c +c==== +c 2. creation de la fonction +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call gmalot ( nofonc, 'Fonction', 0, iaux, codret ) +c + endif +c +c 2.2. ==> les caracteristiques de cette fonction +c + if ( codret.eq.0 ) then +c + call gmecat ( nofonc, 1, typgeo, codre1 ) + call gmecat ( nofonc, 2, ngauss, codre2 ) + call gmecat ( nofonc, 3, nbenmx, codre3 ) + call gmecat ( nofonc, 4, nbvapr, codre4 ) + call gmecat ( nofonc, 5, nbtyas, codre5 ) + call gmecat ( nofonc, 6, carsup, codre6 ) + call gmecat ( nofonc, 7, nbtafo, codre7 ) + call gmecat ( nofonc, 8, typint, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + iaux = nbenmx*nbtafo + if ( ngauss.ne.ednopg ) then + iaux = iaux*ngauss + endif + if ( typcha.eq.edfl64 ) then + call gmaloj ( nofonc//'.ValeursR', ' ', iaux, advalr, codre1 ) + else + call gmaloj ( nofonc//'.ValeursE', ' ', iaux, advale, codre1 ) + endif + call gmaloj ( nofonc//'.InfoCham', ' ', nbtafo, adobch, codre2 ) + iaux = 3 + call gmaloj ( nofonc//'.InfoPrPG', ' ', iaux, adprpg, codre3 ) + if ( nbtyas.gt.0 ) then + call gmaloj ( nofonc//'.TypeSuAs', ' ', nbtyas, adtyas, codre4 ) + else + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nofonc ) +cgn call gmprot (nompro, nofonc//'.ValeursR', 1, 10 ) +cgn call gmprsx (nompro, nofonc//'.InfoCham' ) +cgn call gmprsx (nompro, nofonc//'.InfoPrPG' ) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalih.F b/src/tool/Utilitaire/utalih.F new file mode 100644 index 00000000..b3a6071e --- /dev/null +++ b/src/tool/Utilitaire/utalih.F @@ -0,0 +1,154 @@ + subroutine utalih ( nohind, codent, nbento, nbcomp, motaux, + > adenin, adensu, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation de l'Indicateur HOMARD +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nohind . e . ch8 . nom de l'objet contenant l'indicateur . +c . codent . e . 1 . code des entites au sens homard . +c . nbento . e . 1 . nombre total d'entites . +c . nbcomp . e . 1 . nombre de composantes du champ . +c . motaux . e . ch8 . branche de l'indicateur . +c . adenin . s . 1 . adresse de l'indicateur . +c . adensu . s . 1 . adresse du support de l'indicateur . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALIH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer codent, nbento, nbcomp + integer adenin, adensu +c + character*8 motaux + character*8 nohind +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre0 + integer iaux +c + character*14 saux14 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,''.. Allocation de la branche sur les : '',a,/,37(''-''))' +c + texte(2,4) = + > '(/,''.. Allocation of branch for : '',a,/,24(''-''))' +c +c==== +c 2. Allocation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,codent) +#endif +c + saux14 = nohind//'.'//suffix(1,codent)(1:5) +c + call gmaloj ( saux14, ' ', 0, iaux, codre1 ) + call gmecat ( saux14, 1, nbento, codre2 ) + call gmecat ( saux14, 2, nbcomp, codre3 ) + if ( codent.lt.0 ) then + iaux = 1 + else + iaux = 2 + endif + call gmecat ( saux14, 3, iaux, codre4 ) + call gmaloj ( saux14//'.Support', ' ', nbento, adensu, codre5 ) + iaux = nbento*nbcomp + call gmaloj ( saux14//'.'//motaux, ' ', iaux, adenin, codre6 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, codre6 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, codre6 ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,4)) mess14(langue,3,codent) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalpf.F b/src/tool/Utilitaire/utalpf.F new file mode 100644 index 00000000..7cf26453 --- /dev/null +++ b/src/tool/Utilitaire/utalpf.F @@ -0,0 +1,217 @@ + subroutine utalpf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation d'un Paquet de Fonctions +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obpafo . s . char8 . nom de l'objet du paquet de fonctions . +c . nbfopa . e . 1 . nombre de fonctions dans le paquet . +c . typgpf . e . 1 . si >0 : type geometrique s'il est unique . +c . . . . si <0 : nombre de type geometriques associe. +c . ngauss . e . 1 . nombre de points de gauss . +c . carsup . e . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . typint . e . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . adobfo . s . 1 . adresse des noms des objets 'Fonction' et . +c . . . . de l'eventuel paquet associe . +c . adtyge . s . 1 . adresse des types geometriques . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALPF' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 obpafo +c + integer nbfopa, typgpf, ngauss, carsup, typint + integer adobfo, adtyge +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Creation du paquet de fonctions : '',a)' +c + texte(2,4) = '(''Creation of pack of functions : '',a)' +c +#include "impr03.h" +c +c==== +c 2. creation de la structure generale du paquet de fonctions +c==== +c + if ( codret.eq.0 ) then +c + call gmalot ( obpafo, 'PackFonc', 0, iaux, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) obpafo +#endif +c +c==== +c 3. les caracteristiques de ce paquet de fonctions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. caracteristiques ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfopa', nbfopa + write (ulsort,90002) 'typgpf', typgpf + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint +#endif +c + call gmecat ( obpafo, 1, nbfopa, codre1 ) + call gmecat ( obpafo, 2, typgpf, codre2 ) + call gmecat ( obpafo, 3, ngauss, codre3 ) + call gmecat ( obpafo, 4, carsup, codre4 ) + call gmecat ( obpafo, 5, typint, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 4. les branches +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. branches ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbfopa + 1 + call gmaloj ( obpafo//'.Fonction', ' ', iaux, adobfo, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + if ( typgpf.lt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = abs(typgpf) + call gmaloj ( obpafo//'.TypeSuAs', ' ', iaux, adtyge, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) + call gmprsx (nompro, obpafo//'.TypeSuAs' ) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalpg.F b/src/tool/Utilitaire/utalpg.F new file mode 100644 index 00000000..0e5751be --- /dev/null +++ b/src/tool/Utilitaire/utalpg.F @@ -0,0 +1,206 @@ + subroutine utalpg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation de la localisation des Points de Gauss +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . oblopg . s . char8 . nom de l'objet points de Gauss . +c . nolopg . e . char64 . nom de la localisation des Points de Gauss . +c . typgeo . e . 1 . type geometrique au sens MED . +c . ngauss . e . 1 . nombre de points de Gauss . +c . dimcpg . e . 1 . dimension des coordonnees des pts de Gauss . +c . adcono . s . 1 . adresse des coordonnees des noeuds . +c . adcopg . s . 1 . adresse des coordonnees des points de Gauss. +c . adpopg . s . 1 . adresse des poids des points de Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALPG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 oblopg + character*64 nolopg +c + integer typgeo, ngauss, dimcpg + integer adcono, adcopg, adpopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer lgnoml, adnoml + integer nbnoeu +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom de la localisation : '',a)' +c + texte(2,4) = '(''Name of the localization : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nolopg +#endif +c +c==== +c 2. les caracteristiques de cette localisation +c==== +c + if ( codret.eq.0 ) then +c + call utlgut ( lgnoml, nolopg, + > ulsort, langue, codret ) +c + endif +c + nbnoeu = mod(typgeo,100) +C +c==== +c 3. creation de la localisation des points de Gauss +c==== +c +c 3.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call gmalot ( oblopg, 'LocaPG', 0, iaux, codret ) +c + endif +c +c 3.2. ==> les attributs +c + if ( codret.eq.0 ) then +c + call gmecat ( oblopg, 1, lgnoml, codre1 ) + call gmecat ( oblopg, 2, typgeo, codre2 ) + call gmecat ( oblopg, 3, ngauss, codre3 ) + call gmecat ( oblopg, 4, dimcpg, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( mod(lgnoml,8).eq.0 ) then + iaux = lgnoml/8 + else + iaux = (lgnoml-mod(lgnoml,8))/8 + 1 + endif + call gmaloj ( oblopg//'.NomLocPG', ' ', iaux, adnoml, codre1 ) + iaux = nbnoeu*dimcpg + call gmaloj ( oblopg//'.CoorNoeu', ' ', iaux, adcono, codre2 ) + iaux = ngauss*dimcpg + call gmaloj ( oblopg//'.CoorPtGa', ' ', iaux, adcopg, codre3 ) + call gmaloj ( oblopg//'.PoidPtGa', ' ', ngauss, adpopg, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 3.3. ==> memorisation du nom +c + if ( codret.eq.0 ) then +c + call utchs8 ( nolopg, lgnoml, smem(adnoml), + > ulsort, langue, codret ) +c + endif +c +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, oblopg ) + call gmprsx (nompro, oblopg//'.NomLocPG' ) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalpr.F b/src/tool/Utilitaire/utalpr.F new file mode 100644 index 00000000..6a015321 --- /dev/null +++ b/src/tool/Utilitaire/utalpr.F @@ -0,0 +1,172 @@ + subroutine utalpr ( obprof, + > nbvapr, noprof, + > adlipr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation d'un PRofil +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obprof . s . char8 . nom de l'objet profil . +c . nbvapr . e . 1 . nombre de valeurs . +c . noprof . e . char64 . nom du profil . +c . adlipr . s . 1 . adresse de la liste des entites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALPR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 obprof + character*64 noprof +c + integer nbvapr + integer adlipr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer lgnomp, adnomp +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. creation du profil +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call gmalot ( obprof, 'Profil', 0, iaux, codret ) +c + endif +c +c 2.2. ==> les caracteristiques de ce profil +c + if ( codret.eq.0 ) then +c + call utlgut ( lgnomp, noprof, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( obprof, 1, lgnomp, codre1 ) + call gmecat ( obprof, 2, nbvapr, codre2 ) + if ( mod(lgnomp,8).eq.0 ) then + iaux = lgnomp/8 + else + iaux = (lgnomp-mod(lgnomp,8))/8 + 1 + endif + call gmaloj ( obprof//'.NomProfi', ' ', iaux, adnomp, codre3 ) + call gmaloj ( obprof//'.ListEnti', ' ', nbvapr, adlipr, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 2.3. ==> memorisation du nom +c + if ( codret.eq.0 ) then +c + call utchs8 ( noprof, lgnomp, smem(adnomp), + > ulsort, langue, codret ) +c + endif +c +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obprof ) + call gmprsx (nompro, obprof//'.NomProfi' ) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utalso.F b/src/tool/Utilitaire/utalso.F new file mode 100644 index 00000000..b78db17d --- /dev/null +++ b/src/tool/Utilitaire/utalso.F @@ -0,0 +1,228 @@ + subroutine utalso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ALlocation d'une SOlution +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . s . char8 . nom de l'objet solution . +c . nbcham . e . 1 . nombre de champs associes . +c . nbpafo . e . 1 . nombre d'inf. sur les paquets de fonctions . +c . nbprof . e . 1 . nombre de profils associes . +c . nblopg . e . 1 . nombre de localisations de points de Gauss . +c . adinch . s . 1 . adresse de l'information sur les champs . +c . adinpf . s . 1 . adresse de l'inf. sur paquets de fonctions . +c . adinpr . s . 1 . adresse de l'information sur les profils . +c . adinlg . s . 1 . adresse de l'information sur les . +c . . . . localisations de points de Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTALSO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nocsol +c + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + character*08 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Erreur en allouant '',a)' +c + texte(2,4) = '(''Error while allocating '',a)' +c + codret = 0 +c +c==== +c 2. structure generale +c==== +c + if ( codret.eq.0 ) then +c + call gmalot ( nocsol, 'Solution', 0, iaux, codret ) +c + if ( codret.ne.0 ) then + saux08 = 'Solution' + endif +c + endif +c +c==== +c 3. les attributs +c==== +c + if ( codret.eq.0 ) then +c + call gmecat ( nocsol, 1, nbcham, codre1 ) + call gmecat ( nocsol, 2, nbpafo, codre2 ) + call gmecat ( nocsol, 3, nbprof, codre3 ) + call gmecat ( nocsol, 4, nblopg, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( codret.ne.0 ) then + saux08 = 'Attribut' + endif +c + endif +c +c==== +c 4. les eventuelles branches +c==== +c +c 4.1. ==> l'information sur les champs +c + if ( codret.eq.0 ) then +c + if ( nbcham.ne.0 ) then + call gmaloj ( nocsol//'.InfoCham', ' ', nbcham, adinch, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoCham' + endif + endif +c + endif +c +c 4.2. ==> l'information sur les paquets de fonctions +c + if ( codret.eq.0 ) then +c + if ( nbpafo.ne.0 ) then + call gmaloj ( nocsol//'.InfoPaFo', ' ', nbpafo, adinpf, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoPaFo' + endif + endif +c + endif +c +c 4.3. ==> l'information sur les profils +c + if ( codret.eq.0 ) then +c + if ( nbprof.ne.0 ) then + call gmaloj ( nocsol//'.InfoProf', ' ', nbprof, adinpr, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoProf' + endif + endif +c + endif +c +c 4.4. ==> les localisations de points de Gauss +c + if ( codret.eq.0 ) then +c + if ( nblopg.ne.0 ) then + call gmaloj ( nocsol//'.InfoLoPG', ' ', nblopg, adinlg, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoLoPG' + endif + endif +c + endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) + call gmprsx (nompro, nocsol//'.InfoLoPG' ) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) saux08 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utaptc.F b/src/tool/Utilitaire/utaptc.F new file mode 100644 index 00000000..dfdb788b --- /dev/null +++ b/src/tool/Utilitaire/utaptc.F @@ -0,0 +1,332 @@ + subroutine utaptc ( nobjet, typnom, choix, + > nombre, lgtabl, + > adpoin, adtail, adtabl, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Allocation d'un objet de type PtTabC08 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nobjet . es . char8 . nom de l'objet PtTabC08 . +c . typnom . e . 1 . type du nom de l'objet PtTabC08 . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . choix . e . 1 . option de la recherche : . +c . . . . 0 : on alloue tete et branches . +c . . . . 1 : on n'alloue que la tete . +c . . . . 2 : on n'alloue que les branches . +c . . . . 3 : on modifie les longueurs . +c . . . . 4 : on enregistre les attributs . +c . . . . 5 : on recupere attributs et adresses . +c . nombre . es . 1 . nombre d'entrees ; le tableau Pointeur est . +c . . . . dimensionne a (0:nombre) . +c . lgtabl . es . 1 . longueur commune a Taille et Table . +c . adpoin . s . 1 . adresse de Pointeur . +c . adtail . s . 1 . adresse de Taille . +c . adtabl . s . 1 . adresse de Table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAPTC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*(*) nobjet +c + integer typnom + integer choix + integer nombre, lgtabl + integer adpoin, adtail, adtabl +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer iaux, jaux, kaux +c + character*8 nomobj +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Mauvaise demande de type de nom :'',i6)' + texte(1,5) = '(''Probleme pour allouer l''''objet '',a8)' + texte(1,6) = '(''choix = '',i3)' + texte(1,7) = '(''typnom = '',i3)' + texte(1,8) = '(''nombre = '',i3,'', lgtabl = '',i3)' + texte(1,9) = '(''Avant modification de tailles :'')' +c + texte(2,4) = '(''Bad request for the type of the name :'',i6)' + texte(2,5) = '(''Problem while allocating object '',a8)' + texte(2,6) = texte(1,6) + texte(2,7) = texte(1,7) + texte(2,8) = '(''nombre = '',i3,'', lgtabl = '',i3)' + texte(2,9) = '(''Before size modification :'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) choix + if ( choix.le.1 ) then + write (ulsort,texte(langue,7)) typnom + endif + if ( choix.ne.1 .and. choix.ne.5 ) then + write (ulsort,texte(langue,8)) nombre, lgtabl + endif +#endif +c +c==== +c 2. Allocation de l'objet de tete +c==== +c + if ( choix.eq.0 .or. choix.eq.1 ) then +c + if ( typnom.eq.0 ) then +c + call gmalot ( nobjet, 'PtTabC08', 0, iaux, codre1 ) + codret = abs(codre1) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nobjet, 'PtTabC08', 0, iaux, codre1 ) + codret = abs(codre1) +c + else +c + codret = -1 +c + endif +c + else +c + codret = 0 +c + endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nobjet, nomobj, codret ) +c + endif +c +c==== +c 3. Allocation des branches +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Les branches ; codret =', codret +#endif +c + if ( choix.eq.0 .or. choix.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( nomobj, 1, nombre, codre1 ) + iaux = nombre + 1 + call gmaloj ( nomobj//'.Pointeur', ' ', iaux, adpoin, codre2 ) + call gmecat ( nomobj, 2, lgtabl, codre3 ) + call gmaloj ( nomobj//'.Taille', ' ', lgtabl, adtail, codre4 ) + call gmaloj ( nomobj//'.Table' , ' ', lgtabl, adtabl, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(adpoin) = 0 +c + endif +c + endif +c +c==== +c 4. Modifications +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Modifications ; codret =', codret +#endif +c + if ( choix.eq.3 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nomobj, 1, iaux, codre1 ) + call gmliat ( nomobj, 2, jaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Taille' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c + call gmecat ( nomobj, 1, nombre, codre1 ) + call gmecat ( nomobj, 2, lgtabl, codre2 ) + call gmmod ( nomobj//'.Pointeur', adpoin, + > iaux+1, nombre+1, 1, 1, codre3 ) + call gmmod ( nomobj//'.Taille', adtail, + > jaux, lgtabl, 1, 1, codre4 ) + call gmmod ( nomobj//'.Table', adtabl, + > jaux, lgtabl, 1, 1, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + endif +c +c==== +c 5. Enregistrement des attributs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Les attributs ; codret =', codret +#endif +c + if ( choix.eq.4 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( nomobj, 1, nombre, codre1 ) + call gmecat ( nomobj, 2, lgtabl, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 6. Recuperation des attributs et des adresses +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. Recuperation ; codret =', codret +#endif +c + if ( choix.eq.5 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nomobj, 1, nombre, codre1 ) + call gmliat ( nomobj, 2, lgtabl, codre2 ) + call gmadoj ( nomobj//'.Pointeur', adpoin, iaux, codre3 ) + call gmadoj ( nomobj//'.Taille', adtail, jaux, codre4 ) + call gmadoj ( nomobj//'.Table' , adtabl, kaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + endif +c +c==== +c 7. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Taille' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( choix.le.1 ) then + write (ulsort,texte(langue,4)) typnom + else + write (ulsort,texte(langue,5)) nomobj + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utapte.F b/src/tool/Utilitaire/utapte.F new file mode 100644 index 00000000..5a95ae2d --- /dev/null +++ b/src/tool/Utilitaire/utapte.F @@ -0,0 +1,264 @@ + subroutine utapte ( nomobj, typnom, choix, + > nombre, lgtabl, + > adpoin, adtabl, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Allocation d'un objet de type PtTabEnt +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomobj . es . char8 . nom de l'objet PtTabEnt . +c . typnom . e . 1 . type du nom de l'objet PtTabEnt . +c . . . . 0 : le nom est a creer automatiquement . +c . . . . 1 : le nom est impose par l'appel . +c . choix . e . 1 . option du travail : . +c . . . . 0 : on fait tout . +c . . . . 1 : on n'alloue que la tete . +c . . . . 2 : on n'alloue que les branches . +c . . . . 3 : on modifie les longueurs . +c . nombre . e . 1 . nombre d'entrees ; le tableau Pointeur est . +c . . . . dimensionne (0:nombre) . +c . lgtabl . e . 1 . longueur de la Table . +c . adpoin . s . 1 . adresse de Pointeur . +c . adtabl . s . 1 . adresse de Table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAPTE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*8 nomobj +c + integer typnom + integer choix + integer nombre, lgtabl + integer adpoin, adtabl +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4 + integer codre0 + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Mauvaise demande de type de nom :'',i6)' + texte(1,4) = '(''Probleme pour allouer l''''objet '',a8)' + texte(1,5) = '(''typnom = '',i3,'', choix = '',i3)' + texte(1,6) = '(''nombre = '',i3,'', lgtabl = '',i3)' + texte(1,7) = '(''Avant modification de tailles :'')' +c + texte(2,10) = '(''Bad request for the type of the name :'',i6)' + texte(2,4) = '(''Problem while allocating object '',a8)' + texte(2,5) = '(''typnom = '',i3,'', choix = '',i3)' + texte(2,6) = '(''nombre = '',i3,'', lgtabl = '',i3)' + texte(2,7) = '(''Before size modification :'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) typnom, choix + write (ulsort,texte(langue,6)) nombre, lgtabl +#endif +c +c==== +c 2. Allocation de l'objet de tete +c==== +c +c 2.1. ==> la tete +c + if ( choix.eq.0 .or. choix.eq.1 ) then +c + if ( typnom.eq.0 ) then +c + call gmalot ( nomobj, 'PtTabEnt', 0, iaux, codre1 ) + codret = abs(codre1) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( nomobj, 'PtTabEnt', 0, iaux, codre1 ) + codret = abs(codre1) +c + else +c + codret = -1 +c + endif +c + if ( codret.eq.0 ) then +c + call gmecat ( nomobj, 1, nombre, codret ) +c + endif +c + else +c + codret = 0 +c + endif +c +c==== +c 3. Les branches +c==== +c + if ( choix.eq.0 .or. choix.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmecat ( nomobj, 1, nombre, codre1 ) + iaux = nombre + 1 + call gmaloj ( nomobj//'.Pointeur', ' ', iaux, adpoin, codre2 ) + call gmecat ( nomobj, 2, lgtabl, codre3 ) + call gmaloj ( nomobj//'.Table' , ' ', lgtabl, adtabl, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + imem(adpoin) = 0 +c + endif +c + endif +c +c==== +c 4. Modifications +c==== +c + if ( choix.eq.3 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nomobj, 1, iaux, codre1 ) + call gmliat ( nomobj, 2, jaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c + call gmecat ( nomobj, 1, nombre, codre1 ) + call gmecat ( nomobj, 2, lgtabl, codre2 ) + call gmmod ( nomobj//'.Pointeur', adpoin, + > iaux+1, nombre+1, 1, 1, codre3 ) + call gmmod ( nomobj//'.Table', adtabl, + > jaux, lgtabl, 1, 1, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,10)) typnom + else + write (ulsort,texte(langue,4)) nomobj + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utarhe.F b/src/tool/Utilitaire/utarhe.F new file mode 100644 index 00000000..ccef8b8c --- /dev/null +++ b/src/tool/Utilitaire/utarhe.F @@ -0,0 +1,142 @@ + subroutine utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ARetes d'un HExaedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbhecf . e . 1 . nombre d'hexaedres decrits par faces . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . listar . s . 12 . les 12 aretes de l'hexaedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "j1234j.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer nbquto, nbhecf + integer listar(12) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac5, lafac6 + integer codfa1, codfa2, codfa5, codfa6 +c +#include "impr03.h" +c +c==== +c 1. traitement +c==== +c S5 a9 S6 +c ---------------------------- +c /| /| +c / | / | +c / | / | +c / | / | +c a6/ | /a5 | +c / | / | +c / a11| / |a10 +c / | a1 / | +c S2----------------------------- S1 | +c | | | | +c | | a12 | | +c | S8 -------------------|--------|S7 +c | / | / +c a3| / |a2 / +c | / | / +c | / | / +c | a8/ | /a7 +c | / | / +c | / | / +c |/ |/ +c ----------------------------- +c S3 a4 S4 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c Avec le code 1, les faces sont : +c Face 1 : aretes 1, 2, 4, 3 +c Face 2 : aretes 1, 6, 9, 5 +c Face 3 : aretes 2, 5, 10, 7 +c Face 4 : aretes 3, 8, 11, 6 +c Face 5 : aretes 4, 7, 12, 8 +c Face 6 : aretes 9, 11, 12, 10 +c + lafac1 = quahex(lehexa,1) + lafac2 = quahex(lehexa,2) + lafac5 = quahex(lehexa,5) + lafac6 = quahex(lehexa,6) +cgn if ( lehexa.ge.210803 ) then +cgn write(*,90002) 'nbquto, nbhecf',nbquto, nbhecf +cgn write(*,90002) 'lafac1, lafac2, lafac5, lafac6', +cgn > lafac1, lafac2, lafac5, lafac6 +cgn endif +c + codfa1 = coquhe(lehexa,1) + codfa2 = coquhe(lehexa,2) + codfa5 = coquhe(lehexa,5) + codfa6 = coquhe(lehexa,6) +cgn if ( lehexa.ge.210803 ) then +cgn write(*,90002) 'codfa1, codfa2, codfa5, codfa6', +cgn > codfa1, codfa2, codfa5, codfa6 +cgn endif +c + listar(1) = arequa(lafac1,j1(codfa1)) + listar(2) = arequa(lafac1,j2(codfa1)) + listar(3) = arequa(lafac1,j4(codfa1)) + listar(4) = arequa(lafac1,j3(codfa1)) + listar(5) = arequa(lafac2,j4(codfa2)) + listar(6) = arequa(lafac2,j2(codfa2)) + listar(7) = arequa(lafac5,j2(codfa5)) + listar(8) = arequa(lafac5,j4(codfa5)) + listar(9) = arequa(lafac2,j3(codfa2)) + listar(10) = arequa(lafac6,j4(codfa6)) + listar(11) = arequa(lafac6,j2(codfa6)) + listar(12) = arequa(lafac6,j3(codfa6)) +cgn if ( lehexa.ge.210803 ) then +cgn write(*,*) 'listar en sortie de utarhe' +cgn write(*,91010) listar +cgn endif +c + end diff --git a/src/tool/Utilitaire/utarpe.F b/src/tool/Utilitaire/utarpe.F new file mode 100644 index 00000000..885a7dd4 --- /dev/null +++ b/src/tool/Utilitaire/utarpe.F @@ -0,0 +1,116 @@ + subroutine utarpe ( lepent, + > nbquto, nbpecf, + > arequa, facpen, cofape, + > listar ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ARetes d'un PEntaedre decrit par ses faces +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbpecf . e . 1 . nombre total de pentaedres . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. codes des 5 faces des pentaedres . +c . listar . s . 9 . les 9 aretes du pentaedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "j1234j.h" +c +c 0.3. ==> arguments +c + integer lepent + integer nbquto, nbpecf + integer listar(9) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5) +c +c 0.4. ==> variables locales +c + integer lafac3, lafac4, lafac5 + integer codfa3, codfa4, codfa5 +c +c Sur ce croquis, semblable a la documentation sur les structures de +c donnees, la droite S2-S5 est a l'arriere-plan. +c +c S3 a9 S6 +c x------------------------------------------x +c . . +c . . . . +c a3 . a6 . +c . . . . +c . . +c . .a1 . .a4 +c . . +c S2. . a8 S5. . +c x - - - - - - - - - - - - - - - - - - - - -x +c . . . . +c . . +c a2 . . a5 . . +c x------------------------------------------x +c S1 a7 S4 +c La face f1 est le triangle (S1,S2,S3). +c La face f2 est le triangle (S4,S6,S5). +c L'arete a1 est relie les sommets S1 et S3. +c Les aretes (a1,a2,a3) realisent une rotation entrante dans le +c pentaedre. L'arete ai+3 est parallele a l'arete ai. +c La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2. +c +c remarque : le schema de mmag35 doit etre similaire +c==== +c 1. traitement +c==== +c + lafac3 = facpen(lepent,3) + lafac4 = facpen(lepent,4) + lafac5 = facpen(lepent,5) +c + codfa3 = cofape(lepent,3) + codfa4 = cofape(lepent,4) + codfa5 = cofape(lepent,5) +c + listar(1) = arequa(lafac3,j1(codfa3)) + listar(2) = arequa(lafac4,j1(codfa4)) + listar(3) = arequa(lafac5,j1(codfa5)) + listar(4) = arequa(lafac3,j3(codfa3)) + listar(5) = arequa(lafac4,j3(codfa4)) + listar(6) = arequa(lafac5,j3(codfa5)) + listar(7) = arequa(lafac3,j4(codfa3)) + listar(8) = arequa(lafac4,j4(codfa4)) + listar(9) = arequa(lafac5,j4(codfa5)) +c + end diff --git a/src/tool/Utilitaire/utarpy.F b/src/tool/Utilitaire/utarpy.F new file mode 100644 index 00000000..1e773d54 --- /dev/null +++ b/src/tool/Utilitaire/utarpy.F @@ -0,0 +1,117 @@ + subroutine utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) + +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ARetes d'une PYramide decrite par ses faces +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbpycf . e . 1 . nombre total de pyramides . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . listar . s . 8 . les 8 aretes de la pyramide . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer lapyra + integer nbtrto, nbpycf + integer listar(8) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac3, lafac4 + integer codfa1, codfa2, codfa3, codfa4 +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c S5 +c x +c . . . . +c . . . . +c . . a4. . +c . . . . +c . . x . . +c a1 . . . S4 . .a3 +c . . . . . +c . . . . +c . . . a7 . . +c . .a8 . . . +c . . . . . +c S1 . .a2 . . +c x . . . . +c a5 . . . +c x--------------------------------------------------------x +c S2 a6 S3 +c La face f5 est le quadrangle. +c La face fi, i<5, est le triangle s'appuyant sur l'arete ai. +c +c==== +c 1. traitement +c==== +c + lafac1 = facpyr(lapyra,1) + lafac2 = facpyr(lapyra,2) + lafac3 = facpyr(lapyra,3) + lafac4 = facpyr(lapyra,4) +c + codfa1 = cofapy(lapyra,1) + codfa4 = cofapy(lapyra,4) + codfa2 = cofapy(lapyra,2) + codfa3 = cofapy(lapyra,3) +cgn print 1789, 'triangles ',lafac1, lafac2, lafac3, lafac4 +cgn print 1789, 'codes ',codfa1, codfa2, codfa3, codfa4 +cgn 1789 format(a,5i10) +c + listar(1) = aretri(lafac1,i1(codfa1)) + listar(2) = aretri(lafac1,i2(codfa1)) + listar(3) = aretri(lafac2,i2(codfa2)) + listar(4) = aretri(lafac3,i2(codfa3)) + listar(5) = aretri(lafac1,i3(codfa1)) + listar(6) = aretri(lafac2,i3(codfa2)) + listar(7) = aretri(lafac3,i3(codfa3)) + listar(8) = aretri(lafac4,i2(codfa4)) +c + end diff --git a/src/tool/Utilitaire/utarro.F b/src/tool/Utilitaire/utarro.F new file mode 100644 index 00000000..e62e3e73 --- /dev/null +++ b/src/tool/Utilitaire/utarro.F @@ -0,0 +1,418 @@ + subroutine utarro ( x1, x2, xar1, xar2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ARROndi +c -- ---- +c +c retourne un encadrement arrondi a une "bonne" puissance de 10 +c d'un intervalle reel +c le but est d'avoir 2 chiffres de difference entre les bornes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . x1 . e . 1 . premiere valeur a arrondir . +c . x2 . e . 1 . seconde valeur a arrondir . +c . xar1 . s . 1 . premiere valeur arrondie . +c . xar2 . s . 1 . seconde valeur arrondie . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTARRO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + double precision x1, x2, xar1, xar2 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer vmiexp, vmaexp, vecexp +c + double precision vminia, vmaxia + double precision dxmax, dxmin + double precision vmiman, vmaman, vecman + double precision daux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Valeur '',i1,'' a arrondir :'',g25.17)' + texte(1,6) = '(''--> valeur '',i1,'' arrondie :'',g25.17)' +c + texte(2,4) = '(''Value '',i1,'' to round :'',g25.17)' + texte(2,6) = '(''--> round value '',i1,'' :'',g25.17)' +c +#include "impr03.h" + 1001 format(a,' :',f20.17,' * 10**',i3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 1, x1 + write (ulsort,texte(langue,4)) 2, x2 + write (ulsort,90004) 'epsima', epsima + write (ulsort,90004) 'dmxent', dmxent +#endif +c + codret = 0 +c +c==== +c 2. recherche des bornes +c j = 0 : les deux valeurs sont confondues +c . soit parce qu'elles sont toutes les deux inferieures +c au zero machine +c . soit parce que leur ecart relatif est inferieur au nombre +c de chiffres significatifs decelables +c j = 1 : 0 <= x1 < x2 +c j = 2 : x1 < 0 < x2 et abs(x2)>=abs(x1) +c j = 3 : x1 < 0 < x2 et abs(x1)>abs(x2) +c j = 4 : x1 < x2 < 0 +c j = 5 : 0 <= x2 < x1 +c j = 6 : x2 < 0 < x1 et abs(x2)>=abs(x1) +c j = 7 : x2 < 0 < x1 et abs(x1)>=abs(x2) +c j = 8 : x2 < x1 < 0 +c==== +c + daux = abs(x1) + abs(x2) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Somme des valeurs absolues', daux +#endif + if ( daux.le.zeroma ) then +c + jaux = 0 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) '. Ecart en v abs', abs(x2-x1) + write (ulsort,90004) '. Ecart en v rel', abs(x2-x1)/daux + write (ulsort,90004) '. Ecart teste', dmxent*abs(x2-x1)/daux +#endif +c + if ( dmxent*abs(x2-x1)/daux.le.1.d0 ) then +c + jaux = 0 +c + elseif ( x2.gt.x1 ) then +c + if ( x1.ge.0.d0 ) then + jaux = 1 + vmaxia = x2 + vminia = x1 + elseif ( x2.ge.0.d0 ) then + if ( abs(x2).ge.abs(x1) ) then + jaux = 2 + vmaxia = abs(x2) + vminia = abs(x1) + else + jaux = 3 + vmaxia = abs(x1) + vminia = abs(x2) + endif + else + jaux = 4 + vmaxia = abs(x1) + vminia = abs(x2) + endif +c + else +c + if ( x2.ge.0.d0 ) then + jaux = 5 + vmaxia = x1 + vminia = x2 + elseif ( x1.ge.0.d0 ) then + if ( abs(x2).ge.abs(x1) ) then + jaux = 6 + vmaxia = abs(x2) + vminia = abs(x1) + else + jaux = 7 + vmaxia = abs(x1) + vminia = abs(x2) + endif + else + jaux = 8 + vmaxia = abs(x2) + vminia = abs(x1) + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '=> jaux', jaux +#endif +c +c==== +c 3. Recherche d'un ecart en puissance de 10 quand les valeurs sont +c differentes +c Attention a gerer les cas >0 et <0 ... +c==== +c + if ( jaux.eq.0 ) then +c + xar1 = (x1+x2)/2.d0 + xar2 = xar1 +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. jaux', jaux + write (ulsort,90004) '. vminia', vminia + write (ulsort,90004) '. vmaxia', vmaxia +#endif +c +c 3.1. ==> transformation en mantisse/exposant +c + call utpd10 ( vminia, vmiman, vmiexp, + > ulsort, langue, codret ) +c + call utpd10 ( vmaxia, vmaman, vmaexp, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) 'v abs mini', vmiman, vmiexp + write (ulsort,1001) 'v abs maxi', vmaman, vmaexp +#endif +c +c 3.2. ==> Si l'ecart de puissance est d'au moins 2 : +c . la plus grande variable en valeur absolue est +c du type +/-0.xx000dn +c . la plus petite variable en valeur absolue est +c . mise a zero si les deux variables sont de meme signe +c . -/+0.01dn si les variables sont de signe oppose +c + if ( abs(vmaexp-vmiexp).ge.2 ) then +c +c 3.2.1. ==> Arrondi de la grande variable en valeur absolue +c +cgn daux = vmaman*100.d0 + daux = vmaxia*(10.d0**(2-vmaexp)) + iaux = int(daux) + dxmax = dble(iaux)*(10.d0**(vmaexp-2)) +cgn write (ulsort,*) iaux,dxmax,abs(dxmax-vmaxia) + if ( abs(dxmax-vmaxia).gt.epsima ) then + dxmax = dble(iaux+1)*(10.d0**(vmaexp-2)) + endif +c +c 3.2.2. ==> La petite variable en valeur absolue +c + if ( jaux.eq.1 .or. jaux.eq.4 .or. + > jaux.eq.5 .or. jaux.eq.8 )then + dxmin = 0.d0 + else + dxmin = 0.01d0*(10.d0**vmaexp) + endif +c +c 3.3. ==> Sinon : +c . la plus grande variable en valeur absolue est +c du type +/-0.x--xab000dn +c . la plus petite variable en valeur absolue est +c du type +/-0.x--xcd000dn +c + else +c +c 3.3.1. ==> Calcul de l'ecart des valeurs absolues +c + daux = abs(vmaxia-vminia) + call utpd10 ( daux, vecman, vecexp, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) 'ecart des va ', vecman, vecexp +#endif +c +c 3.3.2. ==> Arrondi de la grande variable en valeur absolue +c + daux = vmaxia*(10.d0**(2-vecexp)) + iaux = int(daux) +cgn write (ulsort,90044) 'daux =',daux,' => iaux =',iaux +cgn write (ulsort,90002) 'vmaexp,vecexp,vmaexp-vecexp+2', +cgn > vmaexp,vecexp,vmaexp-vecexp+2 + dxmax = dble(iaux)*(10.d0**(vecexp-2)) +cgn write (ulsort,90004) 'dxmax',dxmax,abs(dxmax-vmaxia) + if ( abs(dxmax-vmaxia).gt.epsima ) then + dxmax = dble(iaux+1)*(10.d0**(vecexp-2)) + endif +c +c 3.3.3. ==> La petite variable en valeur absolue +c + daux = vminia*(10.d0**(2-vecexp)) + iaux = int(daux) +cgn write (ulsort,*) daux,iaux + dxmin = dble(iaux)*(10.d0**(vecexp-2)) + if ( jaux.eq.2 .or. jaux.eq.3 .or. + > jaux.eq.6 .or. jaux.eq.7 )then + if ( abs(dxmin-vminia).gt.epsima ) then + dxmin = dble(iaux+1)*(10.d0**(vecexp-2)) + endif + endif +c + endif +c +c 3.4. ==> Transfert +c + if ( jaux.eq.1 ) then + xar1 = dxmin + xar2 = dxmax + elseif ( jaux.eq.2 ) then + xar1 = -dxmin + xar2 = dxmax + elseif ( jaux.eq.3 ) then + xar1 = -dxmax + xar2 = dxmin + elseif ( jaux.eq.4 ) then + xar1 = -dxmax + xar2 = -dxmin + elseif ( jaux.eq.5 ) then + xar1 = dxmax + xar2 = dxmin + elseif ( jaux.eq.6 ) then + xar1 = dxmin + xar2 = -dxmax + elseif ( jaux.eq.7 ) then + xar1 = dxmax + xar2 = -dxmin + else + xar1 = -dxmin + xar2 = -dxmax + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) 1, xar1 + write (ulsort,texte(langue,6)) 2, xar2 +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +cgn +cgn programme de test +cgn +cgn program toto +cgn implicit none +cgn double precision x1, x2, xar1, xar2 +cgn integer ulsort, langue, codret +cgn integer iaux +cgn ulsort = 6 +cgn langue = 1 +cgnccc write (6,*) 'x1, x2 ?' +cgnccc read (5,*) x1, x2 +cgn do 11 , iaux = 1 , 8 +cgn xar1 = 100304.d0 +cgn xar2 = 99213.d0 +cgn xar1 = sqrt(2.d0) +cgn xar2 = sqrt(3.d0)*1.d0 +cgn x1 = min(xar1,xar2) +cgn x2 = max(xar1,xar2) +cgn xar1 = x1 +cgn xar2 = x2 +cgn if ( iaux.eq.1 ) then +cgn x1 = xar1 +cgn x2 = xar2 +cgn elseif ( iaux.eq.2 ) then +cgn x1 = -xar1 +cgn x2 = xar2 +cgn elseif ( iaux.eq.3 ) then +cgn x1 = -xar2 +cgn x2 = xar1 +cgn elseif ( iaux.eq.4 ) then +cgn x1 = -xar2 +cgn x2 = -xar1 +cgn elseif ( iaux.eq.5 ) then +cgn x1 = xar2 +cgn x2 = xar1 +cgn elseif ( iaux.eq.6 ) then +cgn x1 = xar1 +cgn x2 = -xar2 +cgn elseif ( iaux.eq.7 ) then +cgn x1 = xar2 +cgn x2 = -xar1 +cgn elseif ( iaux.eq.8 ) then +cgn x1 = -xar1 +cgn x2 = -xar2 +cgn endif +cgn call utarro ( x1, x2, xar1, xar2, +cgn > ulsort, langue, codret ) +cgn write (ulsort,*) x1,' ==> ',xar1 +cgn write (ulsort,*) x2,' ==> ',xar2 +cgn print * ,' ' +cgn 11 continue +cgn end +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utarte.F b/src/tool/Utilitaire/utarte.F new file mode 100644 index 00000000..d30ab897 --- /dev/null +++ b/src/tool/Utilitaire/utarte.F @@ -0,0 +1,110 @@ + subroutine utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : ARetes d'un TEtraedre decrit par ses faces +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbtecf . e . 1 . nombre total de tetraedres decrits par face. +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des 4 triangles des tetraedres . +c . listar . s . 6 . les 6 aretes du tetraedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "i1i2i3.h" +c +c 0.3. ==> arguments +c + integer letetr + integer nbtrto, nbtecf + integer listar(6) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac3, lafac4 + integer codfa1, codfa3, codfa4 +c +c==== +c 1. traitement +c==== +c +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a3 +c . . . +c . . . +c a1 . a2 . . n4 +c . . * +c . . . . +c . a5 . . . a6 +c . . . . +c . . .. +c . . . +c *..................................* +c n2 a4 n3 +c +c . Les noeuds (1,2,3) definissent un triangle a orientation +c vers l'exterieur +c Avec le code 1, les faces sont : +c Face 1 : aretes 4, 5, 6 (sortante) +c Face 2 : aretes 2, 3, 6 (entrante) +c Face 3 : aretes 1, 3, 5 (sortante) +c Face 4 : aretes 1, 2, 4 (entrante) +c + lafac1 = tritet(letetr,1) + lafac3 = tritet(letetr,3) + lafac4 = tritet(letetr,4) +c + codfa1 = cotrte(letetr,1) + codfa3 = cotrte(letetr,3) + codfa4 = cotrte(letetr,4) +c + listar(1) = aretri(lafac4,i1(codfa4)) + listar(2) = aretri(lafac4,i2(codfa4)) + listar(3) = aretri(lafac3,i2(codfa3)) + listar(4) = aretri(lafac1,i1(codfa1)) + listar(5) = aretri(lafac1,i2(codfa1)) + listar(6) = aretri(lafac1,i3(codfa1)) +c + end diff --git a/src/tool/Utilitaire/utashe.F b/src/tool/Utilitaire/utashe.F new file mode 100644 index 00000000..d1f043b0 --- /dev/null +++ b/src/tool/Utilitaire/utashe.F @@ -0,0 +1,103 @@ + subroutine utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Aretes et Sommets d'un HExaedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero du hexaedre a analyser . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbhecf . e . 1 . nombre d'hexaedres decrits par faces . +c . nbheca . e . 1 . nombre d'hexaedres decrits par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . listar . s . 12 . les 12 aretes de l'hexaedre . +c . listso . s . 8 . liste des sommets de l'hexaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lehexa + integer nbquto, nbhecf, nbheca +c + integer somare(2,*) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c + integer listar(12), listso(8) +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. Les aretes de l'hexaedre +c==== +c + if ( lehexa.le.nbhecf ) then +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + else +c + do 11 , iaux = 1 , 12 + listar(iaux) = arehex(lehexa-nbhecf,iaux) + 11 continue +c + endif +cgn if ( lehexa.le.-210803 ) then +cgn write(1,*) 'listar en sortie de utashe' +cgn write(1,91010) listar +cgn endif +c +c==== +c 2. les sommets de l'hexaedre +c==== +c + call utsohe ( somare, listar, listso ) +c + end diff --git a/src/tool/Utilitaire/utaspe.F b/src/tool/Utilitaire/utaspe.F new file mode 100644 index 00000000..75803d25 --- /dev/null +++ b/src/tool/Utilitaire/utaspe.F @@ -0,0 +1,98 @@ + subroutine utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Aretes et Sommets d'un PEntaedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbpecf . e . 1 . nombre total de pentas decrits par faces . +c . nbpeca . e . 1 . nombre total de pentas decrits par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. codes des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. code des 9 aretes des pentaedres . +c . listar . s . 9 . les 9 aretes du pentaedre . +c . listso . s . 6 . liste des sommets du pentaedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lepent + integer nbquto, nbpecf, nbpeca +c + integer somare(2,*) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c + integer listar(9), listso(6) +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. Les aretes du pentaedre +c==== +c + if ( lepent.le.nbpecf ) then +c + call utarpe ( lepent, + > nbquto, nbpecf, + > arequa, facpen, cofape, + > listar ) +c + else +c + do 11 , iaux = 1 , 9 + listar(iaux) = arepen(lepent-nbpecf,iaux) + 11 continue +c + endif +c +c==== +c 2. les sommets du pentaedre +c==== +c + call utsope ( somare, listar, listso ) +c + end diff --git a/src/tool/Utilitaire/utaspy.F b/src/tool/Utilitaire/utaspy.F new file mode 100644 index 00000000..f2c7619d --- /dev/null +++ b/src/tool/Utilitaire/utaspy.F @@ -0,0 +1,99 @@ + subroutine utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) + +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Aretes et Sommets d'une PYramide +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbpycf . e . 1 . nombre total de pyramides decrits par faces. +c . nbpyca . e . 1 . nombre total de pyras decrits par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . listar . s . 8 . les 8 aretes de la pyramide . +c . listso . s . 5 . liste des sommets de la pyramide . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lapyra + integer nbtrto, nbpycf, nbpyca +c + integer somare(2,*) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c + integer listar(8), listso(5) +c +c 0.4. ==> variables locales +c +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. Les aretes de la pyramide +c==== +c + if ( lapyra.le.nbpycf ) then +c + call utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) +c + else +c + do 11 , iaux = 1 , 8 + listar(iaux) = arepyr(lapyra-nbpycf,iaux) + 11 continue +c + endif +c +c==== +c 2. les sommets de la pyramide +c==== +c + call utsopy ( somare, listar, listso ) +c + end diff --git a/src/tool/Utilitaire/utaste.F b/src/tool/Utilitaire/utaste.F new file mode 100644 index 00000000..9ca066c0 --- /dev/null +++ b/src/tool/Utilitaire/utaste.F @@ -0,0 +1,97 @@ + subroutine utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Aretes et Sommets d'un TEtraedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbtecf . e . 1 . nombre total de tetraedres decrits par face. +c . nbteca . e . 1 . nombre total de tetras decrits par aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . listar . s . 6 . les 6 aretes du tetraedre . +c . listso . s . 4 . liste des sommets du tetraedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer letetr + integer nbtrto, nbtecf, nbteca +c + integer somare(2,*) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) +c + integer listar(6), listso(4) +c +c 0.4. ==> variables locales +c + integer iaux +c ______________________________________________________________________ +c +c==== +c 1. Les aretes du tetraedre +c==== +c + if ( letetr.le.nbtecf ) then +c + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + else +c + do 11 , iaux = 1 , 6 + listar(iaux) = aretet(letetr-nbtecf,iaux) + 11 continue +c + endif +c +c==== +c 2. les sommets du tetraedre +c==== +c + call utsote ( somare, listar, listso ) +c + end diff --git a/src/tool/Utilitaire/utaurq.F b/src/tool/Utilitaire/utaurq.F new file mode 100644 index 00000000..818ea93a --- /dev/null +++ b/src/tool/Utilitaire/utaurq.F @@ -0,0 +1,255 @@ + subroutine utaurq ( modhom, eleinc, + > nocman, + > nbelig, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - AUtorisation de Raffinement des Quadrangles +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . -5 : executable du suivi de frontiere . +c . . . . -4 : exec. de l'interface apres adaptation . +c . . . . -3 : exec. de l'interface avant adaptation . +c . . . . -2 : executable de l'information . +c . . . . -1 : executable de l'adaptation . +c . . . . 0 : executable autre . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . eleinc . e . 1 . elements incompatibles . +c . . . . 0 : on bloque s'il y en a . +c . . . . 1 : on les ignore s'il y en a . +c . nocman . e . char*8 . nom de l'objet maillage calcul iteration n . +c . nbelig . s . 1 . nombre d'elements elimines . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : presence de quadrangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTAURQ' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer modhom, eleinc + integer nbelig +c + character*8 nocman +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer adnomb + integer sdimca, mdimca + integer degre, mailet, maconf, homolo, hierar, nbnomb + integer nbpyra +c + character*7 saux07 + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. a priori, tout va bien +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + texte(1,4) = '(/,''Maillage de calcul : '',a)' + texte(1,5) = '(''Mode HOMARD :'',i3)' + texte(1,6) = '(''Ce maillage comporte'',i8,1x,a)' + texte(1,7) = '(''Elimination de'',i8,1x,a)' + texte(1,8) = + > '(5x,''Nombre de '',a,'' a '',a,'' :'',i8)' + texte(1,9) = + > '(''Cela est incompatible avec ce raffinement.'',/)' + texte(1,10) ='(/,''On '',a,'' les mailles incompatibles.'')' +c + texte(2,4) = '(/,''Calculation mesh : '',a)' + texte(2,5) = '(''HOMARD mode :'',i3)' + texte(2,6) = '(''This mesh contains'',i8,1x,a)' + texte(2,7) = '(''Elimination of'',i8,1x,a)' + texte(2,8) = '(5x,''Number of '',a,'' '',a,'' :'',i8)' + texte(2,9) = '(''It is forbidden with this refinement.'')' + texte(2,10) ='(/,''Incompatible meshes are '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) modhom + if ( eleinc.eq.0 ) then + write (ulsort,texte(langue,10)) 'bloque' + else + write (ulsort,texte(langue,10)) 'ignore' + endif +#endif +c +c==== +c 2. Recherche du nombre de pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocman, + > sdimca, mdimca, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbpyra = imem(adnomb+19) +c + endif +c +c==== +c 3. determination du nombre de mailles a eliminer +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. determination ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbpyra, mess14(langue,3,5) +#endif +c + if ( modhom.eq.1 .or. modhom.eq.-1 ) then + nbelig = nbpyra + else + nbelig = 0 + endif +c + endif +c +c==== +c 4. diagnostic +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. diagnostic ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbelig, mess14(langue,3,5) +#endif +c + if ( nbelig.ne.0 ) then +c +c 4.1. ==> messages +c + if ( eleinc.eq.0 ) then + saux07 = 'bloquer' + else + saux07 = 'ignorer' + endif +c + write (ulsort,texte(langue,8))mess14(langue,3,5),saux07,nbelig + write (ulsort,*) ' ' +c +c 4.2. ==> Si on bloque en presence de telles mailles +c + if ( eleinc.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nocman +#endif + write (ulsort,texte(langue,9)) + codret = 2 +c + endif +c + endif +c + endif +c +c=== +c 5. la fin +c=== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb02a.F b/src/tool/Utilitaire/utb02a.F new file mode 100644 index 00000000..e1e964cd --- /dev/null +++ b/src/tool/Utilitaire/utb02a.F @@ -0,0 +1,1063 @@ + subroutine utb02a ( hetare, + > hettri, pertri, voltri, + > hetqua, volqua, + > posifa, facare, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 02 +c -- - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB02A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envada.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto) + integer hettri(nbtrto), pertri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto) + integer volqua(2,nbquto) + integer posifa(0:nbarto), facare(nbfaar) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete, letria,lequad + integer nbarba, nbarbt, nbaria, nbarit + integer nbfaba, nbfabt, nbfava, nbfavt + integer pos, fac1, fac2, vois1, vois2 + integer iaux, jaux +c + logical arbord +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*54 mess54(nblang,nbmess) + character*43 saux43 + character*43 mess43(nblang,150) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''NOMBRE D''''ENTITES HOMARD'',/,3x,23(''=''),/)' +c + texte(2,4) = + > '(//,3x,''NUMBER OF HOMARD ENTITIES'',/,3x,25(''=''),/)' +c + mess54(1,5) = + > ' Le maillage presente des homologues ' +c +c 1234567890123456789012345678901234567890123 + mess43(1,1) = 'Nombre total ' + mess43(1,2) = '. dont sommets d''aretes (noeud P1) ' + mess43(1,3) = '. dont milieux d''aretes (noeud P2) ' + mess43(1,4) = '. dont noeuds internes aux mailles ' + mess43(1,5) = '. dont noeuds isoles ' + mess43(1,6) = '. dont noeuds mailles ignorees uniquement ' + mess43(1,7) = '. dont noeuds mailles-points uniquement ' + mess43(1,8) = 'Nombre de noeuds du macro-maillage ' +c + mess43(1,12) = 'Ces aretes sont reparties en N types : ' + mess43(1,13) = '. des aretes du macro-maillage ' + mess43(1,14) = '. des aretes crees par le decoupage ' + mess43(1,15) = '. des aretes creees par le decoupage en ' + mess43(1,16) = ' deux des triangles ' + mess43(1,17) = ' - trois triangles des quadrangles ' + mess43(1,18) = ' - deux quadrangles des quadrangles ' + mess43(1,19) = ' - trois quadrangles des quadrangles ' + mess43(1,20) = '. des aretes internes pour le decoupage par' + mess43(1,21) = ' conformite des ' + mess43(1,26) = '. dont aretes isolees ' + mess43(1,27) = '. dont aretes de bord de regions 2D ' + mess43(1,28) = '. dont aretes internes aux faces/volumes ' + mess43(1,29) = 'Nombre d''aretes actives ' +c +c 1234567890123456789012345678901234567890123 + mess43(1,31) = 'Ces triangles sont d''un seul type : ' + mess43(1,32) = 'Ces triangles sont repartis en N types : ' + mess43(1,33) = '. des triangles du macro-maillage ' + mess43(1,34) = '. des triangles crees par le decoupage ' + mess43(1,38) = '. des triangles crees par le decoupage en ' + mess43(1,39) = ' deux des triangles ' + mess43(1,40) = ' trois des quadrangles ' + mess43(1,41) = '. des triangles internes aux tetraedres ' + mess43(1,42) = ' decoupes en deux ou quatre ' + mess43(1,43) = '. des triangles internes aux hexaedres ' + mess43(1,44) = '. des triangles internes aux pentaedres ' + mess43(1,45) = ' decoupes par conformite ' + mess43(1,46) = '. dont triangles de regions 2D ' + mess43(1,47) = '. dont triangles de bord ' + mess43(1,48) = '. dont triangles internes aux volumes ' + mess43(1,49) = 'Nombre de triangles actifs ' +c + mess43(1,51) = 'Ces quadrangles sont d''un seul type : ' + mess43(1,52) = 'Ces quadrangles sont repartis en N types : ' + mess43(1,53) = '. des quadrangles du macro-maillage ' + mess43(1,54) = '. des quadrangles crees par le decoupage ' + mess43(1,58) = '. des quadrangles crees par le decoupage en' + mess43(1,59) = ' - deux des quadrangles ' + mess43(1,60) = ' - trois des quadrangles ' + mess43(1,66) = '. dont quadrangles de regions 2D ' + mess43(1,67) = '. dont quadrangles de bord ' + mess43(1,68) = '. dont quadrangles internes aux volumes ' + mess43(1,69) = 'Nombre de quadrangles actifs ' +c +c 1234567890123456789012345678901234567890123 + mess43(1,71) = 'Ces tetraedres sont d''un seul type : ' + mess43(1,72) = 'Ces tetraedres sont repartis en ' + mess43(1,73) = '. des tetraedres du macro-maillage ' + mess43(1,74) = '. des tetraedres crees par le decoupage ' + mess43(1,75) = '. des tetraedres crees par le decoupage ' + mess43(1,76) = ' d''un tetra en quatre a partir d''une face ' + mess43(1,77) = ' d''un tetra en quatre a partir de 2 aretes' + mess43(1,78) = ' d''un tetra en deux a partir d''une arete ' + mess43(1,79) = 'Nombre de tetraedres actifs ' +c + mess43(1,81) = 'Ces hexaedres sont d''un seul type : ' + mess43(1,82) = 'Ces hexaedres sont repartis en N types : ' + mess43(1,83) = '. des hexaedres du macro-maillage ' + mess43(1,84) = '. des hexaedres crees par le decoupage ' + mess43(1,85) = ' de conformite des hexaedres ' + mess43(1,89) = 'Nombre d''hexaedres actifs ' +c +c 1234567890123456789012345678901234567890123 + mess43(1,91) = 'Ces pyramides sont d''un seul type : ' + mess43(1,92) = 'Ces pyramides sont reparties en N types : ' + mess43(1,93) = '. des pyramides du macro-maillage ' + mess43(1,94) = '. des pyramides creees par le decoupage ' + mess43(1,95) = '. des pyramides creees par le decoupage ' + mess43(1,99) = 'Nombre de pyramides actives ' +c + mess43(1,101) = 'Ces pentaedres sont repartis en N types : ' + mess43(1,102) = '. des pentaedres du macro-maillage ' + mess43(1,103) = '. des pentaedres crees par le decoupage ' + mess43(1,109) = 'Nombre de pentaedres actifs ' +c + mess43(1,111) = ' a partir d''une face d''hexaedre ' + mess43(1,112) = ' a partir de trois aretes d''hexaedre ' + mess43(1,113) = ' a partir de deux aretes d''hexaedre ' + mess43(1,114) = ' a partir d''une arete d''hexaedre ' +c + mess43(1,121) = ' a partir d''une arete tri de pentaedre ' + mess43(1,122) = ' a partir d''une arete qua de pentaedre ' + mess43(1,123) = ' a partir de 2 aretes tri/qua de pentaedre' + mess43(1,124) = ' a partir de 2 aretes tri de pentaedre ' + mess43(1,125) = ' a partir d''une face qua de pentaedre ' + mess43(1,126) = ' a partir d''une face tri de pentaedre ' +c + mess43(1,130) = 'Paires de ' +c 1234567890123456789012345678901234567890123 +c + mess43(1,131) = ' standard du maillage ' +c + mess54(2,5) = + > ' The mesh implies homologous condition. ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,1) = 'Total number ' + mess43(2,2) = '. included vertices of edges (P1 node) ' + mess43(2,3) = '. included centers of edges (P2 node) ' + mess43(2,4) = '. included internal nodes ' + mess43(2,5) = '. included isolated nodes ' + mess43(2,6) = '. included only ignored meshes nodes ' + mess43(2,7) = '. included only mesh-point nodes ' + mess43(2,8) = 'Nodes from the initial mesh ' +c + mess43(2,12) = 'These edges compose N types: ' + mess43(2,13) = '. edges from the initial mesh ' + mess43(2,14) = '. edges created for the standard ' + mess43(2,15) = '. edges created for the cutting into ' + mess43(2,16) = ' two of triangles ' + mess43(2,17) = ' - three triangles of quadrangles ' + mess43(2,18) = ' - two quadrangles of quadrangles ' + mess43(2,19) = ' - three quadrangles of quadrangles ' + mess43(2,20) = '. internal edges for the cutting by ' + mess43(2,21) = ' conformity of the ' + mess43(2,26) = '. included isolated edges ' + mess43(2,27) = '. included boundaries of 2D areas ' + mess43(2,28) = '. included internal in faces/volumes ' + mess43(2,29) = 'Number of active edges ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,31) = 'These triangles compose one single type: ' + mess43(2,32) = 'These triangles compose N types: ' + mess43(2,33) = '. triangles from the initial mesh ' + mess43(2,34) = '. triangles created for the standard ' + mess43(2,38) = '. triangles created for the cutting into ' + mess43(2,39) = ' two of triangles ' + mess43(2,40) = ' three of quadrangles ' + mess43(2,41) = '. internal triangles for tetraedra cutting ' + mess43(2,42) = ' into two or four ' + mess43(2,43) = '. internal triangles for hexaedra cutting ' + mess43(2,44) = '. internal triangles for prisms cutting ' + mess43(2,45) = ' by conformity ' + mess43(2,46) = '. included triangles of 2D areas ' + mess43(2,47) = '. included boundary triangles ' + mess43(2,48) = '. included internal triangles ' + mess43(2,49) = 'Number of active triangles ' +c + mess43(2,51) = 'These quadrangles compose one single type: ' + mess43(2,52) = 'These quadrangles compose N types: ' + mess43(2,53) = '. quadrangles from the initial mesh ' + mess43(2,54) = '. quadrangles created for the standard ' + mess43(2,58) = '. quadrangles created for the cutting into ' + mess43(2,59) = ' - two of quadrangles ' + mess43(2,60) = ' - three of quadrangles ' + mess43(2,66) = '. included quadrangles of 2D areas ' + mess43(2,67) = '. included boundary quadrangles ' + mess43(2,68) = '. included internal quadrangles ' + mess43(2,69) = 'Number of active quadrangles ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,71) = 'These tetrahedra compose one single type: ' + mess43(2,72) = 'These tetrahedra compose ' + mess43(2,73) = '. tetrahedra from the initial mesh ' + mess43(2,74) = '. tetrahedra created for the standard ' + mess43(2,75) = '. tetrahedra created for the cutting ' + mess43(2,76) = ' of a tetrahedron into four from a face ' + mess43(2,77) = ' of a tetrahedron into four from 2 edges ' + mess43(2,78) = ' of a tetrahedron into two from an edge ' + mess43(2,79) = 'Number of active tetrahedra ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,81) = 'These hexahedra compose one single type: ' + mess43(2,82) = 'These hexahedra compose N types: ' + mess43(2,83) = '. hexahedra from the initial mesh ' + mess43(2,84) = '. hexahedra created for the standard ' + mess43(2,85) = ' of the hexahedra for the conformity ' + mess43(2,89) = 'Number of active hexahedra ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,91) = 'These pyramids compose one single type: ' + mess43(2,92) = 'These pyramids compose N types: ' + mess43(2,93) = '. pyramids from the initial mesh ' + mess43(2,94) = '. pyramids created for the standard ' + mess43(2,95) = '. pyramids created for the splitting ' + mess43(2,99) = 'Number of active pyramids ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,101) = 'These pentahedra compose N types: ' + mess43(2,102) = '. pentahedra from the initial mesh ' + mess43(2,103) = '. pentahedra created for the standard ' + mess43(2,109) = 'Number of active pentahedra ' +c + mess43(2,111) = ' from a face of an hexahedron ' + mess43(2,112) = ' from three edges of an hexahedron ' + mess43(2,113) = ' from two edges of an hexahedron ' + mess43(2,114) = ' from one edge of an hexahedron ' +c + mess43(2,121) = ' from one edge tri of a prism ' + mess43(2,122) = ' from one edge qua of a prism ' + mess43(2,123) = ' from two edges tri/qua of a prism ' + mess43(2,124) = ' from two edges tri of a prism ' + mess43(2,125) = ' from one face qua of a prism ' + mess43(2,126) = ' from one face tri of a prism ' +c + mess43(2,130) = 'Pairs of ' +c 1234567890123456789012345678901234567890123 +c + mess43(2,131) = ' refinement of the mesh ' +c + write (ulbila,texte(langue,4)) +c +#include "impr03.h" +c +10100 format(/,5x,60('*')) +10200 format( 5x,60('*')) +c +11100 format( 5x,'* ',a54,' *') +11200 format( 5x,'* ',21x,a14,21x,' *') +c +12100 format( 5x,'* ',a43,' *', 12x,'*') +12200 format( 5x,'* ',a43,' * ', i10,' *') +c + codret = 0 +c +c==== +c 2. noeuds +c==== +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,-1) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbnoto + if ( degre.eq.2 .or. + > nbnois.ne.0 .or. nbnoei.ne.0 .or. nbnomp.ne.0 ) then + write (ulbila,12200) mess43(langue,2), nbnop1 + endif + if ( degre.eq.2 ) then + write (ulbila,12200) mess43(langue,3), nbnop2 + endif + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then + write (ulbila,12200) mess43(langue,4), nbnoim + endif + if ( nbnois.ne.0 ) then + write (ulbila,12200) mess43(langue,5), nbnois + endif + if ( nbnoei.ne.0 ) then + write (ulbila,12200) mess43(langue,6), nbnoei + endif + if ( nbnomp.ne.0 ) then + write (ulbila,12200) mess43(langue,7), nbnomp + endif + write (ulbila,12200) mess43(langue,8), nbnoma + write (ulbila,10200) +c +c==== +c 3. mailles-points +c==== +c + if ( nbmpto.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,0) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbmpto + write (ulbila,10200) +c + endif +c +c==== +c 4. aretes +c==== +c +c on definit une arete de bord comme etant une arete ayant : +c . une seule face voisine, +c . deux faces voisines : +c . deux triangles dont l'un est le pere de l'autre : cas du +c decoupage de conformite provenant de l'arete de bord ; cela n'a +c lieu qu'avec des homologues. +c . un triangle et un quadrangle qui en est le pere des autres : cas +c du decoupage non conforme d'un quadrangle de bord. +c + nbarba = 0 + nbarbt = 0 + nbaria = 0 + nbarit = 0 +c + do 41 , larete = 1, nbarto +c + arbord = .false. +c + if ( posifa(larete-1)+2.eq.posifa(larete) ) then + pos = posifa(larete) + fac1 = facare(pos-1) + fac2 = facare(pos) + if ( fac1.gt.0 .and. fac2.gt.0 ) then + vois1 = min(fac1,fac2) + vois2 = max(fac1,fac2) + if ( pertri(vois2).eq.vois1 ) then + arbord = .true. + endif + elseif ( fac1.gt.0 .and. fac2.lt.0 ) then + if ( pertri(fac1).eq.fac2 ) then + arbord = .true. + endif + elseif ( fac1.lt.0 .and. fac2.gt.0 ) then + if ( pertri(fac2).eq.fac1 ) then + arbord = .true. + endif + endif + elseif ( posifa(larete-1)+1.eq.posifa(larete) ) then + arbord = .true. + elseif ( posifa(larete-1)+1.gt.posifa(larete) ) then + nbarit = nbarit +1 + if ( mod(hetare(larete),10).eq.0 ) then + nbaria = nbaria + 1 + endif + endif +c + if ( arbord ) then +cgn write(ulsort,*) 'larete = ',larete +cgn write(ulsort,*) '... ',posifa(larete-1), posifa(larete), +cgn > ' ==> face = ',facare(posifa(larete)) + nbarbt = nbarbt +1 + if ( mod(hetare(larete),10).eq.0 ) then + nbarba = nbarba + 1 + endif + endif +c + 41 continue +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,1) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbarto + if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + write (ulbila,12200) mess43(langue,26), nbarit + write (ulbila,12200) mess43(langue,27), nbarbt + write (ulbila,12200) mess43(langue,28), nbarto-nbarit-nbarbt + endif + if ( nbiter.ge.1 ) then + iaux = 2 + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + if ( nbtrma.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbquma.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbtema.ne.0 .or. nbhema.ne.0 .or. + > nbpema.ne.0 .or. nbpyma.ne.0 ) then + iaux = iaux + 1 + endif + endif + if ( langue.eq.1 ) then + jaux = 30 + else + jaux = 21 + endif + saux43 = mess43(langue,12) + write(saux43(jaux:jaux),'(i1)') iaux + write (ulbila,12100) saux43 + write (ulbila,12200) mess43(langue,13), nbarma + write (ulbila,12100) mess43(langue,14) + write (ulbila,12200) mess43(langue,131), nbarde + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + if ( nbtrma.ne.0 ) then + write (ulbila,12100) mess43(langue,15) + write (ulbila,12200) mess43(langue,16), nbart2 + endif + if ( nbquma.ne.0 ) then + write (ulbila,12100) mess43(langue,15) + write (ulbila,12200) mess43(langue,17), nbarq3 + write (ulbila,12200) mess43(langue,18), nbarq2 + write (ulbila,12200) mess43(langue,19), nbarq5 + endif + if ( nbtema.ne.0 .or. nbhema.ne.0 .or. + > nbpema.ne.0 .or. nbpyma.ne.0 ) then + write (ulbila,12100) mess43(langue,20) + if ( nbtema.ne.0 .and. + > ( nbhema+nbpema+nbpyma).eq.0 ) then + iaux = 3 + elseif ( nbhema.ne.0 .and. + > (nbtema +nbpema+nbpyma).eq.0 ) then + iaux = 6 + elseif ( nbpema.ne.0 .and. + > (nbtema+nbhema +nbpyma).eq.0 ) then + iaux = 7 + elseif ( nbpyma.ne.0 .and. + > (nbtema+nbhema+nbpema ).eq.0 ) then + iaux = 5 + else + iaux = 9 + endif + saux43 = mess43(langue,21) + if ( langue.eq.1 ) then + jaux = 18 + else + jaux = 21 + endif + saux43(jaux:jaux+13) = mess14(langue,3,iaux) + write (ulbila,12200) saux43, nbarin + endif + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,29), nbarac + if ( nbtrma.ne.0 .or. nbquma.ne.0 ) then + write (ulbila,12200) mess43(langue,26), nbaria + write (ulbila,12200) mess43(langue,27), nbarba + write (ulbila,12200) mess43(langue,28), nbarac-nbaria-nbarba + endif + endif + write (ulbila,10200) +c +c==== +c 5. triangles +c==== +c + if ( nbtrto.ne.0 ) then +c +c 5.1. ==> Les generalites +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,2) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbtrto +c +c 5.2. ==> Les bords +c Un triangle de bord est un triangle ayant un et un seul +c volume voisin. +c Le stockage etant different de la dimension deux, le tableau +c voltri ne garde que le volume fils. +c + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c + nbfaba = 0 + nbfabt = 0 + nbfava = 0 + nbfavt = 0 + do 52 , letria = 1, nbtrto + if ( voltri(1,letria).ne.0 ) then + if ( voltri(2,letria).eq.0 ) then + nbfabt = nbfabt + 1 + if ( mod(hettri(letria),10).eq.0 ) then + nbfaba = nbfaba + 1 + endif + else + nbfavt = nbfavt + 1 + if ( mod(hettri(letria),10).eq.0 ) then + nbfava = nbfava + 1 + endif + endif + endif + 52 continue +c + write (ulbila,12200) mess43(langue,46), nbtrto-nbfabt-nbfavt + write (ulbila,12200) mess43(langue,47), nbfabt + write (ulbila,12200) mess43(langue,48), nbfavt +c + endif +c +c 5.3. ==> Les historiques +c + if ( nbiter.ge.1 ) then +c + iaux = 0 + if ( nbtrma.ne.0 ) then + iaux = iaux + 2 + endif + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + if ( nbtrma.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbquma.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbtema.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbhema.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbpema.ne.0 ) then + iaux = iaux + 1 + endif + endif + if ( iaux.eq.1 ) then + saux43 = mess43(langue,31) + else + saux43 = mess43(langue,32) + if ( langue.eq.1 ) then + jaux = 32 + else + jaux = 25 + endif + write(saux43(jaux:jaux),'(i1)') iaux + endif + write (ulbila,12100) saux43 + if ( nbtrma.ne.0 ) then + write (ulbila,12200) mess43(langue,33), nbtrma + write (ulbila,12100) mess43(langue,34) + write (ulbila,12200) mess43(langue,131), nbtrde + endif + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + if ( nbtrma.ne.0 ) then + write (ulbila,12100) mess43(langue,38) + write (ulbila,12200) mess43(langue,39), nbtrt2 + endif + if ( nbquma.ne.0 ) then + write (ulbila,12100) mess43(langue,38) + write (ulbila,12200) mess43(langue,40), nbtrq3 + endif + if ( nbtema.ne.0 ) then + write (ulbila,12100) mess43(langue,41) + write (ulbila,12200) mess43(langue,42), nbtrtc + endif + if ( nbhema.ne.0 ) then + write (ulbila,12100) mess43(langue,43) + write (ulbila,12200) mess43(langue,45), nbtrhc + endif + if ( nbpema.ne.0 ) then + write (ulbila,12100) mess43(langue,44) + write (ulbila,12200) mess43(langue,45), nbtrpc + endif + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,49), nbtrac + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + write (ulbila,12200) mess43(langue,46), nbtrac-nbfaba-nbfava + write (ulbila,12200) mess43(langue,47), nbfaba + write (ulbila,12200) mess43(langue,48), nbfava + endif + endif +c + write (ulbila,10200) +c + endif +c +c==== +c 6. quadrangles +c==== +c + if ( nbquto.ne.0 ) then +c +c 6.1. ==> Les generalites +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,4) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbquto +c +c 6.2. ==> Les bords +c Un quadrangle de bord est un quadrangle ayant un et un seul +c volume voisin. +c Le stockage etant different de la dimension deux, le tableau +c volqua ne garde que le volume fils. +c + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then +c + nbfaba = 0 + nbfabt = 0 + nbfava = 0 + nbfavt = 0 + do 62 , lequad = 1, nbquto + if ( volqua(1,lequad).ne.0 ) then + if ( volqua(2,lequad).eq.0 ) then + nbfabt = nbfabt + 1 + if ( mod(hetqua(lequad),100).eq.0 ) then + nbfaba = nbfaba + 1 + endif + else + nbfavt = nbfavt + 1 + if ( mod(hetqua(lequad),100).eq.0 ) then + nbfava = nbfava + 1 + endif + endif + endif + 62 continue +c + write (ulbila,12200) mess43(langue,66), nbquto-nbfabt-nbfavt + write (ulbila,12200) mess43(langue,67), nbfabt + write (ulbila,12200) mess43(langue,68), nbfavt +c + endif +c +c 6.3. ==> Les historiques +c + if ( nbiter.ge.1 ) then +c + iaux = 0 + if ( nbquma.ne.0 ) then + iaux = iaux + 2 + endif + if ( iaux.eq.1 ) then + saux43 = mess43(langue,51) + else + saux43 = mess43(langue,52) + if ( langue.eq.1 ) then + jaux = 34 + else + jaux = 27 + endif + write(saux43(jaux:jaux),'(i1)') iaux + endif + write (ulbila,12100) saux43 + write (ulbila,12200) mess43(langue,53), nbquma + write (ulbila,12100) mess43(langue,54) + write (ulbila,12200) mess43(langue,131), nbqude + if ( ( maconf.eq.0 ) .or. ( maconf.eq.-1 ) ) then + if ( nbquma.ne.0 ) then + write (ulbila,12100) mess43(langue,58) + write (ulbila,12200) mess43(langue,59), nbquq2 + write (ulbila,12200) mess43(langue,60), nbquq5 + endif + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,69), nbquac + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + write (ulbila,12200) mess43(langue,66), nbquac-nbfaba-nbfava + write (ulbila,12200) mess43(langue,67), nbfaba + write (ulbila,12200) mess43(langue,68), nbfava + endif + endif +c + write (ulbila,10200) +c + endif +c +c==== +c 7. tetraedres +c==== +c + if ( nbteto.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,3) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbteto + if ( nbiter.ge.1 ) then + iaux = 0 + if ( nbtema.ne.0 ) then + iaux = iaux + 2 + endif + if ( nbtef4.ne.0 .or. nbtea4.ne.0 .or. nbtea2.ne.0 ) then + iaux = iaux + 3 + endif + if ( nbheco.ne.0 ) then + iaux = iaux + 3 + endif + if ( nbpeco.ne.0 ) then + iaux = iaux + 6 + endif + if ( iaux.eq.1 ) then + saux43 = mess43(langue,71) + else + if ( langue.eq.1 ) then + jaux = 33 + else + jaux = 26 + endif + saux43 = mess43(langue,72) + if ( iaux.le.9 ) then + write(saux43(jaux:jaux),'(i1)') iaux + jaux = jaux + 2 + else + write(saux43(jaux:jaux+1),'(i2)') iaux + jaux = jaux + 3 + endif + saux43(jaux:jaux+4) = 'types' + if ( langue.eq.1 ) then + jaux = jaux + 6 + else + jaux = jaux + 5 + endif + saux43(jaux:jaux) = ':' + endif + write (ulbila,12100) saux43 + if ( nbtema.ne.0 ) then + write (ulbila,12200) mess43(langue,73), nbtema + write (ulbila,12100) mess43(langue,74) + write (ulbila,12200) mess43(langue,131), nbtede + endif + if ( nbtef4.ne.0 .or. nbtea4.ne.0 .or. nbtea2.ne.0 ) then + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,76), nbtef4 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,77), nbtea4 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,78), nbtea2 + endif + if ( nbheco.ne.0 ) then + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,111), nbteh1 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,112), nbteh2 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,113), nbteh3 + endif + if ( nbpeco.ne.0 ) then + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,121), nbtep0 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,122), nbtep1 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,123), nbtep2 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,124), nbtep3 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,125), nbtep4 + write (ulbila,12100) mess43(langue,75) + write (ulbila,12200) mess43(langue,126), nbtep5 + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,79), nbteac + endif + write (ulbila,10200) +c + endif +c +c==== +c 8. hexaedres +c==== +c + if ( nbheto.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,6) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbheto + if ( nbiter.ge.1 ) then + iaux = 0 + if ( nbhema.ne.0 ) then + iaux = iaux + 2 + endif + if ( iaux.eq.1 ) then + saux43 = mess43(langue,81) + else + if ( langue.eq.1 ) then + jaux = 32 + else + jaux = 25 + endif + saux43 = mess43(langue,82) + write(saux43(jaux:jaux),'(i1)') iaux + endif + write (ulbila,12100) saux43 + if ( nbhema.ne.0 ) then + write (ulbila,12200) mess43(langue,83), nbhema + write (ulbila,12100) mess43(langue,84) + write (ulbila,12200) mess43(langue,131), nbhede + endif + if ( nbhedh.ne.0 ) then + write (ulbila,12100) mess43(langue,84) + write (ulbila,12200) mess43(langue,131), nbhedh + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,89), nbheac + endif + write (ulbila,10200) +c + endif +c +c==== +c 9. pyramides +c==== +c + if ( nbpyto.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,5) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbpyto + if ( nbiter.ge.1 ) then + iaux = 0 + if ( nbpyma.ne.0 ) then + iaux = iaux + 1 + endif + if ( nbheco.ne.0 ) then + if ( maconf.eq.-1 ) then + iaux = iaux + 3 + else + iaux = iaux + 1 + endif + endif + if ( nbpeco.ne.0 ) then + iaux = iaux + 6 + endif + if ( iaux.eq.1 ) then + saux43 = mess43(langue,91) + else + if ( langue.eq.1 ) then + jaux = 33 + else + jaux = 24 + endif + saux43 = mess43(langue,92) + write(saux43(jaux:jaux),'(i1)') iaux + endif + write (ulbila,12100) saux43 + if ( nbpyma.ne.0 ) then + write (ulbila,12200) mess43(langue,93), nbpyma + endif + if ( nbheco.ne.0 ) then + if ( maconf.eq.-1 ) then + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,111), nbpyh1 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,113), nbpyh3 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,114), nbpyh4 + else + write (ulbila,12100) mess43(langue,95) + write (ulbila,12200) mess43(langue,85), nbpydh + endif + endif + if ( nbpeco.ne.0 ) then + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,121), nbpyp0 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,122), nbpyp1 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,123), nbpyp2 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,124), nbpyp3 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,125), nbpyp4 + write (ulbila,12100) mess43(langue,94) + write (ulbila,12200) mess43(langue,126), nbpyp5 + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,99), nbpyac + endif + write (ulbila,10200) +c + endif +c +c==== +c 10. pentaedres +c==== +c + if ( nbpeto.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,7) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbpeto + if ( nbiter.ge.1 ) then + iaux = 0 + if ( nbpema.ne.0 ) then + iaux = iaux + 2 + endif + if ( langue.eq.1 ) then + jaux = 33 + else + jaux = 26 + endif + saux43 = mess43(langue,101) + write(saux43(jaux:jaux),'(i1)') iaux + write (ulbila,12100) saux43 + if ( nbpema.ne.0 ) then + write (ulbila,12200) mess43(langue,102), nbpema + write (ulbila,12100) mess43(langue,103) + write (ulbila,12200) mess43(langue,131), nbpede + endif + write (ulbila,10200) + write (ulbila,12200) mess43(langue,109), nbpeac + endif + write (ulbila,10200) +c + endif +c +c==== +c 11. reperage des homologues +c==== +c + if ( homolo.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11100) mess54(langue,5) + write (ulbila,10200) + saux43 = mess43(langue,130) + saux43(11:24) = mess14(langue,3,-1) + write (ulbila,12200) saux43, nbpnho + if (nbppho.gt.0) then + saux43(11:24) = mess14(langue,3,0) + write (ulbila,12200) saux43, nbppho + endif + if (nbpaho.gt.0) then + saux43(11:24) = mess14(langue,3,1) + write (ulbila,12200) saux43, nbpaho + endif + if ( nbptho.gt.0 ) then + saux43(11:24) = mess14(langue,3,2) + write (ulbila,12200) saux43, nbptho + endif + if ( nbpqho.gt.0 ) then + saux43(11:24) = mess14(langue,3,4) + write (ulbila,12200) saux43, nbpqho + endif + write (ulbila,10200) +c + endif +c +c==== +c 12. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb03a.F b/src/tool/Utilitaire/utb03a.F new file mode 100644 index 00000000..9b86bd31 --- /dev/null +++ b/src/tool/Utilitaire/utb03a.F @@ -0,0 +1,791 @@ + subroutine utb03a ( hetnoe, coonoe, + > hetare, somare, posifa, + > hettri, aretri, voltri, + > hetqua, arequa, volqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > np2are, + > xyzmin, xyzmax, xyzeps, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 03 +c -- - -- +c ______________________________________________________________________ +c +c but : controle la non coincidence des noeuds et l'interpenetration +c des aretes, des mailles de surface ou de volume +c en mode debug, on indique egalement les noeuds p2 qui sont sur +c les bords des mailles auxquels ils appartiennent. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . np2are . e . nbarto . noeud milieux des aretes . +c . xyzmin . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales du domaine total . +c . xyzmax . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales du domaine total . +c . xyzeps . e . sdim . -1 si min = max dans la direction, . +c . . . . ecart sinon. . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB03A' ) +c +#include "nblang.h" +c + integer nbintx + parameter ( nbintx = 15 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + double precision xyzmin(sdim), xyzmax(sdim), xyzeps(sdim) +c + integer hetnoe(nbnoto) + integer hetare(nbarto), somare(2,nbarto), posifa(0:nbarto) + integer hettri(nbtrto), aretri(nbtrto,3), voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4), volqua(2,nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer np2are(nbarto) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbpbco(-1:7) + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer nbbomx, lglibo + integer nbboit(3) + integer nsectl(-1:7) +c + logical logaux +c + double precision boimin(3,0:nbintx), boimax(3,0:nbintx) +c + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*54 saux54 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*08 mess08(nblang,13) + character*43 mess43(nblang,3) + character*54 mess54(nblang,20) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + if ( sdim.eq.1 ) then + write (ulsort,*) nompro + write (ulsort,*) 'Ne pas oublier de programmer pour sdim = 1' + codret = 0 + return + endif +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''INTERPENETRATION DES MAILLES'',/,3x,28(''=''),/)' + texte(1,6) = + > '(3x,''Le maillage est non-conforme par construction.'')' + texte(1,7) = '(3x,''On ne sait pas controler.'')' +c + texte(2,4) = '(//,3x,''STAGGERED MESHES'',/,3x,16(''=''),/)' + texte(2,6) = + > '(3x,''The mesh contains hanging nodes at the beginning.'')' + texte(2,7) = '(3x,''Control cannot be made.'')' +c +#include "impr03.h" +c + mess54(1,1) = + > ' Aucun probleme n''a ete rencontre. ' + mess54(1,2) = + > 'Probleme d''interpenetration pour les ' + mess54(1,3) = + > 'Bizarre, c''est un des noeuds P2 de la maille. ' + mess54(1,4) = + > 'Les noeuds suivants sont coincidents : ' + mess54(1,8) = + > 'Nombre de coincidences : ' + mess54(1,13) = + > 'Un noeud est a l''interieur de mailles ' + mess54(1,14) = + > 'Nombre de noeuds P2 a l''interieur d''une maille ' + mess54(1,15) = + > 'Ce n''est donc peut-etre pas tres grave. ' + mess54(1,16) = + > ' Recapitulatif sur les ' +c 12345678901234567890123456789012345678901234567890 + mess54(1,20) = + > 'Il faut revoir le maillage. ' +c + mess54(2,1) = + > ' No problem was found. ' + mess54(2,2) = + > 'Problems with staggered meshes for ' + mess54(2,3) = + > 'Strange : it is a P2 node of the mesh. ' + mess54(2,4) = + > 'Following nodes are coincidents : ' + mess54(2,8) = + > 'Number of coincidences : ' + mess54(2,13) = + > 'One node is inside meshes . ' + mess54(2,14) = + > 'Number of P2 node inside a mesh ' + mess54(2,15) = + > 'So, it is not serious may-be. ' + mess54(2,16) = + > ' Summary about ' +c 12345678901234567890123456789012345678901234567890 + mess54(2,20) = + > 'Mesh must be reviewed. ' +c +c 1234567890123456789012345678901234567890123 + mess43(1,1) = 'noeuds sont a l''interieur de mailles. ' + mess43(1,2) = 'auquel ils appartiennent : ' + mess43(1,3) = 'Nombre de noeuds P1 bizarres : ' +c + mess43(2,1) = 'nodes are inside meshes. ' + mess43(2,2) = 'belong : ' + mess43(2,3) = 'Number of strange P1 nodes : ' +c + mess08(1,1) = ' Il est' + mess08(1,2) = ' dans le' + mess08(1,3) = 'de somme' + mess08(1,4) = 'ts ' +c + mess08(2,1) = ' It is ' + mess08(2,2) = 'into the' + mess08(2,3) = 'with ver' + mess08(2,4) = 'tices ' +c +c 1.2. ==> divers +c + do 12 , iaux = 1 , 2 +c + if ( iaux.eq.1 ) then + kaux = ulbila + else + if ( ulbila.eq.ulsort ) then + goto 12 + else + kaux = ulsort + endif + endif +c + write (kaux,texte(langue,4)) +c + 12 continue +c +c 1.3. ==> constantes +c + codret = 0 +c + do 13 , iaux = -1 , 7 + nbpbco(iaux) = -1 + nsectl(iaux) = 142+iaux + call gtnoms ( nsectl(iaux), 1 , + > '.. int. 42 '//mess14(langue,3,iaux)(1:13) ) +c 12345678901 2345678901234 + 13 continue + nsectl(-1) = 131 + call gtnoms ( nsectl(-1), 1 , + > '.. int. 42 '//mess14(langue,3,-1)(1:13) ) + call gtnoms ( nsectl(-1)+1, 1 , '... dont boites' ) + call gtnoms ( nsectl(-1)+2, 1 , '... dont controle' ) +c +c==== +c 2. controle de la non coincidence des noeuds +c==== + call gtdems (nsectl(-1)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. noeuds ; codret', codret +#endif +c +c 2.1. ==> tableaux memorisant les eventuelles coincidences +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nbnoto, ptrav1, codre1 ) + iaux = 2 + nbnoto/2 + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', nbnoto, ptrav3, codre3 ) + if ( sdim.eq.1 ) then + nbbomx = nbintx + elseif ( sdim.eq.2 ) then + nbbomx = nbintx**2 + elseif ( sdim.eq.3 ) then + nbbomx = nbintx**3 + endif + iaux = nbbomx + 1 + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c 2.2. ==> creation des boites + call gtdems (nsectl(-1)+1) +c 2.2.1. ==> tri des noeuds +c + if ( codret.eq.0 ) then +c + iaux = nbintx +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N1', nompro +#endif + call utb3n1 ( coonoe, + > iaux, nbbomx, + > lglibo, imem(ptrav4), + > xyzmin, xyzmax, xyzeps, + > nbboit, boimin, boimax, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx ( nompro, ntrav4 ) +c +c 2.2.1. ==> mise sous forme PtTabEnt +c +cc call gtdems (113) + if ( codret.eq.0 ) then +c + call gmalot ( ntrav5, 'entier ', lglibo, ptrav5, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = nbintx +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N2', nompro +#endif + call utb3n2 ( coonoe, + > iaux, nbbomx, + > lglibo, imem(ptrav4), imem(ptrav5), + > nbboit, boimin, boimax, + > ulsort, langue, codret ) +c + endif +cc call gtfims (113) +cgn call gmprsx ( nompro, ntrav4 ) +cgn call gmprot ( nompro, ntrav5, 1, 100 ) + call gtfims (nsectl(-1)+1) +c +c 2.3. ==> controle des coincidences +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. ; codret', codret +#endif +c + call gtdems (nsectl(-1)+2) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N0', nompro +#endif + call utb3n0 ( coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > nbbomx, lglibo, imem(ptrav4), imem(ptrav5), + > nbpbco, mess54, + > ulbila, ulsort, langue, codret ) +c + endif + call gtfims (nsectl(-1)+2) +cgn call gmprot ( nompro, ntrav2,1, 60) +cgn call gmprot ( nompro, ntrav3,1, 100) + call gtfims (nsectl(-1)) +c +c==== +c 3. prealables +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. prealables ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + logaux = .true. +#else + if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then + logaux = .true. + else + logaux = .false. + endif +#endif +c + if ( logaux ) then +c + do 31 , iaux = 1 , 2 +c + if ( iaux.eq.1 ) then + jaux = ulbila + else + if ( ulbila.eq.ulsort ) then + goto 31 + else + jaux = ulsort + endif + endif +c + if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then + write (jaux,texte(langue,6)) + write (jaux,texte(langue,7)) + endif +c + 31 continue +c + endif +c + endif +c + if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then + goto 70 + endif +c +c==== +c 4. controle de la non-interpenetration des aretes +c remarques : +c 1. on ne s'interesse qu'aux actives car les autres sont +c censees avoir ete controlees aux iterations anterieures +c 2. on ne s'interesse qu'aux aretes de region 1D, car celles qui +c bordent des triangles seront vues par la suite. +c 3. La verification est sujette a caution car le test sur la +c colinearite est un test sur une egalite de reels ... +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbarac.ne.0 ) then + call gtdems (nsectl(1)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3A0', nompro +#endif + call utb3a0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > hetare, somare, posifa, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c + call gtfims (nsectl(1)) + endif +c + endif +c +c==== +c 5. controle de la non-interpenetration des surfaces +c remarques : +c 1. on ne s'interesse qu'aux actives car les autres sont +c censes avoir ete controles aux iterations anterieures +c 2. on ne s'interesse qu'aux faces de region 2D, car celles qui +c bordent des volumes seront vues par la suite. +c 3. La verification est sujette a caution car le test sur la +c coplanarite est un test sur une egalite de reels ... +c==== +c 5.1. ==> les triangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.1. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrac.ne.0 ) then + call gtdems (nsectl(2)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3B0', nompro +#endif + call utb3b0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > hettri, aretri, voltri, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) + call gtfims (nsectl(2)) +c + endif +c + endif +c +c 5.2. ==> les quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5.2. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquac.ne.0 ) then + call gtdems (nsectl(4)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3C0', nompro +#endif + call utb3c0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > hetqua, arequa, volqua, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c + call gtfims (nsectl(4)) + endif +c + endif +c +c==== +c 6. controle de la non-interpenetration des volumes +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +c +c 6.1 ==> Noeuds dans les tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.1 tetraedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteac.ne.0 ) then + call gtdems (nsectl(3)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3D0', nompro +#endif + call utb3d0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > aretri, + > hettet, tritet, cotrte, aretet, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) + + call gtfims (nsectl(3)) + endif +c + endif +c +c 6.2 ==> Noeuds dans les hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheac', nbheac +#endif +c + if ( nbheac.ne.0 ) then + call gtdems (nsectl(6)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3E0', nompro +#endif + call utb3e0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > arequa, + > hethex, quahex, coquhe, arehex, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) + + call gtfims (nsectl(6)) + endif +c + endif +c +c 6.3 ==> Noeuds dans les pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.3. pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpyac', nbpyac +#endif +c + if ( nbpyac.ne.0 ) then + call gtdems (nsectl(5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3F0', nompro +#endif + call utb3f0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > aretri, + > hetpyr, facpyr, cofapy, arepyr, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c + call gtfims (nsectl(5)) + endif +c + endif +c +c 6.4 ==> Noeuds dans les pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.4. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpeac', nbpeac +#endif +c + if ( nbpeac.ne.0 ) then + call gtdems (nsectl(7)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3G0', nompro +#endif + call utb3g0 ( hetnoe, coonoe, + > imem(ptrav1), imem(ptrav2), imem(ptrav3), + > somare, + > arequa, + > hetpen, facpen, cofape, arepen, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) + + call gtfims (nsectl(7)) + endif +c + endif +c +c==== +c 7. bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. Bilan ; codret', codret +#endif +c + 70 continue +c + do 71 , iaux = 1 , 2 +c + if ( iaux.eq.1 ) then + kaux = ulbila + else + if ( ulbila.eq.ulsort ) then + goto 71 + else + kaux = ulsort + endif + endif +c + do 72 , jaux = -1 , 7 +c + if ( nbpbco(jaux).ge.0 ) then +c + write (kaux,10100) + saux54 = mess54(langue,16) + saux54(30:43) = mess14(langue,3,jaux) + write (kaux,11100) saux54 + write (kaux,10300) + if ( nbpbco(jaux).eq.0 ) then + write (kaux,11100) mess54(langue,1) + else + if ( jaux.eq.-1 ) then + write (kaux,12200) mess54(langue,8), nbpbco(jaux) + else + if ( nbpbco(jaux).eq.1 ) then + write (kaux,11100) mess54(langue,13) + else + write (kaux,12100) nbpbco(jaux), mess43(langue,1) + endif + endif + endif + write (kaux,10200) +c + endif +c + 72 continue +c + if ( max(nbpbco(0),nbpbco(1),nbpbco(2),nbpbco(3),nbpbco(4), + > nbpbco(5),nbpbco(6),nbpbco(7)).gt.0 ) then + write (kaux,10100) + write (kaux,11100) mess54(langue,20) + write (kaux,10200) + endif +c + 71 continue +c +10100 format(/,5x,58('*'), + / /,5x,'*',56x,'*') +10200 format( 5x,'*',56x,'*', + / /,5x,58('*'),/) +10300 format( 5x,'*',56x,'*') +c +11100 format( 5x,'* ',a54,' *') +c +12100 format( 5x,'* ',i8,1x,a43,' *') +12200 format( 5x,'* ',a43,1x,i8,' *') +c +c==== +c 8. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) + call gmlboj ( ntrav3, codre3 ) + call gmlboj ( ntrav4, codre4 ) + call gmlboj ( ntrav5, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c +c==== +c 9. on impose un code de retour toujours nul +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif +c + endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb05a.F b/src/tool/Utilitaire/utb05a.F new file mode 100644 index 00000000..a0d11c9e --- /dev/null +++ b/src/tool/Utilitaire/utb05a.F @@ -0,0 +1,554 @@ + subroutine utb05a ( choix, + > coonoe, somare, + > hettri, aretri, + > famtri, cfatri, + > hetqua, arequa, + > famqua, cfaqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 05 - etape a +c -- - -- - +c remarque : utb05a et utb19a sont des clones +c ______________________________________________________________________ +c +c but : controle de la qualite des mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du traitement . +c . . . . 0 : creation et affichage des histogrammes . +c . . . . 2 : sortie de la qualite des triangles . +c . . . . 3 : sortie de la qualite des tetraedres . +c . . . . 4 : sortie de la qualite des quadrangles . +c . . . . 5 : sortie de la qualite des pyramides . +c . . . . 6 : sortie de la qualite des hexaedres . +c . . . . 7 : sortie de la qualite des pentaedres . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . nbeexa . s . 1 . nombre d'entites examinees . +c . tbiau1 . a . * . liste des entites examinees . +c . tbiau2 . a . * . tableau entier auxiliaire . +c . tabaur . a . * . qualite des entites . +c . tabau2 . a . * . qualite des entites . +c . nbiter . e . 1 . numero de l'iteration courante . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB05A' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + double precision tabaur(*) + double precision tabau2(*) +c + integer choix +c + integer somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer nbeexa + integer tbiau1(*), tbiau2(*) + integer nbiter +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer letria, lequad + integer iaux, jaux + integer nbvoto +c + double precision daux1, daux2 + double precision tbdaux(1) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. titre +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''QUALITES DES MAILLES'',/,3x,20(''=''))' + texte(1,5) = '(3x,''Qualite '',a,'' des '',a,'' : '',g12.5)' + texte(1,6) = '(3x,''Nombre de '',a,'' a examiner : '',i8)' + texte(1,7) = '(3x,''Nombre de '',a,'' aplatis : '',i8)' +c + texte(2,4) = + > '(//,3x,''QUALITIES OF MESHES'',/,3x,19(''=''))' + texte(2,5) = '(3x,''Quality '',a,'' of '',a,'': '',g12.5)' + texte(2,6) = '(3x,''Number of '',a,'' to be examined: '',i8)' + texte(2,7) = '(3x,''Number of flat '',a,'': '',i8)' +c +#include "impr03.h" +c + write (ulsort,texte(langue,4)) + if ( ulbila.ne.ulsort ) then + write (ulbila,texte(langue,4)) + endif +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c +c==== +c 2. calcul des qualites des tetraedres +c=== +c + if ( choix.eq.0 .or. choix.eq.3 ) then +c + if ( nbteto.ne.0 ) then +c + iaux = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05C_te', nompro +#endif + call utb05c ( choix, + > iaux, nbteto, nbtecf, nbteca, + > coonoe, somare, + > aretri, arequa, + > hettet, tritet, cotrte, aretet, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. calcul des qualites des pyramides +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. pyramides ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.5 ) then +c + if ( nbpyto.ne.0 ) then +c + iaux = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05C_py', nompro +#endif + call utb05c ( choix, + > iaux, nbpyto, nbpycf, nbpyca, + > coonoe, somare, + > aretri, arequa, + > hetpyr, facpyr, cofapy, arepyr, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. calcul des qualites des hexaedres +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. hexaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.6 ) then +c + if ( nbheto.ne.0 ) then +c + iaux = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05C_he', nompro +#endif + call utb05c ( choix, + > iaux, nbheto, nbhecf, nbheca, + > coonoe, somare, + > aretri, arequa, + > hethex, quahex, coquhe, arehex, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. calcul des qualites des pentaedres +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. pentaedres ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.7 ) then +c + if ( nbpeto.ne.0 ) then +c + iaux = 7 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05C_pe', nompro +#endif + call utb05c ( choix, + > iaux, nbpeto, nbpecf, nbpeca, + > coonoe, somare, + > aretri, arequa, + > hetpen, facpen, cofape, arepen, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. calcul des qualites des triangles d'un maillage 2d ou 2,5d +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. triangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.2 ) then +c + if ( nbtrto.ne.0 ) then +c +c 6.1. ==> liste des triangles a examiner : +c . en l'absence de tetraedre, pentaedre et pyramide, ce sont +c tous les triangles actifs ; +c . en presence de tetraedre, pentaedre ou pyramide, ce sont les +c triangles actifs qui sont des elements de calcul +c + nbeexa = 0 +c + if ( nbteto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 611 , letria = 1 , nbtrto + if ( mod(hettri(letria),10).eq.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = letria + endif + 611 continue +c + else +c + do 612 , letria = 1 , nbtrto + if ( mod(hettri(letria),10).eq.0 .and. + > cfatri(cotyel,famtri(letria)).ne.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = letria + endif + 612 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,2), nbeexa +#endif +c +c 6.2. ==> calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6.2. calcul ; codret', codret +#endif +c + if ( nbeexa.gt.0 ) then +c + do 62 , iaux = 1 , nbeexa +c + letria = tbiau1(iaux) +c + call utqtri ( letria, daux1, daux2, + > coonoe, somare, aretri ) +c + tabaur(iaux) = daux1 +c + 62 continue +c + endif +c +c 6.3. ==> impression sur la sortie standard et sur un fichier +c a exploiter par xmgrace +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + jaux = 1 + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B tri', nompro +#endif + call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 7. calcul des qualites des quadrangles d'un maillage 2d ou 2,5d +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.4 ) then +c + if ( nbquto.ne.0 ) then +c +c 7.1. ==> liste des quadrangles a examiner : +c . en l'absence d'hexaedre, pentaedre et pyramide, ce sont +c tous les quadrangles actifs ; +c . en presence d'hexaedre, pentaedre ou pyramide, ce sont les +c quadrangles actifs qui sont des elements de calcul +c + nbeexa = 0 +c + if ( nbheto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 711 , lequad = 1 , nbquto + if ( mod(hetqua(lequad),100).eq.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = lequad + endif + 711 continue +c + else +c + do 712 , lequad = 1 , nbquto + if ( mod(hetqua(lequad),100).eq.0 .and. + > cfaqua(cotyel,famqua(lequad)).ne.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = lequad + endif + 712 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,4), nbeexa +#endif +c +c 7.2. ==> calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7.2. calcul ; codret', codret +#endif +c + if ( nbeexa.gt.0 ) then +c + do 72 , iaux = 1 , nbeexa +c + lequad = tbiau1(iaux) +c + call utqqua ( lequad, daux1, daux2, + > coonoe, somare, arequa ) +c + tabaur(iaux) = daux1 +c + 72 continue +c + endif +c +c 7.3. ==> impression sur la sortie standard et sur un fichier +c a exploiter par xmgrace +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + jaux = 1 + iaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B qua', nompro +#endif + call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb05b.F b/src/tool/Utilitaire/utb05b.F new file mode 100644 index 00000000..3ab967d6 --- /dev/null +++ b/src/tool/Utilitaire/utb05b.F @@ -0,0 +1,944 @@ + subroutine utb05b ( choix, typenh, nbeexa, quadia, qualij, + > nbiter, rafdef, nbvoto, enqinf, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 05 - etape b +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . variantes . +c . . . . 0 : diametres . +c . . . . 1 : qualites . +c . . . . 2 : qualites par le jacobien normalise . +c . typenh . e . 1 . variantes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbeexa . e . 1 . nombre d'entites a examiner . +c . quadia . e . nbeexa . qualite/diametre des entites a examiner . +c . qualij . e . nbeexa . qualite par le jacobien normalise . +c . nbiter . e . 1 . numero de l'iteration courante . +c . rafdef . e . 1 . histoire du maillage en raff/dera/modi . +c . nbvoto . e . 1 . nombre de volumes . +c . enqinf . e . * . liste des entites de qualite infinie . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB05B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "enti01.h" +#include "impr02.h" +#include "precis.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + double precision quadia(*) + double precision qualij(*) + double precision valmin, valmax +c + integer choix, typenh, nbeexa + integer nbiter, nbvoto + integer enqinf(*) +c + integer ulbila, rafdef + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lechoi, choide, choifi + integer nbqinf +c + integer nbclmx + parameter (nbclmx=50) + integer histog(nbclmx) + integer iclass(0:nbclmx) + double precision rclass(0:nbclmx) + integer nbclas +c + character*8 titcou(6) + character*9 saux09 +c + integer typval, ival(1) + integer iaux, jaux, kaux + integer nuroul, lnomfl + integer difexp + integer lgmess(nblang,0:2) + integer nxmd58(nblang,7) + integer nxmq58(nblang,7) + integer nxmj58(nblang,7) +c + double precision xlow + double precision vamiar, vamaar, valdif, difman, valech + double precision daux, daux1 + double precision vmax, vmin +c + character*80 saux80, sau80a + character*08 mess08(nblang,4) + character*09 mess09(nblang,0:2) + character*200 nomflo +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*58 mege58(nblang,0:nbmess) + character*58 medi58(nblang,nbmess,7) + character*58 mequ58(nblang,nbmess,7) + character*58 meqj58(nblang,nbmess,7) +c + logical consta +c +c 0.5. ==> initialisations +c + data typval / 2 / + data xlow / 1.d0 / +c ______________________________________________________________________ +c +c==== +c 1. Messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> Messages generaux +c 123456789 + mess09(1,0) = 'Diametre ' + mess09(1,1) = 'Qualite ' + mess09(1,2) = 'Qualite ' +c + mess09(2,0) = 'Diameter ' + mess09(2,1) = 'Quality ' + mess09(2,2) = 'Quality ' +c + texte(1,4) = '(''Nombre de '',a,'' a examiner : '',i8)' + texte(1,5) = '(''--> valeur arrondie pour le '',a,'' :'',g15.6)' + texte(1,6) = '(5x,''Nombre de '',a,'' aplatis : '',i8)' + texte(1,7) = '(5x,''Le '',a,i10,'' est aplati.'')' +c + texte(2,4) = '(''Number of '',a,'' to be examined : '',i8)' + texte(2,5) = '(''--> round value for '',a,'' :'',g15.6)' + texte(2,6) = '(5x,''Number of flat '',a,'': '',i8)' + texte(2,7) = '(5x,''The '',a,'' #'',i10,'' is flat.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'ulbila', ulbila +#endif +c +c 1234567890123456789012345678901234567890123456789012345678 + mege58(1,0) = + > 'DIAMETRES DES ' + lgmess(1,0) = 13 + mege58(1,1) = + > 'QUALITES DES ' + lgmess(1,1) = 12 + mege58(1,2) = + > 'QUALITES EN JACOBIEN NORMALISE DES ' + lgmess(1,2) = 34 + mege58(1,3) = + > ' Valeur constante : ' + mege58(1,4) = + > 'Remarque : on ne regarde ici que les triangles qui ' + mege58(1,5) = + > 'sont de vraies mailles de calcul. ' + mege58(1,6) = + > 'Remarque : on ne regarde ici que les quadrangles qui ' +c + mege58(2,0) = + > 'DIAMETERS OF ' + lgmess(2,0) = 12 + mege58(2,1) = + > 'QUALITY OF ' + lgmess(2,1) = 10 + mege58(2,2) = + > 'QUALITY WITH SCALED JACOBIAN OF ' + lgmess(2,2) = 31 + mege58(2,3) = + > ' Constant value : ' + mege58(2,4) = + > 'Remark : only triangles which are real calculation ' + mege58(2,5) = + > 'meshes are seen here. ' + mege58(2,6) = + > 'Remark : only quadrangles which are real calculation ' +c +c 1.2. ==> Messages lies aux diametres +c + medi58(1,1,1) = + > 'Rappel : le diametre est egal a la longueur du plus ' + medi58(1,2,1) = + > 'grand segment que l''on peut tracer dans la maille. ' +c + medi58(1,1,2) = + > 'Pour un triangle, c''est la longueur de la plus ' + medi58(1,2,2) = + > 'grande arete. ' + nxmd58(1,2) = 2 +c + medi58(1,1,3) = + > 'Pour un tetraedre, c''est la longueur de la plus ' + medi58(1,2,3) = + > 'grande arete. ' + nxmd58(1,3) = 2 +c + medi58(1,1,4) = + > 'Pour un quadrangle, c''est la plus grande longueur entre ' + medi58(1,2,4) = + > 'les aretes et les diagonales. ' + nxmd58(1,4) = 2 +c + medi58(1,1,5) = + > 'Pour une pyramide, c''est la plus grande longueur entre ' + medi58(1,2,5) = + > 'les aretes et les diagonales de la base. ' + nxmd58(1,5) = 2 +c + medi58(1,1,6) = + > 'Pour un hexaedre, c''est la plus grande longueur entre ' + medi58(1,2,6) = + > 'les aretes et les diagonales. ' + nxmd58(1,6) = 2 +c + medi58(1,1,7) = + > 'Pour un pentaedre, c''est la plus grande longueur entre ' + medi58(1,2,7) = + > 'les aretes et les diagonales. ' + nxmd58(1,7) = 2 +c + medi58(2,1,1) = + > 'Note: diameter egals the length of the largest line that ' + medi58(2,2,1) = + > 'can be placed in the mesh. ' +c + medi58(2,1,2) = + > 'For a triangle, it is the length of the largest edge. ' + nxmd58(2,2) = 1 +c + medi58(2,1,3) = + > 'For a tetradron, it is the length of the largest edge. ' + nxmd58(2,3) = 1 +c + medi58(2,1,4) = + > 'For a quadrangle, it is the largest length between edges ' + medi58(2,2,4) = + > 'and diagonals. ' + nxmd58(2,4) = 2 +c + medi58(2,1,5) = + > 'For a pyramid, it is the largest length between edges ' + medi58(2,2,5) = + > 'and diagonals of the basis. ' + nxmd58(2,5) = 2 +c + medi58(2,1,6) = + > 'For an hexahedron, it is the largest length between edges ' + medi58(2,2,6) = + > 'and diagonals. ' + nxmd58(2,6) = 2 +c + medi58(2,1,7) = + > 'For a prism, it is the largest length between edges and ' + medi58(2,2,7) = + > 'diagonals of the basis. ' + nxmd58(2,7) = 2 +c +c 1.3. ==> Messages lies aux qualites +c + mequ58(1,1,2) = + > 'Rappel : la qualite est egale au rapport du diametre du ' + mequ58(1,2,2) = + > 'triangle sur le rayon du cercle inscrit, normalise a 1 ' + mequ58(1,3,2) = + > 'pour un triangle equilateral. ' + nxmq58(1,2) = 3 +c + mequ58(1,1,3) = + > 'Rappel : la qualite est egale au rapport du diametre du ' + mequ58(1,2,3) = + > 'tetraedre sur le rayon de la sphere inscrite, ' + mequ58(1,3,3) = + > 'normalise a 1 pour un tetraedre regulier. ' + nxmq58(1,3) = 3 +c + mequ58(1,1,4) = + > 'Rappel : la qualite est egale au rapport du produit de ' + mequ58(1,2,4) = + > 'la plus grande longueur des cotes et des diagonales et ' + mequ58(1,3,4) = + > 'de la moyenne quadratique des cotes sur la surface ' + mequ58(1,4,4) = + > 'minimum des triangles inscrits, normalise a 1 pour ' + mequ58(1,5,4) = + > 'pour un carre. ' + nxmq58(1,4) = 5 +c +c 123456789012345678901234567890123456789012345678901234 + mequ58(1,1,5) = + > 'Non definie aujourd''hui. ' + nxmq58(1,5) = 1 +c + mequ58(1,1,6) = + > 'Rappel : la qualite est egale a la qualite du pire des ' + mequ58(1,2,6) = + > '24 tetraedres composant l''hexaedre, normalise a 1 ' + mequ58(1,3,6) = + > 'pour un cube. ' + nxmq58(1,6) = 3 +c + mequ58(1,1,7) = + > 'Non definie aujourd''hui. ' + nxmq58(1,7) = 1 +c +c 1234567890123456789012345678901234567890123456789012345678 + mequ58(2,1,2) = + > 'Note: the quality equals the ratio of the diametre ' + mequ58(2,2,2) = + > 'of the triangle by the radius of the inscribed circle ' + mequ58(2,3,2) = + > 'normalised to 1 for an equilateral triangle. ' + nxmq58(2,2) = 3 +c + mequ58(2,1,3) = + > 'Note: the quality equals the ratio of the diametre ' + mequ58(2,2,3) = + > 'of the tetradron by the radius of the inscribed sphere ' + mequ58(2,3,3) = + > 'normalised to 1 for a regular tetrahedron. ' + nxmq58(2,3) = 3 +c + mequ58(2,1,4) = + > 'Note: the quality equals the ratio of the product of ' + mequ58(2,2,4) = + > 'the largest edge and diagonals and square mean of edge ' + mequ58(2,3,4) = + > 'over minimum surface of inscribed triangles. ' + mequ58(2,4,4) = + > 'This valeur is normalised to 1 for a square. ' + nxmq58(2,4) = 4 +c + mequ58(2,1,5) = + > 'Not available. ' + nxmq58(2,5) = 1 +c + mequ58(2,1,6) = + > 'Note: the quality equals the worse quality of the ' + mequ58(2,2,6) = + > 'the 24 tetrahedron composing the hexahedron ' + mequ58(2,3,6) = + > 'normalised to 1 for a cube. ' + nxmq58(2,6) = 3 +c + mequ58(2,1,7) = + > 'Not available. ' + nxmq58(2,7) = 1 +c +c 1.4. ==> Messages lies aux qualites en jacobien normalise +c + meqj58(1,1,2) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,2) = + > 'pour chacun des sommets, normalise a 1 pour ' + meqj58(1,3,2) = + > 'un triangle equilateral. ' + nxmj58(1,2) = 3 +c + meqj58(1,1,3) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,3) = + > 'pour chacun des sommets, normalise a 1 pour ' + meqj58(1,3,3) = + > 'un tetraedre regulier. ' + nxmj58(1,3) = 3 +c + meqj58(1,1,4) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,4) = + > 'pour chacun des sommets, normalise a 1 pour un carre. ' + nxmj58(1,4) = 2 +c + meqj58(1,1,5) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,5) = + > 'pour chacun des sommets, normalise a 1 pour ' + meqj58(1,3,5) = + > 'une pyramide reguliere. ' + nxmj58(1,5) = 3 +c + meqj58(1,1,6) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,6) = + > 'pour chacun des sommets, normalise a 1 pour un cube. ' + nxmj58(1,6) = 2 +c + meqj58(1,1,7) = + > 'Rappel : la qualite est egale au minimum des Jacobiens ' + meqj58(1,2,7) = + > 'pour chacun des sommets, normalise a 1 pour ' + meqj58(1,3,7) = + > 'un pentaedre regulier. ' + nxmj58(1,7) = 3 +c +c 1234567890123456789012345678901234567890123456789012345678 + meqj58(2,1,2) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,2) = + > 'every node, normalised to 1 for an equilateral triangle. ' + nxmj58(2,2) = 2 +c + meqj58(2,1,3) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,3) = + > 'every node, normalised to 1 for a regular tetrahedron. ' + nxmj58(2,3) = 2 +c + meqj58(2,1,4) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,4) = + > 'every node, normalised to 1 for a square. ' + nxmj58(2,4) = 2 +c + meqj58(2,1,5) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,5) = + > 'every node, normalised to 1 for a regular pyramid. ' + nxmj58(2,5) = 2 +c + meqj58(2,1,6) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,6) = + > 'every node, normalised to 1 for a cube. ' + nxmj58(2,6) = 2 +c + meqj58(2,1,7) = + > 'Note: the quality equals the minimum of the Jacobian for ' + meqj58(2,2,7) = + > 'every node, normalised to 1 for a regular prism. ' + nxmj58(2,7) = 2 +c +10100 format(/,5x,64('*')) +10200 format( 5x,64('*')) +11100 format(/,4x,a,/,4x,a) +11200 format( 5x,'* ',a58,' *') +c + codret = 0 +c +c==== +c 2. Initialisations +c==== +c 2.1. ==> Recherche des types d'impressions a faire +c + if ( choix.eq.12 ) then + choide = 1 + choifi = 2 + else + choide = choix + choifi = choix + endif +c +c 2.2. ==> Valeurs extremes pour les aplatissements +c + vmax = 0.99d0 * vinfpo + vmin = 1.11d0 * epsima +c + do 20 , lechoi = choide, choifi +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lechoi', lechoi +#endif +c +c==== +c 3. ecriture de l'entete +c==== +c + saux80 = mege58(langue,lechoi) + iaux = lgmess(langue,lechoi) + 1 + saux80(iaux+1:iaux+14) = mess14(langue,5,typenh) + call utlgut ( jaux, saux80, + > ulsort, langue, codret ) + do 31 , iaux = 1, jaux + sau80a(iaux:iaux) = '-' + 31 continue + write (ulbila,11100) saux80(1:jaux), sau80a(1:jaux) +c +c==== +c 4. les extremes +c==== +c +c 4.1. ==> Des entites sont aplaties +c + valmin = vinfpo + valmax = vinfne +c + nbqinf = 0 +c + if ( lechoi.le.1 ) then +c + do 411 , iaux = 1 , nbeexa +cgn write (ulsort,90114) 'quadia', iaux, quadia(iaux) + if ( quadia(iaux).gt.vmin .and. quadia(iaux).lt.vmax ) then + valmin = min ( valmin, quadia(iaux) ) + valmax = max ( valmax, quadia(iaux) ) + else + nbqinf = nbqinf + 1 + enqinf(nbqinf) = iaux + endif + 411 continue +c + else +c + do 412 , iaux = 1 , nbeexa +cgn write (ulsort,90114) 'qualij', iaux, qualij(iaux) + if ( qualij(iaux).gt.vmin .and. qualij(iaux).lt.vmax ) then + valmin = min ( valmin, qualij(iaux) ) + valmax = max ( valmax, qualij(iaux) ) + else + nbqinf = nbqinf + 1 + enqinf(nbqinf) = iaux + endif + 412 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh), nbeexa +cgn if ( lechoi.ne.1 ) then + write (ulsort,90004) mess09(langue,lechoi)//'min', valmin +cgn endif + write (ulsort,90004) mess09(langue,lechoi)//'max', valmax +#endif +c +c 4.2. ==> Des entites sont aplaties +c + if ( nbqinf.gt.0 ) then +c + write (ulbila,texte(langue,6)) mess14(langue,3,typenh), nbqinf + do 42 , iaux = 1 , nbqinf + write (ulbila,texte(langue,7)) mess14(langue,1,typenh), + > enqinf(iaux) + 42 continue +c + endif +c +c 4.3. ==> Est-ce constant ? +c + if ( valmax.le.epsima ) then + consta = .true. + else + if ( (valmax-valmin)/valmax.le.1.d-6 ) then + consta = .true. + else + consta = .false. + endif + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'consta', consta +#endif +c +c==== +c 5. arrondis des valeurs extremes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. arrondis ; codret', codret +#endif +c + if ( .not.consta ) then +c +c 5.1. ==> Programme de calcul des arrondis +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARRO', nompro +#endif + call utarro ( valmin, valmax, vamiar, vamaar, + > ulsort, langue, codret ) +c + endif +c +c 5.2. ==> Ajustement en fonction du traitement +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Arrondi min', vamiar + write (ulsort,90004) 'Arrondi max', vamaar +#endif +c + if ( lechoi.eq.0 .or. lechoi.eq.2 ) then + vamiar = max(vamiar,0.d0) + elseif ( lechoi.eq.1 ) then + vamiar = max(vamiar,1.d0) + endif +c + if ( lechoi.eq.2 ) then + vamaar = min(vamaar,1.d0) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'Arrondi min final', vamiar + write (ulsort,90004) 'Arrondi max final', vamaar +#endif +c + endif +c + endif +c +c==== +c 6. Creation des classes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. Creation des classes ; codret', codret +#endif +c + if ( .not.consta ) then +c +c 6.1 ==> Gestion de l'ordre de grandeur +c C'est un probleme qui se pose pour le diametre en fonction des +c unites qui ont ete utilisees. +c + if ( codret.eq.0 ) then +c + valdif = ( vamaar - vamiar ) * 0.99999999d0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPD10', nompro +#endif + call utpd10 ( valdif, difman, difexp, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'valdif', valdif + write (ulsort,90004) '==> difman', difman + write (ulsort,90002) '==> difexp', difexp +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( difexp.le.0 ) then + valech = 10.d0**(1-difexp) + elseif ( difexp.ge.4 ) then + valech = 10.d0**(2-difexp) + else + valech = 1.d0 + endif + daux = valdif*valech +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'valech', valech + write (ulsort,90004) 'daux=valdif*valech', daux +#endif +c + endif +c +c 6.2 ==> Les classes +c + if ( codret.eq.0 ) then +c + if ( daux.le.1.d0 ) then +c + nbclas = 20 + daux1 = 0.05d0/valech +c + elseif ( daux.le.2.d0 ) then +c + nbclas = 40 + daux1 = 0.05d0/valech +c + elseif ( daux.le.2.5d0 ) then +c + nbclas = 50 + daux1 = 0.05d0/valech +c + elseif ( daux.le.4.d0 ) then +c + nbclas = 40 + daux1 = 0.10d0/valech +c + elseif ( daux.le.5.d0 ) then +c + nbclas = 50 + daux1 = 0.10d0/valech +c + elseif ( daux.le.7.5d0 ) then +c + nbclas = 30 + daux1 = 0.25d0/valech +c + elseif ( daux.le.10.d0 ) then +c + nbclas = 40 + daux1 = 0.25d0/valech +c + elseif ( daux.le.15.d0 ) then +c + nbclas = 30 + daux1 = 0.50d0/valech +c + elseif ( daux.le.20.d0 ) then +c + nbclas = 40 + daux1 = 0.50d0/valech +c + elseif ( daux.le.50.d0 ) then +c + nbclas = 25 + daux1 = 2.00d0/valech +c + elseif ( daux.le.100.d0 ) then +c + nbclas = 50 + daux1 = 2.00d0/valech +c + else +c + nbclas = nbclmx + daux1 = (vamaar-vamiar) / dble(nbclas) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbclas', nbclas + write (ulsort,90004) 'daux1', daux1 +#endif + rclass(0) = vamiar + do 62 , iaux = 1 , nbclas + rclass(iaux) = rclass(iaux-1) + daux1 + if ( rclass(iaux).ge.vamaar ) then + jaux = iaux + goto 620 + endif + 62 continue + jaux = nbclas + 620 continue + nbclas = jaux +c + endif +c +#ifdef _DEBUG_HOMARD_ + do 6999 , iaux = 0 , nbclas + write (ulsort,90114) 'rclass', iaux, rclass(iaux) + 6999 continue +#endif +c + endif +c +c==== +c 7. ecriture sur le fichier d'information +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. ecriture ; codret', codret +#endif +c 7.1. ==> ecriture de l'entete +c + if ( codret.eq.0 ) then +c + write (ulbila,10100) +c + if ( lechoi.eq.0 ) then +c + write (ulbila,11200) medi58(langue,1,1) + write (ulbila,11200) medi58(langue,2,1) + do 710 , iaux = 1, nxmd58(langue,typenh) + write (ulbila,11200) medi58(langue,iaux,typenh) + 710 continue +c + elseif ( lechoi.eq.1 ) then +c + do 711 , iaux = 1, nxmq58(langue,typenh) + write (ulbila,11200) mequ58(langue,iaux,typenh) + 711 continue +c + else +c + do 712 , iaux = 1, nxmj58(langue,typenh) + write (ulbila,11200) meqj58(langue,iaux,typenh) + 712 continue +c + endif +c + if ( nbvoto.ne.0 ) then + if ( typenh.eq.2 .or. typenh.eq.4 ) then + write (ulbila,11200) mege58(langue,typenh+2) + write (ulbila,11200) mege58(langue,5) + endif + endif +c + endif +c +c 7.2. ==> message si constant +c + if ( codret.eq.0 ) then +c + if ( consta ) then +c + write (ulbila,10200) + write (mege58(langue,3)(32:42),'(f11.4)') valmin + write (ulbila,11200) mege58(langue,3) + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 8. sortie pour xmgrace et ecriture de la table +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. ecriture ; codret', codret +#endif +c + if ( .not.consta ) then +c +c 8.1. ==> Ouverture du fichier +c + if ( codret.eq.0 ) then +c + if ( lechoi.eq.0 ) then + saux09 = 'diam.'//suffix(2,typenh)(1:4) + elseif ( lechoi.eq.1 ) then + saux09 = 'qual.'//suffix(2,typenh)(1:4) + else + saux09 = 'quaj.'//suffix(2,typenh)(1:4) + endif + iaux = 2 + jaux = -1 + if ( rafdef.eq.31 ) then + kaux = 1 + else + kaux = nbiter + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI', nompro +#endif + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux09, kaux, jaux, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90003) 'nomflo', nomflo +#endif +c + endif +c +c 8.2. ==> Ecriture +c + if ( codret.eq.0 ) then +c + mess08(1,2) = ' des '//mess14(langue,3,typenh)(1:3) + mess08(1,3) = mess14(langue,3,typenh)(4:11) + mess08(1,4) = mess14(langue,3,typenh)(12:13)//' ' +c + mess08(2,2) = ' of '//mess14(langue,3,typenh)(1:4) + mess08(2,3) = mess14(langue,3,typenh)(5:12) + mess08(2,4) = mess14(langue,3,typenh)(13:14)//' ' +c + titcou(1) = mess09(langue,lechoi)(1:8) + titcou(2) = mess08(langue,2) + titcou(3) = mess08(langue,3) + titcou(4) = mess08(langue,4) + titcou(5) = titcou(1) +c + iaux = nuroul + if ( lechoi.le.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCRHI / quadia', nompro +#endif + call utcrhi ( nbclas, rclass, iclass, histog, + > nbeexa, typval, quadia, ival, + > titcou, xlow, ulbila, iaux, + > ulsort, langue, codret ) + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCRHI / qualij', nompro +#endif + call utcrhi ( nbclas, rclass, iclass, histog, + > nbeexa, typval, qualij, ival, + > titcou, xlow, ulbila, iaux, + > ulsort, langue, codret ) + endif +c + endif +c +c 8.3. ==> Fermeture du fichier +c + if ( codret.eq.0 ) then +c + call gufeul ( nuroul , codret) +c + endif +c + endif +c + 20 continue +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb05c.F b/src/tool/Utilitaire/utb05c.F new file mode 100644 index 00000000..3fc07f36 --- /dev/null +++ b/src/tool/Utilitaire/utb05c.F @@ -0,0 +1,345 @@ + subroutine utb05c ( choix, + > typenh, nbento, nbencf, nbenca, + > coonoe, somare, + > aretri, arequa, + > hetvol, facvol, cofavo, arevol, + > nbiter, + > nbeexa, tbiau1, tbiau2, tabaur, tabau2, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 05 - etape c +c -- - -- - +c ______________________________________________________________________ +c +c but : controle de la qualite des volumes +c remarque : utb05c et utb19c sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du traitement . +c . . . . 0 : creation et affichage des histogrammes . +c . . . . 2 : sortie de la qualite des triangles . +c . . . . 3 : sortie de la qualite des tetraedres . +c . . . . 4 : sortie de la qualite des quadrangles . +c . . . . 6 : sortie de la qualite des hexaedres . +c . typenh . e . 1 . variantes . +c . . . . 3 : tetraedres . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbento . e . 1 . nombre d'entites . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetvol . e . nbento . historique de l'etat des volumes . +c . facvol . e .nbencf**. numeros des faces des volumes . +c . cofavo . e .nbencf**. code des faces des volumes . +c . arevol . e .nbenca**. code des aretes des volumes . +c . nbeexa . s . 1 . nombre d'entites examinees . +c . tbiau1 . a . * . liste des entites examinees . +c . tbiau2 . a . * . tableau entier auxiliaire . +c . tabaur . a . * . qualite des entites . +c . tabau2 . a . * . qualite des entites . +c . nbiter . e . 1 . numero de l'iteration courante . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB05C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + double precision tabaur(*) + double precision tabau2(*) +c + integer choix + integer typenh, nbento, nbencf, nbenca +c + integer somare(2,nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer hetvol(nbento) + integer facvol(nbencf,*), cofavo(nbencf,*), arevol(nbenca,*) + integer nbiter + integer nbeexa, tbiau1(*), tbiau2(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbvoto +c + double precision daux1, daux2, daux3 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. titre +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Pour les'',i10,1x,a)' + texte(1,5) = '(3x,''Qualite '',a,'' des '',a,'' : '',g12.5)' + texte(1,6) = '(''Type d''''entite inconnu :'',i10)' + texte(1,7) = '(''Nombre d''''entites examinees :'',i10)' + texte(1,8) = '(''Nombre de '',a,'' de qualite infinie'',i10)' +c + texte(2,4) = '(''. For the'',i10,1x,a)' + texte(2,5) = '(3x,''Quality '',a,'' of '',a,'' : '',g12.5)' + texte(2,6) = '(''Unknown entity type :'',i10)' + texte(2,7) = '(''Number of examined entities :'',i10)' + texte(2,8) = '(''Nombre de '',a,'' de qualite infinie'',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbento, mess14(langue,3,typenh) +#endif +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c + nbeexa = 0 +c +c==== +c 2. tetraedres +c==== +c + if ( typenh.eq.3 ) then +c + do 21 , iaux = 1 , nbteto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = iaux +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTQTET', nompro +#endif + call utqtet ( jaux, daux1, daux2, daux3, + > coonoe, somare, aretri, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux1 + tabau2(nbeexa) = daux2 +c + endif +c + 21 continue +c +c==== +c 3. pyramides +c==== +c + elseif ( typenh.eq.5 ) then +c + do 31 , iaux = 1 , nbpyto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = iaux +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTQPYR', nompro +#endif + call utqpyr ( jaux, daux1, daux2, daux3, + > coonoe, somare, aretri, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux1 + tabau2(nbeexa) = daux2 +c + endif +c + 31 continue +c +c==== +c 4. hexaedres +c==== +c + elseif ( typenh.eq.6 ) then +c + do 41 , iaux = 1 , nbheto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = iaux +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTQHEX', nompro +#endif + call utqhex ( jaux, daux1, daux2, daux3, + > coonoe, somare, arequa, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux1 + tabau2(nbeexa) = daux2 +c + endif +c + 41 continue +c +c==== +c 5. pentaedres +c==== +c + elseif ( typenh.eq.7 ) then +c + do 51 , iaux = 1 , nbpeto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = iaux +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTQPEN', nompro +#endif + call utqpen ( jaux, daux1, daux2, daux3, + > coonoe, somare, arequa, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux1 + tabau2(nbeexa) = daux2 +c + endif +c + 51 continue +c +c==== +c 6. probleme +c==== +c + else +c + write (ulsort,texte(langue,6)) typenh + codret = 1 +c + endif +c +c==== +c 7. impression sur la sortie standard et sur un fichier a exploiter +c par xmgrace +c==== +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + if ( typenh.eq.3 .or. typenh.eq.6 ) then + iaux = 12 + elseif ( typenh.eq.5 .or. typenh.eq.7 ) then + iaux = 2 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B', nompro +#endif + call utb05b ( iaux, typenh, nbeexa, tabaur, tabau2, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb07a.F b/src/tool/Utilitaire/utb07a.F new file mode 100644 index 00000000..8835c115 --- /dev/null +++ b/src/tool/Utilitaire/utb07a.F @@ -0,0 +1,1072 @@ + subroutine utb07a ( hetare, + > hettri, nivtri, pertri, + > voltri, + > hetqua, nivqua, + > volqua, + > hettet, tritet, pertet, pthepe, + > hethex, quahex, perhex, + > hetpyr, facpyr, perpyr, pphepe, + > hetpen, facpen, perpen, + > posifa, facare, + > famnoe, cfanoe, + > fammpo, cfampo, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > tabaui, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 07 +c -- - -- +c ______________________________________________________________________ +c +c Nombre de mailles du calcul qui sont actives. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . nivtri . e . nbtrto . niveau des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nivqua . e . nbquto . niveau des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . perpyr . e . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . pphepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . perpen . e . nbpeto . pere des pentaedres . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbnoto . 1 : famille MED . +c . . . . + l : appartenance a l'equivalence l . +c . famnoe . e . nbnoto . famille des aretes . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . + l : appartenance a l'equivalence l . +c . fammpo . e . nbmpto . famille des mailles-points . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . . . . + l : appartenance a l'equivalence l . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfpe. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . tabaui . a .-nivsu-1. tableau de travail . +c . . .:nivsu+1. . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB07A' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envada.h" +#include "envca1.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto) + integer hettri(nbtrto), nivtri(nbtrto), pertri(nbtrto) + integer voltri(2,nbtrto) + integer hetqua(nbquto), nivqua(nbquto) + integer volqua(2,nbquto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettet(nbteto), tritet(nbtecf,4) + integer pertet(nbteto), pthepe(*) + integer hethex(nbheto), quahex(nbhecf,6) + integer perhex(nbheto) + integer hetpyr(nbpyto), facpyr(nbpycf,5) + integer perpyr(nbpyto), pphepe(*) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer perpen(nbpeto) +c + integer famnoe(nbnoto), cfanoe(nctfno,nbfnoe) + integer fammpo(nbmpto), cfampo(nctfmp,nbfmpo) + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer tabaui(-nivsup-1:nivsup+1) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, ideb, ifin + integer lenoeu, lamapo, larete, letria, lequad, letetr + integer lehexa, lapyra, lepent + integer etat + integer nbmapo + integer nbaret, nbarbt, nbarit + integer nbfabt, nbfavt + integer nbvolu + integer pos, fac1, fac2, vois1, vois2 + integer nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu +c + double precision niveau +c + logical arbord +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*54 mess54(nblang,nbmess) + character*43 saux43 + character*43 mess43(nblang,100) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''NOMBRE D''''ENTITES DU CALCUL'',/,3x,26(''=''),/)' +c + texte(2,4) = + > '(//,3x,''NUMBER OF CALCULATION ENTITIES'',/,3x,30(''=''),/)' +cgn ulbila = ulsort +c + write (ulbila,texte(langue,4)) +c + mess54(1,1) = + > ' Le maillage presente des homologues. ' +c + mess43(1,1) = 'Nombre total ' + mess43(1,3) = '. dont sommets d''aretes ' + mess43(1,4) = '. dont milieux d''aretes ' + mess43(1,5) = '. dont noeuds internes aux mailles ' + mess43(1,6) = '. dont noeuds isoles ' + mess43(1,7) = '. dont noeuds uniquement mailles ignorees ' + mess43(1,8) = '. dont noeuds uniquement mailles-points ' +c + mess43(1,10) = '. dont aretes isolees ' + mess43(1,11) = '. dont aretes de bord de regions 2D ' + mess43(1,12) = '. dont aretes internes aux faces/volumes ' +c + mess43(1,20) = '. dont triangles de regions 2D ' + mess43(1,21) = '. dont triangles de bord ' + mess43(1,22) = '. dont triangles internes aux volumes ' +c + mess43(1,30) = '. dont quadrangles de regions 2D ' + mess43(1,31) = '. dont quadrangles de bord ' + mess43(1,32) = '. dont quadrangles internes aux volumes ' +c + mess43(1,60) = 'Paires de ' +c 1234567890123456789012345678901234567890123 +c + mess54(2,1) = + > ' The mesh implies homologous condition. ' +c + mess43(2,1) = 'Total number ' + mess43(2,3) = '. included vertices of edges ' + mess43(2,4) = '. included centers of edges ' + mess43(2,5) = '. included internal nodes ' + mess43(2,6) = '. included isolated nodes ' + mess43(2,7) = '. included only ignored meshes nodes ' + mess43(2,8) = '. included only mesh-point nodes ' +c + mess43(2,10) = '. included isolated edges ' + mess43(2,11) = '. included boundaries of 2D areas ' + mess43(2,12) = '. included internal in faces/volumes ' +c + mess43(2,20) = '. included triangles of 2D areas ' + mess43(2,21) = '. included boundary triangles ' + mess43(2,22) = '. included internal triangles ' +c + mess43(2,30) = '. included quadrangles of 2D areas ' + mess43(2,31) = '. included boundary quadrangles ' + mess43(2,32) = '. included internal quadrangles ' +c + mess43(2,60) = 'Pairs of ' +c 1234567890123456789012345678901234567890123 +c +10100 format(/,5x,60('*')) +10200 format( 5x,60('*')) +c +11100 format( 5x,'* ',a54,' *') +11200 format( 5x,'* ',21x,a14,21x,' *') +c +12200 format( 5x,'* ',a43,' * ', i10,' *') +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lg de tabaui = nivsup', nivsup +#endif +c +c==== +c 2. noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. nbnoto',nbnoto +#endif +c + nbeqno = 0 + ideb = nctfno - ncefno + 1 + ifin = nctfno +c + do 21 , lenoeu = 1, nbnoto +c + do 211 , iaux = ideb , ifin + if ( cfanoe(iaux,famnoe(lenoeu)).ne.0 ) then + nbeqno = nbeqno + 1 + endif + 211 continue +c + 21 continue +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,-1) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbnoto + if ( degre.eq.2 .or. + > nbnois.ne.0 .or. nbnoei.ne.0 .or. nbnomp.ne.0 ) then + write (ulbila,12200) mess43(langue,3), nbnop1 + endif + if ( degre.eq.2 ) then + write (ulbila,12200) mess43(langue,4), nbnop2 + endif + if ( mod(mailet,2).eq.0 .or. + > mod(mailet,3).eq.0 .or. + > mod(mailet,5).eq.0 ) then + write (ulbila,12200) mess43(langue,5), nbnoim + endif + if ( nbnois.ne.0 ) then + write (ulbila,12200) mess43(langue,6), nbnois + endif + if ( nbnoei.ne.0 ) then + write (ulbila,12200) mess43(langue,7), nbnoei + endif + if ( nbnomp.ne.0 ) then + write (ulbila,12200) mess43(langue,8), nbnomp + endif + write (ulbila,10200) +c +c==== +c 3. mailles-points +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. nbmpto',nbmpto +#endif +c + if ( nbmpto.ne.0 ) then +c + nbmapo = 0 + nbeqmp = 0 + ideb = nctfmp - ncefmp + 1 + ifin = nctfmp +c + do 31 , lamapo = 1, nbmpto +c + if ( cfampo(cotyel,fammpo(lamapo)).ne.0 ) then +c + nbmapo = nbmapo + 1 +c + do 311 , iaux = ideb , ifin + if ( cfampo(iaux,fammpo(lamapo)).ne.0 ) then + nbeqmp = nbeqmp + 1 + endif + 311 continue +c + endif +c + 31 continue +c + if ( nbmapo.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,0) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbmapo + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 4. aretes +c==== +c on rappelle que la caracteristique numero cotyel des aretes est +c nulle si ce n'etait pas une maille du calcul. +c si c'est une maille de calcul, la caracteristique vaut le type +c correspondant a celui du code de calcul associe. +c +c on definit une arete de bord comme etant une arete ayant : +c . une seule face voisine, +c . deux faces voisines : +c . deux triangles dont l'un est le pere de l'autre : cas du +c decoupage de conformite provenant de l'arete de bord ; cela n'a +c lieu qu'avec des homologues. +c . un triangle et un quadrangle qui en est le pere des autres : cas +c du decoupage non conforme d'un quadrangle de bord. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. nbarto',nbarto +#endif +c + nbaret = 0 + nbarbt = 0 + nbarit = 0 + nbeqar = 0 + ideb = nctfar - ncefar + 1 + ifin = nctfar +c + do 41 , larete = 1, nbarto +c + if ( cfaare(cotyel,famare(larete)).ne.0 ) then +c + etat = mod(hetare(larete) , 10 ) +c + if ( etat.eq.0 ) then +c + nbaret = nbaret + 1 + arbord = .false. +c + if ( posifa(larete-1)+2.eq.posifa(larete) ) then + pos = posifa(larete) + fac1 = facare(pos-1) + fac2 = facare(pos) + if ( fac1.gt.0 .and. fac2.gt.0 ) then + vois1 = min(fac1,fac2) + vois2 = max(fac1,fac2) + if ( pertri(vois2).eq.vois1 ) then + arbord = .true. + endif + elseif ( fac1.gt.0 .and. fac2.lt.0 ) then + if ( pertri(fac1).eq.fac2 ) then + arbord = .true. + endif + elseif ( fac1.lt.0 .and. fac2.gt.0 ) then + if ( pertri(fac2).eq.fac1 ) then + arbord = .true. + endif + endif + elseif ( posifa(larete-1)+1.eq.posifa(larete) ) then + arbord = .true. + elseif ( posifa(larete-1)+1.gt.posifa(larete) ) then + nbarit = nbarit +1 + endif +c + if ( arbord ) then + nbarbt = nbarbt +1 + endif +c + do 411 , iaux = ideb , ifin + if ( cfaare(iaux,famare(larete)).ne.0 ) then + nbeqar = nbeqar + 1 + endif + 411 continue +c + endif +c + endif +c + 41 continue +c + if ( nbaret.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,1) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbaret + if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + write (ulbila,12200) mess43(langue,10), nbarit + write (ulbila,12200) mess43(langue,11), nbarbt + write (ulbila,12200) mess43(langue,12), nbaret-nbarit-nbarbt + endif + write (ulbila,10200) +c + endif +c +c==== +c 5. triangles +c==== +c on rappelle que la caracteristique numero 2 des faces est nulle si +c ce n'etait pas une maille du calcul. +c si c'est une maille de calcul, la caracteristique vaut le type +c correspondant a celui du code de calcul associe. +c Un triangle de bord est un triangle ayant un et un seul +c volume voisin. +c Le stockage etant different de la dimension deux, le tableau +c voltri ne garde que le volume fils. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. nbtrto',nbtrto +#endif +c + if ( nbtrto.ne.0 ) then +c + do 51 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 51 continue +c + nbvolu = nbteto + nbpyto + nbpeto + jaux = 0 + nbfabt = 0 + nbfavt = 0 + nbeqtr = 0 + ideb = nctftr - nceftr + 1 + ifin = nctftr +c + do 52 , letria = 1, nbtrto +c + if ( cfatri(cotyel,famtri(letria)).ne.0 ) then +c + etat = mod(hettri(letria) , 10 ) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivtri(letria) + if ( letria.gt.nbtrpe ) then + iaux = -iaux + endif + tabaui(iaux) = tabaui(iaux) + 1 +c + if ( nbvolu.ne.0 ) then +c + if ( voltri(1,letria).ne.0 ) then + if ( voltri(2,letria).eq.0 ) then + nbfabt = nbfabt + 1 + else + nbfavt = nbfavt + 1 + endif + endif +c + endif +c + do 521 , iaux = ideb , ifin + if ( cfatri(iaux,famtri(letria)).ne.0 ) then + nbeqtr = nbeqtr + 1 + endif + 521 continue +c + endif +c + endif +c + 52 continue +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,2) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux + if ( nbvolu.ne.0 ) then + write (ulbila,12200) mess43(langue,20), jaux-nbfabt-nbfavt + write (ulbila,12200) mess43(langue,21), nbfabt + write (ulbila,12200) mess43(langue,22), nbfavt + endif +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 6. quadrangles +c==== +c on rappelle que la caracteristique numero 2 des faces est nulle si +c ce n'etait pas une maille du calcul. +c si c'est une maille de calcul, la caracteristique vaut le type +c correspondant a celui du code de calcul associe. +c Un quadrangle de bord est un quadrangle ayant un et un seul +c volume voisin. +c Le stockage etant different de la dimension deux, le tableau +c volqua ne garde que le volume fils. +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. nbquto',nbquto +#endif +c + if ( nbquto.ne.0 ) then +c + do 61 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 61 continue +c + nbvolu = nbheto + nbpyto + nbpeto + jaux = 0 + nbfabt = 0 + nbfavt = 0 + nbeqqu = 0 + ideb = nctfqu - ncefqu + 1 + ifin = nctfqu +c + do 62 , lequad = 1, nbquto +c + if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then +c + etat = mod(hetqua(lequad),100) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivqua(lequad) + if ( lequad.gt.nbqupe ) then + iaux = -iaux + endif + tabaui(iaux) = tabaui(iaux) + 1 +c + if ( nbvolu.ne.0 ) then +c + if ( volqua(1,lequad).ne.0 ) then + if ( volqua(2,lequad).eq.0 ) then + nbfabt = nbfabt + 1 + else + nbfavt = nbfavt + 1 + endif + endif +c + endif +c + do 621 , iaux = ideb , ifin + if ( cfaqua(iaux,famqua(lequad)).ne.0 ) then + nbeqqu = nbeqqu + 1 + endif + 621 continue +c + endif +c + endif +c + 62 continue +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,4) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux + if ( nbvolu.ne.0 ) then + write (ulbila,12200) mess43(langue,30), jaux-nbfabt-nbfavt + write (ulbila,12200) mess43(langue,31), nbfabt + write (ulbila,12200) mess43(langue,32), nbfavt + endif +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 7. tetraedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. nbteto, nbtepe, nbtecf, nbteca', + > nbteto, nbtepe, nbtecf, nbteca +#endif +c + if ( nbteto.ne.0 ) then +c + do 70 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 70 continue +c + jaux = 0 +c +c 7.1. ==> Les tetraedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 71 , letetr = 1, nbtepe +c + if ( cfatet(cotyel,famtet(letetr)).ne.0 ) then +c + etat = mod(hettet(letetr),100) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivtri(tritet(letetr,1)) + tabaui(iaux) = tabaui(iaux) + 1 +c + endif +c + endif +c + 71 continue +cgn write (ulsort,90002) 'jaux', jaux +c +c 7.2. ==> Les tetraedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 72 , letetr = nbtepe+1 , nbteto +c + call utntet ( letetr, niveau, + > tritet, pertet, pthepe, + > nivtri, nivqua, + > quahex, facpen ) +c + jaux = jaux + 1 + iaux = -int(niveau) - 1 + tabaui(iaux) = tabaui(iaux) + 1 +c + 72 continue +cgn write (ulsort,90002) 'jaux', jaux +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,3) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 8. hexaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. nbheto, nbhecf',nbheto, nbhecf +#endif +c + if ( nbheto.ne.0 ) then +c + do 80 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 80 continue +c + jaux = 0 +c +c 8.1. ==> Les hexaedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 81 , lehexa = 1, nbhepe +c + if ( cfahex(cotyel,famhex(lehexa)).ne.0 ) then +c + etat = mod(hethex(lehexa),1000) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivqua(quahex(lehexa,1)) + tabaui(iaux) = tabaui(iaux) + 1 +c + endif +c + endif +c + 81 continue +c +c 8.2. ==> Les hexaedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 82 , lehexa = nbhepe+1 , nbheto +c + call utnhex ( lehexa, niveau, + > quahex, perhex, + > nivqua ) +c + jaux = jaux + 1 + iaux = -int(niveau) - 1 + tabaui(iaux) = tabaui(iaux) + 1 +c + 82 continue +c + jaux = jaux + nbheca +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,6) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 9. pyramides +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '9. nbpyto, nbpype, nbpycf, nbpyca', + > nbpyto, nbpype, nbpycf, nbpyca +#endif +c + if ( nbpyto.ne.0 ) then +c + do 90 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 90 continue +c + jaux = 0 +c +c 9.1. ==> Les pyramides de depart ou issues d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : elles sont toujours decrites par faces +c + do 91 , lapyra = 1, nbpype +cgn write (ulsort,90002) 'pyramide',lapyra +c + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then +c + etat = mod(hetpyr(lapyra),100) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivtri(facpyr(lapyra,1)) + tabaui(iaux) = tabaui(iaux) + 1 +c + endif +c + endif +c + 91 continue +cgn write (ulsort,90002) 'jaux', jaux +cgn write (ulsort,*) '************************' +c +c 9.2. ==> Les pyramides issues d'un decoupage de conformite +c Remarque : elles sont toujours actives +c + do 92 , lapyra = nbpype+1 , nbpyto +cgn write (ulsort,90002) 'pyramide',lapyra +cgn write (ulsort,90002) 'jaux',jaux +c + call utnpyr ( lapyra, niveau, + > facpyr, perpyr, pphepe, + > nivtri, nivqua, + > quahex, facpen ) +c + jaux = jaux + 1 + iaux = -int(niveau) - 1 + tabaui(iaux) = tabaui(iaux) + 1 +c + 92 continue +cgn write (ulsort,90002) 'jaux', jaux +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,5) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 10. pentaedres +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '10. nbpeto, nbpecf',nbpeto, nbpecf +#endif +c + if ( nbpeto.ne.0 ) then +c + do 100 , iaux = -nivsup-1, nivsup+1 + tabaui(iaux) = 0 + 100 continue +c + jaux = 0 +c +c 10.1. ==> Les pentaedres de depart ou issus d'un decoupage en 8 +c Les faces sont toutes du meme niveau +c Remarque : ils sont toujours decrits par faces +c + do 101 , lepent = 1, nbpepe +c + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then +c + etat = mod(hetpen(lepent),100) +c + if ( etat.eq.0 ) then +c + jaux = jaux + 1 + iaux = nivtri(facpen(lepent,1)) + tabaui(iaux) = tabaui(iaux) + 1 +c + endif +c + endif +c + 101 continue +c +c 10.2. ==> Les pentaedres issus d'un decoupage de conformite +c Remarque : ils sont toujours actifs +c + do 102 , lepent = nbpepe+1 , nbpeto +c + call utnpen ( lepent, niveau, + > facpen, perpen, + > nivtri, nivqua ) +c + jaux = jaux + 1 + iaux = -int(niveau) - 1 + tabaui(iaux) = tabaui(iaux) + 1 +c + 102 continue +c + jaux = jaux + nbpeca +c + if ( jaux.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,7) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), jaux +c + if ( nbiter.ge.1 ) then + call utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) + endif +c + write (ulbila,10200) +c + endif +c + endif +c +c==== +c 11. reperage des homologues +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '11. homolo',homolo +#endif +c + if ( homolo.ne.0 ) then +c + write (ulbila,10100) + write (ulbila,11100) mess54(langue,1) + write (ulbila,10200) + saux43 = mess43(langue,60) + if (nbeqno.gt.0) then + saux43(11:24) = mess14(langue,3,-1) + write (ulbila,12200) saux43, nbeqno/2 + endif + if (nbeqmp.gt.0) then + saux43(11:24) = mess14(langue,3,0) + write (ulbila,12200) saux43, nbeqmp/2 + endif + if (nbeqar.gt.0) then + saux43(11:24) = mess14(langue,3,1) + write (ulbila,12200) saux43, nbeqar/2 + endif + if ( nbeqtr.gt.0 ) then + saux43(11:24) = mess14(langue,3,2) + write (ulbila,12200) saux43, nbeqtr/2 + endif + if ( nbeqqu.gt.0 ) then + saux43(11:24) = mess14(langue,3,4) + write (ulbila,12200) saux43, nbeqqu/2 + endif + write (ulbila,10200) +c + endif +c +c==== +c 12. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '12. codret',codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb07b.F b/src/tool/Utilitaire/utb07b.F new file mode 100644 index 00000000..4e573ec8 --- /dev/null +++ b/src/tool/Utilitaire/utb07b.F @@ -0,0 +1,187 @@ + subroutine utb07b ( tabaui, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 07 - impressions +c -- - -- +c ______________________________________________________________________ +c +c Imprime les statistiques sur les niveaux des mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tabaui . a .-nivsup . tableau de travail . +c . . . :nivsup. . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB07B' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer tabaui(-nivsup-1:nivsup+1) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(5x,''* . du niveau '',i3,28x,'' * '',i10,'' *'')' + texte(1,5) = + >'(5x,''* . du niveau '',i3,''.5'',26x,'' * '',i10,'' *'')' +c + texte(2,4) = + >'(5x,''* . from level '',i3,27x,'' * '',i10,'' *'')' + texte(2,5) = + >'(5x,''* . from level '',i3,''.5'',25x,'' * '',i10,'' *'')' +cgn ulbila = ulsort +c +10200 format( 5x,60('*')) +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'maconf', maconf + write (ulsort,90002) 'lg de tabaui = nivsup+1', nivsup+1 + write (ulsort,90002) 'tabaui', + > (tabaui(iaux),iaux=-nivsup-1,nivsup+1) +#endif +c +c==== +c 2. Recherche du niveau maximal atteint pour la categorie +c en cours d'impression +c==== +c + jaux = -1 +c + do 21 , iaux = nivsup+1, 0, -1 +c + if ( iaux.le.nivsup .and. + > ( ( maconf.eq.-1 ) .or. ( maconf.eq.0 ) ) .and. + > tabaui(-iaux-1).ne.0 ) then + jaux = iaux + 1 + goto 211 + endif +c + if ( tabaui(iaux).ne.0 ) then + jaux = iaux + goto 211 + endif +c + 21 continue +c + 211 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> jaux', jaux +#endif +c +c==== +c 3. Impressions +c==== +c + if ( jaux.ge.0 ) then +c + write (ulbila,10200) +c + do 31 , iaux = 0 , jaux +c + if ( iaux.lt.jaux .or. tabaui(iaux).ne.0 ) then + write (ulbila,texte(langue,4)) iaux, tabaui(iaux) + endif +c + if ( iaux.lt.jaux .and. + > ( ( maconf.eq.-1 ) .or. ( maconf.eq.0 ) ) ) then + write (ulbila,texte(langue,5)) iaux, tabaui(-iaux-1) + endif +c + 31 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11a.F b/src/tool/Utilitaire/utb11a.F new file mode 100644 index 00000000..50da5a1a --- /dev/null +++ b/src/tool/Utilitaire/utb11a.F @@ -0,0 +1,447 @@ + subroutine utb11a ( hetare, somare, + > hettri, aretri, + > voltri, pypetr, + > hetqua, arequa, + > volqua, pypequ, + > hettet, tritet, + > hethex, quahex, + > hetpyr, facpyr, + > hetpen, facpen, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > tabau1, tabau2, tabau3, tabau4, + > taba11, taba12, taba13, taba14, + > taba15, taba16, + > nublen, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 +c -- - -- +c ______________________________________________________________________ +c +c analyse de la connexite du maillage de calcul +c remarque : pour du raffinement non-conforme, chaque niveau est +c un bloc +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . povoso . e .0:nbnoto. pointeur des voisins par noeud . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy*. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . tabau1 . a . * . tableau de travail . +c . tabau2 . a . * . tableau de travail . +c . tabau3 . a . * . tableau de travail . +c . tabau4 . a .-nbquto . tableau de travail . +c . . . :nbtrto. . +c . taba11 . a . * . tableau de travail . +c . taba12 . a . nbnoto . tableau de travail . +c . taba13 . a . nbarto . tableau de travail . +c . taba14 . a . * . tableau de travail . +c . taba15 . a . nbarto . tableau de travail . +c . taba16 . a . * . tableau de travail . +c . nublen . s . * . numero de blocs par entite . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto), somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer voltri(2,nbtrto), pypetr(2,*) + integer hetqua(nbquto), arequa(nbquto,4) + integer volqua(2,nbquto), pypequ(2,*) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer povoso(0:nbnoto), voisom(*) + integer posifa(0:nbarto), facare(nbfaar) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer tabau1(*) + integer tabau2(nbnoto) + integer tabau3(nbarto) + integer tabau4(-nbquto:*) + integer taba11(*) + integer taba12(nbnoto) + integer taba13(nbarto) + integer taba14(*) + integer taba15(nbarto) + integer taba16(*) + integer nublen(-nbquto:*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbblar, nbblfa, nbblvo +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''CONNEXITE DES ENTITES DU CALCUL'',/,3x,31(''=''),/)' + texte(1,5) = + >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')' +c + texte(2,4) = + > '(//,3x,''CONNEXITY OF CALCULATION ENTITIES'',/,3x,33(''=''),/)' + texte(2,5) = + >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')' +c + write (ulbila,texte(langue,4)) +c +#ifdef _DEBUG_HOMARD_ +10001 format(4x,60('-')) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. blocs de volumes +c Remarque : impossible si des volumes sont decrits par leurs aretes +c==== +c + if ( codret.eq.0 ) then +c + if ( nbteca.eq.0 .and. nbheca.eq.0 .and. + > nbpyca.eq.0 .and. nbpeca.eq.0 ) then +c +c + if ( nbteac.gt.0 .or. nbheac.gt.0 .or. + > nbpyac.gt.0 .or. nbpeac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11B', nompro +#endif + call utb11b ( nbblvo, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > hettet, tritet, + > hethex, quahex, + > hetpyr, facpyr, + > hetpen, facpen, + > povoso, voisom, + > posifa, facare, + > voltri, pypetr, + > volqua, pypequ, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > tabau1, tabau2, tabau3, tabau4, + > taba11, taba12, taba13, taba14, + > taba15, taba16, + > nublen, + > ulbila, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fin etape 2 avec codret', codret + write(ulsort,texte(langue,5)) mess14(langue,3,3) + write(ulsort,91040) (iaux, + > iaux=1,min(20,nbteto+nbheto+nbpyto-nbquto)) + write(ulsort,10001) + write(ulsort,91040) (nublen(iaux), + > iaux=-nbquto,nbteto+nbheto+nbpyto-nbquto-1) +#endif +c + endif +c + endif +c + endif +c +c==== +c 3. blocs de faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. bloc de faces ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then +c +c on examine toutes les faces actives du calcul +c + do 31 , iaux = -nbquto, nbtrto + tabau4(iaux) = 1 + 31 continue + tabau4(0) = 0 + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11C', nompro +#endif + call utb11c ( nbblfa, iaux, tabau4, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > tabau1, tabau2, tabau3, + > taba15, taba16, + > nublen, + > ulbila, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Fin etape 3 avec codret', codret + if ( nbtrac.gt.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,2) + write(ulsort,91040) (iaux,iaux=1,min(20,nbtrto)) + write(ulsort,10001) + write(ulsort,91040) + >(nublen(iaux),iaux=-nbquto+1,-nbquto+min(100,nbtrto)) + endif + if ( nbquac.gt.0 ) then + write(ulsort,texte(langue,5)) mess14(langue,3,4) + write(ulsort,91040) (iaux,iaux=1,min(20,nbquto)) + write(ulsort,10001) + write(ulsort,91040) + >(nublen(iaux),iaux=-nbquto,-nbquto+min(100,nbquto)-1) + endif +#endif +c + endif +c + endif +c +c==== +c 4. blocs d'aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. bloc d aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c on examine toutes les aretes actives du calcul +c + do 41 , iaux = 1, nbarto + tabau3(iaux) = 1 + 41 continue + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11D', nompro +#endif + call utb11d ( nbblar, iaux, tabau3, + > hetare, somare, + > povoso, voisom, + > famare, cfaare, + > tabau1, tabau2, + > nublen, + > ulbila, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Fin etape 4 avec codret', codret + write(ulsort,texte(langue,5)) mess14(langue,3,1) + write(ulsort,91040) (iaux,iaux=1,min(20,nbarto)) + write(ulsort,10001) + write(ulsort,91040) + >(nublen(iaux),iaux=-nbquto,-nbquto+min(100,nbarto)-1) +#endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11b.F b/src/tool/Utilitaire/utb11b.F new file mode 100644 index 00000000..4f385550 --- /dev/null +++ b/src/tool/Utilitaire/utb11b.F @@ -0,0 +1,1355 @@ + subroutine utb11b ( nbbloc, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > hettet, tritet, + > hethex, quahex, + > hetpyr, facpyr, + > hetpen, facpen, + > povoso, voisom, + > posifa, facare, + > voltri, pypetr, + > volqua, pypequ, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > lapile, tabau2, tabau3, tabau4, + > taba11, taba12, taba13, taba14, + > taba15, taba16, + > nublvo, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 - phase b +c -- - -- - +c ______________________________________________________________________ +c +c analyse de la connexite des volumes +c remarque : on s'est arrange pour que les mailles externes soient +c numerotes dans cet ordre : +c . les tetraedres +c . les triangles +c . les aretes +c . les mailles-points +c . les quadrangles +c . les hexaedres +c . les pyramides +c . les pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbbloc . s . 1 . nombre de blocs . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . povoso . e .0:nbnoto. pointeur des voisins par noeud . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy*. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . lapile . a . * . tableau de travail . +c . tabau2 . a . nbnoto . tableau de travail . +c . tabau3 . a . nbarto . tableau de travail . +c . tabau4 . a .-nbquto . tableau de travail . +c . . . :nbtrto. . +c . taba11 . a . * . tableau de travail . +c . taba12 . a . nbnoto . tableau de travail . +c . taba13 . a . nbarto . tableau de travail . +c . taba14 . a . * . tableau de travail . +c . taba15 . a . nbarto . tableau de travail . +c . taba16 . a . * . tableau de travail . +c . nublvo . s . * . numero de blocs des volumes, ranges ainsi :. +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . . . . si 0 : on n'ecrit rien . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11B' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbbloc + integer hetare(nbarto), somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer hettet(nbteto), tritet(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5) + integer posifa(0:nbarto), facare(nbfaar) + integer povoso(0:nbnoto), voisom(*) + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer lapile(*) + integer tabau2(nbnoto) + integer tabau3(nbarto) + integer tabau4(-nbquto:*) + integer taba11(*) + integer taba12(nbnoto) + integer taba13(nbarto) + integer taba14(*) + integer taba15(nbarto) + integer taba16(*) + integer nublvo(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux + integer tbiaux(1) + integer levolu, nument, typvo0, typvol + integer etat + integer lamail, lgpile + integer maxtet, maxhex, maxpyr, maxpen + integer dectet, dechex, decpyr, decpen + integer lapyra, lepent + integer nbblfa +#ifdef _DEBUG_HOMARD_ + integer glop + integer typenh +#endif +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> Les messages +c + texte(1,4) = '(/,3x,''. Connexite des '',a)' + texte(1,5) = + >'(5x,''* Les '',a,'' sont en un seul bloc.'',15x,''*'')' + texte(1,6) = + >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')' + texte(1,7) = + >'(5x,''* Bloc numero '',i8,5x,'' * '',i11,1x,a,'' *'')' + texte(1,8) = + >'(5x,''* Nombre d''''Euler (2+V-F+A-S) :'',i5,19x,''*'')' + texte(1,9) = '(''.. Nombre de blocs de '',a,'':'',i5)' + texte(1,10) = '(''.. Impression du bloc'',i8)' +c + texte(2,4) = '(/,3x,''. Connexity of '',a)' + texte(2,5) = + >'(5x,''* All the '',a,'' are connected.'',18x,''*'')' + texte(2,6) = + >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')' + texte(2,7) = + >'(5x,''* Block # '',i8,9x,'' * '',i11,1x,a,'' *'')' + texte(2,8) = + >'(5x,''* Euler characteristic (2+V-F+A-S):'',i5,14x,''*'')' + texte(2,9) = '(''.. Number of blocks of '',a,'':'',i5)' + texte(2,10) = '(''.. Printing of block #'',i8)' +c +#include "impr03.h" +cgn print 91020,(voltri(1,iaux),iaux=1,nbtrto) +cgn print 91020,(voltri(2,iaux),iaux=1,nbtrto) +cgn print 91020,(pypetr(1,iaux),iaux=1,16) +cgn print 91020,(pypetr(2,iaux),iaux=1,56) +cgn print 91020,(pypequ(1,iaux),iaux=1,4) +cgn print 91020,(pypequ(2,iaux),iaux=1,14) +c +10100 format(/,5x,58('*')) +10200 format( 5x,58('*')) +c +c 1.2. ==> constantes +c + if ( nbpyac.eq.0 .and. nbheac.eq.0 .and. nbpeac.eq.0 ) then + typvo0 = 3 + elseif ( nbheac.eq.0 .and. nbpeac.eq.0 .and. nbteac.eq.0 ) then + typvo0 = 5 + elseif ( nbpeac.eq.0 .and. nbteac.eq.0 .and. nbpyac.eq.0 ) then + typvo0 = 6 + elseif ( nbteac.eq.0 .and. nbpyac.eq.0 .and. nbheac.eq.0 ) then + typvo0 = 7 + else + typvo0 = 9 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( ulbila.gt.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,typvo0) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbteto, nbtecf, nbteca', + > nbteto, nbtecf, nbteca + write (ulsort,90002) 'nbheto, nbhecf, nbheca', + > nbheto, nbhecf, nbheca + write (ulsort,90002) 'nbpyto, nbpycf, nbpyca', + > nbpyto, nbpycf, nbpyca + write (ulsort,90002) 'nbpeto, nbpecf, nbpeca', + > nbpeto, nbpecf, nbpeca +#endif +c + dectet = 0 + maxtet = dectet + nbteto + dechex = maxtet + maxhex = dechex + nbheto + decpyr = maxhex + maxpyr = decpyr + nbpyto + decpen = maxpyr + maxpen = decpen + nbpeto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'dectet', dectet, ', maxtet', maxtet + write (ulsort,90015) 'dechex', dechex, ', maxhex', maxhex + write (ulsort,90015) 'decpyr', decpyr, ', maxpyr', maxpyr + write (ulsort,90015) 'decpen', decpen, ', maxpen', maxpen +#endif +c +c 1.3. ==> Aucun bloc au depart +c + do 13 , iaux = 1 , maxpen + nublvo(iaux) = 0 + 13 continue +c + codret = 0 +c +c==== +c 2. blocs de volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. blocs de volumes ; codret =', codret +#endif +c + iaux = 2 + iaux = iaux + ( nbteac + nbheac + nbpyac + nbpeac ) + iaux = iaux - ( nbtrac + nbquac ) + iaux = iaux + nbarac + iaux = iaux - nbnop1 + write (ulbila,10100) + write (ulbila,texte(langue,8)) iaux + write (ulbila,10200) +c + nbbloc = 0 + lgpile = 0 +c + do 20 , levolu = 1, maxpen +c + etat = -1 +#ifdef _DEBUG_HOMARD_ + if ( levolu.eq.0 ) then + glop = 1 + else + glop = 01 + endif +#endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) 'Volume', levolu + endif +#endif + if ( levolu.le.maxtet ) then + nument = levolu - dectet + if ( cfatet(cotyel,famtet(nument)).ne.0 ) then + etat = mod(hettet(nument),100) + endif + elseif ( levolu.le.maxhex ) then + nument = levolu - dechex + if ( cfahex(cotyel,famhex(nument)).ne.0 ) then + etat = mod(hethex(nument),1000) + endif + elseif ( levolu.le.maxpyr ) then + nument = levolu - decpyr + if ( cfapyr(cotyel,fampyr(nument)).ne.0 ) then + etat = mod(hetpyr(nument),100) + endif + else + nument = levolu - decpen + if ( cfapen(cotyel,fampen(nument)).ne.0 ) then + etat = mod(hetpen(nument),100) + endif + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '============== etat', etat + endif +#endif +c + if ( etat.eq.0 ) then +c + if ( nublvo(levolu).eq.0 ) then +c +c 2.1. ==> on commence un nouveau bloc +c 2.1.1. ==> impression des caracteristiques du bloc precedent +c + if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbbloc', nbbloc +#endif +c +c 2.1.1.1. ==> recherche des faces actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublvo, + > tbiaux, + > tbiaux, tbiaux, + > tritet, quahex, facpyr, facpen, + > maxtet, maxhex, maxpyr, maxpen, + > tabau3, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 2.1.1.2. ==> recherche des blocs de faces actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11C', nompro +#endif + call utb11c ( nbblfa, iaux, tabau4, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > taba11, taba12, taba13, + > taba15, taba16, + > taba14, + > jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.1.1.3. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) nbbloc +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( nbbloc, nbblfa, typvo0, typvol, + > nublvo, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.1.2. ==> initialisations pour un nouveau bloc +c + nbbloc = nbbloc + 1 + lamail = levolu +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'debut du bloc ',nbbloc, + > ' avec lamail = ', lamail +#endif +c + do 2121 , iaux = 1 , nbnoto + tabau2(iaux) = 0 + 2121 continue + do 2122 , iaux = 1 , nbarto + tabau3(iaux) = 0 + 2122 continue +c + typvol = 0 +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( lamail.le.maxtet ) then + typenh = 3 + elseif ( lamail.le.maxhex ) then + typenh = 6 + elseif ( lamail.le.maxpyr ) then + typenh = 5 + else + typenh = 7 + endif + write (ulsort,*) '... Maille', lamail, + > ' (',mess14(langue,1,typenh),')' + endif +#endif +c +c 2.2. ==> memorisation du bloc pour la maille courante +c + nublvo(lamail) = nbbloc +c + if ( lamail.le.maxtet ) then + if ( typvol.eq.0 ) then + typvol = 3 + elseif ( typvol.ne.3 ) then + typvol = 9 + endif + elseif ( lamail.le.maxhex ) then + if ( typvol.eq.0 ) then + typvol = 6 + elseif ( typvol.ne.6 ) then + typvol = 9 + endif + elseif ( lamail.le.maxpyr ) then + if ( typvol.eq.0 ) then + typvol = 5 + elseif ( typvol.ne.5 ) then + typvol = 9 + endif + else + if ( typvol.eq.0 ) then + typvol = 7 + elseif ( typvol.ne.7 ) then + typvol = 9 + endif + endif +c +c 2.3. ==> mise des voisins dans la pile s'ils n'ont pas ete vus. +c Il faut faire attention a la numerotation. Pour la pile et +c nublvo, c'est la numerotation globale des mailles ; pour les +c caracteristiques des entites, c'est leur numero local. +c +c 2.3.1. ==> Cas d'un tetraedre +c + if ( lamail.le.maxtet ) then +c + nument = lamail - dectet +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'C''est le tetraedre ', nument + endif +#endif +c + if ( nument.le.nbtecf ) then +c + do 231 , iaux = 1 , 4 +c + jaux = tritet(nument,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '..... triangle jaux = ', jaux + endif +#endif + do 2311 , laux = 1 , 3 + kaux = aretri(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 + 2311 continue +c + do 2312 , laux = 1 , 2 +c + kaux = voltri(laux,jaux) +c +c 2.3.1.1. ==> Le voisin est un autre tetraedre +c + if ( kaux.gt.0 .and. kaux.ne.nument ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le tetraedre ',kaux + write (ulsort,90002) '....... du bloc ',nublvo(kaux) + endif +#endif +c + if ( nublvo(kaux).eq.0 ) then + if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then + etat = mod( hettet(kaux),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +c +c 2.3.1.2. ==> Le voisin est une pyramide +c + if ( pypetr(1,kaux).ne.0 ) then + lapyra = pypetr(1,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ',lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.1.3. ==> Le voisin est un pentaedre +c + if ( pypetr(2,kaux).ne.0 ) then + lepent = pypetr(2,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c + 2312 continue +c + 231 continue +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) 'OK' + endif +#endif +c + endif +c +c 2.3.2. ==> Cas d'un hexaedre +c + elseif ( lamail.le.maxhex ) then +c + nument = lamail-dechex +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'C''est l''hexaedre ', nument + endif +#endif +c + if ( nument.le.nbhecf ) then +c + do 232 , iaux = 1 , 6 +c + jaux = quahex(nument,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) '..... quadrangle jaux = ', jaux + endif +#endif + do 2321 , laux = 1 , 4 + kaux = arequa(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 + 2321 continue +c + do 2322 , laux = 1 , 2 +c + kaux = volqua(laux,jaux) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) '....... kaux = ', kaux + endif +#endif +c +c 2.3.2.1. ==> Le voisin est un autre hexaedre +c + if ( kaux.gt.0 .and. kaux.ne.nument ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est l''hexaedre ',kaux + write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux) + endif +#endif + if ( nublvo(dechex+kaux).eq.0 ) then + if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then + etat = mod( hethex(kaux),1000) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = dechex+kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +cgn if ( glop.eq.1 ) then +cgn write (ulsort,90002) 'pypequ(1,kaux)', pypequ(1,kaux) +cgn write (ulsort,90002) 'pypequ(2,kaux)', pypequ(2,kaux) +cgn endif +c +c 2.3.2.2. ==> Le voisin est une pyramide +c + if ( pypequ(1,kaux).ne.0 ) then + lapyra = pypequ(1,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ', lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.2.3. ==> Le voisin est un pentaedre +c + if ( pypequ(2,kaux).ne.0 ) then + lepent = pypequ(2,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c + 2322 continue +c + 232 continue +c + endif +c +c 2.3.3. ==> Cas de la pyramide +c + elseif ( lamail.le.maxpyr ) then +c + nument = lamail-decpyr +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'C''est la pyramide ',nument + endif +#endif +c + if ( nument.le.nbpycf ) then +c +c 2.3.3.1. ==> Le voisinage par les triangles +c + do 233 , iaux = 1 , 4 +c + jaux = facpyr(nument,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux + endif +#endif + do 2331 , laux = 1 , 3 + kaux = aretri(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 + 2331 continue +c + do 2332 , laux = 1 , 2 +c + kaux = voltri(laux,jaux) +c +c 2.3.3.1.1. ==> Le voisin est un tetraedre +c + if ( kaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le tetraedre ',kaux + write (ulsort,90002) '....... du bloc ', nublvo(kaux) + endif +#endif + if ( nublvo(kaux).eq.0 ) then + if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then + etat = mod( hettet(kaux),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +c +c 2.3.3.1.2. ==> Le voisin est une autre pyramide +c + lapyra = pypetr(1,kaux) + if ( lapyra.ne.0 .and. lapyra.ne.nument ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ',lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.3.1.3. ==> Le voisin est un pentaedre +c + if ( pypetr(2,kaux).ne.0 ) then + lepent = pypetr(2,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c + 2332 continue +c + 233 continue +c +c 2.3.3.2. ==> Le voisinage par le quadrangle +c + jaux = facpyr(nument,5) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) '..... le quadrangle numero', jaux + endif +#endif + do 2333 , laux = 1 , 4 + kaux = arequa(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 + 2333 continue +c + do 2334 , laux = 1 , 2 +c + kaux = volqua(laux,jaux) +c +c 2.3.3.2.1. ==> Le voisin est un hexaedre +c + if ( kaux.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est l''hexaedre ',kaux + write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux) + endif +#endif +c + if ( nublvo(dechex+kaux).eq.0 ) then + if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then + etat = mod( hethex(kaux),1000) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = dechex+kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +c +c 2.3.3.2.2. ==> Le voisin est une autre pyramide +c + lapyra = pypequ(1,kaux) + if ( lapyra.ne.0 .and. lapyra.ne.nument ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ',lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.3.2.3. ==> Le voisin est un pentaedre +c + if ( pypequ(2,kaux).ne.0 ) then + lepent = pypequ(2,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c + 2334 continue +c + endif +c +c 2.3.4. ==> Cas du pentaedre +c + else +c + nument = lamail-decpen +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'C''est le pentaedre ',nument + endif +#endif +c + if ( nument.le.nbpecf ) then +c +c 2.3.4.1. ==> Le voisinage par les triangles +c + do 2341 , iaux = 1 , 2 +c + jaux = facpen(nument,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '..... ', iaux,'-ieme triangle = ', jaux + endif +#endif + do 23411 , laux = 1 , 3 + kaux = aretri(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 +23411 continue +c + do 23412 , laux = 1 , 2 +c + kaux = voltri(laux,jaux) +c +c 2.3.4.1.1. ==> Le voisin est un tetraedre +c + if ( kaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le tetraedre ',kaux + write (ulsort,90002) '....... du bloc ', nublvo(kaux) + endif +#endif + if ( nublvo(kaux).eq.0 ) then + if ( cfatet(cotyel,famtet(kaux)).ne.0 ) then + etat = mod( hettet(kaux),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +c +c 2.3.4.1.2. ==> Le voisin est une pyramide +c + if ( pypetr(1,kaux).ne.0 ) then + lapyra = pypetr(1,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ',lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.4.1.3. ==> Le voisin est un autre pentaedre +c + lepent = pypetr(2,kaux) + if ( lepent.ne.0 .and. lepent.ne.nument ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) 'nument', nument + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c +23412 continue +c + 2341 continue +c +c 2.3.4.2. ==> Le voisinage par les quadrangles +c + do 2342 , iaux = 3 , 5 +c + jaux = facpen(nument,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '..... ', iaux,'-ieme quadrangle =', jaux + endif +#endif + do 23421 , laux = 1 , 4 + kaux = arequa(jaux,laux) + tabau3(kaux) = tabau3(kaux) + 1 + maux = somare(1,kaux) + tabau2(maux) = tabau2(maux) + 1 + maux = somare(2,kaux) + tabau2(maux) = tabau2(maux) + 1 +23421 continue +c + do 23422 , laux = 1 , 2 +c + kaux = volqua(laux,jaux) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90002) '....... kaux = ', kaux + endif +#endif +c +c 2.3.4.2.1. ==> Le voisin est un hexaedre +c + if ( kaux.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est l''hexaedre ',kaux + write (ulsort,90002) '....... du bloc ', nublvo(dechex+kaux) + endif +#endif +c + if ( nublvo(dechex+kaux).eq.0 ) then + if ( cfahex(cotyel,famhex(kaux)).ne.0 ) then + etat = mod( hethex(kaux),1000) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = dechex+kaux + endif + endif + endif +c + elseif ( kaux.lt.0 ) then +c + kaux = -kaux +c +c 2.3.4.2.2. ==> Le voisin est une pyramide +c + if ( pypequ(1,kaux).ne.0 ) then + lapyra = pypequ(1,kaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est la pyramide ',lapyra + write (ulsort,90002) '....... du bloc ', nublvo(decpyr+lapyra) + endif +#endif + if ( nublvo(decpyr+lapyra).eq.0 ) then + if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then + etat = mod( hetpyr(lapyra),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpyr+lapyra + endif + endif + endif + endif +c +c 2.3.4.2.3. ==> Le voisin est un autre pentaedre +c + lepent = pypequ(2,kaux) + if ( lepent.ne.0 .and. lepent.ne.nument ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,90015) '....... Le ',laux, + > '-ieme voisin est le pentaedre ',lepent + write (ulsort,90002) '....... du bloc ', nublvo(decpen+lepent) + endif +#endif + if ( nublvo(decpen+lepent).eq.0 ) then + if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then + etat = mod( hetpen(lepent),100) + if ( etat.eq.0 ) then + lgpile = lgpile + 1 + lapile(lgpile) = decpen+lepent + endif + endif + endif + endif +c + endif +c +23422 continue +c + 2342 continue +c + endif +c + endif +c +c 2.4. ==> on passe a la maille suivante de la pile +c + if ( lgpile.gt.0 ) then +c + lamail = lapile(lgpile) + lgpile = lgpile - 1 + goto 21 +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'fin du bloc', nbbloc +#endif +c + endif +c + endif +c + 20 continue +c +c==== +c 3. impression du dernier bloc +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. impression dernier bloc ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( ulbila.gt.0 ) then +c +c 3.1. ==> recherche des faces actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublvo, + > tbiaux, + > tbiaux, tbiaux, + > tritet, quahex, facpyr, facpen, + > maxtet, maxhex, maxpyr, maxpen, + > tabau3, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> recherche des blocs de faces actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11C', nompro +#endif + call utb11c ( nbblfa, iaux, tabau4, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > taba11, taba12, taba13, + > taba15, taba16, + > taba14, + > jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) mess14(langue,3,8), nbblfa + write (ulsort,texte(langue,10)) nbbloc +#endif +c + if ( nbbloc.eq.1 ) then + iaux = -nbbloc + else + iaux = nbbloc + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( iaux, nbblfa, typvo0, typvol, + > nublvo, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + write (ulbila,3000) + 3000 format(5x,58('*')) +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11c.F b/src/tool/Utilitaire/utb11c.F new file mode 100644 index 00000000..c660d18d --- /dev/null +++ b/src/tool/Utilitaire/utb11c.F @@ -0,0 +1,600 @@ + subroutine utb11c ( nbbloc, option, tabau4, + > hetare, somare, + > hettri, aretri, + > hetqua, arequa, + > povoso, voisom, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > lapile, tabau2, tabau3, + > taba15, taba16, + > nublfa, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 - phase c +c -- - -- - +c ______________________________________________________________________ +c +c analyse de la connexite des faces +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbbloc . s . 1 . nombre de blocs . +c . option . e . 1 . 0 : on prend toutes les faces . +c . . . . 1 : on prend les faces actives de HOMARD . +c . . . . 2 : on prend les faces actives du calcul . +c . tabau4 . e .-nbquto . indicateurs sur les faces a examiner : . +c . . . :nbtrto. 0 : on ne traite pas la face . +c . . . . >0 : on traite la face . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . povoso . e .0:nbnoto. pointeur des voisins par noeud . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . lapile . a . * . tableau de travail . +c . tabau2 . a . nbnoto . tableau de travail . +c . tabau3 . a . nbarto . tableau de travail . +c . taba15 . a . nbarto . tableau de travail . +c . taba16 . a . * . tableau de travail . +c . nublfa . s .-nbquto . numero du bloc pour chaque face . +c . . . :nbtrto. . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . . . . si 0 : on n'ecrit rien . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11C' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbbloc, option + integer tabau4(-nbquto:*) + integer hetare(nbarto), somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer povoso(0:nbnoto), voisom(*) + integer posifa(0:nbarto), facare(nbfaar) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) +c + integer lapile(*) + integer tabau2(nbnoto) + integer tabau3(nbarto) + integer taba15(nbarto) + integer taba16(*) + integer nublfa(-nbquto:*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux, ldeb, lfin + integer tbiaux(1) + integer laface, typfa0, typfac + integer etat + integer elem, lgpile, nbaret + integer nbblar +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,3x,''. Connexite des '',a)' + texte(1,5) = '(''.. Impression du bloc'',i8)' +c + texte(2,4) = '(/,3x,''. Connexity of '',a)' + texte(2,5) = '(''.. Printing of block #'',i8)' +c +#include "impr03.h" +c + if ( nbtrac.eq.0 ) then + typfa0 = 4 + elseif ( nbquac.eq.0 ) then + typfa0 = 2 + else + typfa0 = 8 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typfa0) + write (ulsort,90002) 'option', option +#endif +c +c 1.3. ==> Aucun bloc au depart +c +cgn write (ulsort,90002) 'nbquto', nbquto +cgn write (ulsort,90002) 'nbtrto', nbtrto + do 13 , iaux = -nbquto , nbtrto + nublfa(iaux) = 0 + 13 continue + nublfa(0) = -1 +c + codret = 0 +c +c==== +c 2. blocs de faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. blocs de faces ; codret =', codret +#endif +c + nbbloc = 0 + lgpile = 0 +c + do 22 , laface = -nbquto , nbtrto +c +#ifdef _DEBUG_HOMARD_ + if ( laface.ne.0 ) then + write (ulsort,90015) 'Debut boucle 22, avant le bloc',nbbloc+1, + >', laface = ', laface, tabau4(laface) + endif +#endif +c On examine les faces presentes dans la liste transmise +c + if ( tabau4(laface).eq.1 ) then +c +c On examine les faces qui ne sont pas deja dans un bloc +c + if ( nublfa(laface).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( laface.gt.0 ) then + write (ulsort,90015) 'etat = ', hettri(laface), + > ', type =',cfatri(cotyel,famtri(laface)) + elseif ( laface.lt.0 ) then + write (ulsort,90015) 'etat = ', hetqua(-laface), + > ', type =',cfaqua(cotyel,famqua(-laface)) + endif +#endif +c + if ( option.gt.0 ) then +c + etat = -9999 + if ( laface.gt.0 ) then + etat = mod( hettri(laface) , 10 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat = ', etat, + > ', type =',cfatri(cotyel,famtri(laface)) +#endif + if ( option.gt.1 ) then + if ( cfatri(cotyel,famtri(laface)).eq.0 ) then + etat = -9999 + endif + endif + elseif ( laface.lt.0 ) then + etat = mod( hetqua(-laface) , 100 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'etat = ', etat, + > ', type =',cfaqua(cotyel,famqua(-laface)) +#endif + if ( option.gt.1 ) then + if ( cfaqua(cotyel,famqua(-laface)).eq.0 ) then + etat = -9999 + endif + endif + endif +c + else +c + etat = 0 +c + endif +c + if ( etat.eq.0 ) then +c +c 2.1. ==> on commence un nouveau bloc : +c 2.1.1. ==> impression des caracteristiques du bloc precedent +c + if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then +c +c 2.1.1.1. ==> recherche des aretes actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublfa, + > somare, + > aretri, arequa, + > tbiaux, tbiaux, tbiaux, tbiaux, + > jaux, jaux, jaux, jaux, + > tabau3, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 2.1.1.2. ==> recherche des blocs d'aretes actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11D', nompro +#endif + call utb11d ( nbblar, iaux, tabau3, + > hetare, somare, + > povoso, voisom, + > famare, cfaare, + > taba15, tabau2, + > taba16, + > jaux, + > ulsort, langue, codret ) +c + endif +c +c 2.1.1.3. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbbloc +#endif +c + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( nbbloc, nbblar, typfa0, typfac, + > nublfa, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.1.2. ==> initialisations +c + nbbloc = nbbloc + 1 + elem = laface +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'debut du bloc',nbbloc,' avec elem = ', elem +#endif +c + do 2121 , iaux = 1 , nbnoto + tabau2(iaux) = 0 + 2121 continue + do 2122 , iaux = 1 , nbarto + tabau3(iaux) = 0 + 2122 continue +c + typfac = 0 +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'bloc ',nbbloc,' avec elem = ', elem +#endif +c +c 2.2. ==> memorisation du bloc pour l'element courant +c + nublfa(elem) = nbbloc +cgn print *,'elem,nbbloc ',elem, nbbloc +c + if ( elem.lt.0 ) then + if ( typfac.eq.0 ) then + typfac = 4 + elseif ( typfac.ne.4 ) then + typfac = 8 + endif + else + if ( typfac.eq.0 ) then + typfac = 2 + elseif ( typfac.ne.2 ) then + typfac = 8 + endif + endif +c +c 2.3. ==> mise des voisins dans la pile +c + if ( elem.gt.0 ) then + nbaret = 3 + else + nbaret = 4 + endif +c + do 222 , iaux = 1 , nbaret +c +c 2.3.1. ==> reperage des voisins de elem par sa iaux-ieme arete +c + if ( elem.gt.0 ) then + jaux = aretri(elem,iaux) + else + jaux = arequa(-elem,iaux) + endif + tabau3(jaux) = tabau3(jaux) + 1 + kaux = somare(1,jaux) + tabau2(kaux) = tabau2(kaux) + 1 + kaux = somare(2,jaux) + tabau2(kaux) = tabau2(kaux) + 1 + ldeb = posifa(jaux-1)+1 + lfin = posifa(jaux) +c +c 2.3.2. ==> examen des voisins qui ne sont pas deja dans un bloc +c et qui font partie de la liste +c + do 2221 , laux = ldeb, lfin +c + kaux = facare(laux) + if ( nublfa(kaux).eq.0 ) then +c + if ( tabau4(kaux).eq.1 ) then + if ( option.gt.0 ) then + etat = -2220 + if ( kaux.gt.0 ) then + etat = mod( hettri(kaux) , 10 ) +cgn write (ulsort,*) kaux,' : etat = ', etat, +cgn > ', type =',cfatri(cotyel,famtri(kaux)) + if ( option.gt.1 ) then + if ( cfatri(cotyel,famtri(kaux)).eq.0 ) then + etat = -2221 + endif + endif + else + etat = mod( hetqua(-kaux) , 100 ) +cgn write (ulsort,*) kaux,' : etat = ', etat, +cgn > ', type =',cfaqua(cotyel,famqua(-kaux)) + if ( option.gt.1 ) then + if ( cfaqua(cotyel,famqua(-kaux)).eq.0 ) then + etat = -2222 + endif + endif + endif + else + etat = 0 + endif +cgn print *,'==> etat ',etat + if ( etat.eq.0 ) then + do 2222 , maux = 1 , lgpile + if ( lapile(maux).eq.kaux ) then + goto 2221 + endif + 2222 continue +cgn write (ulsort,*) '==> ajout de', kaux + lgpile = lgpile + 1 + lapile(lgpile) = kaux +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,1789) (lapile(maux), maux = 1 , lgpile) +cgn 1789 format(10i5) +#endif + endif + endif +c + endif +c + 2221 continue +c + 222 continue +c +c 2.4. ==> on passe a l'element suivant de la pile +c + if ( lgpile.gt.0 ) then +c + elem = lapile(lgpile) + lgpile = lgpile - 1 + goto 21 +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'fin du bloc', nbbloc + write (ulsort,*) 'tabau2 (noeuds)' + write (ulsort,91040) (tabau2(iaux), iaux=1,min(20,nbnoto)) + write (ulsort,*) 'tabau3 (aretes)' + write (ulsort,91040) (tabau3(iaux), iaux=1,min(20,nbarto)) +c write (ulsort,91040) (tabau3(iaux), iaux=1,min(20000,nbarto)) +#endif +c + endif +c +c 2.5. ==> on continue la liste des faces en prevision d'un eventuel +c nouveau bloc +c + endif +c + endif +c + 22 continue +c +c==== +c 3. impression du dernier bloc +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '3. impression dernier bloc ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( ulbila.gt.0 .and. nbbloc.gt.0 ) then +c +c 3.1. ==> recherche des aretes actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublfa, + > somare, + > aretri, arequa, + > tbiaux, tbiaux, tbiaux, tbiaux, + > jaux, jaux, jaux, jaux, + > tabau3, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> recherche des blocs d'aretes actives de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11D', nompro +#endif + call utb11d ( nbblar, iaux, tabau3, + > hetare, somare, + > povoso, voisom, + > famare, cfaare, + > taba15, tabau2, + > taba16, + > jaux, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbbloc +#endif +c + if ( nbbloc.eq.1 ) then + iaux = -nbbloc + else + iaux = nbbloc + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( iaux, nbblar, typfa0, typfac, + > nublfa, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + write (ulbila,3000) + 3000 format(5x,58('*')) +c + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11d.F b/src/tool/Utilitaire/utb11d.F new file mode 100644 index 00000000..08401604 --- /dev/null +++ b/src/tool/Utilitaire/utb11d.F @@ -0,0 +1,430 @@ + subroutine utb11d ( nbbloc, option, tabau4, + > hetare, somare, + > povoso, voisom, + > famare, cfaare, + > lapile, tabau2, + > nublar, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 - phase d +c -- - -- - +c ______________________________________________________________________ +c +c analyse de la connexite des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbbloc . s . 1 . nombre de blocs . +c . option . e . 1 . 0 : on prend toutes les aretes . +c . . . . 1 : on prend les aretes actives de HOMARD . +c . . . . 2 : on prend les aretes actives du calcul . +c . tabau4 . e . nbarto . indicateurs sur les aretes a examiner : . +c . . . . 0 : on ne traite pas l'arete . +c . . . . >0 : on traite l'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . povoso . e .0:nbnoto. pointeur des voisins par noeud . +c . voisom . e . nvosom . aretes voisines de chaque noeud . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . lapile . a . * . tableau de travail . +c . tabau2 . a . nbnoto . tableau de travail . +c . nublar . s . nbarto . numero du bloc pour chaque arete . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . . . . si 0 : on n'ecrit rien . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11D' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbbloc, option + integer tabau4(nbarto) + integer hetare(nbarto), somare(2,nbarto) + integer povoso(0:nbnoto), voisom(*) + integer famare(nbarto), cfaare(nctfar,nbfare) +c + integer lapile(*) + integer tabau2(nbnoto) + integer nublar(nbarto) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux, ldeb, lfin + integer larete + integer etat + integer elem, lgpile + integer tabau3(1) + integer tbiaux(1) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,3x,''. Connexite des '',a)' + texte(1,10) = '(''.. Impression du bloc'',i8)' +c + texte(2,4) = '(/,3x,''. Connexity of '',a)' + texte(2,10) = '(''.. Printing of block #'',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) + write (ulsort,*) 'option =', option +#endif +c +c 1.3. ==> Aucun bloc au depart +c + do 13 , iaux = 1 , nbarto + nublar(iaux) = 0 + 13 continue +c + codret = 0 +c +c==== +c 2. blocs d'aretes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. blocs d''aretes ; codret =', codret +#endif +c + nbbloc = 0 + lgpile = 0 +c + do 22 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Debut boucle 22, avant le bloc',nbbloc+1, + >', larete =', larete, tabau4(larete) +#endif +c +c On examine les aretes presentes dans la liste transmise +c + if ( tabau4(larete).eq.1 ) then +c +c On examine les faces qui ne sont pas deja dans un bloc +c + if ( nublar(larete).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'larete =', larete, + > ', etat =', hetare(larete), + > ', type =',cfaare(cotyel,famare(larete)) +#endif +c + if ( option.gt.0 ) then +c + etat = mod( hetare(larete) , 10 ) + if ( option.gt.1 ) then + if ( cfaare(cotyel,famare(larete)).eq.0 ) then + etat = -9999 + endif + endif +c + else +c + etat = 0 +c + endif +c + if ( etat.eq.0 ) then +c +c 2.1. ==> on commence un nouveau bloc : +c 2.1.1. ==> impression des caracteristiques du bloc precedent +c + if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then +c +c 2.1.1.1. ==> recherche des noeuds de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublar, + > somare, + > tbiaux, tbiaux, + > tbiaux, tbiaux, tbiaux, tbiaux, + > jaux, jaux, jaux, jaux, + > tabau2, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 2.1.1.2. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) nbbloc + write (ulsort,*) nublar +#endif +c + jaux = 0 + kaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( nbbloc, jaux, kaux, kaux, + > nublar, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.1.2. ==> initialisations +c + nbbloc = nbbloc + 1 + elem = larete +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'debut du bloc ',nbbloc,' avec elem = ', elem +#endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,*) 'bloc ',nbbloc,' avec elem = ', elem +#endif +c +c 2.2. ==> memorisation du bloc pour l'element courant +c + nublar(elem) = nbbloc +cgn print *,'elem,nbbloc ',elem, nbbloc +c +c 2.3. ==> mise des voisins dans la pile +c + do 222 , iaux = 1 , 2 +c +c 2.3.1. ==> reperage des voisins de elem par son iaux-ieme sommet +c + jaux = somare(iaux,elem) + ldeb = povoso(jaux-1)+1 + lfin = povoso(jaux) +c +c 2.3.2. ==> examen des voisins +c + do 2221 , laux = ldeb, lfin +c + kaux = voisom(laux) + if ( nublar(kaux).eq.0 ) then +c + if ( tabau4(kaux).eq.1 ) then + if ( option.gt.0 ) then + etat = mod( hetare(kaux) , 10 ) +cgn write (ulsort,*) kaux,' : etat = ', etat, +cgn > ', type =',cfaare(cotyel,famare(kaux)) + if ( option.gt.1 ) then + if ( cfaare(cotyel,famare(kaux)).eq.0 ) then + etat = -2221 + endif + endif + else + etat = 0 + endif +cgn print *,'==> etat ',etat + if ( etat.eq.0 ) then + do 2222 , maux = 1 , lgpile + if ( lapile(maux).eq.kaux ) then + goto 2221 + endif + 2222 continue +cgn write (ulsort,*) '==> ajout de', kaux + lgpile = lgpile + 1 + lapile(lgpile) = kaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,1789) (lapile(maux), maux = 1 , lgpile) + 1789 format(10i5) +#endif + endif + endif +c + endif +c + 2221 continue +c + 222 continue +c +c 2.4. ==> on passe a l'element suivant de la pile +c + if ( lgpile.gt.0 ) then +c + elem = lapile(lgpile) + lgpile = lgpile - 1 + goto 21 +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'fin du bloc', nbbloc +#endif +c + endif +c + endif +c +c 2.5. ==> on continue la liste des aretes en prevision d'un eventuel +c nouveau bloc +c + endif +c + 22 continue +c +c==== +c 3. impression du dernier bloc +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) '3. impression dernier bloc ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( ulbila.gt.0 .and. nbbloc.gt.0 ) then +c +c 3.1. ==> recherche des noeuds de ce bloc +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11E', nompro +#endif + call utb11e ( iaux, nbbloc, nublar, + > somare, + > tbiaux, tbiaux, + > tbiaux, tbiaux, tbiaux, tbiaux, + > jaux, jaux, jaux, jaux, + > tabau2, tabau4, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> impression veritable +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) nbbloc +cgn write (ulsort,*) nublar +#endif +c + endif +c + if ( nbbloc.eq.1 ) then + iaux = -nbbloc + else + iaux = nbbloc + endif + jaux = 0 + kaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11F', nompro +#endif + call utb11f ( iaux, jaux, kaux, kaux, + > nublar, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c + write (ulbila,3000) + 3000 format(5x,58('*')) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11e.F b/src/tool/Utilitaire/utb11e.F new file mode 100644 index 00000000..b44fb565 --- /dev/null +++ b/src/tool/Utilitaire/utb11e.F @@ -0,0 +1,372 @@ + subroutine utb11e ( option, nubloc, nublen, + > somare, + > aretri, arequa, + > tritet, quahex, facpyr, facpen, + > maxtet, maxhex, maxpyr, maxpen, + > tabau3, tabau4, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 - phase e +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 3 : les faces des volumes . +c . . . . 2 : les aretes des faces . +c . . . . 1 : les noeuds des aretes . +c . nubloc . e . 1 . numero du bloc a traiter . +c . nublen . e . * . numero de blocs des entites . +c . . . . Pour les volumes, ils sont ranges ainsi : . +c . . . . les tetraedres . +c . . . . les hexaedres . +c . . . . les pyramides . +c . . . . les pentaedres . +c . . . . Pour les faces, ils sont ranges ainsi : . +c . . . . les quadrangles . +c . . . . les triangles . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . tabau3 . s . nbarto . Nombre d'occurences de l'arete dans le . +c . . . . bloc de volumes . +c . . ./ nbnoto. Nombre d'occurences du noeud dans le . +c . . . . bloc de volumes . +c . tabau4 . s .-nbquto . Nombre d'occurences de la face dans le . +c . . . :nbtrto. bloc de volumes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option, nubloc, nublen(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer tritet(nbtecf,4), quahex(nbhecf,6) + integer facpyr(nbpycf,5), facpen(nbpecf,5) + integer maxtet, maxhex, maxpyr, maxpen + integer tabau3(*) + integer tabau4(-nbquto:nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nument +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Bloc numero '',i8)' + texte(1,5) = '(''Bloc de '',a)' + texte(1,6) = '(''Traitement du '',a,i8)' +c + texte(2,4) = '(Block # '',i8)' + texte(2,5) = '(Block of '',i8)' + texte(2,6) = '(''Treatment of '',a,i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nubloc +#endif +c + codret = 0 +c +c==== +c 2. Recherche des faces du bloc volumique courant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. bloc de volume ; codret =', codret +#endif +c + if ( option.eq.3 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,9) +#endif +c +c 2.1. ==> Rien a priori +c + do 21 , iaux = -nbquto , nbtrto + tabau4(iaux) = 0 + 21 continue +c +c 2.2. ==> On explore tous les volumes du bloc. On cumule les faces +c + do 22 , nument = 1, maxpen +c + if ( nublen(nument).eq.nubloc ) then +c +c 2.2.1. ==> Tetraedre +c + if ( nument.le.maxtet ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,3), nument +#endif +c + if ( nument.le.nbtecf ) then +c + do 221 , iaux = 1 , 4 + tabau4(tritet(nument,iaux)) = + > tabau4(tritet(nument,iaux)) + 1 + 221 continue +c + endif +c +c 2.2.2. ==> Hexaedre +c + elseif ( nument.le.maxhex ) then +c + jaux = nument - maxtet +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,6), jaux +#endif +c + if ( jaux.le.nbhecf ) then +c + do 222 , iaux = 1 , 6 + tabau4(-quahex(jaux,iaux)) = + > tabau4(-quahex(jaux,iaux)) + 1 + 222 continue +c + endif +c +c 2.2.3. ==> Pyramide +c + elseif ( nument.le.maxpyr ) then +c + jaux = nument - maxhex +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,5), jaux +#endif +c + if ( jaux.le.nbpycf ) then +c + do 223 , iaux = 1 , 4 + tabau4(facpyr(jaux,iaux)) = + > tabau4(facpyr(jaux,iaux)) + 1 + 223 continue + tabau4(-facpyr(jaux,5)) = + > tabau4(-facpyr(jaux,5)) + 1 +c + endif +c +c 2.2.4. ==> Pentaedre +c + else +c + jaux = nument - maxpyr +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,7), jaux +#endif +c + if ( jaux.le.nbpecf ) then +c + do 2241 , iaux = 1 , 2 + tabau4(facpen(jaux,iaux)) = + > tabau4(facpen(jaux,iaux)) + 1 + 2241 continue + do 2242 , iaux = 3 , 5 + tabau4(-facpen(jaux,iaux)) = + > tabau4(-facpen(jaux,iaux)) + 1 + 2242 continue +c + endif +c + endif +c + endif +c + 22 continue +c +c==== +c 3. Recherche des aretes du bloc surfacique courant +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. bloc de faces ; codret =', codret +#endif +c + elseif ( option.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,8) +#endif +c +c 3.1. ==> Rien a priori +c + do 31 , iaux = 1 , nbarto + tabau3(iaux) = 0 + 31 continue +c +c 3.2. ==> On explore toutes les faces du bloc. On cumule les aretes +c + do 32 , nument = -nbquto, nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), nument +cgn write (ulsort,*) nublen(nbquto+1+nument) +#endif +c + if ( nublen(nbquto+1+nument).eq.nubloc ) then +c +c 3.2.1. ==> Quadrangle +c + if ( nument.lt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), nument +#endif + do 321 , iaux = 1 , 4 + tabau3(arequa(-nument,iaux)) = + > tabau3(arequa(-nument,iaux)) + 1 + 321 continue +c +c 3.2.2. ==> Triangle +c + elseif ( nument.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), nument +#endif + do 322 , iaux = 1 , 3 + tabau3(aretri(nument,iaux)) = + > tabau3(aretri(nument,iaux)) + 1 + 322 continue +c + endif +c + endif +c + 32 continue +c +c==== +c 4. Recherche des noeuds du bloc lineique courant +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. bloc d''aretes ; codret =', codret +#endif +c + elseif ( option.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,1) +#endif +c +c 4.1. ==> Rien a priori +c + do 41 , iaux = 1 , nbnoto + tabau3(iaux) = 0 + 41 continue +c +c 4.2. ==> On explore toutes les aretes du bloc. On cumule les noeuds +c + do 42 , nument = 1, nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,1), nument +cgn write (ulsort,*) nublen(nbquto+1+nument) +#endif +c + if ( nublen(nument).eq.nubloc ) then +c + do 421 , iaux = 1 , 2 + tabau3(somare(iaux,nument)) = + > tabau3(somare(iaux,nument)) + 1 + 421 continue +c + endif +c + 42 continue +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb11f.F b/src/tool/Utilitaire/utb11f.F new file mode 100644 index 00000000..08b1bf08 --- /dev/null +++ b/src/tool/Utilitaire/utb11f.F @@ -0,0 +1,452 @@ + subroutine utb11f ( nubloc, nbbl00, typen0, typent, + > nublen, tabau2, tabau3, tabau4, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 11 - phase f +c -- - -- - +c Impressions +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nubloc . e . 1 . numero du bloc s'il y en a plusieurs . +c . . . . -1 si un seul bloc . +c . nbbl00 . e . 1 . si bloc volumique, nombre de blocs . +c . . . . surfaciques associes . +c . . . . si bloc surfacique, nombre de blocs . +c . . . . lineiques associes . +c . typen0 . e . 1 . type d'entites des blocs de meme type . +c . typent . e . 1 . type d'entites du bloc . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . . . . 8 : triangle et quadrangle . +c . . . . 9 : melange de volumes . +c . nublen . e .-nbquto . numero du bloc pour chaque entite . +c . . . :* . . +c . tabau2 . e . nbnoto . nombre de cas ou un noeud est dans le bloc . +c . tabau3 . e . nbarto . nombre de cas ou une arete est dans le bloc. +c . tabau4 . e .-nbquto . nombre de fois ou la face est dans le bloc . +c . . . :nbtrto. volumique : . +c . . . . 0 : jamais . +c . . . . 1 : c'est une face du bord . +c . . . . 2 : c'est une face interieure . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . . . . si 0 : on n'ecrit rien . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB11F' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +#include "nombpe.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nubloc, nbbl00, typen0, typent + integer nublen(-nbquto:*) + integer tabau2(nbnoto) + integer tabau3(nbarto) + integer tabau4(-nbquto:*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbnobl, nbarbl, nbfabl, nbvobl + integer nbnomu + integer nbenbl + integer euler + integer dimblo +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a,'' : bloc numero'',i5)' + texte(1,6) = + >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')' + texte(1,7) = + >'(5x,''* Les '',a,'' sont en un seul bloc.'',15x,''*'')' + texte(1,8) = + >'(5x,''* Bloc numero '',i8,5x, '' *'',11x,''1 '',a,'' *'')' + texte(1,9) = + >'(5x,''* Bloc numero '',i8,5x, '' * '',i11,1x,a,'' *'')' + texte(1,10) = + >'(5x,''* Nombre de cavites internes :'',i5,19x,''*'')' + texte(1,11) = + >'(5x,''* Nombre de trous traversant :'',i5,19x,''*'')' + texte(1,12) = + >'(5x,''* Cette surface est fermee.'',27x,''*'')' + texte(1,13) = + >'(5x,''* Cette surface a 1 bord.'',29x,''*'')' + texte(1,14) = + >'(5x,''* Cette surface a'',i5,'' bords.'',25x,''*'')' + texte(1,15) = + >'(5x,''* Cette ligne est fermee.'',29x,''*'')' + texte(1,16) = + >'(5x,''* Cette ligne a deux extremites.'',22x,''*'')' + texte(1,17) = + >'(5x,''* Cette ligne a'',i3,'' extremites.'',24x,''*'')' + texte(1,18) = + >'(5x,''* Cette ligne a'',i5,'' noeuds multiples.'',16x,''*'')' + texte(1,20) = '(''. Nombre de '',a,'':'',i11)' +c + texte(2,4) = '(/,a,'' : block #'',i5)' + texte(2,6) = + >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')' + texte(2,7) = + >'(5x,''* All the '',a,'' are connected.'',18x,''*'')' + texte(2,8) = + >'(5x,''* Block # '',i8,9x, '' *'',11x,''1'',1x,a,'' *'')' + texte(2,9) = + >'(5x,''* Block # '',i8,9x, '' * '',i11,1x,a,'' *'')' + texte(2,10) = + >'(5x,''* Number of internal cavities :'',i5,18x,''*'')' + texte(2,11) = + >'(5x,''* Number of crossing holes :'',i5,18x,''*'')' + texte(2,12) = + >'(5x,''* This surface does not have any boundary.'',12x,''*'')' + texte(2,13) = + >'(5x,''* This surface has 1 boundary.'',24x,''*'')' + texte(2,14) = + >'(5x,''* This surface has'',i5,'' boundaries.'',19x,''*'')' + texte(2,15) = + >'(5x,''* This line is closed.'',32x,''*'')' + texte(2,16) = + >'(5x,''* This line has 2 ends.'',31x,''*'')' + texte(2,17) = + >'(5x,''* This line has'',i3,'' ends.'',32x,''*'')' + texte(2,18) = + >'(5x,''* This line has'',i5,'' multiples nodes.'',17x,''*'')' + texte(2,20) = '(''. Number of '',a,'':'',i11)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,4,typent),abs(nubloc) +#endif +c +#include "impr03.h" +c +10100 format(/,5x,58('*')) +10200 format( 5x,58('*')) +c + codret = 0 +c + if ( typent.eq.1 ) then + dimblo = 1 + elseif ( typent.eq.2 .or. typent.eq.4 .or. typent.eq.8 ) then + dimblo = 2 + else + dimblo = 3 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'dimblo =', dimblo +#endif +c +c==== +c 2. Decompte des nombres d'entites +c==== +c 2.1. ==> Volumes +c + if ( dimblo.eq.3 ) then +c + iaux = abs(nubloc) + kaux = nbteto + nbpyto + nbheto + nbpeto - nbquto - 1 + nbvobl = 0 + do 21 , jaux = -nbquto , kaux +cgn write(ulsort, *)jaux,nublen(jaux) + if ( nublen(jaux).eq.iaux ) then + nbvobl = nbvobl + 1 + endif + 21 continue + nbenbl = nbvobl +c + endif +c +c 2.2. ==> Faces +c + if ( dimblo.eq.3 ) then +c + nbfabl = 0 + do 221 , iaux = -nbquto , nbtrto + if ( tabau4(iaux).gt.0 ) then + nbfabl = nbfabl + 1 + endif + 221 continue +c + elseif ( dimblo.eq.2 ) then +c + iaux = abs(nubloc) + nbfabl = 0 + do 222 , jaux = -nbquto , nbtrto + if ( nublen(jaux).eq.iaux ) then + nbfabl = nbfabl + 1 + endif + 222 continue + nbenbl = nbfabl +c + endif +c +c 2.3. ==> Aretes +c + nbarbl = 0 +c + if ( dimblo.eq.1 ) then +c + iaux = abs(nubloc) + kaux = nbarto - nbquto - 1 + do 231 , jaux = -nbquto , kaux +cgn write(ulsort, *)iaux,nublen(iaux) + if ( nublen(jaux).eq.iaux ) then + nbarbl = nbarbl + 1 + endif + 231 continue + nbenbl = nbarbl +cgn write(ulsort, *)nbarbl +c + else +c + do 232 , iaux = 1 , nbarto +cgn write(ulsort, *)iaux,tabau3(iaux) + if ( tabau3(iaux).gt.0 ) then + nbarbl = nbarbl + 1 + endif + 232 continue +c + endif +c +c 2.4. ==> Noeuds +c + nbnobl = 0 + nbnomu = 0 +c + if ( dimblo.eq.1 ) then +c + do 241 , iaux = 1 , nbnoto +cgn write(ulsort, *)iaux,tabau2(iaux) + if ( tabau2(iaux).eq.1 ) then + nbnobl = nbnobl + 1 + elseif ( tabau2(iaux).ge.3 ) then + nbnomu = nbnomu + 1 + endif + 241 continue +c + else +c + do 242 , iaux = 1 , nbnoto +cgn write(ulsort, *)iaux,tabau2(iaux) + if ( tabau2(iaux).gt.0 ) then + nbnobl = nbnobl + 1 + endif + 242 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) mess14(langue,3,-1), nbnobl + write (ulsort,texte(langue,20)) mess14(langue,3,1), nbarbl + if ( dimblo.eq.3 ) then + write (ulsort,texte(langue,20)) mess14(langue,3,8), nbfabl + write (ulsort,texte(langue,20)) + > 'blocs de '//mess14(langue,3,8), nbbl00 + write (ulsort,texte(langue,20)) mess14(langue,3,typent), nbvobl + elseif ( dimblo.eq.2 ) then + write (ulsort,texte(langue,20)) + > 'blocs de '//mess14(langue,3,1), nbbl00 + write (ulsort,texte(langue,20)) mess14(langue,3,typent), nbfabl + endif +#endif +c +c==== +c 3. Impression +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) '3. impression ; codret = ', codret +#endif +c 3.1. ==> En tete au premier passage +c + if ( nubloc.eq.1 ) then + write (ulbila,10100) + write (ulbila,texte(langue,6)) mess14(langue,3,typen0) + write (ulbila,10200) + endif +c +c 3.2. ==> Texte +c + if ( nubloc.lt.0 ) then +c + write (ulbila,10100) + write (ulbila,texte(langue,7)) mess14(langue,3,typent) +c + else +c + if ( nbenbl.eq.1 ) then + write (ulbila,texte(langue,8)) nubloc, mess14(langue,1,typent) + else + write (ulbila,texte(langue,9)) nubloc, nbenbl, + > mess14(langue,3,typent) + endif +c + endif +c +c 3.3. ==> Trous ? +c Remarques : +c . on ne sait le faire que pour un maillage conforme +c . en mode optimise, on n'imprime que s'il y a un trou. +c +c 3.3.1. ==> Examen d'un volume +c + if ( dimblo.eq.3 ) then +c + if ( ( maconf.eq.-1 ) .or. ( maconf.eq.0 ) ) then +c + euler = nbbl00 + nbvobl - nbfabl + nbarbl - nbnobl +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) ' nbbl00', nbbl00 + write (ulsort,90002) '+ nbvobl', nbvobl + write (ulsort,90002) '- nbfabl', -nbfabl + write (ulsort,90002) '+ nbarbl', nbarbl + write (ulsort,90002) '- nbnobl', - nbnobl + write (ulsort,90002) '= euler', euler +#endif +c +#ifdef _DEBUG_HOMARD_ +#else + if ( euler.gt.0 .or. nbbl00.gt.1 ) then +#endif +c + if ( nbbl00.gt.1 ) then + write (ulbila,texte(langue,10)) nbbl00 - 1 + endif + if ( euler.gt.0 ) then + write (ulbila,texte(langue,11)) euler + endif +c +#ifdef _DEBUG_HOMARD_ +#else + endif +#endif +c + endif +c +c 3.3.2. ==> Examen d'une surface +c + elseif ( dimblo.eq.2 ) then +c +#ifdef _DEBUG_HOMARD_ +#else + if ( nbbl00.ne.1 ) then +#endif + if ( nbbl00.eq.0 ) then + write (ulbila,texte(langue,12)) + elseif ( nbbl00.eq.1 ) then + write (ulbila,texte(langue,13)) + else + write (ulbila,texte(langue,14)) nbbl00 + endif +c +#ifdef _DEBUG_HOMARD_ +#else + endif +#endif +c +c 3.3.3. ==> Examen d'une ligne +c + else +c +#ifdef _DEBUG_HOMARD_ +#else + if ( nbnobl.ne.2 ) then +#endif + if ( nbnobl.eq.0 ) then + write (ulbila,texte(langue,15)) + elseif ( nbnobl.eq.2 ) then + write (ulbila,texte(langue,16)) + else + write (ulbila,texte(langue,17)) nbnobl + endif + if ( nbnomu.gt.0 ) then + write (ulbila,texte(langue,18)) nbnomu + endif +c +#ifdef _DEBUG_HOMARD_ +#else + endif +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb13a.F b/src/tool/Utilitaire/utb13a.F new file mode 100644 index 00000000..12b4b59a --- /dev/null +++ b/src/tool/Utilitaire/utb13a.F @@ -0,0 +1,350 @@ + subroutine utb13a ( coonoe, + > somare, hetare, + > hettri, aretri, + > hetqua, arequa, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > nbfmed, numfam, unicoo, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 13 +c -- - -- +c ______________________________________________________________________ +c +c longueurs, surfaces et volumes des sous-domaines du maillage de calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . . . . + l : appartenance a l'equivalence l . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy*. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . unicoo . e .(2,sdim). nom et unite des coordonnees au sens MED . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB13A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) + character*16 unicoo(2,sdim) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(//,3x,''TAILLES DES SOUS-DOMAINES DE CALCUL'',/,3x,35(''=''),/)' + texte(1,5) = + > '(/,10x,''Direction | Unite'',/,5x,41(''-''))' + texte(1,6) = '(8x,a16,'' | '',a16)' +c + texte(2,4) = + > '(//,3x,''SIZES OF CALCULATION SUB-DOMAINS'',/,3x,32(''=''),/)' + texte(2,5) = + < '(/,10x,''Direction | Unit'',/,5x,41(''-''))' + texte(2,6) = '(8x,a16,'' | '',a16)' +c +#include "impr03.h" +c + codret = 0 +c + write (ulbila,texte(langue,4)) +c + write (ulbila,texte(langue,5)) + do 11 , iaux = 1 , sdim + write (ulbila,texte(langue,6)) unicoo(1,iaux), unicoo(2,iaux) + 11 continue +c +c==== +c 2. volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. volumes : codret', codret +#endif +c + if ( nbteac.gt.0 .or. nbheac.gt.0 .or. + > nbpyac.gt.0 .or. nbpeac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13B', nompro +#endif + call utb13b ( coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. surfaces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. surfaces : codret', codret +#endif +c + if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13C', nompro +#endif + call utb13c ( coonoe, + > somare, + > hettri, aretri, + > hetqua, arequa, + > famtri, cfatri, + > famqua, cfaqua, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c +c + endif +c +c==== +c 4. longueurs +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. longueurs : codret', codret +#endif +c + if ( nbarac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13D', nompro +#endif + call utb13d ( coonoe, + > somare, hetare, + > famare, cfaare, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + end diff --git a/src/tool/Utilitaire/utb13b.F b/src/tool/Utilitaire/utb13b.F new file mode 100644 index 00000000..5b3e39ef --- /dev/null +++ b/src/tool/Utilitaire/utb13b.F @@ -0,0 +1,518 @@ + subroutine utb13b ( coonoe, + > somare, + > aretri, + > arequa, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 13 - phase b +c -- - -- - +c ______________________________________________________________________ +c +c volumes des sous-domaines du maillage de calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . cfatet . . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . . . . + l : appartenance a l'equivalence l . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . . nctfpy*. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB13B' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) +c + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer entit0, entite, etat + integer famnbv + integer listar(12),listso(8) +c + double precision daux +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)' + texte(1,5) = '(''. Examen du '',a,i8)' + texte(1,6) = '(''... Volume du '',a,i8,'' :'',g16.8)' + texte(1,7) = '(''..... Stockage'',i8,'' pour la famille '',i8)' +c + texte(2,4) = '(''Number of active '',a,'': '',i8)' + texte(2,5) = '(''. Examination of '',a,''#'',i8)' + texte(2,6) = '(''... Volume of '',a,''#'',i8,'':'',g16.8)' + texte(2,7) = '(''..... Save'',i8,'' for familiy #'',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3), nbteac + write (ulsort,texte(langue,4)) mess14(langue,3,5), nbpyac + write (ulsort,texte(langue,4)) mess14(langue,3,6), nbheac + write (ulsort,texte(langue,4)) mess14(langue,3,7), nbpeac +#endif +c +c 1.2. ==> initialisation +c + famnbv = 0 +c + codret = 0 +c + if ( nbteac.gt.0 .or. nbpyac.ne.0 .or. + > nbheac.ne.0 .or. nbpeac.ne.0 ) then +c + jaux = nbteac + nbpyac + nbheac + nbpeac + do 12 , iaux = 1 , jaux + famnum(iaux) = 0 + famval(iaux) = 0.d0 + 12 continue +c + endif +c +c==== +c 2. calcul des volumes des zones maillees en tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. tetraedres, codret', codret +#endif +c + if ( nbteac.gt.0 ) then +c + do 2 , entit0 = 1, nbteto +c + entite = entit0 +c + if ( cfatet(cotyel,famtet(entite)).ne.0 ) then +c + etat = mod( hettet(entite) , 100 ) +c + if ( etat.eq.0 ) then +c +c 2.1. ==> les aretes et les sommets +c + call utaste ( entite, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c +c 2.2. ==> calcul du volume du tetraedre +c + call utvote ( coonoe, listso, daux ) +cgn if ( famtet(entite).eq.2 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,3), entite, daux +cgn endif +c +c 2.3. ==> stockage dans la bonne famille +c + kaux = 0 + do 23 , jaux = 1 , famnbv + if ( famnum(jaux).eq.cfatet(cofamd,famtet(entite)) ) then + kaux = jaux + goto 231 + endif + 23 continue + famnbv = famnbv + 1 + kaux = famnbv + famnum(kaux) = cfatet(cofamd,famtet(entite)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) kaux, famnum(kaux) +#endif +c + 231 continue +c + famval(kaux) = famval(kaux) + daux +c + endif +c + endif +c + 2 continue +c + endif +c +c==== +c 3. calcul des volumes des zones maillees en hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. hexaedres, codret', codret +#endif +c + if ( nbheac.gt.0 ) then +c + do 3 , entit0 = 1, nbheto +c + entite = entit0 +c +cgn write (ulsort,90001) '. Famille hexa', entite, famhex(entite) + if ( cfahex(cotyel,famhex(entite)).ne.0 ) then +c +cgn write (ulsort,90001) '.. Etat hexa', entite, hethex(entite) + etat = mod(hethex(entite),1000) +c + if ( etat.eq.0 ) then +c +c 3.1. ==> les aretes et les sommets +c + call utashe ( entite, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c 3.2. ==> calcul du volume de l'hexraedre +c + call utvohe ( coonoe, listso, daux ) +cgn if ( famhex(entite).eq.5 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,6), entite, daux +cgn endif +c +c 3.3. ==> stockage dans la bonne famille +c + kaux = 0 + do 33 , jaux = 1 , famnbv + if ( famnum(jaux).eq.cfahex(cofamd,famhex(entite)) ) then + kaux = jaux + goto 331 + endif + 33 continue + famnbv = famnbv + 1 + kaux = famnbv + famnum(kaux) = cfahex(cofamd,famhex(entite)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) kaux, famnum(kaux) +#endif +c + 331 continue +c + famval(kaux) = famval(kaux) + daux +c + endif +c + endif +c + 3 continue +c + endif +c +c==== +c 4. calcul des volumes des zones maillees en pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. pyramides, codret', codret +#endif +c + if ( nbpyac.gt.0 ) then +c + do 4 , entit0 = 1, nbpyto +c + entite = entit0 +c + if ( cfapyr(cotyel,fampyr(entite)).ne.0 ) then +c + etat = mod( hetpyr(entite) , 100) +c + if ( etat.eq.0 ) then +c +c 4.1. ==> les aretes +c + call utaspy ( entite, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +c 4.2. ==> calcul du volume de la pyramide +c + call utvopy ( coonoe, listso, daux ) +cgn if ( fampyr(entite).eq.5 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,5), entite, daux +cgn endif +c +c 4.3. ==> stockage dans la bonne famille +c + kaux = 0 + do 43 , jaux = 1 , famnbv + if ( famnum(jaux).eq.cfapyr(cofamd,fampyr(entite)) ) then + kaux = jaux + goto 431 + endif + 43 continue + famnbv = famnbv + 1 + kaux = famnbv + famnum(kaux) = cfapyr(cofamd,fampyr(entite)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) kaux, famnum(kaux) +#endif +c + 431 continue +c + famval(kaux) = famval(kaux) + daux +c + endif +c + endif +c + 4 continue +c + endif +c +c==== +c 5. calcul des volumes des zones maillees en pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. pentaedres, codret', codret +#endif +c + if ( nbpeac.gt.0 ) then +c + do 5 , entit0 = 1, nbpeto +c + entite = entit0 +c + if ( cfapen(cotyel,fampen(entite)).ne.0 ) then +c + etat = mod( hetpen(entite) , 100) +c + if ( etat.eq.0 ) then +c +c 5.1. ==> les aretes +c + call utaspe ( entite, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c 5.2. ==> calcul du volume du pentaedre +c + call utvope ( coonoe, listso, daux ) +cgn if ( fampen(entite).eq.5 ) then +cgn write (ulsort,texte(langue,6)) mess14(langue,1,7), entite, daux +cgn endif +c +c 5.3. ==> stockage dans la bonne famille +c + kaux = 0 + do 53 , jaux = 1 , famnbv + if ( famnum(jaux).eq.cfapen(cofamd,fampen(entite)) ) then + kaux = jaux + goto 531 + endif + 53 continue + famnbv = famnbv + 1 + kaux = famnbv + famnum(kaux) = cfapen(cofamd,fampen(entite)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) kaux, famnum(kaux) +#endif +c + 531 continue +c + famval(kaux) = famval(kaux) + daux +c + endif +c + endif +c + 5 continue +c + endif +c +c==== +c 6. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. impression ; codret =', codret + write (ulsort,90002) 'famnbv', famnbv +#endif +c + if ( famnbv.ne.0 ) then +c + iaux = 1 + kaux = 3 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_vol', nompro +#endif + call utb13e ( kaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnbv, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + end diff --git a/src/tool/Utilitaire/utb13c.F b/src/tool/Utilitaire/utb13c.F new file mode 100644 index 00000000..d80bb613 --- /dev/null +++ b/src/tool/Utilitaire/utb13c.F @@ -0,0 +1,451 @@ + subroutine utb13c ( coonoe, + > somare, + > hettri, aretri, + > hetqua, arequa, + > famtri, cfatri, + > famqua, cfaqua, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 13 - phase c +c -- - -- - +c ______________________________________________________________________ +c +c surfaces des sous-domaines du maillage de calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB13C' ) +c +#include "nblang.h" +#include "fracta.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) +c + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1 + integer a1, a2, a3, a4 + integer letria, lequad + integer etat + integer famnbv +c + double precision v1(3), v2(3), v3(3), vn(3), vdiag(3) + double precision daux, daux1, daux2 +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)' + texte(1,5) = '(''. Examen du '',a,i8)' + texte(1,6) = '(''... Surface du '',a,i8,'' :'',g16.8)' + texte(1,7) = '(''..... Stockage'',i8,'' pour la famille '',i8)' +c + texte(2,4) = '(''Number of active '',a,'' : '',i8)' + texte(2,5) = '(''. Examination of '',a,''#'',i8)' + texte(2,6) = '(''... Surface of '',a,''#'',i8,'' :'',g14.6)' + texte(2,7) = '(''..... Save'',i8,'' for familiy # '',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrac + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquac +#endif +c + codret = 0 +c +c==== +c 2. calcul des surfaces +c==== +c +c 2.1. ==> initialisation +c + famnbv = 0 +c + if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then +c + jaux = nbtrac + nbquac + do 21 , iaux = 1 , jaux + famnum(iaux) = 0 + famval(iaux) = 0.d0 + 21 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'jaux = ', jaux +#endif +c + endif +c +c 2.2. ==> les zones maillees en triangles +c + if ( nbtrac.gt.0 ) then +c + do 22 , letria = 1, nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,2), letria +#endif +c + if ( cfatri(cotyel,famtri(letria)).ne.0 ) then +c + etat = mod( hettri(letria) , 10 ) +c + if ( etat.eq.0 ) then +c +c 2.2.1. ==> les aretes et les noeuds du triangle +c + iaux = aretri(letria,1) + jaux = aretri(letria,2) + kaux = aretri(letria,3) +c + call utsotr ( somare, iaux, jaux, kaux, + > sa1a2, sa2a3, sa3a1 ) +c +c 2.2.2. ==> calcul de la surface +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c + if ( sdim.eq.2 ) then +c + v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) +c + v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1) + v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2) +c + daux = abs( v2(1)*v3(2) - v2(2)*v3(1) ) +c + else +c + v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) +c + v3(1) = coonoe(sa3a1,1) - coonoe(sa1a2,1) + v3(2) = coonoe(sa3a1,2) - coonoe(sa1a2,2) + v3(3) = coonoe(sa3a1,3) - coonoe(sa1a2,3) +c + vn(1) = v2(2)*v3(3) - v2(3)*v3(2) + vn(2) = v2(3)*v3(1) - v2(1)*v3(3) + vn(3) = v2(1)*v3(2) - v2(2)*v3(1) +c + daux = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + endif +c + daux = unsde * daux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), letria, daux +#endif +c +c 2.2.3. ==> stockage dans la bonne famille +c + jaux = 0 + do 2231 , iaux = 1 , famnbv + if ( famnum(iaux).eq.cfatri(cofamd,famtri(letria)) ) then + jaux = iaux + goto 2232 + endif + 2231 continue + famnbv = famnbv + 1 + jaux = famnbv + famnum(jaux) = cfatri(cofamd,famtri(letria)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) jaux, famnum(jaux) +#endif +c + 2232 continue +c + famval(jaux) = famval(jaux) + daux +c + endif +c + endif +c + 22 continue +c + endif +c +c 2.3. ==> les zones maillees en quadrangles +c + if ( nbquac.gt.0 ) then +c + do 23 , lequad = 1, nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,4), lequad +#endif +c + if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then +c + etat = mod( hetqua(lequad) , 100 ) +c + if ( etat.eq.0 ) then +c +c 2.3.1. ==> les aretes et les noeuds du quadrangle +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c 2.3.2. ==> calcul de la surface +c pour la calculer, on coupe le quadrangle en deux triangles +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c v1 : arete a1 (sa4a1-sa1a2) +c v2 : arete a4 (sa4a1-sa3a4) +c vdiag = diagonale(sa4a1-sa2a3) +c +c sa4a1 a4 sa3a4 +c .______. +c .. . +c . . . +c a1. . .a3 +c . . . +c . . . +c . .. +c .______. +c sa1a2 a2 sa2a3 +c + if ( sdim.eq.2 ) then +c + v1(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1) + v1(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2) +c + v2(1) = coonoe(sa3a4,1) - coonoe(sa4a1,1) + v2(2) = coonoe(sa3a4,2) - coonoe(sa4a1,2) +c + vdiag(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1) + vdiag(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2) +c + daux1 = abs ( v1(1)*vdiag(2) - v1(2)*vdiag(1) ) +c + daux2 = abs ( v2(1)*vdiag(2) - v2(2)*vdiag(1) ) +c + else +c + v1(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1) + v1(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2) + v1(3) = coonoe(sa1a2,3) - coonoe(sa4a1,3) +c + v2(1) = coonoe(sa3a4,1) - coonoe(sa4a1,1) + v2(2) = coonoe(sa3a4,2) - coonoe(sa4a1,2) + v2(3) = coonoe(sa3a4,3) - coonoe(sa4a1,3) +c + vdiag(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1) + vdiag(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2) + vdiag(3) = coonoe(sa2a3,3) - coonoe(sa4a1,3) +c + vn(1) = v1(2)*vdiag(3) - v1(3)*vdiag(2) + vn(2) = v1(3)*vdiag(1) - v1(1)*vdiag(3) + vn(3) = v1(1)*vdiag(2) - v1(2)*vdiag(1) +c + daux1 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + vn(1) = v2(2)*vdiag(3) - v2(3)*vdiag(2) + vn(2) = v2(3)*vdiag(1) - v2(1)*vdiag(3) + vn(3) = v2(1)*vdiag(2) - v2(2)*vdiag(1) +c + daux2 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + endif +c + daux = unsde * ( daux1 + daux2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad, daux +#endif +c +c 2.3.3. ==> stockage dans la bonne famille +c + jaux = 0 + do 2331 , iaux = 1 , famnbv + if ( famnum(iaux).eq.cfaqua(cofamd,famqua(lequad)) ) then + jaux = iaux + goto 2332 + endif + 2331 continue + famnbv = famnbv + 1 + jaux = famnbv + famnum(jaux) = cfaqua(cofamd,famqua(lequad)) +c + 2332 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) jaux, famnum(jaux) +#endif +c + famval(jaux) = famval(jaux) + daux +c + endif +c + endif +c + 23 continue +c + endif +c +c==== +c 3. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. impression ; codret =', codret + write (ulsort,90002) 'famnbv', famnbv +#endif +c + if ( famnbv.ne.0 ) then +c + iaux = 1 + kaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_fac', nompro +#endif + call utb13e ( kaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnbv, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + end diff --git a/src/tool/Utilitaire/utb13d.F b/src/tool/Utilitaire/utb13d.F new file mode 100644 index 00000000..b7552ec5 --- /dev/null +++ b/src/tool/Utilitaire/utb13d.F @@ -0,0 +1,265 @@ + subroutine utb13d ( coonoe, + > somare, hetare, + > famare, cfaare, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 13 - phase d +c -- - -- - +c ______________________________________________________________________ +c +c longueurs des sous-domaines du maillage de calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB13D' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "envca1.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), hetare(nbarto) +c + integer famare(nbarto), cfaare(nctfar,nbfare) +c + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(*) + double precision famval(*) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer larete + integer etat + integer famnbv +c + double precision daux +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)' + texte(1,5) = '(''. Examen du '',a,i8)' + texte(1,6) = '(''... Longueur du '',a,i8,'' :'',g14.6)' + texte(1,7) = '(''..... Stockage'',i8,'' pour la famille '',i8)' +c + texte(2,4) = '(''Number of active '',a,'' : '',i8)' + texte(2,5) = '(''. Examination of '',a,''#'',i8)' + texte(2,6) = '(''... Length of '',a,''#'',i8,'' :'',g14.6)' + texte(2,7) = '(''..... Save'',i8,'' for familiy # '',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarac +#endif +c + codret = 0 +c +c==== +c 2. calcul des longueurs des aretes +c==== +c +c 2.1. ==> initialisation +c + famnbv = 0 +c + if ( nbarac.gt.0 ) then +c + do 21 , iaux = 1 , nbarac + famnum(iaux) = 0 + famval(iaux) = 0.d0 + 21 continue +c + do 22 , larete = 1, nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,1), larete +#endif +c + if ( cfaare(cotyel,famare(larete)).ne.0 ) then +c + etat = mod( hetare(larete) , 10 ) +c + if ( etat.eq.0 ) then +c +c 2.2.1. ==> longueur de l'arete courante +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTLGAR', nompro +#endif + call utlgar ( larete, coonoe, somare, + > daux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,1), larete, daux +#endif +c +c 4.2.2. ==> stockage dans la bonne famille +c + jaux = 0 + do 222 , iaux = 1 , famnbv + if ( famnum(iaux).eq.cfaare(cofamd,famare(larete)) ) then + jaux = iaux + goto 223 + endif + 222 continue + famnbv = famnbv + 1 + jaux = famnbv + famnum(jaux) = cfaare(cofamd,famare(larete)) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) jaux, famnum(jaux) +#endif +c + 223 continue +c + famval(jaux) = famval(jaux) + daux +c + endif +c + endif +c + 22 continue +c + endif +c +c==== +c 3. impression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. impression ; codret =', codret + write (ulsort,90002) 'famnbv', famnbv +#endif +c + if ( famnbv.ne.0 ) then +c + iaux = 1 + kaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13E_are', nompro +#endif + call utb13e ( kaux, iaux, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnbv, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + end diff --git a/src/tool/Utilitaire/utb13e.F b/src/tool/Utilitaire/utb13e.F new file mode 100644 index 00000000..2db9f936 --- /dev/null +++ b/src/tool/Utilitaire/utb13e.F @@ -0,0 +1,325 @@ + subroutine utb13e ( dimsd, option, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > famnbv, famnum, famval, + > lifagr, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 13 - phase e +c -- - -- - +c ______________________________________________________________________ +c +c impression +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dimsd . e . 1 . dimension du sous-domaine . +c . option . e . 1 . 1 : affichage pour les sous-domaines . +c . . . . 2 : affichage pour les joints simples . +c . . . . 3 : affichage pour les joints triples . +c . . . . 4 : affichage pour les joints quadruples . +c . nbfmed . e . 1 . nombre de familles au sens MED . +c . numfam . e . nbfmed . numero des familles au sens MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . nbgrfm . e . 1 . nombre de groupes . +c . nomgro . e .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . e . nbgrfm . longueur des noms des groupes . +c . famnbv . e . 1 . famille : nombre des valeurs . +c . famnum . a . * . famille : numero avec une valeur . +c . famval . a . * . famille : la valeur . +c . lifagr . a . * . liste des familles contenant le groupe . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB13E' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer dimsd, option + integer nbfmed, numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(nbgrfm) + integer famnbv +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer famnum(famnbv) + double precision famval(famnbv) +c + integer lifagr(*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lnogro, nbfgro + integer nblign + integer imprgr +c + logical logaux +c + double precision daux + double precision vmin, vmax +c + character*80 saux80 +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) + character*8 mess08(nblang,0:3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) ='(''Nombre de familles :'',i8)' + texte(1,6) ='(5x,''*'',21x,''Sous-domaines '',i1,''D'',20x,''*'')' + texte(1,7) = '(5x,''*'',18x,''Numero'',17x,''* '',a8,'' *'')' + texte(1,11) ='(5x,''*'',22x,''Joints simples'',22x,''*'')' + texte(1,12) ='(5x,''*'',22x,''Joints triples'',22x,''*'')' + texte(1,13) ='(5x,''*'',20x,''Joints quadruples'',19x,''*'')' +c + texte(2,5) ='(''Number of families :'',i8)' + texte(2,6) = '(5x,''*'',22x,i1,''D'','' sub-domains'',21x,''*'')' + texte(2,7) = '(5x,''*'',10x,''#'',20x,''* '',a8,'' *'')' + texte(2,11) ='(5x,''*'',20x,''Simple junctions'',21x,''*'')' + texte(2,12) ='(5x,''*'',20x,''Triple junctions'',21x,''*'')' + texte(2,13) ='(5x,''*'',19x,''Quadruple junctions'',19x,''*'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option + write (ulsort,texte(langue,5)) nbfmed + write (ulsort,90002) 'nbgrfm', nbgrfm + write (ulsort,90002) 'famnbv', famnbv +#endif +c 12345678 + mess08(1,0) = 'Nom ' + mess08(1,1) = 'Longueur' + mess08(1,2) = 'Surface ' + mess08(1,3) = 'Volume ' +c + mess08(2,0) = 'Name ' + mess08(2,1) = 'Length ' + mess08(2,2) = 'Surface ' + mess08(2,3) = 'Volume ' +c + 1100 format(/,5x,59('*')) + 1101 format( 5x,59('*')) +c + 1001 format(5x,'* ',a40,' * ',12x ,' *') + 1002 format(5x,'* ',a40,' * ',g12.6,' *') + 1003 format(5x,'* Total :',34x,'* ',g12.6,' *') + 1004 format(5x,'* ',a3,'imum :',32x,'* ',g12.6,' *') + 1005 format(5x,'* ',a8,33x,'* ',a8,' *') +c + codret = 0 +c + if ( famnbv.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,91010) (famnum(iaux),iaux=1,famnbv) + write (ulsort,92010) (famval(iaux),iaux=1,famnbv) +#endif +c +c==== +c 2. impression de l'entete +c==== +c + write (ulbila,1100) + if ( option.eq.1 ) then + write (ulbila,texte(langue,6)) dimsd + else + write (ulbila,texte(langue,9+option)) + endif + write (ulbila,1101) +c +c==== +c 3. parcours des groupes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours des groupes ; codret', codret +#endif +c + imprgr = 0 +c + nblign = 0 + vmin = famval(1) + vmax = famval(1) +c + do 30 , iaux = 1 , nbgrfm +c +c 3.1. ==> Le nom du groupe +c + if ( codret.eq.0 ) then +c + lnogro = lgnogr(iaux) + jaux = 10*(iaux-1) + 1 + call uts8ch ( nomgro(jaux), lnogro, saux80, + > ulsort, langue, codret ) +cgn write(ulsort,90003) '. Groupe ', saux80(1:lnogro) +c + endif +c +c 3.2. ==> Les familles liees a ce groupe +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMGR', nompro +#endif + call utfmgr ( saux80, nbfgro, lifagr, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbfgro + write (ulsort,91020) (lifagr(jaux), jaux=1,nbfgro) +#endif +c + endif +c +c 3.3. ==> Cumul des tailles a partir des tailles des mailles +c par familles +c + if ( codret.eq.0 ) then +c + logaux = .false. + daux = 0.d0 +c + do 33 , jaux = 1 , nbfgro +c + do 331 , kaux = 1 , famnbv + if ( famnum(kaux).eq.lifagr(jaux) ) then + logaux = .true. + daux = daux + famval(kaux) + endif + 331 continue +c + 33 continue +c + endif +c +c 3.3. ==> Impression eventuelle +c + if ( logaux ) then +c + if ( codret.eq.0 ) then +c + if ( imprgr.eq.0 ) then + write (ulbila,1005) mess08(langue,0), mess08(langue,dimsd) + write (ulbila,1101) + imprgr = 1 + endif +c + if ( lnogro.gt.40 ) then + write (ulbila,1001) saux80(1:40) + jaux = 41 + else + jaux = 1 + endif + kaux = lnogro - jaux + if ( kaux.eq.39 ) then + write (ulbila,1002) saux80(jaux:lnogro), daux + else + write (ulbila,1002) saux80(jaux:lnogro)//blan64(1:40-kaux), + > daux + endif +c + vmin = min(vmin,daux) + vmax = max(vmax,daux) + nblign = nblign + 1 +c + endif +c + endif +c + 30 continue +c + if ( imprgr.eq.0 ) then + write (ulbila,1005) blan08, mess08(langue,dimsd) + endif + write (ulbila,1101) +c +c==== +c 4. impression finale +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. impression finale ; codret', codret +#endif +c + daux = 0.d0 + do 40 , iaux = 1 , famnbv + daux = daux + famval(iaux) + 40 continue +c + if ( nblign.gt.2 ) then + write (ulbila,1004) 'Min', vmin + write (ulbila,1004) 'Max', vmax + write (ulbila,1101) + endif + write (ulbila,1003) daux + write (ulbila,1101) +c + endif +c + end diff --git a/src/tool/Utilitaire/utb17a.F b/src/tool/Utilitaire/utb17a.F new file mode 100644 index 00000000..a846541d --- /dev/null +++ b/src/tool/Utilitaire/utb17a.F @@ -0,0 +1,323 @@ + subroutine utb17a ( hetare, somare, np2are, + > posifa, facare, + > hettri, aretri, + > hetqua, arequa, + > hettet, tritet, cotrte, aretet, + > hethex, quahex, coquhe, arehex, + > hetpyr, facpyr, cofapy, arepyr, + > hetpen, facpen, cofape, arepen, + > voltri, + > volqua, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > tabaux, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 17 +c -- - -- +c ______________________________________________________________________ +c +c diagnostic des elements du calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . tabaux . a . nbnoto . tableau auxiliaire . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB17A' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "dicfen.h" +c +c 0.3. ==> arguments +c + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) +c + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer hettet(nbteto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hethex(nbheto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hetpyr(nbpyto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpen(nbpeto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c + integer posifa(0:nbarto), facare(nbfaar) + integer volqua(2,nbquto) + integer voltri(2,nbtrto) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) +c + integer tabaux(nbnoto) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(//,3x,''DIAGNOSTICS SUR LES ELEMENTS DU CALCUL'',/,3x,38(''=''), + >/)' + texte(1,5) = + > '(3x,''Un element est surcontraint si tous ses noeuds sont'')' + texte(1,6) = + > '(3x,''sur le bord du domaine. Cela peut poser un probleme'')' + texte(1,7) = + > '(3x,''selon les conditions aux limites utilisees.'')' +c + texte(2,4) = + > '(//,3x,''DIAGNOSIS OF CALCULATION ELEMENTS'',/,3x,33(''=''),/)' + texte(2,5) = + > '(3x,''An element is overstressed if all its nodes are'')' + texte(2,6) = + > '(3x,''located on the boundary of the domain. It may give,'')' + texte(2,7) = + > '(3x,''problem depending on the used boundary conditions.'')' +c + codret = 0 +c + do 11 , iaux = 4, 7 + write (ulbila,texte(langue,iaux)) + 11 continue +c +c==== +c 2. Mailles surfaciques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Mailles surfaciques : codret = ', codret +#endif +c + if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then +c +c 2.1. ==> Reperage des noeuds de bord +c + if ( codret.eq.0 ) then +c + iaux = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17D', nompro +#endif + call utb17d ( iaux, + > hetare, somare, np2are, + > posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, volqua, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> Calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17C', nompro +#endif + call utb17c ( somare, np2are, + > hettri, aretri, + > hetqua, arequa, + > voltri, + > volqua, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > tabaux, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Mailles volumiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Mailles volumiques : codret = ', codret +#endif +c + if ( nbteac.gt.0 .or. nbheac.gt.0 .or. + > nbpyac.gt.0 .or. nbpeac.gt.0 ) then +c +c 3.1. ==> Reperage des noeuds de bord +c + if ( codret.eq.0 ) then +c + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17D', nompro +#endif + call utb17d ( iaux, + > hetare, somare, np2are, + > posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, volqua, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Calcul +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17B', nompro +#endif + call utb17b ( somare, np2are, + > aretri, voltri, + > famtri, cfatri, + > arequa, volqua, + > famqua, cfaqua, + > hettet, tritet, cotrte, aretet, + > hethex, quahex, coquhe, arehex, + > hetpyr, facpyr, cofapy, arepyr, + > hetpen, facpen, cofape, arepen, + > tabaux, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utb17b.F b/src/tool/Utilitaire/utb17b.F new file mode 100644 index 00000000..ba5e497c --- /dev/null +++ b/src/tool/Utilitaire/utb17b.F @@ -0,0 +1,702 @@ + subroutine utb17b ( somare, np2are, + > aretri, voltri, + > famtri, cfatri, + > arequa, volqua, + > famqua, cfaqua, + > hettet, tritet, cotrte, aretet, + > hethex, quahex, coquhe, arehex, + > hetpyr, facpyr, cofapy, arepyr, + > hetpen, facpen, cofape, arepen, + > tabaux, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 17 - phase b +c -- - -- - +c ______________________________________________________________________ +c +c diagnostic des elements volumiques du calcul +c un element est surcontraint si tous ses noeuds sont au bord du domaine +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . tabaux . e . nbnoto . 0 : le noeud est interne . +c . . . . 1 : le noeud est au bord d'un volume . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB17B' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer somare(2,nbarto), np2are(nbarto) +c + integer aretri(nbtrto,3), voltri(2,nbtrto) + integer famtri(nbtrto), cfatri(nctftr,nbftri) +c + integer arequa(nbquto,4), volqua(2,nbquto) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) +c + integer hettet(nbteto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hethex(nbheto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hetpyr(nbpyto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpen(nbpeto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c + integer tabaux(nbnoto) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letet0, lehex0, lepen0, lapyr0 + integer letetr, lehexa, lepent, lapyra + integer letria, lequad + integer nbensc, nbensb + integer listar(12), listso(8) + integer etat +c + logical aubord + logical afaire +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs : '',i8)' + texte(1,5) = '(''. Examen du '',a,i8)' + texte(1,6) = '(''... '',a,i10,'' au bord'')' + texte(1,7) = + >'(''. Le bord du '',a,i10,'' n''''est pas une maille de calcul.'' + >)' + texte(1,8) = '(''. Le '',a,i8,'' est surcontraint.'')' +c + texte(2,4) = '(''Number of active '',a,'': '',i8)' + texte(2,5) = '(''. Examination of '',a,''#'',i8)' + texte(2,6) = '(''... '',a,''#'',i8,'' on the boundary'')' + texte(2,7) = + >'(''. The boundary of the '',a,i10,'' is not a calculation mesh.'' + >)' + texte(2,8) = '(''. The '',a,''#'',i8,'' is overstressed.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,3), nbteac + write (ulsort,texte(langue,4)) mess14(langue,3,5), nbpyac + write (ulsort,texte(langue,4)) mess14(langue,3,6), nbheac + write (ulsort,texte(langue,4)) mess14(langue,3,7), nbpeac +#endif +c + codret = 0 +c +c==== +c 2. Diagnostic sur les tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. tetraedres, codret', codret +#endif +c + if ( nbteac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbteto', nbteto + write (ulsort,90002) 'nbtecf', nbtecf + write (ulsort,90002) 'nbteca', nbteca +#endif +c + if ( nbteca.eq.0 ) then + afaire =.true. + else + afaire =.false. + endif +c + nbensc = 0 + nbensb = 0 + aubord = .false. +c + do 2 , letet0 = 1, nbteto +c + letetr = letet0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,3), letetr +#endif +c + etat = mod( hettet(letetr),100 ) +c + if ( etat.eq.0 ) then +c +c 2.1. ==> On regarde si tous les noeuds sont sur le bord +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + do 211 , iaux = 1 , 4 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 219 + endif + 211 continue + if ( degre.eq.2 ) then + do 212 , iaux = 1 , 6 + if ( tabaux(np2are(listar(iaux))).eq.0 ) then + goto 219 + endif + 212 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,3), letetr +#endif +c + 219 continue +c +c 2.2. ==> On verifie que chaque face au bord est un element de calcul +c + if ( afaire ) then +c + do 22 , iaux = 1 , 4 +c + letria = tritet(letetr,iaux) + if ( voltri(2,letria).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), letria +#endif +c + aubord = .true. + if ( cfatri(cotyel,famtri(letria)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,3), letetr +#endif + goto 229 + endif +c + endif +c + 22 continue +c + endif +c + 229 continue +c + endif +c + 2 continue +c +c 2.3. ==> Impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 3 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. Diagnostic sur les hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. hexaedres, codret', codret +#endif +c + if ( nbheac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheto', nbheto + write (ulsort,90002) 'nbhecf', nbhecf + write (ulsort,90002) 'nbheca', nbheca +#endif +c + if ( nbheca.eq.0 ) then + afaire =.true. + else + afaire =.false. + endif +c + nbensc = 0 + nbensb = 0 + aubord = .false. +c + do 3 , lehex0 = 1, nbheto +c + lehexa = lehex0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,6), lehexa +#endif +c + etat = mod(hethex(lehexa),1000) +c + if ( etat.eq.0 ) then +c +c 3.1. ==> On regarde si tous les noeuds sont sur le bord +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + do 312 , iaux = 1 , 8 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 319 + endif + 312 continue + if ( degre.eq.2 ) then + do 313 , iaux = 1 , 12 + if ( tabaux(np2are(listar(iaux))).eq.0 ) then + goto 319 + endif + 313 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,6), lehexa +#endif +c + 319 continue +c +c 3.2. ==> On verifie que chaque face au bord est un element de calcul +c + if ( afaire ) then +c +cgn write(ulsort,90002) 'faces', (quahex(lehexa,letet0),letet0=1,6) + do 32 , iaux = 1 , 6 +c + lequad = quahex(lehexa,iaux) + if ( volqua(2,lequad).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad +#endif +c + aubord = .true. + if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,6), lehexa +#endif + goto 329 + endif +c + endif +c + 32 continue +c + endif +c + 329 continue +c + endif +c + 3 continue +c +c 3.3. ==> Impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 6 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Diagnostic sur les pyramides +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. pyramides, codret', codret +#endif +c + if ( nbpyac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpyto', nbpyto + write (ulsort,90002) 'nbpycf', nbpycf + write (ulsort,90002) 'nbpyca', nbpyca +#endif +c + if ( nbpyca.eq.0 ) then + afaire =.true. + else + afaire =.false. + endif +c + nbensc = 0 + nbensb = 0 + aubord = .false. +c + do 4 , lapyr0 = 1, nbpyto +c + lapyra = lapyr0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,5), lapyra +#endif +c + etat = mod( hetpyr(lapyra),100) +c + if ( etat.eq.0 ) then +c +c 4.1. ==> On regarde si tous les noeuds sont sur le bord +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c + do 411 , iaux = 1 , 5 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 419 + endif + 411 continue + if ( degre.eq.2 ) then + do 412 , iaux = 1 , 8 + if ( tabaux(np2are(listar(iaux))).eq.0 ) then + goto 419 + endif + 412 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,5), lapyra +#endif +c + 419 continue +c +c 4.2. ==> On verifie que chaque face au bord est un element de calcul +c + if ( afaire ) then +c + do 42 , iaux = 1 , 4 +c + letria = facpyr(lapyra,iaux) + if ( voltri(2,letria).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), letria +#endif +c + aubord = .true. + if ( cfatri(cotyel,famtri(letria)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra +#endif + goto 429 + endif +c + endif +c + 42 continue +c + lequad = facpyr(lapyra,5) + if ( volqua(2,lequad).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad +#endif +c + aubord = .true. + if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,5), lapyra +#endif + goto 429 + endif +c + endif +c + 429 continue +c + endif +c + endif +c + 4 continue +c +c 4.3. ==> Impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 5 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Diagnostic sur les pentaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. pentaedres, codret', codret +#endif +c + if ( nbpeac.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpeto', nbpeto + write (ulsort,90002) 'nbpecf', nbpecf + write (ulsort,90002) 'nbpeca', nbpeca +#endif +c + if ( nbpeca.eq.0 ) then + afaire =.true. + else + afaire =.false. + endif +c + nbensc = 0 + nbensb = 0 + aubord = .false. +c + do 5 , lepen0 = 1, nbpeto +c + lepent = lepen0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,7), lepent +#endif +c + etat = mod( hetpen(lepent),100) +c + if ( etat.eq.0 ) then +c +c 5.1. ==> On regarde si tous les noeuds sont sur le bord +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c + do 511 , iaux = 1 , 6 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 519 + endif + 511 continue + if ( degre.eq.2 ) then + do 512 , iaux = 1 , 9 + if ( tabaux(np2are(listar(iaux))).eq.0 ) then + goto 519 + endif + 512 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,7), lepent +#endif +c + 519 continue +c +c 5.2. ==> On verifie que chaque face au bord est un element de calcul +c . On regarde si la face est une maille de calcul +c + if ( afaire ) then +c + do 521 , iaux = 1 , 2 +c + letria = facpen(lepent,iaux) + if ( voltri(2,letria).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), letria +#endif +c + aubord = .true. + if ( cfatri(cotyel,famtri(letria)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent +#endif + goto 529 + endif +c + endif +c + 521 continue +c + do 522 , iaux = 3 , 5 +c + lequad = facpen(lepent,iaux) + if ( volqua(2,lequad).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad +#endif +c + aubord = .true. + if ( cfaqua(cotyel,famqua(lequad)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,7), lepent +#endif + goto 529 + endif +c + endif +c + 522 continue +c + 529 continue +c + endif +c + endif +c + 5 continue +c +c 5.3. ==> Impression +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 7 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. La fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb17c.F b/src/tool/Utilitaire/utb17c.F new file mode 100644 index 00000000..ba2e178a --- /dev/null +++ b/src/tool/Utilitaire/utb17c.F @@ -0,0 +1,511 @@ + subroutine utb17c ( somare, np2are, + > hettri, aretri, + > hetqua, arequa, + > voltri, + > volqua, + > posifa, facare, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > tabaux, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 17 - phase c +c -- - -- - +c ______________________________________________________________________ +c +c Diagnostic des elements surfaciques du calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . tabaux . e . nbnoto . 0 : le noeud est interne . +c . . . . 1 : le noeud est au bord d'une face . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB17C' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +#include "dicfen.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer somare(2,nbarto), np2are(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) +c + integer voltri(2,nbtrto) + integer volqua(2,nbquto) + integer posifa(0:nbarto), facare(nbfaar) +c + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) +c + integer tabaux(nbnoto) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer letria, lequad, larete + integer laface + integer nbensc, nbensb + integer nbvoto + integer etat, etat00 + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a1, sa3a4, sa4a1 + integer listso(4) +c + logical afaire + logical aubord +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs :'',i10)' + texte(1,5) = '(''. Examen du '',a,i10)' + texte(1,6) = '(''... '',a,i10,'' au bord'')' + texte(1,7) = + >'(''. Le bord du '',a,i10,'' n''''est pas une maille de calcul.'' + >)' + texte(1,8) = '(''. Le '',a,i8,'' est surcontraint.'')' +c + texte(2,4) = '(''Number of active '',a,'' : '',i8)' + texte(2,5) = '(''. Examination of '',a,''#'',i8)' + texte(2,6) = '(''... '',a,''#'',i8,'' on the boundary'')' + texte(2,7) = + >'(''. The boundary of the '',a,i10,'' is not a calculation mesh.'' + >)' + texte(2,8) = '(''. The '',a,''#'',i8,'' is overstressed.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrac + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquac +#endif +c + codret = 0 +c +c==== +c 2. Diagnostic sur les triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. triangles, codret = ', codret +#endif +c + if ( nbtrac.gt.0 ) then +c + nbensc = 0 + nbensb = 0 + aubord = .false. + afaire = .false. + nbvoto = nbteto + nbpyto + nbpeto +c + do 2 , letria = 1, nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,2), letria +#endif +c + if ( cfatri(cotyel,famtri(letria)).ne.0 ) then +c + etat = mod( hettri(letria),10 ) +c + if ( etat.eq.0 ) then +c +c 2.0. ==> S'il y a des volumes, on ne prend que des triangles purs +c + if ( nbvoto.ne.0 ) then +c + if ( voltri(1,letria).ne.0 ) then + goto 2 + endif +c + endif +c + afaire = .true. +c +c 2.1. ==> On regarde si tous les noeuds sont sur le bord +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + listso(1) = sa1a2 + listso(2) = sa2a3 + listso(3) = sa3a1 +c + do 211 , iaux = 1 , 3 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 219 + endif + 211 continue + if ( degre.eq.2 ) then + do 212 , iaux = 1 , 3 + if ( tabaux(np2are(aretri(letria,iaux))).eq.0 ) then + goto 219 + endif + 212 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,2), letria +#endif +c + 219 continue +c +c 2.2. ==> On verifie que chaque arete au bord est un element de calcul +c + do 22 , iaux = 1 , 3 +c + larete = aretri(letria,iaux) + jdeb = posifa(larete-1)+1 + jfin = posifa(larete) +c +c 2.2.1. ==> L'arete a au plus une face voisine : elle est de bord +c + if ( jfin.le.jdeb ) then +cgn write (ulsort,*) 'au plus une face voisine' +c + kaux = 0 +c +c 2.2.2. ==> L'arete a au moins deux faces voisines : il faut compter +c le nombre de faces actives car avec la conformite, une +c face et sa fille sont declarees voisines de l'arete +c + else +c + kaux = 0 + do 222 , jaux = jdeb, jfin + laface = facare(jaux) +cgn write (ulsort,*) 'voisine de', laface + if ( laface.gt.0 ) then + etat00 = mod(hettri(laface),10) + else + etat00 = mod(hetqua(-laface),100) + endif + if ( etat00.eq.0 ) then + kaux = kaux + 1 + endif + 222 continue +c + endif +c +c 2.2.3. ==> Bilan +c + if ( kaux.le.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,1), larete +#endif + aubord = .true. +c + if ( cfaare(cotyel,famare(larete)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,2), letria +#endif + goto 229 + endif +c + endif +c + 22 continue +c + 229 continue +c + endif +c + endif +c + 2 continue +c +c 2.3. ==> Impression +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 2 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Diagnostic sur les quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. quadrangles, codret = ', codret +#endif +c + if ( nbquac.gt.0 ) then +c + nbensc = 0 + nbensb = 0 + aubord = .false. + afaire = .false. + nbvoto = nbheto + nbpyto + nbpeto +c + do 3 , lequad = 1, nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,4), lequad +#endif +c + if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then +c + etat = mod( hetqua(lequad),100 ) +c + if ( etat.eq.0 ) then +c +c 3.0. ==> S'il y a des volumes, on ne prend que des quadrangles purs +c + if ( nbvoto.ne.0 ) then +c + if ( volqua(1,lequad).ne.0 ) then + goto 3 + endif +c + endif +c + afaire = .true. +c +c 3.1. ==> On regarde si tous les noeuds sont sur le bord +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) + listso(1) = sa1a2 + listso(2) = sa2a3 + listso(3) = sa3a4 + listso(4) = sa4a1 +c + do 311 , iaux = 1 , 4 + if ( tabaux(listso(iaux)).eq.0 ) then + goto 319 + endif + 311 continue + if ( degre.eq.2 ) then + do 312 , iaux = 1 , 4 + if ( tabaux(np2are(arequa(lequad,iaux))).eq.0 ) then + goto 319 + endif + 312 continue + endif +c + nbensc = nbensc + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad +#endif +c + 319 continue +c +c 3.2. ==> On verifie que chaque arete au bord est un element de calcul +c + do 32 , iaux = 1 , 4 +c + larete = arequa(lequad,iaux) + jdeb = posifa(larete-1)+1 + jfin = posifa(larete) +c +c 3.2.1. ==> L'arete a au plus une face voisine : elle est de bord +c + if ( jfin.le.jdeb ) then +cgn write (ulsort,*) 'au plus une face voisine' +c + kaux = 0 +c +c 3.2.2. ==> L'arete a au moins deux faces voisines : il faut compter +c le nombre de faces actives car avec la conformite, une +c face et sa fille sont declarees voisines de l'arete +c + else +c + kaux = 0 + do 322 , jaux = jdeb, jfin + laface = facare(jaux) +cgn write (ulsort,*) 'voisine de', laface + if ( laface.gt.0 ) then + etat00 = mod(hettri(laface),10) + else + etat00 = mod(hetqua(-laface),100) + endif + if ( etat00.eq.0 ) then + kaux = kaux + 1 + endif + 322 continue +c + endif +c +c 3.2.3. ==> Bilan +c + if ( kaux.le.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,1), larete +#endif + aubord = .true. +c + if ( cfaare(cotyel,famare(larete)).eq.0 ) then + nbensb = nbensb + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,4), lequad +#endif + goto 329 + endif +c + endif +c + 32 continue +c + 329 continue +c + endif +c + endif +c + 3 continue +c +c 3.3. ==> Impression +c + if ( afaire ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17E', nompro +#endif + iaux = 4 + call utb17e ( iaux, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utb17d.F b/src/tool/Utilitaire/utb17d.F new file mode 100644 index 00000000..1d54e7fc --- /dev/null +++ b/src/tool/Utilitaire/utb17d.F @@ -0,0 +1,402 @@ + subroutine utb17d ( option, + > hetare, somare, np2are, + > posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, volqua, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 17 - phase d +c -- - -- - +c ______________________________________________________________________ +c +c Reperage des noeuds sur un bord de volume ou de face +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e 1 . 1 : noeuds sur un bord de face . +c . . . . 2 : noeuds sur un bord de volume . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . tabaux . s . nbnoto . 0 : le noeud est interne . +c . . . . 1 : le noeud est au bord d'un volume . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB17D' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option +c + integer hetare(nbarto), somare(2,nbarto), np2are(nbarto) + integer posifa(0:nbarto), facare(nbfaar) +c + integer hettri(nbtrto), aretri(nbtrto,3) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer volqua(2,nbquto) +c + integer tabaux(nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer jdeb, jfin + integer etat, etat00 + integer laface +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a1, sa3a4, sa4a1 +c + logical aubord +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c 1.1. messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de '',a,'' actifs : '',i10)' + texte(1,5) = '(''. Examen du '',a,i10)' + texte(1,6) = '(''... '',a,i10,'' au bord'')' + texte(1,7) = '(''Nombre de '',a,''au bord : '',i10,'' sur'',i10)' +c + texte(2,4) = '(''Number of active '',a,'' : '',i10)' + texte(2,5) = '(''. Examination of '',a,''#'',i10)' + texte(2,6) = '(''... '',a,''#'',i10,'' on the boundary'')' + texte(2,7) = + > '(''Number of '',a,''on boundaries : '',i10,'' over'',i10)' +c + 1000 format('... ',a,':',4i10) +c +#ifdef _DEBUG_HOMARD_ + if ( option.eq.1 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarac + else + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrac + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquac + endif +#endif +c + codret = 0 +c +c==== +c 2. A priori, tous les noeuds sont internes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. noeuds internes, codret = ', codret +#endif +c + do 2 , iaux = 1, nbnoto + tabaux(iaux) = 0 + 2 continue +c +c==== +c 3. Les bords des faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. bords de faces, codret = ', codret +#endif +c + if ( option.eq.1 ) then +c + if ( nbarac.gt.0 ) then +c + do 31 , iaux = 1, nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,1), iaux +#endif +c + etat = mod( hetare(iaux),10 ) +c + if ( etat.eq.0 ) then +c + aubord = .false. + jdeb = posifa(iaux-1)+1 + jfin = posifa(iaux) +c +c 3.1. ==> L'arete a au plus une face voisine : elle est de bord +c + if ( jfin.le.jdeb) then +cgn write (ulsort,*) 'au plus une face voisine' +c + aubord = .true. +c +c 3.2. ==> L'arete a au moins deux faces voisines : il faut compter le +c nombre de faces actives car avec la conformite, une face et +c sa fille sont declarees voisines de l'arete +c + else +c + kaux = 0 + do 312 , jaux = jdeb, jfin + laface = facare(jaux) +cgn write (ulsort,*) 'voisine de', laface + if ( laface.gt.0 ) then + etat00 = mod(hettri(laface),10) + else + etat00 = mod(hetqua(-laface),100) + endif + if ( etat00.eq.0 ) then + kaux = kaux + 1 + endif + 312 continue +c + if ( kaux.le.1 ) then + aubord = .true. + endif +c + endif +c +c 3.3. ==> Transfert de l'information sur les noeuds de l'arete +c + if ( aubord ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,1), iaux +#endif +c + tabaux(somare(1,iaux)) = 1 + tabaux(somare(2,iaux)) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), + > somare(1,iaux), somare(2,iaux) +#endif +c + if ( degre.eq.2 ) then +c + tabaux(np2are(iaux)) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), np2are(iaux) +#endif +c + endif +c + endif +c + endif +c + 31 continue +c + endif +c +c==== +c 4. Les bords des volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. bords de volume, codret = ', codret +#endif +c + else +c +c 4.1. ==> Exploration des triangles +c + if ( nbtrac.gt.0 ) then +c + do 41 , iaux = 1, nbtrto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux +#endif +c + etat = mod( hettri(iaux),10 ) +c + if ( etat.eq.0 ) then +c + if ( voltri(2,iaux).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,2), iaux +#endif +c + a1 = aretri(iaux,1) + a2 = aretri(iaux,2) + a3 = aretri(iaux,3) + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + tabaux(sa1a2) = 1 + tabaux(sa2a3) = 1 + tabaux(sa3a1) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a1 +#endif +c + if ( degre.eq.2 ) then +c + tabaux(np2are(a1)) = 1 + tabaux(np2are(a2)) = 1 + tabaux(np2are(a3)) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), + > np2are(a1), np2are(a2), np2are(a3) +#endif +c + endif +c + endif +c + endif +c + 41 continue +c + endif +c +c 4.2. ==> Exploration des quadrangles +c + if ( nbquac.gt.0 ) then +c + do 42 , iaux = 1, nbquto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,4), iaux +#endif +c + etat = mod( hetqua(iaux),100 ) +c + if ( etat.eq.0 ) then +c + if ( volqua(2,iaux).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), iaux +#endif +c + a1 = arequa(iaux,1) + a2 = arequa(iaux,2) + a3 = arequa(iaux,3) + a4 = arequa(iaux,4) + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 +#endif +c + tabaux(sa1a2) = 1 + tabaux(sa2a3) = 1 + tabaux(sa3a4) = 1 + tabaux(sa4a1) = 1 +c + if ( degre.eq.2 ) then +c + tabaux(np2are(a1)) = 1 + tabaux(np2are(a2)) = 1 + tabaux(np2are(a3)) = 1 + tabaux(np2are(a4)) = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) mess14(langue,3,-1), + > np2are(a1), np2are(a2), np2are(a3), np2are(a4) +#endif +c + endif +c + endif +c + endif +c + 42 continue +c + endif +c + endif +c +c==== +c 5. Bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Bilan, codret = ', codret +#endif +#ifdef _DEBUG_HOMARD_ +c + iaux = 0 + do 5 , sa1a2 = 1, nbnoto + if ( tabaux(sa1a2).ne.0 ) then + iaux = iaux + 1 +cgn else +cgn write (ulsort,1000) mess14(langue,1,-1), sa1a2 + endif + 5 continue + write (ulsort,texte(langue,7)) mess14(langue,3,-1), iaux, nbnoto +#endif +c + end diff --git a/src/tool/Utilitaire/utb17e.F b/src/tool/Utilitaire/utb17e.F new file mode 100644 index 00000000..eee324d1 --- /dev/null +++ b/src/tool/Utilitaire/utb17e.F @@ -0,0 +1,148 @@ + subroutine utb17e ( typent, nbensc, aubord, nbensb, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan sur le maillage - option 17 - phase e +c -- - -- - +c ______________________________________________________________________ +c +c impression +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typent . e . 1 . type d'entites . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . . . . 8 : triangle et quadrangle . +c . . . . 9 : melange de volumes . +c . nbensc . e . 1 . nombre d'entites surcontraintes . +c . aubord . e . 1 . vrai si au moins une maille est au bord . +c . nbensb . e . 1 . nombre d'entites sans mailles de bord . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB17E' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typent + integer nbensc, nbensb +c + logical aubord +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + character*43 mess43(nblang,110) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1234567890123456789012345678901234567890123 + mess43(1,1) = 'Nombre d''elements surcontraints ' + mess43(1,2) = 'Nombre d''elements sans mailles de bord ' +c +c 1234567890123456789012345678901234567890123 + mess43(2,1) = 'Number of overstressed elements ' + mess43(2,2) = 'Number of elements without boundary meshes ' +c +10100 format(/,5x,60('*')) +10200 format( 5x,60('*')) +c +11200 format( 5x,'* ',21x,a14,21x,' *') +c +12200 format( 5x,'* ',a43,' * ', i10,' *') +c + codret = 0 +c +c==== +c 2. impression +c==== +c + write (ulbila,10100) + write (ulbila,11200) mess14(langue,4,typent) + write (ulbila,10200) + write (ulbila,12200) mess43(langue,1), nbensc + if ( aubord ) then + write (ulbila,12200) mess43(langue,2), nbensb + endif + write (ulbila,10200) +c +c==== +c 3. La fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb19a.F b/src/tool/Utilitaire/utb19a.F new file mode 100644 index 00000000..ffd37189 --- /dev/null +++ b/src/tool/Utilitaire/utb19a.F @@ -0,0 +1,540 @@ + subroutine utb19a ( choix, + > coonoe, somare, + > hettri, aretri, + > famtri, cfatri, + > hetqua, arequa, + > famqua, cfaqua, + > tritet, cotrte, aretet, hettet, + > quahex, coquhe, arehex, hethex, + > facpyr, cofapy, arepyr, hetpyr, + > facpen, cofape, arepen, hetpen, + > nbiter, + > tbiau1, tabaur, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 19 - etape a +c -- - -- - +c remarque : utb05a et utb19a sont des clones +c ______________________________________________________________________ +c +c but : controle des diametres des mailles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du traitement . +c . . . . 0 : creation et affichage des histogrammes . +c . . . . 2 : sortie du diametre des triangles . +c . . . . 3 : sortie du diametre des tetraedres . +c . . . . 4 : sortie du diametre des quadrangles . +c . . . . 5 : sortie du diametre des pyramides . +c . . . . 6 : sortie du diametre des hexaedres . +c . . . . 7 : sortie du diametre des pentaedres . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . tbiau1 . a . * . liste des entites examinees . +c . tabaur . a . * . qualite des entites . +c . nbiter . e . 1 . numero de l'iteration courante . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB19A' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + double precision tabaur(*) +c + integer choix +c + integer somare(2,nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer cfatri(nctftr,nbftri), famtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer tbiau1(*) + integer nbiter +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer letria, lequad + integer iaux, jaux + integer nbvoto + integer nbeexa + integer nbqinf + integer tbiau2(1) +c + double precision daux + double precision tbdaux(1) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. titre +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(//,3x,''DIAMETRES DES MAILLES'',/,3x,21(''=''))' + texte(1,5) = '(''Diametre '',a,'' des '',a,'' : '',g12.5)' + texte(1,6) = '(''Nombre de '',a,'' a examiner : '',i8)' +c + texte(2,4) = + > '(//,3x,''DIAMETERS OF MESHES'',/,3x,19(''=''))' + texte(2,5) = '(''Diameter '',a,'' of '',a,'': '',g12.5)' + texte(2,6) = '(''Number of '',a,'' to be examined: '',i8)' +c + write (ulsort,texte(langue,4)) + write (ulbila,texte(langue,4)) +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c + nbqinf = 0 +c +c==== +c 2. calcul des diametres des tetraedres +c=== +c + if ( choix.eq.0 .or. choix.eq.3 ) then +c + if ( nbteto.ne.0 ) then +c + iaux = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB19C_te', nompro +#endif + call utb19c ( choix, iaux, nbteto, nbtecf, nbteca, + > coonoe, somare, + > aretri, arequa, + > hettet, tritet, cotrte, aretet, + > nbiter, tabaur, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. calcul des diametres des pyramides +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. pyramides ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.5 ) then +c + if ( nbpyto.ne.0 ) then +c + iaux = 5 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB19C_py', nompro +#endif + call utb19c ( choix, iaux, nbpyto, nbpycf, nbpyca, + > coonoe, somare, + > aretri, arequa, + > hetpyr, facpyr, cofapy, arepyr, + > nbiter, tabaur, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. calcul des diametres des hexaedres +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. hexaedres ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.6 ) then +c + if ( nbheto.ne.0 ) then +c + iaux = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB19C_he', nompro +#endif + call utb19c ( choix, iaux, nbheto, nbhecf, nbheca, + > coonoe, somare, + > aretri, arequa, + > hethex, quahex, coquhe, arehex, + > nbiter, tabaur, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 5. calcul des diametres des pentaedres +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. pentaedres ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.7 ) then +c + if ( nbpeto.ne.0 ) then +c + iaux = 7 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB19C_pe', nompro +#endif + call utb19c ( choix, iaux, nbpeto, nbpecf, nbpeca, + > coonoe, somare, + > aretri, arequa, + > hetpen, facpen, cofape, arepen, + > nbiter, tabaur, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. calcul des diametres des triangles d'un maillage 2d ou 2,5d +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. triangles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.2 ) then +c + if ( nbtrto.ne.0 ) then +c +c 6.1. ==> liste des triangles a examiner : +c . en l'absence de tetraedre, pentaedre et pyramide, ce sont +c tous les triangles actifs ; +c . en presence de tetraedre, pentaedre ou pyramide, ce sont les +c triangles actifs qui sont des elements de calcul +c + nbeexa = 0 +c + if ( nbteto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 611 , letria = 1 , nbtrto + if ( mod(hettri(letria),10).eq.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = letria + endif + 611 continue +c + else +c + do 612 , letria = 1 , nbtrto + if ( mod(hettri(letria),10).eq.0 .and. + > cfatri(cotyel,famtri(letria)).ne.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = letria + endif + 612 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,2), nbeexa +#endif +c +c 6.2. ==> calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6.2. calcul ; codret = ', codret +#endif +c + if ( nbeexa.gt.0 ) then +c + do 62 , iaux = 1 , nbeexa +c + letria = tbiau1(iaux) +c + call utdtri ( letria, daux, + > coonoe, somare, aretri ) +c + tabaur(iaux) = daux +c + 62 continue +c + endif +c +c 6.3. ==> impression sur la sortie standard et sur un fichier +c a exploiter par xmgrace +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + jaux = 0 + iaux = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B', nompro +#endif + call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 7. calcul des diametres des quadrangles d'un maillage 2d ou 2,5d +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7. quadrangles ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 .or. choix.eq.4 ) then +c + if ( nbquto.ne.0 ) then +c +c 7.1. ==> liste des quadrangles a examiner : +c . en l'absence d'hexaedre, pentaedre et pyramide, ce sont +c tous les quadrangles actifs ; +c . en presence d'hexaedre, pentaedre ou pyramide, ce sont les +c quadrangles actifs qui sont des elements de calcul +c + nbeexa = 0 +c + if ( nbheto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then +c + do 711 , lequad = 1 , nbquto + if ( mod(hetqua(lequad),100).eq.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = lequad + endif + 711 continue +c + else +c + do 712 , lequad = 1 , nbquto + if ( mod(hetqua(lequad),100).eq.0 .and. + > cfaqua(cotyel,famqua(lequad)).ne.0 ) then + nbeexa = nbeexa + 1 + tbiau1(nbeexa) = lequad + endif + 712 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,4), nbeexa +#endif +c +c 7.2. ==> calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '7.2. calcul ; codret = ', codret +#endif +c + if ( nbeexa.gt.0 ) then +c + do 72 , iaux = 1 , nbeexa +c + lequad = tbiau1(iaux) +c + call utdqua ( lequad, daux, + > coonoe, somare, arequa ) +c + tabaur(iaux) = daux +c + 72 continue +c + endif +c +c 7.3. ==> impression sur la sortie standard et sur un fichier +c a exploiter par xmgrace +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + jaux = 0 + iaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B', nompro +#endif + call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb19c.F b/src/tool/Utilitaire/utb19c.F new file mode 100644 index 00000000..08e33b7f --- /dev/null +++ b/src/tool/Utilitaire/utb19c.F @@ -0,0 +1,353 @@ + subroutine utb19c ( choix, typenh, nbento, nbencf, nbenca, + > coonoe, somare, + > aretri, arequa, + > hetvol, facvol, cofavo, arevol, + > nbiter, tabaur, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 19 - etape c +c -- - -- - +c ______________________________________________________________________ +c +c but : controle des diametres des volumes +c remarque : utb05c et utb19c sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du traitement . +c . . . . 0 : creation et affichage des histogrammes . +c . . . . 2 : sortie de la qualite des triangles . +c . . . . 3 : sortie de la qualite des tetraedres . +c . . . . 4 : sortie de la qualite des quadrangles . +c . . . . 6 : sortie de la qualite des hexaedres . +c . typenh . e . 1 . variantes . +c . . . . 3 : tetraedres . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbento . e . 1 . nombre d'entites . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetvol . e . nbento . historique de l'etat des volumes . +c . facvol . e .nbencf**. numeros des faces des volumes . +c . cofavo . e .nbencf**. code des faces des volumes . +c . arevol . e .nbenca**. code des aretes des volumes . +c . tabaur . s . * . qualite des entites . +c . nbiter . e . 1 . numero de l'iteration courante . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB19C' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "envca1.h" +#include "infini.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + double precision tabaur(*) +c + integer choix, typenh, nbento, nbencf, nbenca +c + integer somare(2,nbarto) + integer aretri(nbtrto,3), arequa(nbquto,4) + integer hetvol(nbento) + integer facvol(nbencf,*), cofavo(nbencf,*), arevol(nbenca,*) + integer nbiter +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbvoto + integer nbeexa + integer nbqinf + integer tbiau2(1) +c + double precision daux + double precision dauxmi, dauxma + double precision tbdaux(1) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. titre +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Pour les '',a)' + texte(1,5) = '(''Diametre '',a,'' des '',a,'' : '',g12.5)' + texte(1,6) = '(''Type d''''entite inconnu :'',i10)' + texte(1,7) = '(''Nombre d''''entites examinees :'',i10)' +c + texte(2,4) = '(''. For '',a)' + texte(2,5) = '(''Diameter '',a,'' of '',a,'' : '',g12.5)' + texte(2,6) = '(''Unknown entity type :'',i10)' + texte(2,7) = '(''Number of examined entities :'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c + codret = 0 +c + nbvoto = nbteto + nbpyto + nbheto + nbpeto +c + dauxmi = vinfpo + dauxma = vinfne +c + nbeexa = 0 + nbqinf = 0 +c +c==== +c 2. tetraedres +c=== +c + if ( typenh.eq.3 ) then +c + do 21 , iaux = 1 , nbteto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTDTET', nompro +#endif + call utdtet ( jaux, daux, + > coonoe, somare, aretri, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux +c + dauxmi = min ( dauxmi, daux ) + dauxma = max ( dauxma, daux ) +c + endif +c + 21 continue +c +c==== +c 3. pyramides +c==== +c + elseif ( typenh.eq.5 ) then +c + do 31 , iaux = 1 , nbpyto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTDPYR', nompro +#endif + call utdpyr ( jaux, daux, + > coonoe, somare, aretri, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux +c + dauxmi = min ( dauxmi, daux ) + dauxma = max ( dauxma, daux ) +c + endif +c + 31 continue +c +c==== +c 4. hexaedres +c==== +c + elseif ( typenh.eq.6 ) then +c + do 41 , iaux = 1 , nbheto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTDHEX', nompro +#endif + call utdhex ( jaux, daux, + > coonoe, somare, arequa, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux +c + dauxmi = min ( dauxmi, daux ) + dauxma = max ( dauxma, daux ) +c + endif +c + 41 continue +c +c==== +c 5. pentaedres +c==== +c + elseif ( typenh.eq.7 ) then +c + do 51 , iaux = 1 , nbpeto +c + if ( mod(hetvol(iaux),100).eq.0 ) then +c + nbeexa = nbeexa + 1 +c + jaux = iaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTDPEN', nompro +#endif + call utdpen ( jaux, daux, + > coonoe, somare, arequa, + > facvol, cofavo, arevol ) +c + tabaur(nbeexa) = daux +c + dauxmi = min ( dauxmi, daux ) + dauxma = max ( dauxma, daux ) +c + endif +c + 51 continue +c +c==== +c 6. probleme +c==== +c + else +c + write (ulsort,texte(langue,6)) typenh + codret = 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) 'min', + > mess14(langue,3,typenh), dauxmi + write (ulsort,texte(langue,5)) 'max', + > mess14(langue,3,typenh), dauxma + write (ulsort,texte(langue,7)) nbeexa + endif +#endif +c +c==== +c 7. impression sur la sortie standard et sur un fichier a exploiter +c par xmgrace +c==== +c + if ( codret.eq.0 ) then +c + if ( choix.eq.0 ) then +c + if ( nbeexa.gt.0 ) then +c + iaux = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05B', nompro +#endif + call utb05b ( iaux, typenh, nbeexa, tabaur, tbdaux, + > nbiter, rafdef, nbvoto, + > tbiau2, + > ulbila, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb300.h b/src/tool/Utilitaire/utb300.h new file mode 100644 index 00000000..59b6d9d1 --- /dev/null +++ b/src/tool/Utilitaire/utb300.h @@ -0,0 +1,6 @@ +c + texte(1,4) = + > '(/,3x,''... Interpenetration des '',a,/,3x,35(''-''),/)' +c + texte(2,4) = + > '(/,3x,''... Staggered '',a,/,3x,23(''-''),/)' diff --git a/src/tool/Utilitaire/utb301.h b/src/tool/Utilitaire/utb301.h new file mode 100644 index 00000000..a390687d --- /dev/null +++ b/src/tool/Utilitaire/utb301.h @@ -0,0 +1,23 @@ +c +10100 format(/,5x,68('*')) +10200 format( 5x,68('*')) +c +11100 format( 5x,'* ',a54,11x,'*') +11101 format( 5x,'* ',a37,a14,14x,'*') +c +12100 format( 5x,'* ',6i9,' *') +12101 format( 5x,'* ',a14,' :',49x,'*') +12102 format( 5x,'* ',2a8,1x,a14,i10,', ',2a8,':',5x,'*') +c +14101 format( + >5x,'*',5x,'X = ',g13.6,44x,'*') +14102 format( + >5x,'*',5x,'X = ',g13.6,' Y = ',g13.6,26x,'*') +14103 format( + >5x,'*',5x,'X = ',g13.6,' Y = ',g13.6,' Z = ',g13.6,8x,'*') +14201 format( + >5x,'*',i10,' : X = ',g13.6,36x,'*') +14202 format( + >5x,'*',i10,' : X = ',g13.6,' Y = ',g13.6,18x,'*') +14203 format( + >5x,'*',i10,' : X = ',g13.6,' Y = ',g13.6,' Z = ',g13.6,'*') diff --git a/src/tool/Utilitaire/utb302.h b/src/tool/Utilitaire/utb302.h new file mode 100644 index 00000000..b0456b55 --- /dev/null +++ b/src/tool/Utilitaire/utb302.h @@ -0,0 +1,19 @@ + nbpbco(typenh) = nbpbco(typenh) + 1 +c + write (ulbila,10100) + write (ulbila,11101) mess54(langue,2)(1:37), + > mess14(langue,3,typenh) + write (ulbila,12101) mess14(langue,2,-1) + if ( sdim.eq.1 ) then + write (ulbila,14201) lenoeu, vn(1) + elseif ( sdim.eq.2 ) then + write (ulbila,14202) lenoeu, vn(1), vn(2) + else + write (ulbila,14203) lenoeu, vn(1), vn(2), vn(3) + endif + write (ulbila,12102) mess08(langue,1), + > mess08(langue,2), + > mess14(langue,1,typenh), iaux, + > mess08(langue,3), + > mess08(langue,4) +c diff --git a/src/tool/Utilitaire/utb303.h b/src/tool/Utilitaire/utb303.h new file mode 100644 index 00000000..248888e8 --- /dev/null +++ b/src/tool/Utilitaire/utb303.h @@ -0,0 +1,17 @@ +c + texte(1,4) = '(''. Examen du '',a,i10)' + texte(1,5) = '(''. Apres controle des '',a,'':'')' + texte(1,6) = + >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'', + >i10)' + texte(1,7) = '(''==> Tout va bien.'')' + texte(1,8) = '(''... Reprise du '',a,i10)' +c + texte(2,4) = '(''. Examination of '',a,'' # '',i10)' + texte(2,5) = '(''. After checking of the '',a,'':'')' + texte(2,6) = + >'(''==> Number of corrections of nodes connected to '',a,'':'', + >i10)' + texte(2,7) = '(''==> Everything is OK.'')' + texte(2,8) = '(''... Correction of '',a,i10)' +c diff --git a/src/tool/Utilitaire/utb304.h b/src/tool/Utilitaire/utb304.h new file mode 100644 index 00000000..24f7b789 --- /dev/null +++ b/src/tool/Utilitaire/utb304.h @@ -0,0 +1,20 @@ +c +c 2.3.1. ==> filtrage initial +c + logaux(7) = .false. +c + vn(1) = coonoe(lenoeu,1) + if ( vn(1).ge.xmin .and. vn(1).le.xmax ) then + vn(2) = coonoe(lenoeu,2) + if ( vn(2).ge.ymin .and. vn(2).le.ymax ) then + vn(3) = coonoe(lenoeu,3) + if ( vn(3).ge.zmin .and. vn(3).le.zmax ) then + logaux(7) = .true. + do 231 , iaux = 1 , nbsomm + if ( lenoeu.eq.sommet(iaux) ) then + logaux(7) = .false. + endif + 231 continue + endif + endif + endif diff --git a/src/tool/Utilitaire/utb305.h b/src/tool/Utilitaire/utb305.h new file mode 100644 index 00000000..62cab16e --- /dev/null +++ b/src/tool/Utilitaire/utb305.h @@ -0,0 +1,27 @@ +c +c 2.3.2. ==> le noeud est-il coincident avec un des sommets ? +c + if ( logaux(7) ) then +c + if ( nbpbco(-1).gt.0 ) then +c + nucoin = numcoi(lenoeu) +c + if ( nucoin.ne.0 ) then +c + ptcode = coinpt(nucoin)+1 + ptcofi = coinpt(nucoin+1) + do 232 , ptcoin = ptcode, ptcofi + jaux = coinnn(ptcoin) + do 2321 , iaux = 1 , nbsomm + if ( jaux.eq.sommet(iaux) ) then + goto 23 + endif + 2321 continue + 232 continue +c + endif +c + endif +c + endif diff --git a/src/tool/Utilitaire/utb306.h b/src/tool/Utilitaire/utb306.h new file mode 100644 index 00000000..9216f218 --- /dev/null +++ b/src/tool/Utilitaire/utb306.h @@ -0,0 +1,14 @@ +c +c 2.3.3. ==> exclusivement les noeuds p1 +c + if ( logaux(7) ) then +c + if ( hetnoe(lenoeu).ne.1 .and. + > hetnoe(lenoeu).ne.21 .and. + > hetnoe(lenoeu).ne.51 ) then +c + logaux(7) = .false. +c + endif +c + endif diff --git a/src/tool/Utilitaire/utb307.h b/src/tool/Utilitaire/utb307.h new file mode 100644 index 00000000..bfa86b3a --- /dev/null +++ b/src/tool/Utilitaire/utb307.h @@ -0,0 +1,14 @@ +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,3,typenh) + if ( (nbcoqu+nbcoar).eq.0 ) then + write (ulsort,texte(langue,7)) + else + if ( nbcoqu.gt.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,4), nbcoqu + endif + if ( nbcoar.gt.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,1), nbcoar + endif + endif +#endif diff --git a/src/tool/Utilitaire/utb308.h b/src/tool/Utilitaire/utb308.h new file mode 100644 index 00000000..1a7947e0 --- /dev/null +++ b/src/tool/Utilitaire/utb308.h @@ -0,0 +1,29 @@ +c +c 2.2.1. ==> Elimination des situations ou il est inutile +c de controler car l'arete a deja ete ramenee +c + larete = arefro(nuarfr) +c + if ( larete.le.0 ) then + goto 22 + endif +c +c 2.2.2. ==> Reperage des situations a examiner : +c . le noeud milieu de l'arete decoupee ou +c . les noeuds P2 courbes +c + if ( codret.eq.0 ) then +c + if ( typsfr.le.2 ) then + nbexam = 1 + examar(1) = larete + examno(1) = somare(2,filare(examar(1))) + else + nbexam = 2 + examar(1) = filare(larete) + examno(1) = np2are(examar(1)) + examar(2) = examar(1) + 1 + examno(2) = np2are(examar(2)) + endif +c + endif diff --git a/src/tool/Utilitaire/utb314.h b/src/tool/Utilitaire/utb314.h new file mode 100644 index 00000000..21f2f523 --- /dev/null +++ b/src/tool/Utilitaire/utb314.h @@ -0,0 +1,20 @@ +c +c 2.3.1. ==> filtrage initial +c + logaux(7) = .false. +c + vn(1) = coonoe(lenoeu,1) + if ( vn(1).gt.xmin .and. vn(1).lt.xmax ) then + vn(2) = coonoe(lenoeu,2) + if ( vn(2).gt.ymin .and. vn(2).lt.ymax ) then + vn(3) = coonoe(lenoeu,3) + if ( vn(3).gt.zmin .and. vn(3).lt.zmax ) then + logaux(7) = .true. + do 232 , iaux = 1 , nbsomm + if ( lenoeu.eq.sommet(iaux) ) then + logaux(7) = .false. + endif + 232 continue + endif + endif + endif diff --git a/src/tool/Utilitaire/utb3a0.F b/src/tool/Utilitaire/utb3a0.F new file mode 100644 index 00000000..fdd32b08 --- /dev/null +++ b/src/tool/Utilitaire/utb3a0.F @@ -0,0 +1,422 @@ + subroutine utb3a0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > hetare, somare, posifa, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase A0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des aretes. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3A0' ) +c + integer typenh + parameter ( typenh = 1 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +#include "precis.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer hetare(nbarto), somare(2,nbarto), posifa(0:nbarto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer larete, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(3), nbsomm +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v1(3), v2(3), v4(3), v6(4,3), vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prosca + double precision daux1, daux2 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 2 + else + nbsomm = 3 + endif +c + v1(2) = 0.d0 + v2(2) = 0.d0 + vn(2) = 0.d0 + v1(3) = 0.d0 + v2(3) = 0.d0 + vn(3) = 0.d0 +c +c==== +c 2. controle de la non-interpenetration des aretes +c remarques : +c 1. on ne s'interesse qu'aux actives car les autres sont +c censees avoir ete controlees aux iterations anterieures +c 2. on ne s'interesse qu'aux aretes de region 1D, car celles qui +c bordent des faces seront vues par la suite. +c 3. La verification est plus sujette a caution car le test sur la +c colinearite est un test sur une egalite de reels ... +c==== +c + do 20 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + if ( larete.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hetare(larete),10).eq.0 ) then + if ( nbtrto.eq.0 .and. nbquto.eq.0 ) then + logaux(1) = .true. + else + if ( posifa(larete-1).eq.posifa(larete) ) then + logaux(1) = .true. + else + logaux(1) = .false. + endif + endif + else + logaux(1) = .false. + endif +c + if ( logaux(1) ) then +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +c 2.1. ==> les sommets de cette arete active +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typenh), larete + endif +#endif +c + sommet(1) = somare(1,larete) + sommet(2) = somare(2,larete) +c + if ( degre.eq.2 ) then + sommet(3) = np2are(larete) + endif +c +c 2.2. ==> l'enveloppe +c + v1(1) = coonoe(sommet(1),1) + if ( sdim.ge.2 ) then + v1(2) = coonoe(sommet(1),2) + if ( sdim.eq.3 ) then + v1(3) = coonoe(sommet(1),3) + endif + endif +c + v2(1) = coonoe(sommet(2),1) + if ( sdim.ge.2 ) then + v2(2) = coonoe(sommet(2),2) + if ( sdim.eq.3 ) then + v2(3) = coonoe(sommet(2),3) + endif + endif +c + xmin = min(v1(1),v2(1)) + xmax = max(v1(1),v2(1)) + ymin = min(v1(2),v2(2)) + ymax = max(v1(2),v2(2)) + zmin = min(v1(3),v2(3)) + zmax = max(v1(3),v2(3)) +c +c v6(1,.) represente le vecteur s1s2 +c + v6(1,1) = v2(1)-v1(1) + v6(1,2) = v2(2)-v1(2) + v6(1,3) = v2(3)-v1(3) +c +c v6(2,.) represente le vecteur s2s1 +c + v6(2,1) = - v6(1,1) + v6(2,2) = - v6(1,2) + v6(2,3) = - v6(1,3) +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont strictement dans le +c parallelepide enveloppe de l'arete +c . on commence par eliminer les deux noeuds extremes de l'arete +c . ensuite, on elimine les noeuds coincidents +c . on elimine les noeuds qui ne sont pas sur la ligne de l'arete +c . on recherche si le noeud est a l'interieur de l'arete +c + do 23 , lenoeu = numip1, numap1 +c +c 2.3.1. ==> filtrage initial +c +c ce test sur htenoe est tres couteux ici +cgn if ( mod(hetnoe(lenoeu),10).eq.1 ) then +c + logaux(7) = .false. +c + vn(1) = coonoe(lenoeu,1) + if ( vn(1).ge.xmin .and. vn(1).le.xmax ) then + if ( sdim.ge.2 ) then + vn(2) = coonoe(lenoeu,2) + if ( vn(2).ge.ymin .and. vn(2).le.ymax ) then + if ( sdim.eq.3 ) then + vn(3) = coonoe(lenoeu,3) + if ( vn(3).ge.zmin .and. vn(3).le.zmax ) then + logaux(7) = .true. + endif + else + logaux(7) = .true. + endif + endif + else + logaux(7) = .true. + endif + endif +c + if ( logaux(7) ) then + do 231 , iaux = 1 , nbsomm + if ( lenoeu.eq.sommet(iaux) ) then + goto 23 + endif + 231 continue + endif +c +c 2.3.2. ==> le noeud est-il coincident avec un des sommets ? +c + if ( logaux(7) ) then +c + if ( nbpbco(-1).gt.0 ) then +c + nucoin = numcoi(lenoeu) +c + if ( nucoin.ne.0 ) then +c + ptcode = coinpt(nucoin)+1 + ptcofi = coinpt(nucoin+1) + do 232 , ptcoin = ptcode, ptcofi + jaux = coinnn(ptcoin) + do 2321 , iaux = 1 , nbsomm + if ( jaux.eq.sommet(iaux) ) then + goto 23 + endif + 2321 continue + 232 continue +c + endif +c + endif +c + endif +c +c 2.3.3. ==> exclusivement les noeuds p1 +c + if ( logaux(7) ) then +c + if ( hetnoe(lenoeu).ne.1 .and. + > hetnoe(lenoeu).ne.21 .and. + > hetnoe(lenoeu).ne.51 ) then +c + logaux(7) = .false. +c + endif +c + endif +c +c 2.3.4. ==> le noeud est-il sur la ligne de l'arete ? +c on calcule les deux vecteurs (s1,s2) et (s1,n) +c on cherche s'ils sont paralleles +c + if ( logaux(7) ) then +c +c v4 represente le vecteur s1n +c + v4(1) = vn(1)-v1(1) + v4(2) = vn(2)-v1(2) + v4(3) = vn(3)-v1(3) +c +c daux2 represente la norme du produit vectoriel v4 x v6(1,.) +c + daux2 = abs ( v6(1,2) * v4(3) - v6(1,3) * v4(2) ) + > + abs ( v6(1,3) * v4(1) - v6(1,1) * v4(3) ) + > + abs ( v6(1,1) * v4(2) - v6(1,2) * v4(1) ) +c +c 2.3.4. ==> dans cette ligne, n est-il dedans ? +c cela est vrai si le noeud et un sommet sont dans la meme +c direction sur l'arete a partir de l'autre noeud. pour cela, +c on regarde si les produits scalaires ab.an sont positifs +c pour chaque permutation de a et b. +c + if ( daux2.le.epsima ) then +c +c 2.3.4.1. ==> critere absolu ou relatif +c + daux1 = 0.d0 +c +c 2.3.4.2. ==> a partir de s1 +c + prosca = v4(1)*v6(1,1) + v4(2)*v6(1,2) + v4(3)*v6(1,3) +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.4.3. ==> a partir de s2 +c +c v4 represente le vecteur s2n +c + v4(1) = vn(1)-v2(1) + v4(2) = vn(2)-v2(2) + v4(3) = vn(3)-v2(3) +c + prosca = v4(1)*v6(2,1) + v4(2)*v6(2,2) + v4(3)*v6(2,3) +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.4.4. ==> si on arrive ici, c'est que le noeud est sur l'arete +c ... malaise ... +c + iaux = larete +c +#include "utb302.h" +c + if ( sdim.eq.1 ) then + write (ulbila,14201) sommet(1), v1(1) + write (ulbila,14201) sommet(2), v2(1) + elseif ( sdim.eq.2 ) then + write (ulbila,14202) sommet(1), v1(1), v1(2) + write (ulbila,14202) sommet(2), v2(1), v2(2) + else + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + endif +c + write (ulbila,10200) +c + endif +c + endif +c + 23 continue +c + endif +c + 20 continue +c + end diff --git a/src/tool/Utilitaire/utb3b0.F b/src/tool/Utilitaire/utb3b0.F new file mode 100644 index 00000000..d740edc8 --- /dev/null +++ b/src/tool/Utilitaire/utb3b0.F @@ -0,0 +1,493 @@ + subroutine utb3b0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > hettri, aretri, voltri, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase B0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des triangles. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3B0' ) +c + integer typenh + parameter ( typenh = 2 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +#include "precis.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3), hettri(nbtrto), voltri(2,nbtrto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letria, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(6), nbsomm + integer a1, a2, a3 + integer sa1a2, sa2a3, sa3a1 +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v1(3), v2(3), v3(3), v4(3), v6(4,3), vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prosca + double precision daux1, daux2 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 3 + else + nbsomm = 6 + endif +c + if ( sdim.eq.2 ) then + v1(3) = 0.d0 + v2(3) = 0.d0 + v3(3) = 0.d0 + vn(3) = 0.d0 + endif +c + if ( nbteto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + logaux(2) = .true. + else + logaux(2) = .false. + endif +c +c==== +c 2. controle de la non-interpenetration des triangles +c remarque : +c La verification est sujette a caution car le test sur la +c coplanarite est un test sur une egalite de reels ... +c==== +c + do 20 , letria = 1 , nbtrto +c +#ifdef _DEBUG_HOMARD_ + if ( letria.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +c 2.1. ==> Filtrage +c 1. on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c 2. on ne s'interesse qu'aux triangles de region 2D, car ceux qui +c bordent des volumes seront vus par la suite. +c + if ( mod(hettri(letria),10).eq.0 ) then + if ( logaux(2) ) then + logaux(1) = .true. + else + if ( voltri(1,letria).eq.0 ) then + logaux(1) = .true. + else + logaux(1) = .false. + endif + endif + else + logaux(1) = .false. + endif +c + if ( logaux(1) ) then +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +c 2.3. ==> les aretes et les sommets de ce triangle +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typenh), letria + endif +#endif +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + sommet(1) = sa1a2 + sommet(2) = sa2a3 + sommet(3) = sa3a1 +c + if ( degre.eq.2 ) then + sommet(4) = np2are(a1) + sommet(5) = np2are(a2) + sommet(6) = np2are(a3) + endif +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + if ( sdim.eq.3 ) then + v1(3) = coonoe(sommet(1),3) + endif +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + if ( sdim.eq.3 ) then + v2(3) = coonoe(sommet(2),3) + endif +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + if ( sdim.eq.3 ) then + v3(3) = coonoe(sommet(3),3) + endif +c + xmin = min(v1(1),v2(1),v3(1)) + xmax = max(v1(1),v2(1),v3(1)) + ymin = min(v1(2),v2(2),v3(2)) + ymax = max(v1(2),v2(2),v3(2)) + zmin = min(v1(3),v2(3),v3(3)) + zmax = max(v1(3),v2(3),v3(3)) +c +c v6(1,.) est le produit vectoriel n1n2 x n1n3. +c + v6(1,1) = (v2(2)-v1(2)) * (v3(3)-v1(3)) + > - (v2(3)-v1(3)) * (v3(2)-v1(2)) + v6(1,2) = (v2(3)-v1(3)) * (v3(1)-v1(1)) + > - (v2(1)-v1(1)) * (v3(3)-v1(3)) + v6(1,3) = (v2(1)-v1(1)) * (v3(2)-v1(2)) + > - (v2(2)-v1(2)) * (v3(1)-v1(1)) +c +c v6(2,.) est le produit vectoriel n2n3 x n2n1. +c + v6(2,1) = (v3(2)-v2(2)) * (v1(3)-v2(3)) + > - (v3(3)-v2(3)) * (v1(2)-v2(2)) + v6(2,2) = (v3(3)-v2(3)) * (v1(1)-v2(1)) + > - (v3(1)-v2(1)) * (v1(3)-v2(3)) + v6(2,3) = (v3(1)-v2(1)) * (v1(2)-v2(2)) + > - (v3(2)-v2(2)) * (v1(1)-v2(1)) +c +c v6(3,.) est le produit vectoriel n3n1 x n3n2. +c + v6(3,1) = (v1(2)-v3(2)) * (v2(3)-v3(3)) + > - (v1(3)-v3(3)) * (v2(2)-v3(2)) + v6(3,2) = (v1(3)-v3(3)) * (v2(1)-v3(1)) + > - (v1(1)-v3(1)) * (v2(3)-v3(3)) + v6(3,3) = (v1(1)-v3(1)) * (v2(2)-v3(2)) + > - (v1(2)-v3(2)) * (v2(1)-v3(1)) +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont strictement dans le +c parallelepide enveloppe du triangle +c . on commence par eliminer les trois noeuds du triangle +c . ensuite, on elimine les noeuds coincidents +c . on recherche si le noeud est a l'interieur du triangle +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c En revanche, inutile de deplier davantage les tests +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds du triangle +c car on gagne aussi 40% ! +c + do 23 , lenoeu = numip1, numap1 +c + logaux(7) = .false. +c + vn(1) = coonoe(lenoeu,1) + if ( vn(1).ge.xmin .and. vn(1).le.xmax ) then + vn(2) = coonoe(lenoeu,2) + if ( vn(2).ge.ymin .and. vn(2).le.ymax ) then + if ( sdim.eq.3 ) then + vn(3) = coonoe(lenoeu,3) + if ( vn(3).ge.zmin .and. vn(3).le.zmax ) then + logaux(7) = .true. + endif + else + logaux(7) = .true. + endif + endif + endif +c + if ( logaux(7) ) then + do 231 , iaux = 1 , nbsomm + if ( lenoeu.eq.sommet(iaux) ) then + goto 23 + endif + 231 continue + endif +c +c 2.3.2. ==> le noeud est-il coincident avec un des sommets ? +c + if ( logaux(7) ) then +c + if ( nbpbco(-1).gt.0 ) then +c + nucoin = numcoi(lenoeu) +c + if ( nucoin.ne.0 ) then +c + ptcode = coinpt(nucoin)+1 + ptcofi = coinpt(nucoin+1) + do 232 , ptcoin = ptcode, ptcofi + jaux = coinnn(ptcoin) + do 2321 , iaux = 1 , nbsomm + if ( jaux.eq.sommet(iaux) ) then + goto 23 + endif + 2321 continue + 232 continue +c + endif +c + endif +c + endif +c +c 2.3.3. ==> exclusivement les noeuds p1 +c + if ( logaux(7) ) then +c + if ( hetnoe(lenoeu).ne.1 .and. + > hetnoe(lenoeu).ne.21 .and. + > hetnoe(lenoeu).ne.51 ) then +c + logaux(7) = .false. +c + endif +c + endif +c +c 2.3.2. ==> le noeud est-il dans le plan du triangle ? +c on calcule les deux vecteurs normaux aux triangles +c (s1,s2,s3) et (s1,s2,n) : vecteurs v6 et v4 +c on cherche s'ils sont paralleles, c'est-a-dire de produit +c vectoriel nul +c + if ( logaux(7) ) then +c +c v4 est le produit vectoriel n1n2 x n1n. +c + v4(1) = (v2(2)-v1(2)) * (vn(3)-v1(3)) + > - (v2(3)-v1(3)) * (vn(2)-v1(2)) + v4(2) = (v2(3)-v1(3)) * (vn(1)-v1(1)) + > - (v2(1)-v1(1)) * (vn(3)-v1(3)) + v4(3) = (v2(1)-v1(1)) * (vn(2)-v1(2)) + > - (v2(2)-v1(2)) * (vn(1)-v1(1)) +c +c daux2 represente la norme du produit vectoriel v4 x v6(1,.) +c + daux2 = abs ( v6(1,2) * v4(3) - v6(1,3) * v4(2) ) + > + abs ( v6(1,3) * v4(1) - v6(1,1) * v4(3) ) + > + abs ( v6(1,1) * v4(2) - v6(1,2) * v4(1) ) +c +c 2.3.3. ==> dans ce plan, n est-il dedans ? +c cela est vrai si le noeud et un sommet sont du meme cote +c de l'arete formee par les deux autres sommets. pour cela, +c on regarde si les produits vectoriels (ab,ac) et (ab,an) +c sont de meme orientation pour les trois permutations +c circulaires sur (a,b,c), c'est-a-dire si le produit +c scalaire des deux produits vectoriels est positif. +c on teste le caractere strictement positif du produit +c scalaire, pour pouvoir pieger les cas ou le noeud est sur +c une arete. +c + if ( daux2.le.epsima ) then +c +c 2.3.3.1. ==> critere absolu ou relatif +c + daux1 = 0.d0 +c +c 2.3.3.2. ==> arete (s1,s2) +c + prosca = v4(1)*v6(1,1) + v4(2)*v6(1,2) + v4(3)*v6(1,3) +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.3.3. ==> arete (s2,s3) +c +c v4 est le produit vectoriel n2n3 x s2n. +c + v4(1) = (v3(2)-v2(2)) * (vn(3)-v2(3)) + > - (v3(3)-v2(3)) * (vn(2)-v2(2)) + v4(2) = (v3(3)-v2(3)) * (vn(1)-v2(1)) + > - (v3(1)-v2(1)) * (vn(3)-v2(3)) + v4(3) = (v3(1)-v2(1)) * (vn(2)-v2(2)) + > - (v3(2)-v2(2)) * (vn(1)-v2(1)) +c + prosca = v4(1)*v6(2,1) + v4(2)*v6(2,2) + v4(3)*v6(2,3) +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.3.4. ==> arete (s3,s1) +c +c v4 est le produit vectoriel n3n1 x s3n. +c + v4(1) = (v1(2)-v3(2)) * (vn(3)-v3(3)) + > - (v1(3)-v3(3)) * (vn(2)-v3(2)) + v4(2) = (v1(3)-v3(3)) * (vn(1)-v3(1)) + > - (v1(1)-v3(1)) * (vn(3)-v3(3)) + v4(3) = (v1(1)-v3(1)) * (vn(2)-v3(2)) + > - (v1(2)-v3(2)) * (vn(1)-v3(1)) +c + prosca = v4(1)*v6(3,1) + v4(2)*v6(3,2) + v4(3)*v6(3,3) +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.5. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du triangle ... malaise ... +c + iaux = letria +c +#include "utb302.h" +c + if ( sdim.eq.2 ) then + write (ulbila,14202) sommet(1), v1(1), v1(2) + write (ulbila,14202) sommet(2), v2(1), v2(2) + write (ulbila,14202) sommet(3), v3(1), v3(2) + else + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + endif +c + write (ulbila,10200) +c + endif +c + endif +c + 23 continue +c + endif +c + 20 continue +c + end diff --git a/src/tool/Utilitaire/utb3c0.F b/src/tool/Utilitaire/utb3c0.F new file mode 100644 index 00000000..f249c3fc --- /dev/null +++ b/src/tool/Utilitaire/utb3c0.F @@ -0,0 +1,611 @@ + subroutine utb3c0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > hetqua, arequa, volqua, + > np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase C0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des quadrangles. +c remarque : cela suppose que les quadrangles sont plans +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . hetqua . e . nbtrto . historique de l'etat des quadrangles . +c . arequa . e .nbtrto*4. numeros des 3 aretes des quadrangles . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3C0' ) +c + integer typenh + parameter ( typenh = 4 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "precis.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer hetqua(nbquto), arequa(nbquto,4), volqua(2,nbquto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lequad, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(8), nbsomm + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v1(3), v2(3), v3(3), v4(3), vn(3) + double precision v5(2,3), v6(4,3) + double precision v12(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prosca + double precision daux1, daux2 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 4 + else + nbsomm = 8 + endif +c + if ( sdim.eq.2 ) then + v1(3) = 0.d0 + v2(3) = 0.d0 + v3(3) = 0.d0 + v4(3) = 0.d0 + vn(3) = 0.d0 + endif +c + if ( nbheto.eq.0 .and. nbpyto.eq.0 .and. nbpeto.eq.0 ) then + logaux(2) = .true. + else + logaux(2) = .false. + endif +c +c==== +c 2. controle de la non-interpenetration des quadrangles +c remarques : +c 3. La verification est sujette a caution car le test sur la +c coplanarite est un test sur une egalite de reels ... +c==== +cgn call gtdems (112) +c + do 20 , lequad = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + if ( lequad.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +c 2.1. ==> Filtrage +c 1. on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c 2. on ne s'interesse qu'aux quadrangles de region 2D, car ceux qui +c bordent des volumes seront vus par la suite. +c + if ( mod(hetqua(lequad),100).eq.0 ) then + if ( logaux(2) ) then + logaux(1) = .true. + else + if ( volqua(1,lequad).eq.0 ) then + logaux(1) = .true. + else + logaux(1) = .false. + endif + endif + else + logaux(1) = .false. + endif +c + if ( logaux(1) ) then +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +c 2.3. ==> les aretes et les sommets de ce quadrangle +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typenh), lequad + endif +#endif +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + sommet(1) = sa1a2 + sommet(2) = sa2a3 + sommet(3) = sa3a4 + sommet(4) = sa4a1 +c + if ( degre.eq.2 ) then + sommet(5) = np2are(a1) + sommet(6) = np2are(a2) + sommet(7) = np2are(a3) + sommet(8) = np2are(a4) + endif +c +c 2.3. ==> le parallelepipede enveloppe +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + if ( sdim.eq.3 ) then + v1(3) = coonoe(sommet(1),3) + endif +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + if ( sdim.eq.3 ) then + v2(3) = coonoe(sommet(2),3) + endif +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + if ( sdim.eq.3 ) then + v3(3) = coonoe(sommet(3),3) + endif +c + v4(1) = coonoe(sommet(4),1) + v4(2) = coonoe(sommet(4),2) + if ( sdim.eq.3 ) then + v4(3) = coonoe(sommet(4),3) + endif +c + xmin = min(v1(1),v2(1),v3(1),v4(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2)) + zmin = min(v1(3),v2(3),v3(3),v4(3)) + zmax = max(v1(3),v2(3),v3(3),v4(3)) +cgn if ( lequad.eq.1270 ) then +cgn print *,xmin,xmax,ymin,ymax,zmin,zmax +cgn endif +c + logaux(3) = .true. + logaux(4) = .true. +c +c 2.3. ==> on verifie que le quadrangle est plan +c on calcule les deux vecteurs normaux aux deux triangles +c inclus dans le quadrangle, (s1,s2,s4) et (s3,s2,s4). +c on cherche s'ils sont paralleles, c'est-a-dire de produit +c vectoriel nul +c +c v6(1,.) est le produit vectoriel n1n2 x n1n4. +c + v6(1,1) = (v2(2)-v1(2)) * (v4(3)-v1(3)) + > - (v2(3)-v1(3)) * (v4(2)-v1(2)) + v6(1,2) = (v2(3)-v1(3)) * (v4(1)-v1(1)) + > - (v2(1)-v1(1)) * (v4(3)-v1(3)) + v6(1,3) = (v2(1)-v1(1)) * (v4(2)-v1(2)) + > - (v2(2)-v1(2)) * (v4(1)-v1(1)) +c +c v6(3,.) est le produit vectoriel n3n4 x n3n2. +c + v6(3,1) = (v4(2)-v3(2)) * (v2(3)-v3(3)) + > - (v4(3)-v3(3)) * (v2(2)-v3(2)) + v6(3,2) = (v4(3)-v3(3)) * (v2(1)-v3(1)) + > - (v4(1)-v3(1)) * (v2(3)-v3(3)) + v6(3,3) = (v4(1)-v3(1)) * (v2(2)-v3(2)) + > - (v4(2)-v3(2)) * (v2(1)-v3(1)) +c +c daux2 est le carre de la norme du produit vectoriel +c v6(1,.) x v6(3,.) +c + daux2 = abs ( v6(3,2)*v6(1,3) - v6(3,3)*v6(1,2) ) + > + abs ( v6(3,3)*v6(1,1) - v6(3,1)*v6(1,3) ) + > + abs ( v6(3,1)*v6(1,2) - v6(3,2)*v6(1,1) ) +c + if ( daux2.gt.epsima ) then +cgn print *,'Quadrangle ',lequad,' non plan.' + goto 20 + endif +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont strictement dans le +c parallelepide enveloppe du quadrangle +c . on commence par eliminer les quatre noeuds du quadrangle +c . ensuite, on elimine les noeuds coincidents +c . on elimine les noeuds qui ne sont pas dans le plan du +c quadrangle +c . on recherche si le noeud est a l'interieur du quadrangle +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds du quadrangle +c car on gagne aussi 40% ! +c En revanche, inutile de deplier davantage les tests +c + do 23 , lenoeu = numip1, numap1 +c + logaux(7) = .false. +c + vn(1) = coonoe(lenoeu,1) + if ( vn(1).ge.xmin .and. vn(1).le.xmax ) then + vn(2) = coonoe(lenoeu,2) + if ( vn(2).ge.ymin .and. vn(2).le.ymax ) then + if ( sdim.eq.3 ) then + vn(3) = coonoe(lenoeu,3) + if ( vn(3).ge.zmin .and. vn(3).le.zmax ) then + logaux(7) = .true. + endif + else + logaux(7) = .true. + endif + endif + endif +c + if ( logaux(7) ) then + do 231 , iaux = 1 , nbsomm + if ( lenoeu.eq.sommet(iaux) ) then + goto 23 + endif + 231 continue + endif +c +c 2.3.2. ==> le noeud est-il coincident avec un des sommets ? +c + if ( logaux(7) ) then +c + if ( nbpbco(-1).gt.0 ) then +c + nucoin = numcoi(lenoeu) +c + if ( nucoin.ne.0 ) then +c + ptcode = coinpt(nucoin)+1 + ptcofi = coinpt(nucoin+1) + do 232 , ptcoin = ptcode, ptcofi + jaux = coinnn(ptcoin) + do 2321 , iaux = 1 , nbsomm + if ( jaux.eq.sommet(iaux) ) then + goto 23 + endif + 2321 continue + 232 continue +c + endif +c + endif +c + endif +c +c 2.3.3. ==> exclusivement les noeuds p1 +c + if ( logaux(7) ) then +c + if ( hetnoe(lenoeu).ne.1 .and. + > hetnoe(lenoeu).ne.21 .and. + > hetnoe(lenoeu).ne.51 ) then +c + logaux(7) = .false. +c + endif +c + endif +c +c 2.3.3. ==> En 3D, le noeud est-il dans le plan du quadrangle ? +c on calcule les deux vecteurs normaux aux quadrangles +c (s1,s2,s3,s4) et (s1,s2,s3,n). En fait, il suffit de +c s'interesser aux vecteurs normaux aux sous-triangles +c (s1,s2,s4) et (s1,s2,n), vecteurs v6 et v5 +c on cherche s'ils sont paralleles, c'est-a-dire de produit +c vectoriel nul +c + if ( logaux(7) ) then +c +c v5(1,.) est le produit vectoriel n1n2 x n1n. +c + if ( sdim.eq.3 ) then +c + if ( logaux(3) ) then +c + v12(1) = v2(1)-v1(1) + v12(2) = v2(2)-v1(2) + v12(3) = v2(3)-v1(3) +c + logaux(3) = .false. +c + endif +c + v5(1,1) = v12(2) * (vn(3)-v1(3)) + > - v12(3) * (vn(2)-v1(2)) + v5(1,2) = v12(3) * (vn(1)-v1(1)) + > - v12(1) * (vn(3)-v1(3)) + v5(1,3) = v12(1) * (vn(2)-v1(2)) + > - v12(2) * (vn(1)-v1(1)) +c +c daux2 represente la norme du produit vectoriel v5 x v6(1,.) +c + daux2 = abs ( v6(1,2)*v5(1,3) - v6(1,3)*v5(1,2) ) + > + abs ( v6(1,3)*v5(1,1) - v6(1,1)*v5(1,3) ) + > + abs ( v6(1,1)*v5(1,2) - v6(1,2)*v5(1,1) ) +c + else +c + daux2 = -1.d0 +c + endif +c +c 2.3.4. ==> dans ce plan, n est-il dedans ? +c cela est vrai si les 4 triangles batis sur ce noeud sont +c orientes de la meme facon. Pour cela, on regarde si les +c quatre produits vectoriels (na,nb) sont de meme orientation +c pour les quatre permutations circulaires sur (a,b,c,d), +c c'est-a-dire si le produit scalaire des produits vectoriels +c est de meme signe. +c +c n1 x------------------x n2 +c x . x . +c x . x . +c x . x . +c x . x . +c x . x . +c x .x . +c x x . . +c n4 x------------------x . . +c . n3 . . . +c . n +c +c + if ( daux2.le.epsima ) then +c +c 2.3.4.1. ==> critere absolu ou relatif +c + daux1 = 0.d0 +c +c 2.3.4.2. ==> triangle (n,n1,n2) +c +c v5(1,.) est le produit vectoriel nn1 x nn2 +c + v5(1,1) = (v1(2)-vn(2)) * (v2(3)-vn(3)) + > - (v1(3)-vn(3)) * (v2(2)-vn(2)) + v5(1,2) = (v1(3)-vn(3)) * (v2(1)-vn(1)) + > - (v1(1)-vn(1)) * (v2(3)-vn(3)) + v5(1,3) = (v1(1)-vn(1)) * (v2(2)-vn(2)) + > - (v1(2)-vn(2)) * (v2(1)-vn(1)) +c +c 2.3.4.3. ==> triangle (n,n2,n3) +c +c v5(2,.) est le produit vectoriel nn2 x nn3 +c + v5(2,1) = (v2(2)-vn(2)) * (v3(3)-vn(3)) + > - (v2(3)-vn(3)) * (v3(2)-vn(2)) + v5(2,2) = (v2(3)-vn(3)) * (v3(1)-vn(1)) + > - (v2(1)-vn(1)) * (v3(3)-vn(3)) + v5(2,3) = (v2(1)-vn(1)) * (v3(2)-vn(2)) + > - (v2(2)-vn(2)) * (v3(1)-vn(1)) +c +c si v5(1,.) est le vecteur nul, cela signifie que les noeuds +c n, n1 et n2 sont alignes. Il ne faut donc pas se poser la +c question du triangle (n,n1,n2). On remplace alors (n,n1,n2) +c par (n,n2,n3) comme triangle de reference, c'est-a-dire +c v5(1,.) par v5(2,.). +c On aura remarque que dans ces conditions le vecteur v5(2,.) +c ne peut pas etre nul, sinon cela signifierait que les 3 +c noeuds n1, n2 et n3 sont alignes. +c + if ( ( v5(1,1)*v5(1,1) + v5(1,2)*v5(1,2) + > + v5(1,3)*v5(1,3) ) .le. daux1 ) then + v5(1,1) = v5(2,1) + v5(1,2) = v5(2,2) + v5(1,3) = v5(2,3) + else + prosca = + > v5(1,1)*v5(2,1) + v5(1,2)*v5(2,2) + v5(1,3)*v5(2,3) +cgn if ( lequad.eq.1270 .and. lenoeu.eq.7119 ) then +cgn print *,v5(1,1),v5(1,2),v5(1,3) +cgn print *,v5(2,1),v5(2,2),v5(2,3) +cgn print *,'==> prosca = ',prosca +cgn endif +c + if ( prosca.lt.daux1 ) then + goto 23 + endif + endif +c +c 2.3.4.4. ==> triangle (n,n3,n4) +c +c v5(2,.) est le produit vectoriel nn3 x nn4 +c + v5(2,1) = (v3(2)-vn(2)) * (v4(3)-vn(3)) + > - (v3(3)-vn(3)) * (v4(2)-vn(2)) + v5(2,2) = (v3(3)-vn(3)) * (v4(1)-vn(1)) + > - (v3(1)-vn(1)) * (v4(3)-vn(3)) + v5(2,3) = (v3(1)-vn(1)) * (v4(2)-vn(2)) + > - (v3(2)-vn(2)) * (v4(1)-vn(1)) +c + prosca = + > v5(1,1)*v5(2,1) + v5(1,2)*v5(2,2) + v5(1,3)*v5(2,3) +c +cgn if ( lequad.eq.1270 .and. lenoeu.eq.7119 ) then +cgn print *,v5(2,1),v5(2,2),v5(2,3) +cgn print *,'==> prosca = ',prosca +cgn endif + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.4.5. ==> triangle (n,n4,n1) +c +c v5(2,.) est le produit vectoriel nn4 x nn1 +c + v5(2,1) = (v4(2)-vn(2)) * (v1(3)-vn(3)) + > - (v4(3)-vn(3)) * (v1(2)-vn(2)) + v5(2,2) = (v4(3)-vn(3)) * (v1(1)-vn(1)) + > - (v4(1)-vn(1)) * (v1(3)-vn(3)) + v5(2,3) = (v4(1)-vn(1)) * (v1(2)-vn(2)) + > - (v4(2)-vn(2)) * (v1(1)-vn(1)) +c + prosca = + > v5(1,1)*v5(2,1) + v5(1,2)*v5(2,2) + v5(1,3)*v5(2,3) +cgn if ( lequad.eq.1270 .and. lenoeu.eq.7119 ) then +cgn print *,v5(2,1),v5(2,2),v5(2,3) +cgn print *,'==> prosca = ',prosca +cgn endif +c + if ( prosca.lt.daux1 ) then + goto 23 + endif +c +c 2.3.5. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du quadrangle ... malaise ... +c + iaux = lequad +c +#include "utb302.h" +c + if ( sdim.eq.2 ) then + write (ulbila,14202) sommet(1), v1(1), v1(2) + write (ulbila,14202) sommet(2), v2(1), v2(2) + write (ulbila,14202) sommet(3), v3(1), v3(2) + write (ulbila,14202) sommet(4), v4(1), v4(2) + else + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + endif +c + write (ulbila,10200) +c + endif +c + endif +c + 23 continue +c + endif +c + 20 continue +cgn call gtfims (112) +c + end diff --git a/src/tool/Utilitaire/utb3d0.F b/src/tool/Utilitaire/utb3d0.F new file mode 100644 index 00000000..a90157d8 --- /dev/null +++ b/src/tool/Utilitaire/utb3d0.F @@ -0,0 +1,234 @@ + subroutine utb3d0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > aretri, + > hettet, tritet, cotrte, aretet, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase D0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3D0' ) +c + integer typenh + parameter ( typenh = 3 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letetr, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(10), nbsomm + integer listar(6) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v0(4,3) + double precision v1(3), v2(3), v3(3), v4(3) + double precision v21(3), v23(3), v24(3), v41(3), v43(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 4 + else + nbsomm = 10 + endif +c +c==== +c 2. controle de la non-interpenetration des tetraedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , letetr = 1 , nbteto +c +#ifdef _DEBUG_HOMARD_ + if ( letetr.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hettet(letetr),100).eq.0 ) then +cgn call gtdems (93) +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +#include "utb3d1.h" +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + endif +#endif +c + do 23 , lenoeu = numip1, numap1 +c +#include "utb304.h" +c +#include "utb305.h" +c +#include "utb306.h" +c +#include "utb3d2.h" +c +c 2.3.7. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du tetraedre ... malaise ... +c + if ( logaux(7) ) then +c + iaux = letetr +c +#include "utb302.h" +c + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) +c + write (ulbila,10200) +c + endif +c + 23 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c + end diff --git a/src/tool/Utilitaire/utb3d1.F b/src/tool/Utilitaire/utb3d1.F new file mode 100644 index 00000000..acf66e28 --- /dev/null +++ b/src/tool/Utilitaire/utb3d1.F @@ -0,0 +1,284 @@ + subroutine utb3d1 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > aretri, + > hettet, tritet, cotrte, aretet, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase D1 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle la presence de noeuds dans les tetraedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . es . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . es . 1 . nombre de corrections pour les aretes . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3D1' ) +c + integer typenh + parameter ( typenh = 3 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letetr, larete, lenoeu + integer nuarfr + integer nbexam, examno(2), examar(2) + integer sommet(10), nbsomm + integer listar(6) + integer arequa(1,4), filqua(1) + integer cfaqua(1,1), famqua(1) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v0(4,3) + double precision v1(3), v2(3), v3(3), v4(3) + double precision v21(3), v23(3), v24(3), v41(3), v43(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb303.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 4 + else + nbsomm = 10 + endif +c + nbcoar = 0 + nbcoqu = 0 +c +c==== +c 2. controle de la penetration de noeuds dans les tetraedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , letetr = 1 , nbteto +c +#ifdef _DEBUG_HOMARD_ + if ( letetr.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hettet(letetr),100).eq.0 ) then +cgn call gtdems (93) +cgn write (ulsort,*) '.. ', mess14(langue,2,3), letetr +c +#include "utb3d1.h" +c +c 2.2. ==> Les aretes +c + do 22 , nuarfr = 1 , nbarfr +c +#include "utb308.h" +c +c 2.2.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete +#endif +c + do 223 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb304.h" +c +#include "utb3d2.h" +c +c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du tetraedre ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoar = nbcoar + 1 + arefro(nuarfr) = -larete +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro +#endif + call utcorn ( lenoeu, 0, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 223 continue +c + endif +c + 22 continue +cgn call gtfims (93) +c + endif +c + 20 continue +cgn call gtfims (92) +c +c==== +c 3. La fin +c==== +c +#include "utb307.h" +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3d1.h b/src/tool/Utilitaire/utb3d1.h new file mode 100644 index 00000000..8f082731 --- /dev/null +++ b/src/tool/Utilitaire/utb3d1.h @@ -0,0 +1,87 @@ +c +c 2.1. ==> les aretes et les sommets de ce tetraedre actif +c vi(1->3) = coordonnees du sommet si +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typenh), letetr + endif +#endif +c + if ( letetr.le.nbtecf ) then +c + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + else +c + do 210 , iaux = 1 , 6 + listar(iaux) = aretet(letetr-nbtecf,iaux) + 210 continue +c + endif +c + call utsote ( somare, listar, sommet ) +c + if ( degre.eq.2 ) then + do 211 , iaux = 1 , 6 + sommet(4+iaux) = np2are(listar(iaux)) + 211 continue + endif +c +c 2.2. ==> le parallelepipede enveloppe +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + v1(3) = coonoe(sommet(1),3) +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + v2(3) = coonoe(sommet(2),3) +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + v3(3) = coonoe(sommet(3),3) +c + v4(1) = coonoe(sommet(4),1) + v4(2) = coonoe(sommet(4),2) + v4(3) = coonoe(sommet(4),3) +c + xmin = min(v1(1),v2(1),v3(1),v4(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2)) + zmin = min(v1(3),v2(3),v3(3),v4(3)) + zmax = max(v1(3),v2(3),v3(3),v4(3)) +c + logaux(1) = .true. + logaux(2) = .true. + logaux(3) = .true. + logaux(4) = .true. +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont contenus dans le +c parallelepide enveloppe du tetraedre +c . ensuite, on elimine les noeuds coincidents +c . en degre 2, les noeuds milieux sont examines strictement en +c mode debug, relativement en mode optimise. +c . on recherche si le noeud est a l'interieur du tetraedre +c cela est vrai si le noeud et un sommet sont du meme cote du +c plan forme par les trois autres sommets. pour cela, on +c regarde si les produits mixtes (ab,ac,ad) et (ab,ac,an) sont +c de meme signe pour les quatre permutations circulaires +c sur (a,b,c,d) +c . on elimine les quatre noeuds du tetraedre +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds du tetraedre +c car on gagne aussi 40% ! +c En revanche, inutile de deplier davantage les tests +c +cgn call gtfims (93) diff --git a/src/tool/Utilitaire/utb3d2.h b/src/tool/Utilitaire/utb3d2.h new file mode 100644 index 00000000..3a8272ec --- /dev/null +++ b/src/tool/Utilitaire/utb3d2.h @@ -0,0 +1,184 @@ +c +c 2.3.3. ==> face f1 : plan (s2,s3,s4) +c prmito est le produit mixte du tetraedre total ; selon +c l'orientation, il est >0 ou <0. +c prmilo est le produit mixte pointant sur le noeud a tester. +c il faut que prmito et prmilo soient de meme signe pour que +c le noeud soit du meme cote du plan (s2,s3,s4) que s1. +c on teste le caractere strictement positif du produit +c prmito x prmilo, pour pouvoir pieger les cas ou le +c noeud est sur une face. +cgn call gtdems (94) +c + if ( logaux(7) ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... ', mess14(langue,2,-1), lenoeu + endif +#endif +c + daux1 = 0.d0 +c + if ( logaux(1) ) then +c + v24(1) = v4(1)-v2(1) + v24(2) = v4(2)-v2(2) + v24(3) = v4(3)-v2(3) +c + v23(1) = v3(1)-v2(1) + v23(2) = v3(2)-v2(2) + v23(3) = v3(3)-v2(3) +c + v21(1) = v1(1)-v2(1) + v21(2) = v1(2)-v2(2) + v21(3) = v1(3)-v2(3) +c +c v0(1,.) est le produit vectoriel s2s4 x s2s3. +c + v0(1,1) = v24(2)*v23(3) - v24(3)*v23(2) + v0(1,2) = v24(3)*v23(1) - v24(1)*v23(3) + v0(1,3) = v24(1)*v23(2) - v24(2)*v23(1) +c +c prmito est le produit mixte (s2s4,s2s3,s2s1) +c + prmito = v0(1,1)*v21(1) + > + v0(1,2)*v21(2) + > + v0(1,3)*v21(3) +c +c si le produit mixte est nul, c'est que le volume est nul +c on ne controle donc rien +c + if ( prmito.le.daux1 ) then + goto 20 + endif +c + logaux(1) = .false. +c + endif +c +c prmilo est le produit mixte (s2s4,s2s3,s2sn) +c + prmilo = v0(1,1)*(vn(1)-v2(1)) + > + v0(1,2)*(vn(2)-v2(2)) + > + v0(1,3)*(vn(3)-v2(3)) +c +cgn call gtfims (94) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.4. ==> idem pour la face f2 : plan (s1,s3,s4) +cgn call gtdems (95) +c + if ( logaux(7) ) then +c + if ( logaux(2) ) then +c + v41(1) = v1(1)-v4(1) + v41(2) = v1(2)-v4(2) + v41(3) = v1(3)-v4(3) +c + v43(1) = v3(1)-v4(1) + v43(2) = v3(2)-v4(2) + v43(3) = v3(3)-v4(3) +c +c v0(2,.) est le produit vectoriel s4s1 x s4s3 +c + v0(2,1) = v41(2)*v43(3) - v41(3)*v43(2) + v0(2,2) = v41(3)*v43(1) - v41(1)*v43(3) + v0(2,3) = v41(1)*v43(2) - v41(2)*v43(1) +c +c prmito est le produit mixte (s2s4,s2s3,s2s1) +c = (s2s4,s2s4+s4s3,s2s4+s4s1) +c = (s2s4,s4s3,s4s1) +c = (s4s3,s4s1,s2s4) +c = -(s4s1,s4s3,s2s4) +c = (s4s1,s4s3,s4s2) +c + logaux(2) = .false. +c + endif +c +c prmilo est le produit mixte (s4s1,s4s3,s4sn) +c + prmilo = v0(2,1)*(vn(1)-v4(1)) + > + v0(2,2)*(vn(2)-v4(2)) + > + v0(2,3)*(vn(3)-v4(3)) +c +cgn call gtfims (95) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.5. ==> idem pour la face f3 : plan (s1,s4,s2) +cgn call gtdems (96) +c + if ( logaux(7) ) then +c + if ( logaux(3) ) then +c +c v0(3,.) est le produit vectoriel s4s2 x s4s1 +c + v0(3,1) = - v24(2)*v41(3) + v24(3)*v41(2) + v0(3,2) = - v24(3)*v41(1) + v24(1)*v41(3) + v0(3,3) = - v24(1)*v41(2) + v24(2)*v41(1) +c +c prmito est le produit mixte (s2s4,s2s3,s2s1) +c = (s2s4,s2s4+s4s3,s2s4+s4s1) +c = (s2s4,s4s3,s4s1) +c = -(s4s2,s4s3,s4s1) +c = (s4s2,s4s1,s4s3) +c + logaux(3) = .false. +c + endif +c +c prmilo est le produit mixte (s4s2,s4s1,s4sn) +c + prmilo = v0(3,1)*(vn(1)-v4(1)) + > + v0(3,2)*(vn(2)-v4(2)) + > + v0(3,3)*(vn(3)-v4(3)) +c +cgn call gtfims (96) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.6. ==> idem pour la face f4 : plan (s1,s2,s3) +cgn call gtdems (97) +c + if ( logaux(7) ) then +c + if ( logaux(4) ) then +c +c v0(4,.) est le produit vectoriel s2s3 x s2s1 +c + v0(4,1) = v23(2)*v21(3) - v23(3)*v21(2) + v0(4,2) = v23(3)*v21(1) - v23(1)*v21(3) + v0(4,3) = v23(1)*v21(2) - v23(2)*v21(1) +c +c prmito est le produit mixte (s2s4,s2s3,s2s1) +c = (s2s3,s2s1,s2s4) +c + logaux(4) = .false. +c + endif +c +c prmilo est le produit mixte (s2s3,s2s1,s2sn) +c + prmilo = v0(4,1)*(vn(1)-v2(1)) + > + v0(4,2)*(vn(2)-v2(2)) + > + v0(4,3)*(vn(3)-v2(3)) +c +cgn call gtfims (97) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif diff --git a/src/tool/Utilitaire/utb3e0.F b/src/tool/Utilitaire/utb3e0.F new file mode 100644 index 00000000..b16b3c87 --- /dev/null +++ b/src/tool/Utilitaire/utb3e0.F @@ -0,0 +1,307 @@ + subroutine utb3e0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > arequa, + > hethex, quahex, coquhe, arehex, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase E0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des hexaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3E0' ) +c + integer typenh + parameter ( typenh = 6 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lehexa, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(20), nbsomm + integer listar(12) +c + double precision v0(6,3) + double precision v1(3), v2(3), v3(3), v4(3) + double precision v5(3), v6(3), v7(3), v8(3) + double precision v12(3), v14(3), v16(3) + double precision v83(3), v85(3), v87(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + integer glop + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "utb300.h" +c +#include "utb301.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpbco', nbpbco +#endif +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 8 + else + nbsomm = 20 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheto', nbheto + write (ulsort,90002) 'nbhecf', nbhecf + write (ulsort,90002) 'degre ', degre +#endif +c +c==== +c 2. controle de la non-interpenetration des hexaedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , lehexa = 1 , nbheto +c +#ifdef _DEBUG_HOMARD_ + if ( lehexa.lt.0 ) then + glop = 1 + write (ulsort,*) ' ' + write (ulsort,90002) mess14(langue,1,typenh), lehexa + write (ulsort,90112) 'etat', lehexa,hethex(lehexa) +cgn write (ulsort,90112) 'nbpbco', typenh,nbpbco(typenh) + else + glop = 0 + endif +#endif +c + if ( mod(hethex(lehexa),1000).eq.0 ) then +cgn call gtdems (93) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90112) nompro//' quahex', lehexa, + > (quahex(lehexa,iaux),iaux=1,6) + write (ulsort,90112) nompro//' coquhe', lehexa, + > (coquhe(lehexa,iaux),iaux=1,6) + endif +#endif +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +#include "utb3e1.h" +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulsort,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulsort,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulsort,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulsort,14203) sommet(5), v5(1), v5(2), v5(3) + write (ulsort,14203) sommet(6), v6(1), v6(2), v6(3) + write (ulsort,14203) sommet(7), v7(1), v7(2), v7(3) + write (ulsort,14203) sommet(8), v8(1), v8(2), v8(3) + write (ulsort,90004) 'X min/max', xmin, xmax + write (ulsort,90004) 'Y min/max', ymin, ymax + write (ulsort,90004) 'Z min/max', zmin, zmax + write (ulsort,90002) 'numip1, numap1',numip1, numap1 + endif +#endif +c + do 23 , lenoeu = numip1, numap1 +c +#include "utb304.h" +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .and. lenoeu.lt.0 ) then + write (ulsort,*) 'apres utb304', logaux(7) + write (ulsort,90004) 'vn', vn + endif +#endif +c +#include "utb305.h" +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .and. lenoeu.lt.0 ) then + write (ulsort,*) 'apres utb305', logaux(7) + endif +#endif +c +#include "utb306.h" +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .and. lenoeu.lt.0 ) then + write (ulsort,*) 'apres utb306', logaux(7) + endif +#endif +c +#include "utb3e2.h" +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 .and. lenoeu.lt.0 ) then + write (ulsort,*) 'apres utb3e2', logaux(7) + endif +#endif +c +c 2.3.9. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de l'hexaedre ... malaise ... +c + if ( logaux(7) ) then +c + iaux = lehexa +c +#include "utb302.h" +c + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3) + write (ulbila,14203) sommet(6), v6(1), v6(2), v6(3) + write (ulbila,14203) sommet(7), v7(1), v7(2), v7(3) + write (ulbila,14203) sommet(8), v8(1), v8(2), v8(3) +c + write (ulbila,10200) +c + endif +c + 23 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpbco', nbpbco +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3e1.F b/src/tool/Utilitaire/utb3e1.F new file mode 100644 index 00000000..aea177a6 --- /dev/null +++ b/src/tool/Utilitaire/utb3e1.F @@ -0,0 +1,415 @@ + subroutine utb3e1 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > hethex, quahex, coquhe, arehex, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase E1 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle la presence de noeuds dans les hexaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . es . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . es . 1 . nombre de corrections pour les aretes . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3E1' ) +c + integer typenh + parameter ( typenh = 6 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lehexa, lequad, larete, lenoeu + integer nuarfr, nuqufr + integer nbexam, examno(2), examar(2) + integer sommet(20), nbsomm + integer listar(12) +c + double precision v0(6,3) + double precision v1(3), v2(3), v3(3), v4(3) + double precision v5(3), v6(3), v7(3), v8(3) + double precision v12(3), v14(3), v16(3) + double precision v83(3), v85(3), v87(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + integer glop + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +c ulsort=6 +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb303.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 8 + else + nbsomm = 20 + endif +c + nbcoar = 0 + nbcoqu = 0 +cgn write (ulsort,*) 'nbqufr =',nbqufr +cgn write (ulsort,*) (quafro(nuqufr) ,nuqufr=1,nbqufr) +cgn write (ulsort,*) 'nbarfr =',nbarfr +cgn write (ulsort,*) (arefro(nuarfr) ,nuarfr=1,nbarfr) +c +c==== +c 2. controle de la presence de noeuds dans les hexaedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +c + do 20 , lehexa = 1 , nbheto +c +#ifdef _DEBUG_HOMARD_ + if ( lehexa.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hethex(lehexa),1000).eq.0 ) then +cgn call gtdems (93) +c +#include "utb3e1.h" +c +c 2.1. ==> Les quadrangles +c + do 21 , nuqufr = 1 , nbqufr +c +c 2.1.1. ==> Elimination des situations ou il est inutile +c de controler car le quadrangle a deja ete ramene +c + lequad = quafro(nuqufr) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write (ulsort,*) 'quafro(',nuqufr,') =', lequad + endif +#endif +c + if ( lequad.le.0 ) then + goto 21 + endif +c +c 2.1.2. ==> Reperage des situations a examiner : +c . le noeud central du quadrangle decoupe +c . les noeuds P2 courbes : a faire +c ce noeud central est la seconde extremite de la 2eme ou 3eme +c arete de l'un quelconque des quadrangles fils (cf. cmrdqu) +c + if ( codret.eq.0 ) then +c + if ( typsfr.le.2 ) then + nbexam = 1 + larete = arequa(filqua(lequad),2) + examno(1) = somare(2,larete) + else + codret = 212 + endif +c + endif +c +c 2.1.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad +#endif +c + do 213 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb304.h" +c +cgn write(ulsort,1789) vn +cgn write(ulsort,1789) xmin,xmax +cgn write(ulsort,1789) ymin,ymax +cgn write(ulsort,1789) zmin,zmax +cgn write(ulsort,*) logaux(7) +cgn 1789 format(3g12.5) +c +#include "utb3e2.h" +c +c 2.1.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de l'hexaedre ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoqu = nbcoqu + 1 + quafro(nuqufr) = -lequad +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro +#endif + call utcorn ( lenoeu, lequad, 0, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 213 continue +c + endif +c + 21 continue +c +c 2.2. ==> Les aretes +c + do 22 , nuarfr = 1 , nbarfr +c +#include "utb308.h" +c +c 2.2.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete +#endif +c + do 223 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb314.h" +#ifdef _DEBUG_HOMARD_ + if ( lenoeu.eq.-13186 .and. logaux(7)) then + glop=1 + else + glop=0 + endif +#endif +c +#include "utb3e2.h" +c +c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de l'hexaaedre ... correction +c + if ( logaux(7) ) then +c + if ( lenoeu.eq.13186 ) then + write(ulsort,1789) 'vn ',vn + write(ulsort,1789) 'xmin,xmax',xmin,xmax + write(ulsort,1789) 'ymin,ymax',ymin,ymax + write(ulsort,1789) 'zmin,zmax',zmin,zmax + write(ulsort,*) logaux(7) + 1789 format(a,3g12.5) + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 )then + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu + write (ulsort,*) mess14(langue,1,1), larete + endif +#endif +c + nbcoar = nbcoar + 1 + arefro(nuarfr) = -larete +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro +#endif + call utcorn ( lenoeu, 0, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 223 continue +c + endif +c + 22 continue +c + endif +c + 20 continue +cgn write (ulsort,*) (quafro(nuqufr) ,nuqufr=1,nbqufr) +cgn write (ulsort,*) (arefro(nuarfr) ,nuarfr=1,nbarfr) +c +c==== +c 3. La fin +c==== +c +#include "utb307.h" +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3e1.h b/src/tool/Utilitaire/utb3e1.h new file mode 100644 index 00000000..34f090c5 --- /dev/null +++ b/src/tool/Utilitaire/utb3e1.h @@ -0,0 +1,116 @@ +c +c 2.1. ==> les aretes et les sommets de cet hexaedre actif +c vi(1->3) = coordonnees du sommet si +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,1,typenh), lehexa + endif +#endif +c + if ( lehexa.le.nbhecf ) then +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + else +c + do 210 , iaux = 1 , 12 + listar(iaux) = arehex(lehexa-nbhecf,iaux) + 210 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) 'listar', (listar(iaux),iaux=1,10) + write (ulsort,90002) 'listar', (listar(iaux),iaux=11,12) + endif +#endif +c + call utsohe ( somare, listar, sommet ) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) 'sommet', sommet + endif +#endif +c + if ( degre.eq.2 ) then + do 211 , iaux = 1 , 12 + sommet(8+iaux) = np2are(listar(iaux)) + 211 continue + endif +c +c 2.2. ==> le parallelepipede enveloppe +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + v1(3) = coonoe(sommet(1),3) +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + v2(3) = coonoe(sommet(2),3) +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + v3(3) = coonoe(sommet(3),3) +c + v4(1) = coonoe(sommet(4),1) + v4(2) = coonoe(sommet(4),2) + v4(3) = coonoe(sommet(4),3) +c + v5(1) = coonoe(sommet(5),1) + v5(2) = coonoe(sommet(5),2) + v5(3) = coonoe(sommet(5),3) +c + v6(1) = coonoe(sommet(6),1) + v6(2) = coonoe(sommet(6),2) + v6(3) = coonoe(sommet(6),3) +c + v7(1) = coonoe(sommet(7),1) + v7(2) = coonoe(sommet(7),2) + v7(3) = coonoe(sommet(7),3) +c + v8(1) = coonoe(sommet(8),1) + v8(2) = coonoe(sommet(8),2) + v8(3) = coonoe(sommet(8),3) +c + xmin = min(v1(1),v2(1),v3(1),v4(1),v5(1),v6(1),v7(1),v8(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1),v5(1),v6(1),v7(1),v8(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2),v5(2),v6(2),v7(2),v8(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2),v5(2),v6(2),v7(2),v8(2)) + zmin = min(v1(3),v2(3),v3(3),v4(3),v5(3),v6(3),v7(3),v8(3)) + zmax = max(v1(3),v2(3),v3(3),v4(3),v5(3),v6(3),v7(3),v8(3)) +c + logaux(1) = .true. + logaux(2) = .true. + logaux(3) = .true. + logaux(4) = .true. + logaux(5) = .true. + logaux(6) = .true. +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont contenus dans le +c parallelepide enveloppe de l'hexaedre +c . ensuite, on elimine les noeuds coincidents +c . on recherche si le noeud est a l'interieur de l'hexaedre +c cela est vrai si le noeud et un sommet sont du meme cote du +c plan forme par les quatre autres sommets. pour cela, on +c regarde si les produits mixtes (ab,ac,ad) et (ab,ac,an) sont +c de meme signe pour les quatre permutations circulaires +c sur (a,b,c,d) +c . on elimine les huit noeuds de l'hexaedre +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds de l'hexaedre +c car on gagne aussi 40% ! +c En revanche, inutile de deplier davantage les tests +c +cgn call gtfims (93) diff --git a/src/tool/Utilitaire/utb3e2.h b/src/tool/Utilitaire/utb3e2.h new file mode 100644 index 00000000..b56999d7 --- /dev/null +++ b/src/tool/Utilitaire/utb3e2.h @@ -0,0 +1,287 @@ +c +c 2.3.3. ==> face f1 : plan (s1,s2,s3,s4) +c prmito est le produit mixte du triedre base sur s1 +c prmilo est le produit mixte pointant sur le noeud a tester. +c il faut que prmito et prmilo soient de meme signe pour que +c le noeud soit du meme cote du plan (s1,s2,s3,s4) que s6. +c on teste le caractere strictement positif du produit +c prmito x prmilo, pour pouvoir pieger les cas ou le +c noeud est sur une face. +cgn call gtdems (94) +c + if ( logaux(7) ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,2,-1), lenoeu + endif +#endif +c + daux1 = 0.d0 +c + if ( logaux(1) ) then +c + v14(1) = v4(1)-v1(1) + v14(2) = v4(2)-v1(2) + v14(3) = v4(3)-v1(3) +c + v12(1) = v2(1)-v1(1) + v12(2) = v2(2)-v1(2) + v12(3) = v2(3)-v1(3) +c + v16(1) = v6(1)-v1(1) + v16(2) = v6(2)-v1(2) + v16(3) = v6(3)-v1(3) +c +c v0(1,.) est le produit vectoriel s1s4 x s1s2. +c + v0(1,1) = v14(2)*v12(3) - v14(3)*v12(2) + v0(1,2) = v14(3)*v12(1) - v14(1)*v12(3) + v0(1,3) = v14(1)*v12(2) - v14(2)*v12(1) +c +c prmito est le produit mixte (s1s4,s1s2,s1s6) +c + prmito = v0(1,1)*v16(1) + > + v0(1,2)*v16(2) + > + v0(1,3)*v16(3) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'v14 ', v14(1),v14(2),v14(3) + write (ulsort,90004) 'v12 ', v12(1),v12(2),v12(3) + write (ulsort,90004) 'v16 ', v16(1),v16(2),v16(3) + write (ulsort,90004) 'v0(1,.)', v0(1,1),v0(1,2),v0(1,3) + write (ulsort,90004) 'prmito ', prmito + endif +#endif +c si le produit mixte est nul, c'est que le volume est nul +c on ne controle donc rien +c + if ( prmito.le.daux1 ) then + goto 20 + endif +c + logaux(1) = .false. +c + endif +c +c prmilo est le produit mixte (s1s4,s1s2,s1sn) +c + prmilo = v0(1,1)*(vn(1)-v1(1)) + > + v0(1,2)*(vn(2)-v1(2)) + > + v0(1,3)*(vn(3)-v1(3)) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,90004) 'vn-v1',(vn(iaux)-v1(iaux),iaux=1,3) + write (ulsort,90004) 'f1 prmilo', prmilo + endif +#endif +cgn call gtfims (94) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.4. ==> idem pour la face f2 : plan (s1,s2,s5,s6) +cgn call gtdems (95) +c + if ( logaux(7) ) then +c + if ( logaux(2) ) then +c +c v0(2,.) est le produit vectoriel s1s2 x s1s6 +c + v0(2,1) = v12(2)*v16(3) - v12(3)*v16(2) + v0(2,2) = v12(3)*v16(1) - v12(1)*v16(3) + v0(2,3) = v12(1)*v16(2) - v12(2)*v16(1) +c +c prmito est le produit mixte (s1s4,s1s2,s1s6) +c = (s1s2,s1s6,s1s4) +c + logaux(2) = .false. +c + endif +c +c prmilo est le produit mixte (s1s2,s1s6,s1sn) +c + prmilo = v0(2,1)*(vn(1)-v1(1)) + > + v0(2,2)*(vn(2)-v1(2)) + > + v0(2,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'f2 prmilo', prmilo + endif +#endif +c +cgn call gtfims (95) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.5. ==> idem pour la face f3 : plan (s1,s6,s7,s4) +cgn call gtdems (96) +c + if ( logaux(7) ) then +c + if ( logaux(3) ) then +c +c v0(3,.) est le produit vectoriel s1s6 x s1s4 +c + v0(3,1) = v16(2)*v14(3) - v16(3)*v14(2) + v0(3,2) = v16(3)*v14(1) - v16(1)*v14(3) + v0(3,3) = v16(1)*v14(2) - v16(2)*v14(1) +c +c prmito est le produit mixte (s1s4,s1s2,s1s6) +c = (s1s6,s1s4,s1s2) +c + logaux(3) = .false. +c + endif +c +c prmilo est le produit mixte (s1s6,s1s4,s1sn) +c + prmilo = v0(3,1)*(vn(1)-v1(1)) + > + v0(3,2)*(vn(2)-v1(2)) + > + v0(3,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'f3 prmilo', prmilo + endif +#endif +c +cgn call gtfims (96) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.6. ==> idem pour la face f4 : plan (s2,s3,s8,s5) +cgn call gtdems (97) +c + if ( logaux(7) ) then +c + if ( logaux(4) ) then +c + v85(1) = v5(1)-v8(1) + v85(2) = v5(2)-v8(2) + v85(3) = v5(3)-v8(3) +c + v83(1) = v3(1)-v8(1) + v83(2) = v3(2)-v8(2) + v83(3) = v3(3)-v8(3) +c +c v0(4,.) est le produit vectoriel s8s5 x s8s3 +c + v0(4,1) = v85(2)*v83(3) - v85(3)*v83(2) + v0(4,2) = v85(3)*v83(1) - v85(1)*v83(3) + v0(4,3) = v85(1)*v83(2) - v85(2)*v83(1) +c +c prmito est le produit mixte (s1s4,s1s2,s1s6) +c vu la definition des 8 sommets de l'hexaedre, c'est la +c meme valeur que le produit mixte (s8s5,s8s3,s8s7) +c + logaux(4) = .false. +c + endif +c +c prmilo est le produit mixte (s8s5,s8s3,s8sn) +c + prmilo = v0(4,1)*(vn(1)-v8(1)) + > + v0(4,2)*(vn(2)-v8(2)) + > + v0(4,3)*(vn(3)-v8(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'f4 prmilo', prmilo + endif +#endif +c +cgn call gtfims (97) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.7. ==> idem pour la face f5 : plan (s3,s4,s7,s8) +cgn call gtdems (98) +c + if ( logaux(7) ) then +c + if ( logaux(5) ) then +c + v87(1) = v7(1)-v8(1) + v87(2) = v7(2)-v8(2) + v87(3) = v7(3)-v8(3) +c +c v0(5,.) est le produit vectoriel s8s3 x s8s7 +c + v0(5,1) = v83(2)*v87(3) - v83(3)*v87(2) + v0(5,2) = v83(3)*v87(1) - v83(1)*v87(3) + v0(5,3) = v83(1)*v87(2) - v83(2)*v87(1) +c +c prmito est le produit mixte (s8s5,s8s3,s8s7) +c = (s8s3,s8s7,s8s5) +c + logaux(5) = .false. +c + endif +c +c prmilo est le produit mixte (s8s7,s8s3,s8sn) +c + prmilo = v0(5,1)*(vn(1)-v8(1)) + > + v0(5,2)*(vn(2)-v8(2)) + > + v0(5,3)*(vn(3)-v8(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'f5 prmilo', prmilo + endif +#endif +c +cgn call gtfims (98) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.8. ==> idem pour la face f6 : plan (s5,s8,s7,s6) +cgn call gtdems (99) +c + if ( logaux(7) ) then +c + if ( logaux(6) ) then +c +c v0(6,.) est le produit vectoriel s8s7 x s8s5 +c + v0(6,1) = v87(2)*v85(3) - v87(3)*v85(2) + v0(6,2) = v87(3)*v85(1) - v87(1)*v85(3) + v0(6,3) = v87(1)*v85(2) - v87(2)*v85(1) +c +c prmito est le produit mixte (s8s5,s8s3,s8s7) +c = (s8s7,s8s5,s8s3) +c + logaux(6) = .false. +c + endif +c +c prmilo est le produit mixte (s8s7,s8s5,s8sn) +c + prmilo = v0(6,1)*(vn(1)-v8(1)) + > + v0(6,2)*(vn(2)-v8(2)) + > + v0(6,3)*(vn(3)-v8(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90004) 'f6 prmilo', prmilo + endif +#endif +c +cgn call gtfims (99) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif diff --git a/src/tool/Utilitaire/utb3f0.F b/src/tool/Utilitaire/utb3f0.F new file mode 100644 index 00000000..c2a8caad --- /dev/null +++ b/src/tool/Utilitaire/utb3f0.F @@ -0,0 +1,268 @@ + subroutine utb3f0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > aretri, + > hetpyr, facpyr, cofapy, arepyr, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase F0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des pyramides +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3F0' ) +c + integer typenh + parameter ( typenh = 5 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lapyra, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(13), nbsomm + integer listar(8) +c + double precision v0(5,3) + double precision v1(3), v2(3), v3(3), v4(3), v5(3) + double precision v51(3), v52(3), v53(3), v54(3) + double precision v12(3), v14(3) + double precision v5n(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + integer glop + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbpyca', nbpyca + write(ulsort,90002) 'nbpycf', nbpycf + write(ulsort,90002) 'nbpyto', nbpyto +#endif +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 5 + else + nbsomm = 13 + endif +c +c==== +c 2. controle de la non-interpenetration des pyramides +c remarque : on ne s'interesse qu'aux actives car les autres sont +c censees avoir ete controlees aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , lapyra = 1 , nbpyto +c +#ifdef _DEBUG_HOMARD_ + if ( lapyra.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hetpyr(lapyra),100).eq.0 ) then +cgn call gtdems (93) +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +#include "utb3f1.h" +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3) + endif +#endif +c + do 23 , lenoeu = numip1, numap1 +c +#include "utb304.h" +c +#include "utb305.h" +c +#include "utb306.h" +c +#include "utb3f2.h" +c +c 2.3.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de la pyramide ... malaise ... +c + if ( logaux(7) ) then +c + iaux = lapyra +c +#include "utb302.h" +c + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3) +c + write (ulbila,10200) +c + endif +c + 23 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3f1.F b/src/tool/Utilitaire/utb3f1.F new file mode 100644 index 00000000..251210c1 --- /dev/null +++ b/src/tool/Utilitaire/utb3f1.F @@ -0,0 +1,403 @@ + subroutine utb3f1 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > aretri, + > arequa, filqua, + > cfaqua, famqua, + > hetpyr, facpyr, cofapy, arepyr, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase F1 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle la presence de noeuds dans les pyramides +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . s . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . s . 1 . nombre de corrections pour les aretes . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3F1' ) +c + integer typenh + parameter ( typenh = 5 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombpy.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer hetpyr(nbpyto) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lapyra, lequad, larete, lenoeu + integer nuarfr, nuqufr + integer nbexam, examno(2), examar(2) + integer sommet(13), nbsomm + integer listar(8) +c + double precision v0(5,3) + double precision v1(3), v2(3), v3(3), v4(3), v5(3) + double precision v51(3), v52(3), v53(3), v54(3) + double precision v12(3), v14(3) + double precision v5n(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +#ifdef _DEBUG_HOMARD_ + integer glop + data glop / 0 / +#endif +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "utb303.h" +c +c 1.2. ==> constantes +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbpyca', nbpyca + write(ulsort,90002) 'nbpycf', nbpycf + write(ulsort,90002) 'nbpyto', nbpyto +#endif +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 5 + else + nbsomm = 13 + endif +c + nbcoar = 0 + nbcoqu = 0 +c +c==== +c 2. controle de la penetration de noeuds dans les pyramides +c remarque : on ne s'interesse qu'aux actives car les autres sont +c censees avoir ete controlees aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , lapyra = 1 , nbpyto +c +#ifdef _DEBUG_HOMARD_ + if ( lapyra.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hetpyr(lapyra),100).eq.0 ) then +cgn call gtdems (93) +c +#include "utb3f1.h" +c +c 2.1. ==> Les quadrangles +c + do 21 , nuqufr = 1 , nbqufr +c +c 2.1.1. ==> Elimination des situations ou il est inutile +c de controler car le quadrangle a deja ete ramene +c + lequad = quafro(nuqufr) +c + if ( lequad.le.0 ) then + goto 21 + endif +c +c 2.1.2. ==> Reperage des situations a examiner : +c . le noeud central du quadrangle decoupe +c . les noeuds P2 courbes : a faire +c ce noeud central est la seconde extremite de la 2eme ou 3eme +c arete de l'un quelconque des quadrangles fils (cf. cmrdqu) +c + if ( codret.eq.0 ) then +c + if ( typsfr.le.2 ) then + nbexam = 1 + larete = arequa(filqua(lequad),2) + examno(1) = somare(2,larete) + else + codret = 212 + endif +c + endif +c +c 2.1.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad +#endif +c + do 213 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb304.h" +c +cgn write(ulsort,1789) vn +cgn write(ulsort,1789) xmin,xmax +cgn write(ulsort,1789) ymin,ymax +cgn write(ulsort,1789) zmin,zmax +cgn write(ulsort,*) logaux(7) +cgn 1789 format(3g12.5) +c +#include "utb3f2.h" +c +c 2.1.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de la pyramide ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoqu = nbcoqu + 1 + quafro(nuqufr) = -lequad +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro +#endif + call utcorn ( lenoeu, lequad, 0, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 213 continue +c + endif +c + 21 continue +c +c 2.2. ==> Les aretes +c + do 22 , nuarfr = 1 , nbarfr +c +#include "utb308.h" +c +c 2.2.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete +#endif +c + do 223 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb314.h" +c +cgn write(ulsort,1789) vn +cgn write(ulsort,1789) xmin,xmax +cgn write(ulsort,1789) ymin,ymax +cgn write(ulsort,1789) zmin,zmax +cgn write(ulsort,*) logaux(7) +cgn 1789 format(3g12.5) +c +#include "utb3f2.h" +c +c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur de la pyramide ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoar = nbcoar + 1 + arefro(nuarfr) = -larete +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro +#endif + call utcorn ( lenoeu, 0, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 223 continue +c + endif +c + 22 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c +c==== +c 3. La fin +c==== +c +#include "utb307.h" +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3f1.h b/src/tool/Utilitaire/utb3f1.h new file mode 100644 index 00000000..84bf3fd4 --- /dev/null +++ b/src/tool/Utilitaire/utb3f1.h @@ -0,0 +1,90 @@ +c +c 2.1. ==> les aretes et les sommets de cette pyramide active +c vi(1->3) = coordonnees du sommet si +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) mess14(langue,2,typenh), lapyra +cgn write(ulsort,90112) 'faces',lapyra,(facpyr(lapyra,iaux),iaux=1,5) + endif +#endif +c + if ( lapyra.le.nbpycf ) then +c + call utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) +c + else +c + do 210 , iaux = 1 , 8 + listar(iaux) = arepyr(lapyra-nbpycf,iaux) + 210 continue +c + endif +c + call utsopy ( somare, listar, sommet ) +c + if ( degre.eq.2 ) then + do 211 , iaux = 1 , 8 + sommet(5+iaux) = np2are(listar(iaux)) + 211 continue + endif +c +c 2.2. ==> le parallelepipede enveloppe +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + v1(3) = coonoe(sommet(1),3) +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + v2(3) = coonoe(sommet(2),3) +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + v3(3) = coonoe(sommet(3),3) +c + v4(1) = coonoe(sommet(4),1) + v4(2) = coonoe(sommet(4),2) + v4(3) = coonoe(sommet(4),3) +c + v5(1) = coonoe(sommet(5),1) + v5(2) = coonoe(sommet(5),2) + v5(3) = coonoe(sommet(5),3) +c + xmin = min(v1(1),v2(1),v3(1),v4(1),v5(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1),v5(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2),v5(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2),v5(2)) + zmin = min(v1(3),v2(3),v3(3),v4(3),v5(3)) + zmax = max(v1(3),v2(3),v3(3),v4(3),v5(3)) +c + logaux(1) = .true. + logaux(2) = .true. + logaux(3) = .true. + logaux(4) = .true. + logaux(5) = .true. +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont contenus dans le +c parallelepide enveloppe de la pyramide +c . ensuite, on elimine les noeuds coincidents +c . on recherche si le noeud est a l'interieur de la pyramide +c cela est vrai si le noeud et un sommet sont du meme cote du +c plan forme par les trois autres sommets. pour cela, on regarde +c si les produits mixtes (ab,ac,ad) et (ab,ac,an) sont de meme +c signe pour les quatre permutations circulaires sur (a,b,c,d) +c . on elimine les cinq noeuds de la pyramide +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds +c de la pyramide car on gagne aussi 40% ! +c En revanche, inutile de deplier davantage les tests +c +cgn call gtfims (93) diff --git a/src/tool/Utilitaire/utb3f2.h b/src/tool/Utilitaire/utb3f2.h new file mode 100644 index 00000000..cde40af2 --- /dev/null +++ b/src/tool/Utilitaire/utb3f2.h @@ -0,0 +1,256 @@ +c +c 2.3.4. ==> face f1 : plan (s1,s2,s5) +c prmito est le produit mixte de la pyramide totale. +c prmilo est le produit mixte pointant sur le noeud a tester. +c il faut que prmito et prmilo soient de meme signe pour que +c le noeud soit du meme cote du plan (s1,s2,s5) que s4. +c on teste le caractere strictement positif du produit +c prmito x prmilo, pour pouvoir pieger les cas ou le +c noeud est sur une face. +cgn call gtdems (94) +c + if ( logaux(7) ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... ', mess14(langue,2,-1), lenoeu + endif +#endif +c + daux1 = 0.d0 +c + if ( logaux(1) ) then +c + v52(1) = v2(1)-v5(1) + v52(2) = v2(2)-v5(2) + v52(3) = v2(3)-v5(3) +c + v51(1) = v1(1)-v5(1) + v51(2) = v1(2)-v5(2) + v51(3) = v1(3)-v5(3) +c + v54(1) = v4(1)-v5(1) + v54(2) = v4(2)-v5(2) + v54(3) = v4(3)-v5(3) +c +c v0(1,.) represente le produit vectoriel s5s2 x s5s1. +c + v0(1,1) = v52(2)*v51(3) - v52(3)*v51(2) + v0(1,2) = v52(3)*v51(1) - v52(1)*v51(3) + v0(1,3) = v52(1)*v51(2) - v52(2)*v51(1) +c +c prmito est le produit mixte (s5s2,s5s1,s5s4) +c + prmito = v0(1,1)*v54(1) + > + v0(1,2)*v54(2) + > + v0(1,3)*v54(3) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... v52', v52(1),v52(2),v52(3) + write (ulsort,*) '.... v51', v51(1),v51(2),v51(3) + write (ulsort,*) '.... v54', v54(1),v54(2),v54(3) + write (ulsort,*) '.... v0(1,.)', v0(1,1),v0(1,2),v0(1,3) + write (ulsort,*) '.... ==> prmito =', prmito + endif +#endif +c +c si le produit mixte est nul, c'est que le volume est nul +c on ne controle donc rien +c + if ( prmito.le.daux1 ) then + goto 20 + endif +c + logaux(1) = .false. +c + endif +c + v5n(1) = vn(1)-v5(1) + v5n(2) = vn(2)-v5(2) + v5n(3) = vn(3)-v5(3) +c +c prmilo est le produit mixte (s5s2,s5s1,s5sn) +c + prmilo = v0(1,1)*v5n(1) + > + v0(1,2)*v5n(2) + > + v0(1,3)*v5n(3) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... v5n =',v5n + write (ulsort,*) '.... f1 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (94) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.4. ==> idem pour la face f2 : plan (s2,s3,s5) +cgn call gtdems (95) +c + if ( logaux(7) ) then +c + if ( logaux(2) ) then +c + v53(1) = v3(1)-v5(1) + v53(2) = v3(2)-v5(2) + v53(3) = v3(3)-v5(3) +c +c v0(2,.) est le produit vectoriel s5s3 x s5s2 +c + v0(2,1) = v53(2)*v52(3) - v53(3)*v52(2) + v0(2,2) = v53(3)*v52(1) - v53(1)*v52(3) + v0(2,3) = v53(1)*v52(2) - v53(2)*v52(1) +c +c prmito est le produit mixte (s5s3,s5s2,s5s4) +c vu la definition des 5 sommets de la pyramide, c'est la +c meme valeur que le produit mixte (s5s2,s5s1,s5s4) +c + logaux(2) = .false. +c + endif +c +c prmilo est le produit mixte (s5s3,s5s2,s5sn) +c + prmilo = v0(2,1)*v5n(1) + > + v0(2,2)*v5n(2) + > + v0(2,3)*v5n(3) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... f2 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (95) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.5. ==> idem pour la face f3 : plan (s3,s4,s5) +cgn call gtdems (96) +c + if ( logaux(7) ) then +c + if ( logaux(3) ) then +c +c v0(3,.) est le produit vectoriel s5s4 x s5s3 +c + v0(3,1) = v54(2)*v53(3) - v54(3)*v53(2) + v0(3,2) = v54(3)*v53(1) - v54(1)*v53(3) + v0(3,3) = v54(1)*v53(2) - v54(2)*v53(1) +c +c prmito est le produit mixte (s5s3,s5s2,s5s4) +c = (s5s4,s5s3,s5s2) +c + logaux(3) = .false. +c + endif +c +c prmilo est le produit mixte (s5s4,s5s3,s5sn) +c + prmilo = v0(3,1)*v5n(1) + > + v0(3,2)*v5n(2) + > + v0(3,3)*v5n(3) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... f3 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (96) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.6. ==> idem pour la face f4 : plan (s1,s4,s5) +cgn call gtdems (97) +c + if ( logaux(7) ) then +c + if ( logaux(4) ) then +c +c v0(4,.) est le produit vectoriel s5s1 x s5s4 +c + v0(4,1) = v51(2)*v54(3) - v51(3)*v54(2) + v0(4,2) = v51(3)*v54(1) - v51(1)*v54(3) + v0(4,3) = v51(1)*v54(2) - v51(2)*v54(1) +c +c prmito est le produit mixte (s5s2,s5s1,s5s4) +c = (s5s1,s5s4,s5s2) +c + logaux(4) = .false. +c + endif +c +c prmilo est le produit mixte (s5s1,s5s4,s5sn) +c + prmilo = v0(4,1)*v5n(1) + > + v0(4,2)*v5n(2) + > + v0(4,3)*v5n(3) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... f4 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (97) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.7. ==> idem pour la face f5 : plan (s1,s2,s3,s4) +cgn call gtdems (98) +c + if ( logaux(7) ) then +c + if ( logaux(5) ) then +c + v12(1) = v2(1)-v1(1) + v12(2) = v2(2)-v1(2) + v12(3) = v2(3)-v1(3) +c + v14(1) = v4(1)-v1(1) + v14(2) = v4(2)-v1(2) + v14(3) = v4(3)-v1(3) +c +c v0(5,.) est le produit vectoriel s1s2 x s1s4 +c + v0(5,1) = v12(2)*v14(3) - v12(3)*v14(2) + v0(5,2) = v12(3)*v14(1) - v12(1)*v14(3) + v0(5,3) = v12(1)*v14(2) - v12(2)*v14(1) +c +c prmito est le produit mixte (s1s2,s1s4,s1s5) +c vu la definition des 5 sommets de la pyramide, c'est la +c meme valeur que le produit mixte (s5s2,s5s1,s5s4) +c + logaux(5) = .false. +c + endif +c +c prmilo est le produit mixte (s1s2,s1s4,s1sn) +c + prmilo = v0(5,1)*(vn(1)-v1(1)) + > + v0(5,2)*(vn(2)-v1(2)) + > + v0(5,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v1 =',(vn(iaux)-v1(iaux),iaux=1,3) + write (ulsort,*) '.... f5 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (98) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif diff --git a/src/tool/Utilitaire/utb3g0.F b/src/tool/Utilitaire/utb3g0.F new file mode 100644 index 00000000..b737daee --- /dev/null +++ b/src/tool/Utilitaire/utb3g0.F @@ -0,0 +1,242 @@ + subroutine utb3g0 ( hetnoe, coonoe, + > numcoi, coinpt, coinnn, + > somare, + > arequa, + > hetpen, facpen, cofape, arepen, np2are, + > nbpbco, mess08, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase G0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle l'interpenetration des pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetnoe . e . nbnoto . historique de l'etat des noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . e . nbnoto . numero de la coincidence du noeud . +c . coinpt . e . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . e . * . liste des noeuds coincidents . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . np2are . e . nbarto . noeud milieux des aretes . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3G0' ) +c + integer typenh + parameter ( typenh = 7 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer hetnoe(nbnoto) + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer np2are(nbarto) + integer nbpbco(-1:7) +c + character*08 mess08(nblang,*) + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lepent, lenoeu + integer nucoin, ptcoin, ptcode, ptcofi + integer sommet(15), nbsomm + integer listar(9) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v0(5,3) + double precision v1(3), v2(3), v3(3), v4(3), v5(3), v6(3) + double precision v12(3), v13(3), v14(3) + double precision v52(3), v54(3), v56(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb300.h" +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 6 + else + nbsomm = 15 + endif +c +c==== +c 2. controle de la non-interpenetration des pentaedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , lepent = 1 , nbpeto +c +#ifdef _DEBUG_HOMARD_ + if ( lepent.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hetpen(lepent),100).eq.0 ) then +cgn call gtdems (93) +c + if ( nbpbco(typenh).eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif + nbpbco(typenh) = 0 + endif +c +#include "utb3g1.h" +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulsort,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulsort,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulsort,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulsort,14203) sommet(5), v5(1), v5(2), v5(3) + write (ulsort,14203) sommet(6), v6(1), v6(2), v6(3) + write (ulsort,*) xmin, xmax + write (ulsort,*) ymin, ymax + write (ulsort,*) zmin, zmax + endif +#endif +c + do 23 , lenoeu = numip1, numap1 +c +#include "utb304.h" +c +#include "utb305.h" +c +#include "utb306.h" +c +#include "utb3g2.h" +c +c 2.3.9. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du pentaedre ... malaise ... +c + if ( logaux(7) ) then +c + iaux = lepent +c +#include "utb302.h" +c + write (ulbila,14203) sommet(1), v1(1), v1(2), v1(3) + write (ulbila,14203) sommet(2), v2(1), v2(2), v2(3) + write (ulbila,14203) sommet(3), v3(1), v3(2), v3(3) + write (ulbila,14203) sommet(4), v4(1), v4(2), v4(3) + write (ulbila,14203) sommet(5), v5(1), v5(2), v5(3) + write (ulbila,14203) sommet(6), v6(1), v6(2), v6(3) +c + write (ulbila,10200) +c + endif +c + 23 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c + end diff --git a/src/tool/Utilitaire/utb3g1.F b/src/tool/Utilitaire/utb3g1.F new file mode 100644 index 00000000..dd009e3e --- /dev/null +++ b/src/tool/Utilitaire/utb3g1.F @@ -0,0 +1,388 @@ + subroutine utb3g1 ( nbcoqu, nbcoar, + > coonoe, + > somare, filare, np2are, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > hetpen, facpen, cofape, arepen, + > nbarfr, arefro, + > nbqufr, quafro, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase G1 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle la presence de noeuds dans les pentaedres +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcoqu . es . 1 . nombre de corrections pour les quadrangles . +c . nbcoar . es . 1 . nombre de corrections pour les aretes . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . np2are . e . nbarto . noeud milieux des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . nbarfr . e . 1 . nombre d'aretes concernees . +c . arefro . es . nbarfr . liste des aretes concernees . +c . nbqufr . e . 1 . nombre de quadrangles concernes . +c . quafro . es . nbqufr . liste des quadrangles concernes . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3G1' ) +c + integer typenh + parameter ( typenh = 7 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer nbcoar, nbcoqu + integer somare(2,nbarto), filare(nbarto), np2are(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) + integer hetpen(nbpeto) + integer nbarfr, arefro(nbarfr) + integer nbqufr, quafro(nbqufr) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lepent, lequad, larete, lenoeu + integer nbexam, examno(2), examar(2) + integer nuarfr, nuqufr + integer sommet(15), nbsomm + integer listar(9) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision v0(5,3) + double precision v1(3), v2(3), v3(3), v4(3), v5(3), v6(3) + double precision v12(3), v13(3), v14(3) + double precision v52(3), v54(3), v56(3) + double precision vn(3) + double precision xmax, xmin, ymax, ymin, zmax, zmin + double precision prmito, prmilo + double precision daux1 +c + logical logaux(7) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utb303.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + if ( degre.eq.1 ) then + nbsomm = 6 + else + nbsomm = 15 + endif +c + nbcoar = 0 + nbcoqu = 0 +c +c==== +c 2. controle de la presence de noeuds dans les pentaedres +c remarque : on ne s'interesse qu'aux actifs car les autres sont +c censes avoir ete controles aux iterations anterieures +c==== +cgn call gtdems (92) +c + do 20 , lepent = 1 , nbpeto +c +#ifdef _DEBUG_HOMARD_ + if ( lepent.lt.0 ) then + glop = 1 + else + glop = 0 + endif +#endif +c + if ( mod(hetpen(lepent),100).eq.0 ) then +cgn call gtdems (93) +c +#include "utb3g1.h" +c +c 2.1. ==> Les quadrangles +c + do 21 , nuqufr = 1 , nbqufr +c +c 2.1.1. ==> Elimination des situations ou il est inutile +c de controler car le quadrangle a deja ete ramene +c + lequad = quafro(nuqufr) +c + if ( lequad.le.0 ) then + goto 21 + endif +c +c 2.1.2. ==> Reperage des situations a examiner : +c . le noeud central du quadrangle decoupe +c . les noeuds P2 courbes : a faire +c ce noeud central est la seconde extremite de la 2eme ou 3eme +c arete de l'un quelconque des quadrangles fils (cf. cmrdqu) +c + if ( codret.eq.0 ) then +c + if ( typsfr.le.2 ) then + nbexam = 1 + larete = arequa(filqua(lequad),2) + examno(1) = somare(2,larete) + else + codret = 212 + endif +c + endif +c +c 2.1.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad +#endif +c + do 213 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb304.h" +c +cgn write(ulsort,1789) vn +cgn write(ulsort,1789) xmin,xmax +cgn write(ulsort,1789) ymin,ymax +cgn write(ulsort,1789) zmin,zmax +cgn write(ulsort,*) logaux(7) +cgn 1789 format(3g12.5) +c +#include "utb3g2.h" +c +c 2.1.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du pentaedre ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoqu = nbcoqu + 1 + quafro(nuqufr) = -lequad +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_quadrangle', nompro +#endif + call utcorn ( lenoeu, lequad, 0, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 213 continue +c + endif +c + 21 continue +c +c 2.2. ==> Les aretes +c + do 22 , nuarfr = 1 , nbarfr +c +#include "utb308.h" +c +c 2.2.3. ==> Examen +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), larete +#endif +c + do 223 , jaux = 1 , nbexam +c + lenoeu = examno(jaux) +c +#include "utb314.h" +c +cgn write(ulsort,1789) vn +cgn write(ulsort,1789) xmin,xmax +cgn write(ulsort,1789) ymin,ymax +cgn write(ulsort,1789) zmin,zmax +cgn write(ulsort,*) logaux(7) +cgn 1789 format(3g12.5) +c +#include "utb3g2.h" +c +c 2.2.8. ==> si logaux(7) est encore vrai, c'est que le noeud est +c a l'interieur du pentaedre ... correction +c + if ( logaux(7) ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,-1), lenoeu +#endif +c + nbcoar = nbcoar + 1 + arefro(nuarfr) = -larete +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCORN_arete', nompro +#endif + call utcorn ( lenoeu, 0, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c + endif +c + endif +c + 223 continue +c + endif +c + 22 continue +c + endif +c + 20 continue +cgn call gtfims (92) +c +c==== +c 3. La fin +c==== +c +#include "utb307.h" +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3g1.h b/src/tool/Utilitaire/utb3g1.h new file mode 100644 index 00000000..d0d7edd7 --- /dev/null +++ b/src/tool/Utilitaire/utb3g1.h @@ -0,0 +1,94 @@ +c +c 2.1. ==> les aretes et les sommets de cet pentaedre actif +c vi(1->3) = coordonnees du sommet si +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typenh), lepent + endif +#endif +c + if ( lepent.le.nbpecf ) then +c + call utarpe ( lepent, + > nbquto, nbpeto, + > arequa, facpen, cofape, + > listar ) +c + else +c + do 210 , iaux = 1 , 9 + listar(iaux) = arepen(lepent-nbpecf,iaux) + 210 continue +c + endif +c + call utsope ( somare, listar, sommet ) +c + if ( degre.eq.2 ) then + do 211 , iaux = 1 , 9 + sommet(6+iaux) = np2are(listar(iaux)) + 211 continue + endif +c +c 2.2. ==> le parallelepipede enveloppe +c + v1(1) = coonoe(sommet(1),1) + v1(2) = coonoe(sommet(1),2) + v1(3) = coonoe(sommet(1),3) +c + v2(1) = coonoe(sommet(2),1) + v2(2) = coonoe(sommet(2),2) + v2(3) = coonoe(sommet(2),3) +c + v3(1) = coonoe(sommet(3),1) + v3(2) = coonoe(sommet(3),2) + v3(3) = coonoe(sommet(3),3) +c + v4(1) = coonoe(sommet(4),1) + v4(2) = coonoe(sommet(4),2) + v4(3) = coonoe(sommet(4),3) +c + v5(1) = coonoe(sommet(5),1) + v5(2) = coonoe(sommet(5),2) + v5(3) = coonoe(sommet(5),3) +c + v6(1) = coonoe(sommet(6),1) + v6(2) = coonoe(sommet(6),2) + v6(3) = coonoe(sommet(6),3) +c + xmin = min(v1(1),v2(1),v3(1),v4(1),v5(1),v6(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1),v5(1),v6(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2),v5(2),v6(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2),v5(2),v6(2)) + zmin = min(v1(3),v2(3),v3(3),v4(3),v5(3),v6(3)) + zmax = max(v1(3),v2(3),v3(3),v4(3),v5(3),v6(3)) +c + logaux(1) = .true. + logaux(2) = .true. + logaux(3) = .true. + logaux(4) = .true. + logaux(5) = .true. +c +c 2.3. ==> on passe en revue tous les autres sommets qui ne sont pas des +c sommets isoles. +c . on ne s'interesse qu'a ceux qui sont contenus dans le +c parallelepide enveloppe du pentaedre +c . ensuite, on elimine les noeuds coincidents +c . on recherche si le noeud est a l'interieur du pentaedre +c cela est vrai si le noeud et un sommet sont du meme cote du +c plan forme par les quatre autres sommets. pour cela, on +c regarde si les produits mixtes (ab,ac,ad) et (ab,ac,an) sont +c de meme signe pour les quatre permutations circulaires +c sur (a,b,c,d) +c . on elimine les six noeuds du pentaedre +c +c Remarque hyper importante : il ne faut faire les affectations +c de vn(2) et vn(3) que si c'est utile car elles coutent +c tres cheres (30% du temps total !) +c Remarque hyper importante : il vaut mieux mettre en dernier +c le test sur l'identite de lenoeu avec les noeuds +c du pentaedre car on gagne aussi 40% ! +c En revanche, inutile de deplier davantage les tests +c +cgn call gtfims (93) diff --git a/src/tool/Utilitaire/utb3g2.h b/src/tool/Utilitaire/utb3g2.h new file mode 100644 index 00000000..bc12dea6 --- /dev/null +++ b/src/tool/Utilitaire/utb3g2.h @@ -0,0 +1,255 @@ +c +c 2.3.4. ==> face f1 : plan (s1,s2,s3) +c prmito est le produit mixte du triedre base sur s1 +c prmilo est le produit mixte pointant sur le noeud a tester. +c il faut que prmito et prmilo soient de meme signe pour que +c le noeud soit du meme cote du plan (s1,s2,s3) que s4. +c on teste le caractere strictement positif du produit +c prmito x prmilo, pour pouvoir pieger les cas ou le +c noeud est sur une face. +cgn call gtdems (94) +c + if ( logaux(7) ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... ', mess14(langue,2,-1), lenoeu + endif +#endif +c + daux1 = 0.d0 +c + if ( logaux(1) ) then +c + v12(1) = v2(1)-v1(1) + v12(2) = v2(2)-v1(2) + v12(3) = v2(3)-v1(3) +c + v13(1) = v3(1)-v1(1) + v13(2) = v3(2)-v1(2) + v13(3) = v3(3)-v1(3) +c + v14(1) = v4(1)-v1(1) + v14(2) = v4(2)-v1(2) + v14(3) = v4(3)-v1(3) +c +c v0(1,.) est le produit vectoriel s1s2 x s1s3. +c + v0(1,1) = v12(2)*v13(3) - v12(3)*v13(2) + v0(1,2) = v12(3)*v13(1) - v12(1)*v13(3) + v0(1,3) = v12(1)*v13(2) - v12(2)*v13(1) +c +c prmito est le produit mixte (s1s2,s1s3,s1s4) +c + prmito = v0(1,1)*v14(1) + > + v0(1,2)*v14(2) + > + v0(1,3)*v14(3) +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... v12', v12(1),v12(2),v12(3) + write (ulsort,*) '.... v14', v14(1),v14(2),v14(3) + write (ulsort,*) '.... v13', v13(1),v13(2),v13(3) + write (ulsort,*) '.... v0(1,.)', v0(1,1),v0(1,2),v0(1,3) + write (ulsort,*) '.... ==> prmito =', prmito + endif +#endif +c si le produit mixte est nul, c'est que le volume est nul +c on ne controle donc rien +c + if ( prmito.le.daux1 ) then + goto 20 + endif +c + logaux(1) = .false. +c + endif +c +c prmilo est le produit mixte (s1s2,s1s3,s1sn) +c + prmilo = v0(1,1)*(vn(1)-v1(1)) + > + v0(1,2)*(vn(2)-v1(2)) + > + v0(1,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v1 =',(vn(iaux)-v1(iaux),iaux=1,3) + write (ulsort,*) '.... f1 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (94) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.5. ==> idem pour la face f2 : plan (s4,s5,s6) +cgn call gtdems (95) +c + if ( logaux(7) ) then +c + if ( logaux(2) ) then +c + v54(1) = v4(1)-v5(1) + v54(2) = v4(2)-v5(2) + v54(3) = v4(3)-v5(3) +c + v56(1) = v6(1)-v5(1) + v56(2) = v6(2)-v5(2) + v56(3) = v6(3)-v5(3) +c +c v0(2,.) est le produit vectoriel s5s4 x s5s6 +c + v0(2,1) = v54(2)*v56(3) - v54(3)*v56(2) + v0(2,2) = v54(3)*v56(1) - v54(1)*v56(3) + v0(2,3) = v54(1)*v56(2) - v54(2)*v56(1) +c +c prmito a ete calcule comme le produit mixte (s1s2,s1s3,s1s4) +c vu la definition des 6 sommets du pentaedre, c'est la +c meme valeur que le produit mixte (s5s4,s5s6,s5s2) +c + logaux(2) = .false. +c + endif +c +c prmilo est le produit mixte (s5s4,s5s6,s5sn) +c + prmilo = v0(2,1)*(vn(1)-v5(1)) + > + v0(2,2)*(vn(2)-v5(2)) + > + v0(2,3)*(vn(3)-v5(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v5 =',(vn(iaux)-v5(iaux),iaux=1,3) + write (ulsort,*) '.... f2 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (95) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.6. ==> idem pour la face f3 : plan (s1,s3,s6,s4) +cgn call gtdems (96) +c + if ( logaux(7) ) then +c + if ( logaux(3) ) then +c +c v0(3,.) est le produit vectoriel s1s3 x s1s4 +c + v0(3,1) = v13(2)*v14(3) - v13(3)*v14(2) + v0(3,2) = v13(3)*v14(1) - v13(1)*v14(3) + v0(3,3) = v13(1)*v14(2) - v13(2)*v14(1) +c +c prmito est le produit mixte (s1s2,s1s3,s1s4) +c = (s1s3,s1s4,s1s2) +c + logaux(3) = .false. +c + endif +c +c prmilo est le produit mixte (s1s3,s1s4,s1sn) +c + prmilo = v0(3,1)*(vn(1)-v1(1)) + > + v0(3,2)*(vn(2)-v1(2)) + > + v0(3,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v1 =',(vn(iaux)-v1(iaux),iaux=1,3) + write (ulsort,*) '.... f3 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (96) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.7. ==> idem pour la face f4 : plan (s1,s2,s5,s4) +cgn call gtdems (97) +c + if ( logaux(7) ) then +c + if ( logaux(4) ) then +c +c v0(4,.) est le produit vectoriel s1s4 x s1s2 +c + v0(4,1) = v14(2)*v12(3) - v14(3)*v12(2) + v0(4,2) = v14(3)*v12(1) - v14(1)*v12(3) + v0(4,3) = v14(1)*v12(2) - v14(2)*v12(1) +c +c prmito est le produit mixte (s1s2,s1s3,s1s4) +c = (s1s4,s1s2,s1s3) +c + logaux(4) = .false. +c + endif +c +c prmilo est le produit mixte (s1s4,s1s2,s1sn) +c + prmilo = v0(4,1)*(vn(1)-v1(1)) + > + v0(4,2)*(vn(2)-v1(2)) + > + v0(4,3)*(vn(3)-v1(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v1 =',(vn(iaux)-v1(iaux),iaux=1,3) + write (ulsort,*) '.... f4 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (97) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif +c +c 2.3.8. ==> idem pour la face f5 : plan (s2,s3,s6,s5) +cgn call gtdems (97) +c + if ( logaux(7) ) then +c + if ( logaux(5) ) then +c + v52(1) = v2(1)-v5(1) + v52(2) = v2(2)-v5(2) + v52(3) = v2(3)-v5(3) +c +c v0(5,.) est le produit vectoriel s5s6 x s5s2 +c + v0(5,1) = v56(2)*v52(3) - v56(3)*v52(2) + v0(5,2) = v56(3)*v52(1) - v56(1)*v52(3) + v0(5,3) = v56(1)*v52(2) - v56(2)*v52(1) +c +c prmito est le produit mixte (s1s2,s1s3,s1s4) +c vu la definition des 6 sommets du pentaedre, c'est la +c meme valeur que le produit mixte (s5s4,s5s6,s5s2) +c = (s5s6,s5s2,s5s4) +c + logaux(5) = .false. +c + endif +c +c prmilo est le produit mixte (s5s6,s5s2,s5sn) +c + prmilo = v0(5,1)*(vn(1)-v5(1)) + > + v0(5,2)*(vn(2)-v5(2)) + > + v0(5,3)*(vn(3)-v5(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then +c write (ulsort,*) '.... vn-v5 =',(vn(iaux)-v5(iaux),iaux=1,3) + write (ulsort,*) '.... f5 prmilo =', prmilo + endif +#endif +c +cgn call gtfims (97) + if ( prmito*prmilo.lt.daux1 ) then + logaux(7) = .false. + endif +c + endif diff --git a/src/tool/Utilitaire/utb3n0.F b/src/tool/Utilitaire/utb3n0.F new file mode 100644 index 00000000..67e1f52b --- /dev/null +++ b/src/tool/Utilitaire/utb3n0.F @@ -0,0 +1,364 @@ + subroutine utb3n0 ( coonoe, + > numcoi, coinpt, coinnn, + > nbbomx, lglibo, ptnubo, listbo, + > nbpbco, mess54, + > ulbila, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N0 +c -- - - -- +c ______________________________________________________________________ +c +c but : controle la non coincidence des noeuds. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . numcoi . s . nbnoto . numero de la coincidence du noeud . +c . coinpt . s . * . pointeur de la i-eme coincidence dans coinn. +c . coinnn . s . * . liste des noeuds coincidents . +c . nbbomx . e . 1 . nombre total de boites . +c . lglibo . e . 1 . longueur de listbo . +c . ptnubo . e .0:nbbomx. pointeur dans listbo . +c . listbo . e . lglibo . numero des noeuds dans chaque boite . +c . nbpbco . es . -1:7 . nombre de problemes de coincidences . +c . mess54 . e .nblang,*. messages . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N0' ) +c + integer typenh + parameter ( typenh = -1 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer numcoi(nbnoto), coinpt(*), coinnn(*) + integer nbpbco(-1:7) + integer nbbomx, lglibo + integer ptnubo(0:nbbomx), listbo(lglibo) +c + character*54 mess54(nblang,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer lenoeu + integer nucoin, nucoix, ptcoin, ptcode, ptcofi + integer numboi, ptldeb, ptlfin +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,3x,''... Coincidence des noeuds'',/,3x,26(''-''),/)' + texte(1,5) = + > '(5x,''Deux noeuds sont dits coincidents si l''''ecart absolu'')' + texte(1,6) = + > '(5x,''entre leurs coordonnees est inferieur a :'',g9.2)' +c + texte(2,4) = '(/,3x,''... Coincident nodes'',/,3x,20(''-''),/)' + texte(2,5) = '(5x,''Nodes are declared coincident if their'')' + texte(2,6) = + > '(5x,''absolute coordinate difference is lower than '',g9.2)' +c +#include "utb301.h" +c +c 1.2. ==> constantes +c + codret = 0 +c + do 12 , lenoeu = 1 , nbnoto + numcoi(lenoeu) = 0 + 12 continue + coinpt(1) = 0 + nucoin = 0 + ptcoin = 0 +c +c 1.3. ==> divers +c +#ifdef _DEBUG_HOMARD_ + do 13 , iaux = 1 , 2 +c + if ( iaux.eq.1 ) then + jaux = ulbila + else + if ( ulbila.eq.ulsort ) then + goto 13 + else + jaux = ulsort + endif + endif +c + write (jaux,texte(langue,4)) + write (jaux,texte(langue,5)) + write (jaux,texte(langue,6)) epsima +c + 13 continue +#endif +c +c==== +c 2. controle de la coincidence des noeuds, boite par boite +c remarques : +c 1. La verification est sujette a caution car le test sur la +c coincidence est un test sur une egalite de reels ... +c==== +c +cgn call gtdems (113) +cgn print *,'nbnoto =', nbnoto +cgn print *,'nbbomx =', nbbomx +c + ptlfin = ptnubo(0) +c + do 20 , numboi = 1 , nbbomx +c + ptldeb = ptlfin + 1 + ptlfin = ptnubo(numboi) +cgn print *,numboi, ' : ',ptldeb,ptlfin +c +c 2.1. ==> En 1D +c + if ( sdim.eq.1 ) then +c + do 21 , iaux = ptldeb, ptlfin +c + lenoeu = listbo(iaux) +c + if ( numcoi(lenoeu).eq.0 ) then +c + do 211 , jaux = iaux+1 , ptlfin +c + kaux = listbo(jaux) +c + if ( + > abs(coonoe(kaux,1)-coonoe(lenoeu,1)).le.epsima ) then +c + if ( numcoi(lenoeu).eq.0 ) then + nucoin = nucoin + 1 + numcoi(lenoeu) = nucoin + ptcoin = ptcoin + 1 + coinnn(ptcoin) = lenoeu + endif + numcoi(kaux) = nucoin + ptcoin = ptcoin + 1 + coinpt(nucoin+1) = ptcoin + coinnn(ptcoin) = kaux +c + endif +c + 211 continue +c + endif +c + 21 continue +c +c 2.2. ==> En 2D +c + elseif ( sdim.eq.2 ) then +c + do 22 , iaux = ptldeb, ptlfin +c + lenoeu = listbo(iaux) +c + if ( numcoi(lenoeu).eq.0 ) then +c + do 221 , jaux = iaux+1 , ptlfin +c + kaux = listbo(jaux) +c + if ( + > abs(coonoe(kaux,1)-coonoe(lenoeu,1)).le.epsima ) then +c + if ( + > abs(coonoe(kaux,2)-coonoe(lenoeu,2)).le.epsima ) then +c + if ( numcoi(lenoeu).eq.0 ) then + nucoin = nucoin + 1 + numcoi(lenoeu) = nucoin + ptcoin = ptcoin + 1 + coinnn(ptcoin) = lenoeu + endif + numcoi(kaux) = nucoin + ptcoin = ptcoin + 1 + coinpt(nucoin+1) = ptcoin + coinnn(ptcoin) = kaux +c + endif +c + endif +c + 221 continue +c + endif +c + 22 continue +c +c 2.3. ==> En 3D +c + else +c + do 23 , iaux = ptldeb, ptlfin +c + lenoeu = listbo(iaux) +cgn print *,'. Noeud ', lenoeu +c + if ( numcoi(lenoeu).eq.0 ) then +c + do 231 , jaux = iaux+1 , ptlfin +c + kaux = listbo(jaux) +c + if ( + > abs(coonoe(kaux,1)-coonoe(lenoeu,1)).le.epsima ) then +c + if ( + > abs(coonoe(kaux,2)-coonoe(lenoeu,2)).le.epsima ) then +c + if ( + > abs(coonoe(kaux,3)-coonoe(lenoeu,3)).le.epsima )then +c + if ( numcoi(lenoeu).eq.0 ) then + nucoin = nucoin + 1 + numcoi(lenoeu) = nucoin + ptcoin = ptcoin + 1 + coinnn(ptcoin) = lenoeu + endif + numcoi(kaux) = nucoin + ptcoin = ptcoin + 1 + coinpt(nucoin+1) = ptcoin + coinnn(ptcoin) = kaux +c + endif +c + endif +c + endif +c + 231 continue +c + endif +c + 23 continue +c + endif +c + 20 continue +c + nbpbco(typenh) = nucoin +cgn call gtfims (113) +c +c==== +c 3. Impression +c nucoix = numero de la derniere coincidence imprimee +c Attention : il faut imprimer boite par boite sinon on en oublie ... +c==== +cgn call gtdems (114) +c + nucoix = 0 +c + ptlfin = ptnubo(0) +c + do 31 , numboi = 1 , nbbomx +c + ptldeb = ptlfin + 1 + ptlfin = ptnubo(numboi) +c + do 311 , iaux = ptldeb, ptlfin +c + lenoeu = listbo(iaux) +c + nucoin = numcoi(lenoeu) +c + if ( nucoin.ne.0 .and. nucoin.gt.nucoix ) then +c + write (ulbila,10100) + write (ulbila,11100) mess54(langue,4) + ptcode = coinpt(nucoin)+1 + ptcofi = coinpt(nucoin+1) + write (ulbila,12100) (coinnn(jaux),jaux = ptcode, ptcofi) + if ( sdim.eq.1 ) then + write (ulbila,14101) coonoe(lenoeu,1) + elseif ( sdim.eq.2 ) then + write (ulbila,14102) coonoe(lenoeu,1), coonoe(lenoeu,2) + else + write (ulbila,14103) coonoe(lenoeu,1), coonoe(lenoeu,2), + > coonoe(lenoeu,3) + endif + write (ulbila,10200) +c + nucoix = nucoin +c + endif +c + 311 continue +c + 31 continue +cgn call gtfims (114) +c + end diff --git a/src/tool/Utilitaire/utb3n1.F b/src/tool/Utilitaire/utb3n1.F new file mode 100644 index 00000000..612bca9f --- /dev/null +++ b/src/tool/Utilitaire/utb3n1.F @@ -0,0 +1,387 @@ + subroutine utb3n1 ( coonoe, + > nbintx, nbbomx, + > lglibo, ptnubo, + > xyzmin, xyzmax, xyzeps, + > nbboit, boimin, boimax, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N1 +c -- - - -- +c ______________________________________________________________________ +c +c Repartit les noeuds dans les boites +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . nbintx . e . 1 . nombre maximal d'intervalle . +c . nbbomx . e . 1 . nombre maximal de boites . +c . lglibo . s . 1 . longueur de listbo . +c . ptnubo . s .0:nbbomx. pointeur dans listbo . +c . xyzmin . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales du domaine total . +c . xyzmax . e . sdim . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales du domaine total . +c . xyzeps . e . sdim . -1 si min = max dans la direction, . +c . . . . ecart sinon. . +c . nbboit . s . sdim . nombre de boite dans chaque direction . +c . boimin . s .0:nbintx. limite minimale de chaque boite . +c . boimax . s .0:nbintx. limite maximale de chaque boite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "envca1.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + integer nbintx, nbbomx + integer lglibo + integer ptnubo(0:nbbomx) + integer nbboit(3) +c + double precision coonoe(nbnoto,sdim) + double precision xyzmin(sdim), xyzmax(sdim), xyzeps(sdim) + double precision boimin(3,0:nbintx), boimax(3,0:nbintx) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer tbiaux(3) + integer lgboin, boinoe(8) + integer lenoeu, noedeb + integer nbinte(3) +c + double precision daux, daux1 + double precision coord(3) +c + character*1 nomcoo(3) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data nomcoo / 'x', 'y', 'z' / +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds : '',i10)' + texte(1,5) = '(''Dimension de l''''espace : '',i8)' + texte(1,6) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,7) = '(''Ecart maxi = '',g12.5)' + texte(1,8) = '(''Nombre de boites en '',a1,'' : '',i10)' + texte(1,9) = '(''. Boite'',i4,'' : '',g14.7,'' < '',g14.7)' + texte(1,10) = '(''Nombre total de boites : '',i10)' + texte(1,10) = '(''Longueur des listes des boites : '',i10)' +c + texte(2,4) = '(''Number of nodes : '',i10)' + texte(2,5) = '(''Dimension of the space: '',i8)' + texte(2,6) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,7) = '(''Maximum shift = '',g12.5)' + texte(2,8) = '(''Number of box for '',a1,'' : '',i10)' + texte(2,9) = '(''. Box #'',i4,'' : '',g14.7,'' < '',g14.7)' + texte(2,10) = '(''Total number of boxes : '',i10)' + texte(2,10) = '(''Length of box lists : '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbnoto + write (ulsort,texte(langue,5)) sdim + do 11 , iaux = 1 , sdim + write (ulsort,texte(langue,6)) nomcoo(iaux), + > xyzmin(iaux), xyzmax(iaux) + 11 continue +ccc write (ulsort,*) xyzeps +#endif +c +c 1.2. ==> constantes +c + codret = 0 +c +c==== +c 2. limites des boites +c==== +c 2.1. ==> daux = ecart le plus grand entre mini et maxi +c + daux = 0.d0 + do 21 , iaux = 1 , sdim + if ( xyzmax(iaux)-xyzmin(iaux).ge.daux ) then + daux = xyzmax(iaux)-xyzmin(iaux) + tbiaux(iaux) = 1 + else + tbiaux(iaux) = 0 + endif +cgn write (ulsort,*) xyzmax(iaux)-xyzmin(iaux), daux +cgn write (ulsort,*) tbiaux(iaux) + 21 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) daux +#endif +c +c 2.2. ==> taille des boites egale au plus grand ecart divise par +c le nombre maximal d'intervalle +c la taille est la meme quelle que soit la direction +c . si l'epaisseur est nulle, il faut declarer au moins +c une boite ; cela arrive dans le cas de maillage 1D +c sur un axe de coordonnees +c . quand on est sur une dimension maximale, le nombre de +c boites est maximal +c + daux = daux/dble(nbintx) + do 22 , iaux = 1 , sdim + if ( xyzeps(iaux).le.zeroma ) then + nbboit(iaux) = 1 + elseif ( tbiaux(iaux).eq.1 ) then + nbboit(iaux) = nbintx + else + daux1 = (xyzmax(iaux)-xyzmin(iaux))/daux + jaux = int(daux1) + daux1 = daux1-dble(jaux) + if ( daux1.gt.zeroma) then + jaux = jaux+1 + endif + nbboit(iaux) = jaux + endif + nbinte(iaux) = nbboit(iaux) - 1 + 22 continue +c +c 2.3. ==> limite des boites : on elargit chaque boite pour +c ne rien rater +c + daux1 = 1.d-5*daux + do 23 , iaux = 1 , sdim + do 232 , jaux = 1 , nbboit(iaux) + boimin(iaux,jaux) = + > xyzmin(iaux) + daux*dble(jaux-1) - daux1 + boimax(iaux,jaux) = + > xyzmin(iaux) + daux*dble(jaux) + daux1 + 232 continue + boimin(iaux,1) = xyzmin(iaux) - daux1 + boimax(iaux,nbboit(iaux)) = xyzmax(iaux) + daux1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nomcoo(iaux), nbboit(iaux) + do 2321 , jaux = 1, nbboit(iaux) + write (ulsort,texte(langue,9)) jaux, + > boimin(iaux,jaux), boimax(iaux,jaux) + 2321 continue +#endif + 23 continue +c +c==== +c 3. Elaboration du contenu des boites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Elaboration ; codret', codret +#endif +c 3.0. ==> On controle tous les noeuds, sauf dans un cas : si le code +c de calcul associe est Saturne_2D ou Neptune_2D, le maillage +c est une couche 2D du maillage 3D. Dans ce cas, un noeud +c supplementaire a ete cree pour memoriser les cotes mini +c et maxi du maillage. Ce noeud etant isole se trouve en +c premiere position. Il doit etre retire du controle car il +c n'a pas de sens du point de vue du maillage. +c A la fin de cette etape, ptnubo contient pour chaque boite +c le nombre de noeuds qu'elle contient +c + if ( typcca.eq.26 .or. + > typcca.eq.46 ) then + noedeb = 2 + else + noedeb = 1 + endif +c + do 30 , iaux = 0 , nbbomx + ptnubo(iaux) = 0 + 30 continue +c +c 3.1. ==> en dimension 1 +c + if ( sdim.eq.1 ) then +c + do 31 , lenoeu = noedeb , nbnoto +cgn write (ulsort,*) lenoeu,(coonoe(lenoeu,iaux) , iaux = 1 , sdim) +c + coord(1) = coonoe(lenoeu,1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N5', nompro +#endif + call utb3n5 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c +cgn write (ulsort,*) 'boinoe', (boinoe(iaux),iaux = 1 , lgboin) +cgn write (ulsort,*) 'lgboin', lgboin + do 311 , iaux = 1 , lgboin + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + 311 continue +c + 31 continue +cgn write (ulsort,*) 'ptnubo', (ptnubo(iaux),iaux=1,nbbomx) +c +c 3.2. ==> en dimension 2 +c + elseif ( sdim.eq.2 ) then +c + do 32 , lenoeu = noedeb , nbnoto +cgn write (ulsort,*) lenoeu,(coonoe(lenoeu,iaux) , iaux = 1 , sdim) +c + coord(1) = coonoe(lenoeu,1) + coord(2) = coonoe(lenoeu,2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N4', nompro +#endif + call utb3n4 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c +cgn write (ulsort,90002) 'boinoe', (boinoe(iaux),iaux =1,lgboin) +cgn write (ulsort,90002) 'lgboin', lgboin + do 321 , iaux = 1 , lgboin + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + 321 continue +c + 32 continue +cgn write (ulsort,*) 'ptnubo', (ptnubo(iaux),iaux=1,nbbomx) +c +c 3.3. ==> en dimension 3 +c + else +c + do 33 , lenoeu = noedeb , nbnoto +cgn write (ulsort,90024) 'noeud', lenoeu, +cgn > (coonoe(lenoeu,iaux),iaux=1,sdim) +c + coord(1) = coonoe(lenoeu,1) + coord(2) = coonoe(lenoeu,2) + coord(3) = coonoe(lenoeu,3) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N3', nompro +#endif + call utb3n3 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c + do 331 , iaux = 1 , lgboin + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + 331 continue +c + 33 continue +c + endif +c +c==== +c 4. On initialise le pointeur dans le tableau de la liste +c ptnubo(i) = position du dernier noeud de la boite i-1 +c = nombre cumule de noeuds pour les (i-1) premieres boites +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. On initialise ; codret', codret + write (ulsort,*) 'ptnubo', (ptnubo(iaux),iaux=1,nbbomx) +#endif +c + do 41 , iaux = 1 , nbbomx + ptnubo(iaux) = ptnubo(iaux) + ptnubo(iaux-1) + 41 continue +c + lglibo = ptnubo(nbbomx) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) lglibo +#endif +c + do 42 , iaux = nbbomx , 1 , -1 + ptnubo(iaux) = ptnubo(iaux-1) + 42 continue +cgn write (ulsort,*) 'ptnubo', (ptnubo(iaux),iaux=1,nbbomx) +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3n2.F b/src/tool/Utilitaire/utb3n2.F new file mode 100644 index 00000000..64ca91a0 --- /dev/null +++ b/src/tool/Utilitaire/utb3n2.F @@ -0,0 +1,264 @@ + subroutine utb3n2 ( coonoe, + > nbintx, nbbomx, + > lglibo, ptnubo, listbo, + > nbboit, boimin, boimax, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N2 +c -- - - -- +c ______________________________________________________________________ +c +c Classe les noeuds par boite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . nbintx . e . 1 . nombre maximal d'intervalle . +c . nbbomx . e . 1 . nombre total de boites . +c . lglibo . e . 1 . longueur de listbo . +c . ptnubo . es .0:nbbomx. pointeur dans listbo . +c . listbo . s . lglibo . numero des noeuds dans chaque boite . +c . nbboit . s . sdim . nombre de boite dans chaque direction . +c . boimin . e .0:nbintx. limite minimale de chaque boite . +c . boimax . e .0:nbintx. limite maximale de chaque boite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer nbintx, nbbomx + integer lglibo + integer ptnubo(0:nbbomx), listbo(lglibo) + integer nbboit(3) +c + double precision coonoe(nbnoto,sdim) + double precision boimin(3,0:nbintx), boimax(3,0:nbintx) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lgboin, boinoe(8) + integer lenoeu, noedeb + integer nbinte(3) +c + double precision coord(3) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,2) = '(''Nombre maximal de boites : '',i10)' +c + texte(2,2) = '(''Maximum number of boxes : '',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,2)) nbbomx +#endif +c + codret = 0 +c +c 1.2. ==> Nombre d'intervalles +c + do 12 , iaux = 1 , sdim + nbinte(iaux) = nbboit(iaux) - 1 + 12 continue +c +c==== +c 2. Creation des listes +c==== +c au depart : +c ptnubo(i) = position du dernier noeud de la boite i-1 +c = nombre cumule de noeuds pour les (i-1) premieres boites +c a l'arrivee : +c ptnubo(i) = position du dernier noeud de la boite i +c = nombre cumule de noeuds pour les i premieres boites +c +c 2.0. ==> On controle tous les noeuds, sauf dans un cas : si le code +c de calcul associe est Saturne_2D ou Neptune_2D, le maillage +c est une couche 2D du maillage 3D. Dans ce cas, un noeud +c supplementaire a ete cree pour memoriser les cotes mini +c et maxi du maillage. Ce noeud etant isole se trouve en +c premiere position. Il doit etre retire du controle car il +c n'a pas de sens du point de vue du maillage. +c + if ( typcca.eq.26 .or. + > typcca.eq.46 ) then + noedeb = 2 + else + noedeb = 1 + endif +c +cgn 3000 format(i10,3g12.5) +c +c 2.1. ==> en dimension 1 +c + if ( sdim.eq.1 ) then +c + do 21 , lenoeu = noedeb , nbnoto +c + coord(1) = coonoe(lenoeu,1) +cgn write (ulsort,3000) lenoeu,coord(1) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N5', nompro +#endif + call utb3n5 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c +cgn write(ulsort,*) 'lgboin =', lgboin + do 211 , iaux = 1 , lgboin +cgn write(ulsort,*) 'boinoe(',iaux,') =', boinoe(iaux) + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + listbo(ptnubo(boinoe(iaux))) = lenoeu + 211 continue +c + 21 continue +cgn write(ulsort,*) ptnubo +cgn write(ulsort,*) listbo +c +c 2.2. ==> en dimension 2 +c + elseif ( sdim.eq.2 ) then +c + do 22 , lenoeu = noedeb , nbnoto +c + coord(1) = coonoe(lenoeu,1) + coord(2) = coonoe(lenoeu,2) +cgn write (ulsort,3000) lenoeu,coord(1), coord(2) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N4', nompro +#endif + call utb3n4 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c +cgn write(ulsort,*) 'lgboin =', lgboin + do 221 , iaux = 1 , lgboin +cgn write(ulsort,*) 'boinoe(',iaux,') =', boinoe(iaux) + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + listbo(ptnubo(boinoe(iaux))) = lenoeu + 221 continue +c + 22 continue +cgn write(ulsort,*) ptnubo +cgn write(ulsort,*) listbo +c +c 2.3. ==> en dimension 3 +c + else +c + do 23 , lenoeu = noedeb , nbnoto +cgn write (ulsort,*) lenoeu,(coonoe(lenoeu,iaux) , iaux = 1 , sdim) +c + coord(1) = coonoe(lenoeu,1) + coord(2) = coonoe(lenoeu,2) + coord(3) = coonoe(lenoeu,3) +cgn write (ulsort,3000) lenoeu,coord +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB3N3', nompro +#endif + call utb3n3 ( lgboin, boinoe, + > coord, + > nbboit, nbinte, + > boimin, boimax ) +c + do 231 , iaux = 1 , lgboin + ptnubo(boinoe(iaux)) = ptnubo(boinoe(iaux)) + 1 + listbo(ptnubo(boinoe(iaux))) = lenoeu + 231 continue +c + 23 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3n3.F b/src/tool/Utilitaire/utb3n3.F new file mode 100644 index 00000000..f07cb2f6 --- /dev/null +++ b/src/tool/Utilitaire/utb3n3.F @@ -0,0 +1,283 @@ + subroutine utb3n3 ( lgboin, boinoe, + > coonoe, + > nbboit, nbinte, + > boimin, boimax ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N3 +c -- - - -- +c ______________________________________________________________________ +c +c Retourne la liste des boites d'un noeud - 3D +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgboin . s . 1 . longueur de boinoe . +c . boinoe . s . * . liste des boites du noeud en cours . +c . coonoe . e . sdim . coordonnees du noeud . +c . nbboit . e . sdim . nombre de boites dans chaque dimension . +c . nbinte . e . sdim . nombre d'intervalles dans chaque dimension . +c . boimin . a .0:nbintx. limite minimale de chaque boite . +c . boimax . a .0:nbintx. limite maximale de chaque boite . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N3' ) +c +#ifdef _DEBUG_HOMARD_ + integer ulsort + parameter ( ulsort = 6 ) + integer langue + parameter ( langue = 1 ) +#endif +c + integer sdim + parameter ( sdim = 3 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lgboin, boinoe(*) + integer nbboit(sdim), nbinte(sdim) +c + double precision coonoe(sdim) + double precision boimin(3,0:*), boimax(3,0:*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nombbo + integer numint(2,3) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. Pour une dimension iaux donnee, on passe en revue tous les +c intervalles. +c . Quand on rencontre la premiere limite qui est superieure a +c la coordonnee, on stocke le numero de l'intervalle +c dans numint(1,iaux) +c . Sachant que les limites sont legerement recouvrantes, on +c regarde si la coordonnee n'est pas superieure au minima de +c l'intervalle suivant. Si oui, on stocke le numero de +c l'intervalle suivant dans numint(2,iaux). Sinon, +c numint(2,iaux) vaut numint(1,iaux). +c +c numint : 1 2 3 4 +c | | | | | +c x --> 2/0 +c x --> 2/3 +c==== +c + nombbo = 1 + do 21 , iaux = 1 , sdim +c + numint(1,iaux) = 0 +c + do 211 , jaux = 1 , nbinte(iaux) +cgn write (ulsort,90014) jaux,boimax(iaux,jaux) + if ( coonoe(iaux).le.boimax(iaux,jaux) ) then + if ( numint(1,iaux).eq.0 ) then + numint(1,iaux) = jaux + numint(2,iaux) = jaux + if ( coonoe(iaux).ge.boimin(iaux,jaux+1) ) then + numint(2,iaux) = jaux + 1 + nombbo = nombbo*2 + endif + goto 21 + endif + endif + 211 continue + numint(1,iaux) = nbboit(iaux) + numint(2,iaux) = nbboit(iaux) +c + 21 continue +cgn write (ulsort,91020) (numint(1,iaux),iaux=1,sdim) +cgn write (ulsort,91020) (numint(2,iaux),iaux=1,sdim) +cgn write (ulsort,90002) 'nombre de boites', nombbo +c +c 2.2. ==> Increment des pointeurs +c + jaux = nbboit(1)*nbboit(2) +c +c 2.2.1. ==> La boite principale +c + iaux = jaux*(numint(1,3)-1) + > + nbboit(1)*(numint(1,2)-1) + > + numint(1,1) +cgn write (ulsort,90002) 'b',iaux + lgboin = 1 + boinoe(lgboin) = iaux +c +c 2.2.2. ==> Les boites secondaires +c + if ( nombbo.gt.1 ) then +c + lgboin = 1 + boinoe(lgboin) = iaux +c +c recouvrement en x + iaux = jaux*(numint(1,3)-1) + > + nbboit(1)*(numint(1,2)-1) + > + numint(2,1) + if ( iaux.ne.boinoe(1) ) then +cgn write (ulsort,90002) 'n1',lenoeu +cgn write (ulsort,90002) 'b1',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + endif +cgn write (ulsort,91020) (boinoe(jaux),jaux = 1,lgboin) +c +c recouvrement en y + iaux = jaux*(numint(1,3)-1) + > + nbboit(1)*(numint(2,2)-1) + > + numint(1,1) + do 221 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2211 + endif + 221 continue +cgn write (ulsort,90002) 'n2',lenoeu +cgn write (ulsort,90002) 'b2',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux +cgn write (ulsort,91020) (boinoe(jaux),jaux = 1,lgboin) + 2211 continue +c +c recouvrement en z + iaux = jaux*(numint(2,3)-1) + > + nbboit(1)*(numint(1,2)-1) + > + numint(1,1) + do 222 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2221 + endif + 222 continue +cgn write (ulsort,90002) 'n3',lenoeu +cgn write (ulsort,90002) 'b3',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + 2221 continue +c +c recouvrement en x et y + iaux = jaux*(numint(1,3)-1) + > + nbboit(1)*(numint(2,2)-1) + > + numint(2,1) + do 223 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2231 + endif + 223 continue +cgn write (ulsort,90002) 'n3',lenoeu +cgn write (ulsort,90002) 'b3',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + 2231 continue +c +c recouvrement en y et z + iaux = jaux*(numint(2,3)-1) + > + nbboit(1)*(numint(2,2)-1) + > + numint(1,1) + do 224 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2241 + endif + 224 continue +cgn write (ulsort,90002) 'n3',lenoeu +cgn write (ulsort,90002) 'b3',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + 2241 continue +c +c recouvrement en z et x + iaux = jaux*(numint(2,3)-1) + > + nbboit(1)*(numint(1,2)-1) + > + numint(2,1) + do 225 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2251 + endif + 225 continue +cgn write (ulsort,90002) 'n3',lenoeu +cgn write (ulsort,90002) 'b3',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + 2251 continue +c +c recouvrement en x, y et z + iaux = jaux*(numint(2,3)-1) + > + nbboit(1)*(numint(2,2)-1) + > + numint(2,1) + do 226 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2261 + endif + 226 continue +cgn write (ulsort,90002) 'n3',lenoeu +cgn write (ulsort,90002) 'b3',iaux + 2261 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgboin', lgboin + write (ulsort,91010) (boinoe(jaux),jaux = 1 , lgboin) +#endif +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3n4.F b/src/tool/Utilitaire/utb3n4.F new file mode 100644 index 00000000..3806f21b --- /dev/null +++ b/src/tool/Utilitaire/utb3n4.F @@ -0,0 +1,216 @@ + subroutine utb3n4 ( lgboin, boinoe, + > coonoe, + > nbboit, nbinte, + > boimin, boimax ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N4 +c -- - - -- +c ______________________________________________________________________ +c +c Retourne la liste des boites d'un noeud - 2D +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgboin . s . 1 . longueur de boinoe . +c . boinoe . s . 8 . liste des boites du noeud en cours . +c . coonoe . e . sdim . coordonnees du noeud . +c . nbboit . e . sdim . nombre de boites dans chaque dimension . +c . nbinte . e . sdim . nombre d'intervalles dans chaque dimension . +c . boimin . a .0:nbintx. limite minimale de chaque boite . +c . boimax . a .0:nbintx. limite maximale de chaque boite . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N4' ) +c +#ifdef _DEBUG_HOMARD_ + integer ulsort + parameter ( ulsort = 1 ) + integer langue + parameter ( langue = 1 ) +#endif +c + integer sdim + parameter ( sdim = 2 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lgboin, boinoe(8) + integer nbboit(sdim), nbinte(sdim) +c + double precision coonoe(sdim) + double precision boimin(3,0:*), boimax(3,0:*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nombbo + integer numint(2,3) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + do 11 , iaux = 1 , 8 + boinoe(iaux) = 0 + 11 continue +c +c==== +c 2. Pour une dimension iaux donnee, on passe en revue tous les +c intervalles. +c . Quand on rencontre la premiere limite qui est superieure a +c la coordonnee, on stocke le numero de l'intervalle +c dans numint(1,iaux) +c . Sachant que les limites sont legerement recouvrantes, on +c regarde si la coordonnee n'est pas superieure au minima de +c l'intervalle suivant. Si oui, on stocke le numero de +c l'intervalle suivant dans numint(2,iaux). Sinon, +c numint(2,iaux) vaut numint(1,iaux). +c +c numint : 1 2 3 4 +c | | | | | +c x --> 2/0 +c x --> 2/3 +c==== +cgn 3000 format(i10,3g12.5) +cgn 3001 format(10i4) +cgn 3002 format(a,' :',3i10) +c +cgn write (ulsort,3002) 'sdim', sdim + nombbo = 1 + do 21 , iaux = 1 , sdim +cgn write (ulsort,3002) '. Dimension', iaux +cgn write (ulsort,3002) '. nbinte(iaux)', nbinte(iaux) +c + numint(1,iaux) = 0 +c + do 211 , jaux = 1 , nbinte(iaux) +cgn write (ulsort,3000) jaux,boimax(iaux,jaux) + if ( coonoe(iaux).le.boimax(iaux,jaux) ) then + if ( numint(1,iaux).eq.0 ) then + numint(1,iaux) = jaux + numint(2,iaux) = jaux + if ( coonoe(iaux).ge.boimin(iaux,jaux+1) ) then + numint(2,iaux) = jaux + 1 + nombbo = nombbo*2 + endif + goto 21 + endif + endif + 211 continue + numint(1,iaux) = nbboit(iaux) + numint(2,iaux) = nbboit(iaux) +c + 21 continue +cgn write (ulsort,3002) 'numint(1,*)',(numint(1,iaux),iaux=1,sdim) +cgn write (ulsort,3002) 'numint(2,*)',(numint(2,iaux),iaux=1,sdim) +cgn write (ulsort,3002) 'nombre de boites', nombbo +c +c 2.2. ==> Increment des pointeurs +c 2.2.1. ==> La boite principale + iaux = nbboit(1)*(numint(1,2)-1) + > + numint(1,1) +cgn write (ulsort,3002) 'boite principale',iaux + lgboin = 1 + boinoe(lgboin) = iaux +c +c 2.2.2. ==> Les boites secondaires +c + if ( nombbo.gt.1 ) then +c recouvrement en x + iaux = nbboit(1)*(numint(1,2)-1) + > + numint(2,1) + if ( iaux.ne.boinoe(1) ) then +cgn write (ulsort,3002) 'b1',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + endif +cgn write (ulsort,3001) (boinoe(jaux),jaux = 1,lgboin) +c +c recouvrement en y + iaux = nbboit(1)*(numint(2,2)-1) + > + numint(1,1) + do 221 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2211 + endif + 221 continue +cgn write (ulsort,3002) 'b2',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux +cgn write (ulsort,3001) (boinoe(jaux),jaux = 1,lgboin) + 2211 continue +c +c recouvrement en x et y + iaux = nbboit(1)*(numint(2,2)-1) + > + numint(2,1) + do 222 , jaux = 1 , lgboin + if ( iaux.eq.boinoe(jaux) ) then + goto 2221 + endif + 222 continue + lgboin = lgboin + 1 + boinoe(lgboin) = iaux +cgn write (ulsort,3002) 'b3',iaux + 2221 continue +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utb3n5.F b/src/tool/Utilitaire/utb3n5.F new file mode 100644 index 00000000..c227c85b --- /dev/null +++ b/src/tool/Utilitaire/utb3n5.F @@ -0,0 +1,188 @@ + subroutine utb3n5 ( lgboin, boinoe, + > coonoe, + > nbboit, nbinte, + > boimin, boimax ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Bilan - option 3 - phase N5 +c -- - - -- +c ______________________________________________________________________ +c +c Retourne la liste des boites d'un noeud - 1D +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgboin . s . 1 . longueur de boinoe . +c . boinoe . s . 8 . liste des boites du noeud en cours . +c . coonoe . e . sdim . coordonnees du noeud . +c . nbboit . e . sdim . nombre de boites dans chaque dimension . +c . nbinte . e . sdim . nombre d'intervalles dans chaque dimension . +c . boimin . a .0:nbintx. limite minimale de chaque boite . +c . boimax . a .0:nbintx. limite maximale de chaque boite . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTB3N5' ) +c +#ifdef _DEBUG_HOMARD_ + integer ulsort + parameter ( ulsort = 1 ) + integer langue + parameter ( langue = 1 ) +#endif +c + integer sdim + parameter ( sdim = 1 ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lgboin, boinoe(8) + integer nbboit(sdim), nbinte(sdim) +c + double precision coonoe(sdim) + double precision boimin(3,0:*), boimax(3,0:*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nombbo + integer numint(2,3) +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + do 11 , iaux = 1 , 8 + boinoe(iaux) = 0 + 11 continue +c +c==== +c 2. Pour une dimension iaux donnee, on passe en revue tous les +c intervalles. +c . Quand on rencontre la premiere limite qui est superieure a +c la coordonnee, on stocke le numero de l'intervalle +c dans numint(1,iaux) +c . Sachant que les limites sont legerement recouvrantes, on +c regarde si la coordonnee n'est pas superieure au minima de +c l'intervalle suivant. Si oui, on stocke le numero de +c l'intervalle suivant dans numint(2,iaux). Sinon, +c numint(2,iaux) vaut numint(1,iaux). +c +c numint : 1 2 3 4 +c | | | | | +c x --> 2/0 +c x --> 2/3 +c==== +cgn 3000 format(i10,3g12.5) +cgn 3001 format(10i4) +cgn 3002 format(a,' :',3i10) +c +cgn write (ulsort,3002) 'sdim', sdim + nombbo = 1 + do 21 , iaux = 1 , sdim +cgn write (ulsort,3002) '. Dimension', iaux +cgn write (ulsort,3002) '. nbinte(iaux)', nbinte(iaux) +c + numint(1,iaux) = 0 +c + do 211 , jaux = 1 , nbinte(iaux) +cgn write (ulsort,3000) jaux,boimax(iaux,jaux) + if ( coonoe(iaux).le.boimax(iaux,jaux) ) then + if ( numint(1,iaux).eq.0 ) then + numint(1,iaux) = jaux + numint(2,iaux) = jaux + if ( coonoe(iaux).ge.boimin(iaux,jaux+1) ) then + numint(2,iaux) = jaux + 1 + nombbo = nombbo*2 + endif + goto 21 + endif + endif + 211 continue + numint(1,iaux) = nbboit(iaux) + numint(2,iaux) = nbboit(iaux) +c + 21 continue +cgn write (ulsort,3002) 'numint(1,*)',(numint(1,iaux),iaux=1,sdim) +cgn write (ulsort,3002) 'numint(2,*)',(numint(2,iaux),iaux=1,sdim) +cgn write (ulsort,3002) 'nombre de boites', nombbo +c +c 2.2. ==> Increment des pointeurs +c 2.2.1. ==> La boite principale + iaux = nbboit(1)*(numint(1,2)-1) + > + numint(1,1) +cgn write (ulsort,3002) 'boite principale',iaux + lgboin = 1 + boinoe(lgboin) = iaux +c +c 2.2.2. ==> Les boites secondaires +c + if ( nombbo.gt.1 ) then +c +c recouvrement en x + iaux = nbboit(1)*(numint(1,2)-1) + > + numint(2,1) + if ( iaux.ne.boinoe(1) ) then +cgn write (ulsort,3002) 'b1',iaux + lgboin = lgboin + 1 + boinoe(lgboin) = iaux + endif +cgn write (ulsort,3001) (boinoe(jaux),jaux = 1,lgboin) +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utbica.F b/src/tool/Utilitaire/utbica.F new file mode 100644 index 00000000..3af9e84c --- /dev/null +++ b/src/tool/Utilitaire/utbica.F @@ -0,0 +1,152 @@ + subroutine utbica ( commen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BIlan du maillage de CAlcul +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . commen . e . ch80 . commentaire a ecrire en tete . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBICA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nbutil.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer ulsort, langue, codret +c + character*(*) commen +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer tabaux(0:7) +c + character*50 texte1 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Le maillage de calcul comporte '',i10,'' mailles.'')' + texte(1,5) = '(5x,''Ils sont repartis en :'')' + texte(1,6) = + > '(5x,''Le maillage de calcul est forme de'',i10,1x,a)' +c + texte(2,4) = + > '(5x,''The computationnal mesh contains '',i10,'' meshes.'')' + texte(2,5) = '(5x,''They are spread over :'')' + texte(2,6) = + > '(5x,''The computationnal mesh is made of'',i10,1x,a)' +c + 1000 format (5x,'. ',a14,' :',i10) +c + codret = 0 +c +c==== +c 2. ecriture +c==== +c +c 2.1. ==> ecriture des generalites +c + texte1 = ' ' + iaux = min(50,len(commen)) + if ( iaux.gt.0 ) then + texte1(1:iaux) = commen(1:iaux) + endif + write (ulsort,21000) texte1 +21000 format(//,5x,a50,/) +c +c 2.2. ==> ecriture des caracteristiques du maillage de calcul +c + tabaux(0) = nbmapo + tabaux(1) = nbsegm + tabaux(2) = nbtria + tabaux(3) = nbtetr + tabaux(4) = nbquad + tabaux(5) = nbpyra + tabaux(6) = nbhexa + tabaux(7) = nbpent +c + jaux = 0 + do 221 , iaux = 0 , 7 + if ( tabaux(iaux).gt.0 ) then + jaux = jaux + 1 + kaux = iaux + endif + 221 continue +c + if ( jaux.gt.1 ) then +c + write (ulsort,texte(langue,4)) nbelem + write (ulsort,texte(langue,5)) + do 222 , iaux = 0 , 7 + if ( tabaux(iaux).gt.0 ) then + write (ulsort,1000) mess14(langue,3,iaux), tabaux(iaux) + endif + 222 continue +c + else +c + write (ulsort,texte(langue,6)) tabaux(kaux), + > mess14(langue,3,kaux) +c + endif +c + end diff --git a/src/tool/Utilitaire/utbide.F b/src/tool/Utilitaire/utbide.F new file mode 100644 index 00000000..b2f558cd --- /dev/null +++ b/src/tool/Utilitaire/utbide.F @@ -0,0 +1,79 @@ + subroutine utbide ( codebi, nbval1, tabaux ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : du BInaire vers le DEcimal +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . codebi . e . 1 . code binaire a decoder (<4095=2*12-1) . +c . nbval1 . s . 1 . nombre de valeurs 1 . +c . tabaux . s . 12 . valeurs 0/1 . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer codebi + integer nbval1, tabaux(12) +c +c 0.4. ==> variables locales +c + integer iaux + integer valeur, reste +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. traitement +c Remarque : on pourrait proceder avec des if sucessifs. +c Est-ce plus economique ? +c==== +c + nbval1 = 0 + valeur = codebi + do 10 , iaux = 1 , 12 +c + reste = mod(valeur,2) + if ( reste.eq.0 ) then + tabaux(iaux) = 0 + else + tabaux(iaux) = 1 + valeur = valeur - 1 + nbval1 = nbval1 + 1 + endif + valeur = valeur/2 +c + 10 continue +c + end diff --git a/src/tool/Utilitaire/utbil1.F b/src/tool/Utilitaire/utbil1.F new file mode 100644 index 00000000..f59a49be --- /dev/null +++ b/src/tool/Utilitaire/utbil1.F @@ -0,0 +1,1551 @@ + subroutine utbil1 ( nomail, commen, typbil, action, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BILan sur le maillage - phase 1 +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . commen . e . ch80 . commentaire a ecrire en tete . +c . typbil . e . 1 . type de bilan . +c . . . . la valeur de typbil est le produit de : . +c . . . . 0 : rien du tout . +c . . . . 2 : nombre d'entites homard . +c . . . . 3 : interpenetration des mailles . +c . . . . 5 : qualite des mailles . +c . . . . 7 : nombre d'entites du calcul . +c . . . . 11 : connexite . +c . . . . 13 : tailles des sous-domaines . +c . . . . 17 : diagnostic des elements du calcul . +c . . . . 19 : diametre des mailles . +c . action . e .char8/10. action en cours . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBIL1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca2.h" +#include "envada.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail + character*(*) action + character*(*) commen +c + integer typbil + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nrosec + integer phetno, pcoono, adcocs + integer psomar, phetar + integer advotr, adpptr + integer advoqu, adppqu + integer paretr, phettr, pnivtr, ppertr + integer parequ, phetqu, pnivqu + integer ptrite, pcotrt, parete, phette, pperte, adtes2 + integer pquahe, pcoquh, parehe, phethe, pperhe + integer pfacpy, pcofay, parepy, phetpy, pperpy, adpys2 + integer pfacpe, pcofap, parepe, phetpe, pperpe + integer pnp2ar + integer ppovos, pvoiso + integer pposif, pfacar + integer pfamno, pcfano + integer pfammp, pcfamp + integer pfamar, pcfaar + integer pfamtr, pcfatr + integer pfamqu, pcfaqu + integer pfamte, pcfate + integer pfamhe, pcfahe + integer pfampy, pcfapy + integer pfampe, pcfape + integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5 + integer ptrav6, ptrav7 + integer ptra11, ptra12, ptra13, ptra14 + integer ptra15, ptra16 + integer ptra17, ptra18 + integer ltrav1 + integer adnumf, pinftb + integer adpoin, adtail, adtabl + integer nbpqt +c + integer codava + integer iaux, jaux, kaux, laux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer nuroul, lnomfl + integer nbgrfm, nbfmed, ngrouc, nbelig +c + logical voinoe +c + character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5 + character*8 ntrav6, ntrav7 + character*8 ntra11, ntra12, ntra13, ntra14 + character*8 ntra15, ntra16 + character*8 ntra17, ntra18 + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*16 unicoo(2,3) + character*200 nomflo +c + integer nbmess + parameter (nbmess = 30 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c + if ( typbil.ne.0 ) then +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Date de creation : '',a48)' + texte(1,5) = '(5x,''Dimension :'',i2)' + texte(1,6) = '(5x,''Degre :'',i2)' + texte(1,7) = '(5x,''C''''est un maillage de depart.'')' + texte(1,8) = + > '(5x,''C''''est un maillage obtenu apres une adaptation.'')' + texte(1,9) = + >'(5x,''C''''est un maillage obtenu apres '',i6,'' adaptations.'')' + texte(1,10) = '(5x,''Le niveau minimum actif est :'',i6)' + texte(1,11) = '(5x,''Le niveau minimum actif est :'',i6,''.5'')' + texte(1,12) = '(5x,''Le niveau maximum actif est :'',i6)' + texte(1,13) = '(5x,''Le niveau maximum actif est :'',i6,''.5'')' + texte(1,14) = + > '(/,9x,'// + >'''Direction | Unite | Minimum | Maximum'')' + texte(1,15) = '(5x,a16,'' | '',a16,2x,2(''|'',g12.5))' + texte(1,19) = '(''On impose un code de retour nul.'')' + texte(1,20) = + > '(5x,''Le maillage est non-conforme a 1 arete coupee.'')' + texte(1,21) = '(5x,''Le maillage est conforme par boites.'')' + texte(1,22) = '(5x,''Le maillage est conforme.'')' + texte(1,23) = + >'(5x,'// + >'''Le maillage est non-conforme a max 2 aretes non coupees.'')' + texte(1,24) = + > '(5x,''Le maillage est non-conforme a 1 noeud pendant.'')' + texte(1,25) = + > '(5x,''Le maillage est non-conforme sans contrainte.'')' + texte(1,26) = + > '(5x,''Le maillage est non-conforme par construction.'')' + texte(1,30) = '(//,''ANALYSE DU MAILLAGE'',/,19(''=''),/)' +c + texte(2,4) = '(5x,''Date of creation : '',a48)' + texte(2,5) = '(5x,''Dimension :'',i2)' + texte(2,6) = '(5x,''Degree :'',i2)' + texte(2,7) = '(5x,''This is an initial mesh.'')' + texte(2,8) = + > '(5x,''This is a mesh obtained after one adaptation.'')' + texte(2,9) = + > '(5x,''This is a mesh obtained after '',i6,'' adaptations.'')' + texte(2,10) = '(5x,''The minimum active level is:'',i6)' + texte(2,11) = '(5x,''The minimum active level is:'',i6,''.5'')' + texte(2,12) = '(5x,''The maximum active level is:'',i6)' + texte(2,13) = '(5x,''The maximum active level is:'',i6,''.5'')' + texte(2,14) = + > '(/,9x,'// + >'''Direction | Unit | Minimum | Maximum'')' + texte(2,15) = '(5x,a16,'' | '',a16,2x,2(''|'',g12.5))' + texte(2,19) = '(''A zero error code is imposed.'')' + texte(2,20) = + > '(5x,''The mesh is non-conformal with 1 cut edge.'')' + texte(2,21) = '(5x,''The mesh is conformal with boxes.'')' + texte(2,22) = '(5x,''The mesh is conformal.'')' + texte(2,23) = + > '(5x,''The mesh is non-conformal with at max 2 non cut edges.'')' + texte(2,24) = + > '(5x,''The mesh is non-conformal with 1 hanging node.'')' + texte(2,25) = + > '(5x,''The mesh is non-conformal without any rule.'')' + texte(2,26) = + > '(5x,''The mesh is non-conformal from the beginning.'')' + texte(2,30) = '(//,''ANALYSIS OF THE MESH'',/,20(''=''),/)' +c +#include "impr03.h" +c +10050 format (5x,a50) +10080 format (5x,a80) +10063 format (5x,63('-')) +c +c==== +c 2. determination des pointeurs associes aux structures de +c donnees passees en argument +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. ==> tableaux ; codret', codret + call dmflsh(iaux) +#endif +c +c 2.2.1. ==> les standards +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD01', nompro +#endif + iaux = 3*19 + if ( mod(typbil,3).eq.0 ) then + iaux = iaux*2 + endif + if ( mod(typbil,7).eq.0 ) then + iaux = iaux*7 + endif + call utad01 ( iaux, nhnoeu, + > phetno, + > pfamno, pcfano, jaux, + > pcoono, jaux, jaux, adcocs, + > ulsort, langue, codret ) +c + if ( nbmpto.ne.0 ) then +c + if ( mod(typbil,7).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro +#endif + iaux = 259 + call utad02 ( iaux, nhmapo, + > jaux , jaux , jaux , jaux, + > pfammp, pcfamp, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + iaux = 2 + if ( mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 ) then + iaux = iaux*259 + endif + if ( degre.eq.2 ) then + iaux = iaux*13 + endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux , jaux, + > pfamar, pcfaar, jaux, + > jaux, pnp2ar, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + iaux = 2 + if ( mod(typbil,5).eq.0 .or. + > mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,19).eq.0 ) then + iaux = iaux*14245 + else + if ( mod(typbil,17).eq.0 ) then + iaux = iaux*259 + else + iaux = iaux*55 + endif + endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux , ppertr, + > pfamtr, pcfatr, jaux, + > pnivtr, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + iaux = 2 + if ( mod(typbil,5).eq.0 .or. + > mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,19).eq.0 ) then + iaux = iaux*14245 + else + if ( mod(typbil,17).eq.0 ) then + iaux = iaux*259 + else + iaux = iaux*55 + endif + endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux , jaux, + > pfamqu, pcfaqu, jaux, + > pnivqu, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 26 + if ( mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 ) then + iaux = iaux*259 + endif + if ( nbteh1.gt.0 .or. nbteh2.gt.0 .or. nbteh3.gt.0 .or. + > nbteh4.gt.0 .or. + > nbtep0.gt.0 .or. nbtep1.gt.0 .or. nbtep2.gt.0 .or. + > nbtep3.gt.0 .or. nbtep4.gt.0 .or. nbtep5.gt.0 .or. + > nbtedh.gt.0 .or. nbtedp.gt.0 ) then + iaux = iaux*5*17 + endif + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , pperte, + > pfamte, pcfate, jaux, + > jaux, pcotrt, adtes2, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 26 + if ( mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 ) then + iaux = iaux*259 + endif + if ( mod(typbil,7).eq.0 ) then + iaux = iaux*5 + endif + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , pperhe, + > pfamhe, pcfahe, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 26 + if ( mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 ) then + iaux = iaux*259 + endif + if ( nbpyh1.gt.0 .or. nbpyh2.gt.0 .or. nbpyh3.gt.0 .or. + > nbpyh4.gt.0 .or. + > nbpyp0.gt.0 .or. nbpyp1.gt.0 .or. nbpyp2.gt.0 .or. + > nbpyp3.gt.0 .or. nbpyp4.gt.0 .or. nbpyp5.gt.0 .or. + > nbpydh.gt.0 .or. nbpydp.gt.0 ) then + iaux = iaux*5*17 + endif + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , pperpy, + > pfampy, pcfapy, jaux, + > jaux, pcofay, adpys2, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 26 + if ( mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 ) then + iaux = iaux*259 + endif + if ( mod(typbil,7).eq.0 ) then + iaux = iaux*5 + endif + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , pperpe, + > pfampe, pcfape, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 2.2.2. ==> les voisinages +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Debut etape 2.2.2 : codret', codret +#endif +c +c 2.2.2.1. ==> les voisinages des noeuds s'ils sont absents +c + voinoe = .false. +c + if ( mod(typbil,11).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmobal ( nhvois//'.0D/1D', codre1 ) +c + if ( codre1.eq.0 ) then + codret = 0 + elseif ( codre1.eq.1 ) then + voinoe = .true. + else + codret = 2 + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( .not.voinoe ) then +c + iaux = 1 + jaux = 0 + kaux = 0 + laux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVOIS', nompro +#endif + call utvois ( nomail, nhvois, + > iaux, jaux, kaux, laux, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 2.2.2.2. ==> les adresses +c + if ( codret.eq.0 ) then +c + iaux = 3 + if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*5 + endif + if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*7 + endif + if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then + iaux = iaux*13*17 + endif + if ( mod(typbil,11).eq.0 ) then + iaux = iaux*2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + call utad04 ( iaux, nhvois, + > ppovos, pvoiso, pposif, pfacar, + > advotr, advoqu, + > jaux, jaux, adpptr, adppqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro,nhvois) +cgn call gmprsx (nompro,nhvois//'.PyPe/Tri') +c +c 2.2.3. ==> les infos complementaires eventuelles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Debut etape 2.2.3 : codret', codret +#endif +c +c 2.2.3.1. ==> les unites des coordonnees +c si rien n'est defini, on suppose que ce sont x, y et z +c + if ( codret.eq.0 ) then +c + call gmobal ( nhsupe//'.Tab7', codre0 ) +c + if ( codre0.eq.0 ) then +c 1234567890123456 + unicoo(1,1) = 'x ' + unicoo(2,1) = 'Inconnue ' + unicoo(1,2) = 'y ' + unicoo(2,2) = 'Inconnue ' + unicoo(1,3) = 'z ' + unicoo(2,3) = 'Inconnue ' +c + elseif ( codre0.eq.2 ) then +c + call gmadoj ( nhsups//'.Tab3', pinftb, iaux, codre1 ) + call gmliat ( nhsups, 3, iaux, codre2 ) + nbpqt = iaux/10 +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.eq.0 ) then +c + do 2231 , iaux = 1, nbpqt +c + jaux = pinftb + 10*(iaux-1) +cgn write (ulsort,90064) iaux, '%'//smem(jaux)// +cgn > smem(jaux+1)//smem(jaux+2)//smem(jaux+3)//'%' +c +c 2.1. Repere et noms des coordonnees +c + if ( smem(jaux).eq.'NomCo ' ) then +c + do 22311 , kaux = 1 , sdim + unicoo(1,kaux) = smem(jaux+2*kaux-1)//smem(jaux+2*kaux) +cgn write (ulsort,90064) kaux, '%'//unicoo(1,kaux)//'%' +22311 continue +c +c 2.2. Unites des coordonnees +c + elseif ( smem(jaux).eq.'UniteCo ' ) then +c + do 22312 , kaux = 1 , sdim + unicoo(2,kaux) = smem(jaux+2*kaux-1)//smem(jaux+2*kaux) +cgn write (ulsort,90064) kaux, '%'//unicoo(2,kaux)//'%' +22312 continue +c + endif +c + 2231 continue +c + endif +c + else +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 2.2.3.2. ==> les noms des sous-domaines du calcul +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.3.2. noms sd : codret', codret +#endif +c +cgn call gmprsx ( nompro//' nhsupe', nhsupe ) +cgn call gmprsx ( nompro//' nhsups', nhsups ) + if ( codret.eq.0 ) then +c + call gmobal ( nhsupe//'.Tab9', codre0 ) +c + if ( codre0.eq.0 ) then +c + nbfmed = 0 +c + elseif ( codre0.eq.2 ) then +c + call gmliat ( nhsupe, 9, nbfmed, codre0 ) + codret = max ( abs(codre0), codret ) +c + if ( nbfmed.gt.1 ) then +c + call gmliat ( nhsupe, 6, iaux, codre1 ) + call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre2 ) + call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre3 ) + call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre4 ) + call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + ngrouc = iaux/10 +c + else +c + ngrouc = 0 +c + endif +c + else +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'codret', codret + write(ulsort,90002) 'nbfmed', nbfmed + write(ulsort,90002) 'ngrouc', ngrouc +#endif + if ( nbfmed.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 10*ngrouc + call gmalot ( ntra17, 'chaine ', iaux, ptra17, codre1 ) + call gmalot ( ntra18, 'entier ', ngrouc, ptra18, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFMLG', nompro +#endif + call utfmlg ( nbfmed, ngrouc, + > imem(adpoin), imem(adtail), smem(adtabl), + > nbgrfm, smem(ptra17), imem(ptra18), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 10*ngrouc + jaux = 10*nbgrfm + call gmmod ( ntra17, ptra17, iaux, jaux, 1, 1, codre1 ) + call gmmod ( ntra18, ptra18, ngrouc, nbgrfm, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbgrfm', nbgrfm + call gmprsx ( nompro, ntra17 ) + call gmprsx ( nompro, ntra18 ) +#endif +c + endif +c + endif +c +c 2.2.3.3. ==> les elements elimines +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2.3.3. elements elimines : codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhelig, 1, nbelig, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +c==== +c 3. allocation de tableaux de travail +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Debut etape 3 : codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + if ( mod(typbil,5).eq.0 .or. mod(typbil,19).eq.0 ) then + ltrav1 = max ( nbtrto, nbquto, + > nbteto, nbpyto, nbheto, nbpeto ) + iaux = max ( iaux, 2*ltrav1) + endif + if ( mod(typbil,7).eq.0 ) then + iaux = max ( iaux, 2*nivsup+3 ) + endif + if ( mod(typbil,11).eq.0 ) then + iaux = max ( iaux, + > nbarto, + > nbtrto + nbquto, + > nbteac + nbheac + nbpyac + nbpeac ) + endif + if ( mod(typbil,13).eq.0 ) then + iaux = max ( iaux, + > nbarac, + > nbtrac + nbquac, + > nbteac + nbheac + nbpyac + nbpeac ) + endif + if ( mod(typbil,17).eq.0 ) then + iaux = max ( iaux, + > nbnoto ) + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lg de tabaui (trav1) : ', iaux +#endif + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + if ( mod(typbil,11).eq.0 ) then + iaux = max ( iaux, + > nbnoto ) + endif + if ( mod(typbil,13).eq.0 ) then + iaux = max ( iaux, + > nbfmed ) + endif +c + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( mod(typbil,11).eq.0 ) then +c + call gmalot ( ntrav2, 'entier ', nbnoto, ptrav2, codre1 ) + call gmalot ( ntrav3, 'entier ', nbarto, ptrav3, codre2 ) + iaux = max( nbarto, nbquto + nbtrto + 1 ) + call gmalot ( ntrav4, 'entier ', iaux, ptrav4, codre3 ) + jaux = max ( nbarto, nbquto + nbtrto + 1, + > nbteto + nbheto + nbpyto + nbpeto ) + call gmalot ( ntrav5, 'entier ', jaux, ptrav5, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lg de trav2', nbnoto + write(ulsort,90002) 'lg de trav3', nbarto + write(ulsort,90002) 'lg de trav4', iaux + write(ulsort,90002) 'lg de trav5', Jaux +#endif +c + jaux = nbquto + nbtrto + 1 + call gmalot ( ntra11, 'entier ', jaux, ptra11, codre1 ) + call gmalot ( ntra12, 'entier ', nbnoto, ptra12, codre2 ) + call gmalot ( ntra13, 'entier ', nbarto, ptra13, codre3 ) + call gmalot ( ntra14, 'entier ', jaux, ptra14, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmalot ( ntra15, 'entier ', nbarto, ptra15, codre1 ) + call gmalot ( ntra16, 'entier ', nbarto, ptra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 0 + if ( mod(typbil,5).eq.0 .or. mod(typbil,19).eq.0 ) then + iaux = max ( iaux, nbtrto, nbquto, + > nbteto, nbpyto, nbheto, nbpeto ) + endif + if ( mod(typbil,13).eq.0 ) then + iaux = max ( iaux, + > nbarac, + > nbtrac + nbquac, + > nbteac + nbheac + nbpyac + nbpeac ) + endif +c + if ( iaux.ne.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lg de tabaur (trav6)', iaux +#endif + call gmalot ( ntrav6, 'reel ', iaux, ptrav6, codret ) + if ( codret.eq.0 ) then + if ( mod(typbil,5).eq.0 ) then + call gmalot ( ntrav7, 'reel ', iaux, ptrav7, codret ) + endif + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fin etape 3 avec codret', codret +#endif +c +c==== +c 4. fichier de sortie du bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Debut etape 4 : codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI', nompro +#endif + iaux = 1 + jaux = -1 + if ( rafdef.eq.31 ) then + kaux = 1 + else + kaux = nbiter + endif + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, action, kaux, jaux, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fin etape 4 avec codret', codret +#endif +c +c==== +c 5. bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Debut etape 5 : codret', codret +#endif +c + if ( codret.eq.0 ) then +c + write (nuroul,texte(langue,30)) +c + endif +c +c 5.1. ==> ecriture des generalites +c + if ( codret.eq.0 ) then +c + iaux = min (50, len(commen)) + if ( iaux.gt.0 ) then + write (nuroul,10050) commen(1:iaux) + endif + write (nuroul,10080) titre + write (nuroul,texte(langue,4)) ladate + write (nuroul,texte(langue,5)) sdim + write (nuroul,texte(langue,6)) degre + if ( nbiter.eq.0 ) then + write (nuroul,texte(langue,7)) + else + if ( nbiter.eq.1 ) then + write (nuroul,texte(langue,8)) + else + write (nuroul,texte(langue,9)) nbiter + endif + iaux = mod(niincf,10) + if ( iaux.ne.0 ) then + if ( nivinf.le.((niincf-5)/10) ) then + iaux = 0 + endif + endif + if ( iaux.eq.0 ) then + write (nuroul,texte(langue,10)) nivinf + else + write (nuroul,texte(langue,11)) (niincf-5)/10 + endif + iaux = mod(nisucf,10) + if ( iaux.eq.0 ) then + write (nuroul,texte(langue,12)) nivsup + else + write (nuroul,texte(langue,13)) (nisucf-5)/10 + endif + endif +#ifdef _DEBUG_HOMARD_ + iaux = 21 + min(maconf,4) + write (nuroul,texte(langue,iaux)) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + write (nuroul,texte(langue,14)) + write (nuroul,10063) + do 51 , iaux = 1 , sdim + if ( rmem(adcocs+6+iaux).ge.0.d0 ) then + write (nuroul,texte(langue,15)) unicoo(1,iaux),unicoo(2,iaux), + > rmem(adcocs+iaux), rmem(adcocs+3+iaux) +#ifdef _DEBUG_HOMARD_ + else + write (nuroul,texte(langue,15)) unicoo(1,iaux),unicoo(2,iaux), + > rmem(adcocs+iaux), rmem(adcocs+3+iaux) +#endif + endif + 51 continue +c + endif +c +c 5.2. ==> denombrement des entites au sens homard : +c typbil est multiple de 2 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.2 Nombres HOMARD codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(typbil,2).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB02A', nompro +#endif + call utb02a ( imem(phetar), + > imem(phettr), imem(ppertr), imem(advotr), + > imem(phetqu), imem(advoqu), + > imem(pposif), imem(pfacar), + > nuroul, ulsort, langue, codret ) +c + endif +c + endif +c +c 5.3. ==> controle de la non-interpenetration des mailles : +c typbil est multiple de 3 +C attention : a faire pour HEXA, PYRA, PENT +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.3. Interpenetration codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,3).eq.0 ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB03A', nompro +#endif + call utb03a ( imem(phetno), rmem(pcoono), + > imem(phetar), imem(psomar), imem(pposif), + > imem(phettr), imem(paretr), imem(advotr), + > imem(phetqu), imem(parequ), imem(advoqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > imem(pnp2ar), + > rmem(adcocs+1), rmem(adcocs+4), rmem(adcocs+7), + > nuroul, ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c +c 5.4. ==> qualite des mailles : typbil est multiple de 5 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.4. Qualite codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,5).eq.0 ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB05A', nompro +#endif + call utb05a ( iaux, + > rmem(pcoono), imem(psomar), + > imem(phettr), imem(paretr), + > imem(pfamtr), imem(pcfatr), + > imem(phetqu), imem(parequ), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > nbiter, + > jaux, + > imem(ptrav1), imem(ptrav1+ltrav1), + > rmem(ptrav6), rmem(ptrav7), + > nuroul, + > ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c +c 5.5. ==> denombrement des entites du maillage de calcul : +c typbil est multiple de 7 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.5. Nombres calcul ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(typbil,7).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB07A', nompro +#endif + call utb07a ( imem(phetar), + > imem(phettr), imem(pnivtr), imem(ppertr), + > imem(advotr), + > imem(phetqu), imem(pnivqu), + > imem(advoqu), + > imem(phette), imem(ptrite), + > imem(pperte), imem(adtes2), + > imem(phethe), imem(pquahe), imem(pperhe), + > imem(phetpy), imem(pfacpy), + > imem(pperpy), imem(adpys2), + > imem(phetpe), imem(pfacpe), imem(pperpe), + > imem(pposif), imem(pfacar), + > imem(pfamno), imem(pcfano), + > imem(pfammp), imem(pcfamp), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > imem(ptrav1), + > nuroul, ulsort, langue, codret ) +c + endif +c + endif +c +c 5.6. ==> analyse de la connexite du maillage de calcul : +c typbil est multiple de 11 +c remarque : l'analyse est possible seulement si le maillage +c est conforme +c remarque : impossible si on a elimine des mailles +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.6. Connexite ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,11).eq.0 ) then +c + if ( nbelig.eq.0 ) then +c + if ( ( maconf.eq.-1 ) .or. ( maconf.eq.0 ) ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB11A', nompro +#endif + call utb11a ( imem(phetar), imem(psomar), + > imem(phettr), imem(paretr), + > imem(advotr), imem(adpptr), + > imem(phetqu), imem(parequ), + > imem(advoqu), imem(adppqu), + > imem(phette), imem(ptrite), + > imem(phethe), imem(pquahe), + > imem(phetpy), imem(pfacpy), + > imem(phetpe), imem(pfacpe), + > imem(ppovos), imem(pvoiso), + > imem(pposif), imem(pfacar), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > imem(ptrav1), imem(ptrav2), + > imem(ptrav3), imem(ptrav4), + > imem(ptra11), imem(ptra12), + > imem(ptra13), imem(ptra14), + > imem(ptra15), imem(ptra16), + > imem(ptrav5), + > nuroul, + > ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c + endif +c + endif +c +c 5.7. ==> longueurs, surfaces et volumes des sous-domaines du maillage +c de calcul : typbil est multiple de 13 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.7. tailles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,13).eq.0 ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB13A', nompro +#endif + call utb13a ( rmem(pcoono), + > imem(psomar), imem(phetar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(pfamte), imem(pcfate), + > imem(pfamhe), imem(pcfahe), + > imem(pfampy), imem(pcfapy), + > imem(pfampe), imem(pcfape), + > nbfmed, imem(adnumf), unicoo, + > imem(adpoin), imem(adtail), smem(adtabl), + > nbgrfm, smem(ptra17), imem(ptra18), + > imem(ptrav1), rmem(ptrav6), + > imem(ptrav2), + > nuroul, + > ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c +c 5.8. ==> caracteristiques du calcul : typbil est multiple de 17 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.8. caracteristiques ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,17).eq.0 ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB17A', nompro +#endif + call utb17a ( imem(phetar), imem(psomar), imem(pnp2ar), + > imem(pposif), imem(pfacar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(phette), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phethe), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phetpy), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpe), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(advotr), + > imem(advoqu), + > imem(pfamar), imem(pcfaar), + > imem(pfamtr), imem(pcfatr), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrav1), + > nuroul, + > ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c +c 5.9. ==> diametre des mailles : typbil est multiple de 19 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '5.9. diametre codret', codret +#endif +c + if ( codret.eq.0 ) then +c + taetco(4) = taetco(4) + 1 + nrosec = taetco(4) +c + if ( mod(typbil,19).eq.0 ) then +c + if ( action(1:4).eq.'info' ) then + call gtdems (nrosec) + endif +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTB19A', nompro +#endif + call utb19a ( iaux, + > rmem(pcoono), imem(psomar), + > imem(phettr), imem(paretr), + > imem(pfamtr), imem(pcfatr), + > imem(phetqu), imem(parequ), + > imem(pfamqu), imem(pcfaqu), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(phette), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(phethe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(phetpy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > imem(phetpe), + > nbiter, + > imem(ptrav1), rmem(ptrav6), + > nuroul, + > ulsort, langue, codret ) +c + if ( action(1:4).eq.'info' ) then + call gtfims (nrosec) + endif +c + endif +c + endif +c +c==== +c 6. menage +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '6. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nuroul.ne.ulsort ) then + call gufeul ( nuroul , codret) + endif +c + if ( mod(typbil,5).eq.0 .or. + > mod(typbil,7).eq.0 .or. + > mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,17).eq.0 .or. + > mod(typbil,19).eq.0 ) then +cgn write(ulsort,*) 'trav1' +cgn call gmprsx (nompro, ntrav1) + call gmlboj ( ntrav1 , codret ) + endif +c + if ( mod(typbil,11).eq.0 .or. + > mod(typbil,13).eq.0 ) then +cgn write(ulsort,*) 'trav2' +cgn call gmprsx (nompro, ntrav2) + call gmlboj ( ntrav2 , codret ) + endif +c + if ( mod(typbil,11).eq.0 ) then +c +cgn write(ulsort,*) 'trav3' +cgn call gmprsx (nompro, ntrav3) + call gmlboj ( ntrav3, codre1 ) +cgn write(ulsort,*) 'trav4' +cgn call gmprsx (nompro, ntrav4) + call gmlboj ( ntrav4, codre2 ) +cgn write(ulsort,*) 'trav5' +cgn call gmprsx (nompro, ntrav5) + call gmlboj ( ntrav5, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmlboj ( ntra11, codre1 ) + call gmlboj ( ntra12, codre2 ) + call gmlboj ( ntra13, codre3 ) + call gmlboj ( ntra14, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmlboj ( ntra15, codre1 ) + call gmlboj ( ntra16, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( nbfmed.gt.0 ) then +c + call gmlboj ( ntra17, codre1 ) + call gmlboj ( ntra18, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( mod(typbil,5).eq.0 .or. + > mod(typbil,13).eq.0 .or. + > mod(typbil,19).eq.0 ) then +cgn write(ulsort,*) 'trav6' +cgn call gmprsx (nompro, ntrav6) + call gmlboj ( ntrav6, codre0 ) + codret = max ( abs(codre0), codret ) + endif + if ( mod(typbil,5).eq.0 ) then + call gmlboj ( ntrav7, codre0 ) + codret = max ( abs(codre0), codret ) + endif +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( mod(typbil,11).eq.0 ) then +c + if ( .not.voinoe ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Suppression de nhvois.0D/1D' +#endif + call gmsgoj ( nhvois//'.0D/1D', codret ) +c + endif +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'Fin etape 6 avec codret', codret +#endif +c +c==== +c 7. on impose un code de retour toujours nul +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,19)) +#endif + codret = 0 +c + write(ulsort,*) taetco(4) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Utilitaire/utbilm.F b/src/tool/Utilitaire/utbilm.F new file mode 100644 index 00000000..2c6ac5ac --- /dev/null +++ b/src/tool/Utilitaire/utbilm.F @@ -0,0 +1,236 @@ + subroutine utbilm ( nomail, commen, typbil, action, + > lgetco, taetco, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BILan sur le Maillage +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . commen . e . ch80 . commentaire a ecrire en tete . +c . typbil . e . 1 . type de bilan . +c . . . . la valeur de typbil est le produit de : . +c . . . . 0 : rien du tout . +c . . . . 2 : nombre d'entites homard . +c . . . . 3 : interpenetration des mailles . +c . . . . 5 : qualite des mailles . +c . . . . 7 : nombre d'entites du calcul . +c . . . . 11 : connexite . +c . . . . 13 : tailles des sous-domaines . +c . action . e .char8/10. action en cours . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBILM' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nomail + character*(*) action + character*(*) commen +c + integer typbil + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nretap, nrsset +c + integer codava + integer iaux +c + character*6 saux06 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,a6,'' ANALYSE DU MAILLAGE'')' + texte(1,5) = '(26(''=''),/)' + texte(1,6) = '(''Erreur dans la verification du maillage.'')' +c + texte(2,4) = '(/,a6,'' MESH ANALYSIS'')' + texte(2,5) = '(20(''=''),/)' + texte(2,6) = '(''Error in the verification of the mesh.'')' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux06, iaux, codret ) +c +c 1.5 ==> le titre +c + write (ulsort,texte(langue,4)) saux06 + write (ulsort,texte(langue,5)) +c +#include "impr03.h" +c +c==== +c 2. verifications +c==== +c + if ( action(1:4).eq.'info' ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVERI', nompro +#endif +c + iaux = 0 + call utveri ( action, nomail, nompro, iaux, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,6)) + codret = 0 + goto 40 +c + endif +c + endif +c + endif +c +c==== +c 3. Bilan reel +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Bilan reel ; codret', codret +#endif +c +c 3.1. ==> Pour la conversion avant l'adaptation, on ne fait le bilan +c que si c'est explictement demande +c + if ( codret.eq.0 ) then +c + iaux = abs(typbil) + if ( action(1:4).eq.'avad' ) then + if ( typbil.gt.0 ) then + iaux = 0 + endif + endif +c + endif +c +c 3.2. ==> Appel du programme de base +c + if ( codret.eq.0 ) then +c + if ( iaux.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBIL1', nompro +#endif + call utbil1 ( nomail, commen, iaux, action, + > lgetco, taetco, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 4. on impose un code de retour toujours nul +c==== +c + 40 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '40 continue ; codret', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif +c + endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Utilitaire/utboar.F b/src/tool/Utilitaire/utboar.F new file mode 100644 index 00000000..9fa51e20 --- /dev/null +++ b/src/tool/Utilitaire/utboar.F @@ -0,0 +1,365 @@ + subroutine utboar ( choix, + > nbarto, nbtrto, nbquto, nbteto, nbfaar, + > hetare, filare, + > posifa, facare, + > aretri, hettri, voltri, + > arequa, hetqua, + > nbar2d, nbar3d, borare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BOrd - ARetes +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du travail a faire . +c . . . . 1 : les aretes du bord du domaine . +c . . . . 2 : les aretes a la limite entre deux zones. +c . . . . de raffinement de niveau different . +c . . . . 3 : idem mais en ignorant le bord exterieur. +c . nbarto . e . 1 . nombre d'aretes total . +c . nbtrto . e . 1 . nombre de triangles total . +c . nbquto . e . 1 . nombre de quadrangles total . +c . nbteto . e . 1 . nombre de tetraedres total . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . filare . e . nbarto . fille ainee de chaque arete . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . nbar2d . s . 1 . nombre d'aretes de bord 2D . +c . nbar3d . s . 1 . nombre d'aretes de bord 3D . +c . borare . s . nbarto . reperage des aretes de bord . +c . . . . avec le choix 1 (aretes du bord du domaine). +c . . . . 0 : l'arete est interne au domaine . +c . . . . 1 : l'arete borde une region 2D . +c . . . . 2 : l'arete borde une region 3D . +c . . . . avec le choix 3 (aretes du bord du domaine). +c . . . . 0 : l'arete est interne au domaine . +c . . . . 1 : l'arete borde une region 2D . +c . . . . 2 : l'arete borde une region 3D . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBOAR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer choix + integer nbarto, nbtrto, nbquto, nbteto, nbfaar + integer hetare(nbarto), filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), hettri(nbtrto) + integer voltri(2,nbtrto) + integer arequa(nbquto,4), hetqua(nbquto) + integer nbar2d, nbar3d, borare(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer ideb, ifin + integer larete, laface + integer nbfact +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + logical aubord +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre d''''aretes de bord '',i1,''D :'',i10)' + texte(1,5) = '(''Traitement des '',a)' + texte(1,6) = '(a,''.. Examen du '',a,''numero '',i10)' +c + texte(2,4) = '(''Number of '',i1,''D boundary edges :'',i10)' + texte(2,5) = '(''Treatment of '',a)' + texte(2,6) = '(a,''.. Examination of '',a,'',# '',i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'choix', choix +#endif +c + codret = 0 +c +c==== +c 2. initialisations : tout est interne +c==== +c + do 20 , larete = 1, nbarto + borare(larete) = 0 + 20 continue +c +c==== +c 3. recherche des aretes de bords du domaine +c==== +c + if ( choix.eq.1 ) then +c +c 3.1. ==> les 3 aretes d'un triangle qui borde un tetraedre et un seul +c sont de bord. c'est le bord du domaine volumique. +c + if ( nbteto.ne.0 ) then +c + do 31 , laface = 1, nbtrto + if ( voltri(1,laface).lt.0 .or. voltri(2,laface).lt.0) then + codret = 12 + goto 66 + endif + if ( voltri(1,laface).ne.0 .and. + > voltri(2,laface).eq.0 ) then + borare(aretri(laface,1)) = 2 + borare(aretri(laface,2)) = 2 + borare(aretri(laface,3)) = 2 + endif + 31 continue +c + endif +c +c 3.2. ==> chaque arete qui ne borde qu'une face est de bord. c'est +c le bord du domaine surfacique. +c + do 32 , larete = 1, nbarto +c + if ( posifa(larete-1)+1 .eq. posifa(larete) ) then + borare(larete) = 1 + endif +c + 32 continue +c + endif +c +c==== +c 4. recherche des aretes de bords des zones de differents niveaux +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. recherche ; codret', codret +#endif +c + if ( choix.eq.2 .or. choix.eq.3 ) then +c + do 41 , larete = 1 , nbarto +c + aubord = .false. +c +#ifdef _DEBUG_HOMARD_ + if ( larete.eq.-12) then + glop = 1 + else + glop = 0 + endif +#endif +c +c On s'interesse aux aretes coupees en 2 +c + jaux = mod(hetare(larete),10) + if ( ( jaux.eq.2 ) .or. ( jaux.eq.9 ) ) then +c +c 4.1. ==> Si l'arete a ete reperee au bord par sa mere, on le progage +c directement aux filles +c + if ( borare(larete).gt.0 ) then +c + aubord = .true. +c + else +c +c 4.2. ==> Sinon, on fait l'analyse. +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,texte(langue,6)) ' ', mess14(langue,1,1), larete + endif +#endif +c +c 4.2.1. ==> decompte du nombre de faces actives voisines de cette arete +c + ideb = posifa(larete-1) + 1 + ifin = posifa(larete) + nbfact = 0 + do 421 , iaux = ideb, ifin +c + laface = facare(iaux) + if ( laface.gt.0 ) then + if ( mod(hettri(laface),10).eq.0 ) then + nbfact = nbfact + 1 + endif + else + if ( mod(hetqua(-laface),100).eq.0 ) then + nbfact = nbfact + 1 + endif + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + if ( laface.gt.0 ) then + jaux = 2 + else + jaux = 4 + endif + write (ulsort,texte(langue,6)) ' ..', + > mess14(langue,1,jaux), abs(laface) + endif +#endif +c + 421 continue +c +c 4.2.2. ==> Si au moins une face est active et qu'au moins une autre +c est coupee, c'est que l'arete est a une limite de niveau +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '. nbfact', nbfact + write (ulsort,90002) '. nbfdec', ifin-ideb+1-nbfact + endif +#endif +c + if ( nbfact.ge.(choix-2) ) then +c + iaux = ifin - ideb + 1 - nbfact + if ( iaux.ge.1 ) then + aubord = .true. + endif +c + endif +c + endif +c + endif +c +c 4.3. ==> enregistrement des deux filles +c + if ( aubord ) then +c + do 43 , jaux = 0, 1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '.. reperage de l''arete', + > filare(larete)+jaux + endif +#endif + borare(filare(larete)+jaux) = 1 + 43 continue +c + endif +c + 41 continue +c + endif +c +c==== +c 5. decompte des aretes de bords +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. decompte ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nbar2d = 0 + nbar3d = 0 + do 50 , larete = 1, nbarto + if ( borare(larete).eq.1 ) then + nbar2d = nbar2d + 1 + elseif ( borare(larete).eq.2 ) then + nbar3d = nbar3d + 1 + endif + 50 continue +c + endif +c +c==== +c 6. la fin +c==== +c + 66 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) 2, nbar2d + write(ulsort,texte(langue,4)) 3, nbar3d +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utbofa.F b/src/tool/Utilitaire/utbofa.F new file mode 100644 index 00000000..29900cde --- /dev/null +++ b/src/tool/Utilitaire/utbofa.F @@ -0,0 +1,463 @@ + subroutine utbofa ( typenh, numead, + > nbfato, nbvoto, + > nivfac, filfac, perfac, + > hetvol, hetpyr, + > volfac, pypefa, + > borfac, nbfa2d, nbfabo, + > nbfav2, nbfav3, nbfav4, nbfanc, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BOrd - FAces +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . numead . e . 1 . numero de la mere adoptive . +c . nbfato . e . 1 . nombre de faces total . +c . nbvoto . e . 1 . nombre de volumes total . +c . nivfac . e . nbfato . niveau des faces . +c . perfac . e . nbfato . pere des faces . +c . filfac . e . nbfato . fille des faces . +c . volfac . e .2*nbfato. numeros des 2 volumes par face) . +c . . . . volfac(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre/tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypefa(1/2,j). +c . pypefa . e .2*lgpype. pypefa(1,j) = numero de la pyramide voisine. +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . . . . pypefa(2,j) = numero du pentaedre voisin . +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . hetvol . e . nbvoto . historique de l'etat des volumes . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . borfac . s . nbfato . reperage des faces de bord . +c . . . . -1 : face non classee . +c . . . . 0 : face bidimensionnelle . +c . . . . 1 : face au bord d'un seul volume . +c . . . . 2 : face entre 2 volumes actifs . +c . . . . 3 : face entre 2 volumes dont 1 seul actif. +c . . . . 4 : face entre 2 volumes inactifs . +c . . . . 5 : face de non conformite . +c . nbfa2d . s . 1 . nombre de faces de regions 2D . +c . nbfabo . s . 1 . nombre de faces de bord . +c . nbfav2 . s . 1 . nombre de faces entre 2 volumes actifs . +c . nbfav3 . s . 1 . nombre de faces entre 1 actif et 1 inactif . +c . nbfav4 . s . 1 . nombre de faces entre 2 volumes inactifs . +c . nbfanc . s . 1 . nombre de faces de non conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBOFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, numead + integer nbfato, nbvoto + integer nivfac(nbfato) + integer filfac(nbfato), perfac(nbfato) + integer volfac(2,nbfato), pypefa(2,*) + integer borfac(nbfato) + integer hetvol(*), hetpyr(*) + integer nbfa2d, nbfabo, nbfav2, nbfav3, nbfav4, nbfanc +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux +c + integer laface +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de '',a,'' de regions bidimensionnelles :'',i10)' + texte(1,5) = + > '(''Nombre de '',a,'' de bord exterieur :'',i10)' + texte(1,6) = + > '(''Nombre de '',a,'' entre 2 volumes actifs :'',i10)' + texte(1,7) = + > '(''Nombre de '',a,'' entre 1 actif et 1 inactif :'',i10)' + texte(1,8) = + > '(''Nombre de '',a,'' entre 2 volumes inactifs :'',i10)' + texte(1,9) = + > '(''Nombre de '',a,'' de non conformite :'',i10)' + texte(1,10) = + > '(''Nombre de '',a,'' non classes :'',i10)' + texte(1,16) = '(a,''.. Examen du '',a,''numero '',i10)' + texte(1,17) = '(''Numero de la mere adoptive :'',i10))' + texte(1,18) = '(a,''.... Aieul : '',a,''numero '',i10)' + texte(1,19) = '(''Recherche des faces du bord du domaine'')' + texte(1,20) = '(a,''.. borfac('',i10,'') = '',i10)' +c + texte(2,4) = + > '(''Number of '',a,'' in 2D regions :'',i10)' + texte(2,5) = + > '(''Number of boundary '',a,'' :'',i10)' + texte(2,6) = + > '(''Number of '',a,'' inside of volume :'',i10)' + texte(2,6) = + > '(''Number of '',a,'' inside of volume :'',i10)' + texte(2,6) = + > '(''Number of '',a,'' inside of volume :'',i10)' + texte(2,9) = + > '(''Number of non conformal '',a,'' :'',i10)' + texte(2,10) = + > '(''Number of '',a,'' without any place :'',i10)' + texte(2,16) = '(a,''.. Examination of '',a,'',# '',i10)' + texte(2,17) = '(''Number for adoptive mother :'',i10))' + texte(2,18) = '(a,''.... Old '',a,'',# '',i10)' + texte(2,19) = '(''Research of boundary faces'')' + texte(2,20) = '(a,''.. borfac('',i10,'') = '',i10)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,19)) + write (ulsort,texte(langue,17)) numead +#endif +c +c==== +c 2. la convention est la suivante : +c . borfac(laface) vaut -1 si la face n'est pas classee +c . borfac(laface) vaut 0 si la face ne s'appuie sur aucun +c volume ; c'est le cas d'une portion de domaine bidimensionnel ; +c . borfac(laface) vaut 1 si la face s'appuie sur un volume et +c un seul ; c'est le bord d'un domaine volumique ; +c . borfac(laface) vaut 2 si la face s'appuie sur 2 volumes ; +c c'est une face interne a un domaine volumique ; +c . borfac(laface) vaut 5 si la face s'appuie sur un volume et +c un seul et est une face de non conformite. +c==== +c +c 2.1. ==> en l'absence de volume, toutes les faces font partie +c d'un domaine bidimensionnel +c + if ( nbvoto.eq.0 ) then +c + do 21, laface = 1, nbfato + borfac(laface) = 0 + 21 continue +c +c 2.2 ==> avec des volumes, on decide a chaque fois +c + else +c +c 2.2.1. ==> a priori, les faces ne sont pas classees +c + do 220, laface = 1, nbfato + borfac(laface) = -1 + 220 continue +c + do 22, laface = 1 , nbfato +c +#ifdef _DEBUG_HOMARD_ + if ( laface.eq.17104 .or. + > laface.eq.20633 ) then + glop=1 + else + glop=0 + endif + if ( glop.eq.1 ) then + write (ulsort,texte(langue,16)) ' ', mess14(langue,1,typenh), + > laface + write (ulsort,*) ' niveau : ',nivfac(laface) + write (ulsort,*) ' volfac(*,laface) : ', + > volfac(1,laface),volfac(2,laface) + write(ulsort,*) ' perfac : ',perfac(laface) + write(ulsort,*) ' filfac : ',filfac(laface) + endif +#endif +c +c 2.2.1. ==> Si la face ne borde aucun volume, on le note +c on passe la face suivante dans la boucle 22 +c + if ( volfac(1,laface).eq.0 ) then + borfac(laface) = 0 +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,texte(langue,16)) ' ', mess14(langue,1,typenh), + > laface + write (ulsort,*) ' niveau : ',nivfac(laface) + write (ulsort,*) ' volfac(*,laface) : ', + > volfac(1,laface),volfac(2,laface) + write(ulsort,*) ' perfac : ',perfac(laface) + write(ulsort,*) ' filfac : ',filfac(laface) + endif +#endif +c +c 2.2.2. ==> Si la face borde deux volumes, on le note ainsi : +c 2 : face entre 2 volumes actifs +c 3 : face entre 2 volumes dont 1 seul actif +c 4 : face entre 2 volumes inactifs +c on passe la face suivante dans la boucle 22 +c + elseif ( volfac(2,laface).ne.0 ) then +c + do 222 , kaux = 1 , 2 + laux = volfac(kaux,laface) + if ( laux.gt.0 ) then + jaux = mod(hetvol(laux),100) + else + laux = -laux + if ( pypefa(1,laux).ne.0 ) then + jaux = mod(hetpyr(pypefa(1,laux)),100) + endif + if ( pypefa(2,laux).ne.0 ) then + codret = 1793 + endif + endif + if ( kaux.eq.1 ) then + iaux = jaux + endif + 222 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write(ulsort,texte(langue,16))' ..',mess14(langue,1,typenh),laface + write(ulsort,*) ' volfac :',volfac(1,laface),volfac(2,laface) + write(ulsort,*) ' etats :',iaux,jaux + write(ulsort,*) ' nivfac : ',nivfac(iaux) + write(ulsort,*) ' perfac : ',perfac(iaux) + endif +#endif + if ( iaux.eq.0 .and. jaux.eq.0 ) then + borfac(laface) = 2 + elseif ( iaux.eq.0 .or. jaux.eq.0 ) then + borfac(laface) = 3 + else + borfac(laface) = 4 + endif +c +c 2.2.3. ==> Si la face borde 1 seul volume, on explore son ascendance +c on remonte l'ascendance de la face par la pseudo boucle +c de 223 continue, jusqu'a trouver la face mere primale. +c Dans ce parcours, la face a examiner est iaux +c + else +c + iaux = laface +c + 223 continue +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write(ulsort,texte(langue,16))' ..',mess14(langue,1,typenh),iaux + write(ulsort,*) ' volfac :',volfac(1,iaux),volfac(2,iaux) + write(ulsort,*) ' nivfac : ',nivfac(iaux) + write(ulsort,*) ' perfac : ',perfac(iaux) + endif +#endif +c + if ( perfac(iaux).ne.0 ) then +c + jaux = perfac(iaux) + if ( jaux.lt.0 ) then + if ( jaux.ne.numead ) then + write(ulsort,*) 'PROBLEME DE PERFAC < 0 : ', jaux + write (ulsort,texte(langue,17)) numead + codret = 1 +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,*) 'iaux vaut numead = ',numead +#endif + endif + else + iaux = jaux + goto 223 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,texte(langue,18)) ' ', + > mess14(langue,1,typenh), iaux + endif +#endif +c +c 2.2.4. ==> On examine la face 'iaux'. +c +c A. Si c'est la mere adoptive pour les maillages non +c conformes d'origine, la face courante est une face du +c bord du domaine +c + if ( iaux.eq.numead ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,*) 'pas glop' + endif +#endif + borfac(laface) = 1 +c +c B. Si cette face aieule est de niveau 0 : +c - si cette face aieule a 2 voisins, la face courante est +c de limite de zone de raffinement +c - si la face aieule a 1 seul voisin : +c . si elle n'a pas de fille, c'est que laface = iaux, +c donc on est sur le bord exterieur +c . si elle a une fille de niveau 1, c'est aussi un +c bord exterieur +c . si elle a une fille de niveau 0, on est dans un cas +c de non conformite initiale. Donc laface est sur +c une limite de zone. +c + elseif ( nivfac(iaux).eq.0 ) then +c + if ( volfac(2,iaux).eq.0 ) then + if ( filfac(iaux).gt.0 ) then + if ( nivfac(filfac(iaux)).eq.0 ) then + borfac(laface) = 5 + else + borfac(laface) = 1 + endif + else + borfac(laface) = 1 + endif + else + borfac(laface) = 5 + endif +c +c C. Sinon, c'est une face de limite de zone de raffinement +c non conforme (on est dans le cas d'une filiation d'une +c face qui a ete creee en interne a un volume) +c + else +c + borfac(laface) = 5 +c + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.eq.1 ) then + write (ulsort,texte(langue,20)) ' ', laface, borfac(laface) + endif +#endif +c + endif +c + 22 continue +c + endif +c +c==== +c 3. decompte des faces de bords +c==== +c + if ( nbvoto.ne.0 ) then +c + nbfa2d = 0 + nbfabo = 0 + nbfav2 = 0 + nbfav3 = 0 + nbfav4 = 0 + nbfanc = 0 + do 31, laface = 1, nbfato + if ( borfac(laface).eq.0 ) then + nbfa2d = nbfa2d + 1 + elseif ( borfac(laface).eq.1 ) then + nbfabo = nbfabo + 1 + elseif ( borfac(laface).eq.2 ) then + nbfav2 = nbfav2 + 1 + elseif ( borfac(laface).eq.3 ) then + nbfav3 = nbfav3 + 1 + elseif ( borfac(laface).eq.4 ) then + nbfav4 = nbfav4 + 1 + elseif ( borfac(laface).eq.5 ) then + nbfanc = nbfanc + 1 + endif + 31 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) mess14(langue,3,typenh), nbfa2d + write(ulsort,texte(langue,5)) mess14(langue,3,typenh), nbfabo + write(ulsort,texte(langue,6)) mess14(langue,3,typenh), nbfav2 + write(ulsort,texte(langue,7)) mess14(langue,3,typenh), nbfav3 + write(ulsort,texte(langue,8)) mess14(langue,3,typenh), nbfav4 + write(ulsort,texte(langue,9)) mess14(langue,3,typenh), nbfanc + write(ulsort,texte(langue,10)) mess14(langue,3,typenh), + > nbfato - nbfa2d - nbfabo - nbfav2 - nbfav3 - nbfav4 - nbfanc +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utbono.F b/src/tool/Utilitaire/utbono.F new file mode 100644 index 00000000..0b6c0d86 --- /dev/null +++ b/src/tool/Utilitaire/utbono.F @@ -0,0 +1,209 @@ + subroutine utbono ( choix, + > nbnoto, + > nbarto, nbtrto, nbquto, nbteto, nbfaar, + > somare, + > filare, hetare, + > posifa, facare, + > hettri, aretri, voltri, + > hetqua, arequa, + > nbnobo, bornoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BOrd - NOeuds +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix du travail a faire . +c . . . . 1 : les noeuds du bord du domaine . +c . . . . 2 : les noeuds a la limite entre deux zones. +c . . . . de raffinement de niveau different . +c . . . . 3 : idem mais en ignorant le bord exterieur. +c . nbnoto . e . 1 . nombre de noeuds total . +c . nbarto . e . 1 . nombre d'aretes total . +c . nbtrto . e . 1 . nombre de triangles total . +c . nbquto . e . 1 . nombre de quadrangles total . +c . nbteto . e . 1 . nombre de tetraedres total . +c . somare . e .nbarto*2. numeros des extremites d'arete . +c . filare . e . nbarto . fille ainee de chaque arete . +c . hetare . e . nbarto . historique de l'etat des aretes . +c . posifa . e .0:nbarto. pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nbnobo . s . 1 . nombre de noeuds de bord . +c . bornoe . s . nbnoto . reperage des noeuds de bord . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBONO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer choix + integer nbnoto, nbarto, nbtrto, nbquto, nbteto, nbfaar + integer somare(2,nbarto) + integer hetare(nbarto), filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer hettri(nbtrto), aretri(nbtrto,3) + integer voltri(2,nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer nbnobo, bornoe(nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, lenoeu, nbar2d, nbar3d + integer adtrav +c + character*8 ntrava +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds de bord :'',i10)' +c + texte(2,4) = '(''Number of boundary nodes :'',i10)' +c + codret = 0 +c +c==== +c 2. recherche des aretes de bords du domaine +c==== +c + call gmalot ( ntrava, 'entier', nbarto, adtrav, codret ) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOAR', nompro +#endif + call utboar ( choix, + > nbarto, nbtrto, nbquto, nbteto, nbfaar, + > hetare, filare, + > posifa, facare, + > aretri, hettri, voltri, + > arequa, hetqua, + > nbar2d, nbar3d, imem(adtrav), + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. determination des noeuds de bords +c==== +c + if ( codret.eq.0 ) then +c + do 31 , lenoeu = 1, nbnoto + bornoe(lenoeu) = 0 + 31 continue +c + do 32 , iaux = 1, nbarto + if ( imem(adtrav+iaux-1).ne.0 ) then + bornoe(somare(1,iaux)) = 1 + bornoe(somare(2,iaux)) = 1 + endif + 32 continue +c + nbnobo = 0 + do 33 , lenoeu = 1, nbnoto + nbnobo = nbnobo + bornoe(lenoeu) +cgn write(ulsort,*) lenoeu,' : ',bornoe(lenoeu) + 33 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrava, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) nbnobo +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utboqu.F b/src/tool/Utilitaire/utboqu.F new file mode 100644 index 00000000..aa4059ca --- /dev/null +++ b/src/tool/Utilitaire/utboqu.F @@ -0,0 +1,186 @@ + subroutine utboqu ( nbquto, nbheto, numead, + > nivqua, filqua, perqua, + > hethex, hetpyr, + > volqua, pypequ, + > borqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BOrd - quadrangles +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbquto . e . 1 . nombre de quadrangles total . +c . nbheto . e . 1 . nombre d'hexaedres total . +c . numead . e . 1 . numero de la mere adoptive . +c . nivqua . e . nbquto . niveau des quadrangles . +c . filqua . e . nbquto . fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . volqua . e .nbquto*2. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(k,1/2) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(k,1/2) = -j . +c . borqua . s . nbquto . reperage des quadrangles de bord . +c . . . . -1 : quadrangle non classe . +c . . . . 0 : quadrangle bidimensionnel . +c . . . . 1 : quadrangle au bord d'un seul hexaedre . +c . . . . 2 : quadrangle entre 2 hexaedres . +c . . . . 3 : quadrangle de non conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBOQU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbquto, nbheto, numead + integer nivqua(nbquto) + integer filqua(nbquto), perqua(nbquto) + integer hethex(*), hetpyr(*) + integer volqua(2,nbquto), pypequ(2,*) + integer borqua(nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbqu2d, nbqubo, nbquv2, nbquv3, nbquv4, nbqunc +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de '',a,'' de regions bidimensionnelles :'',i10)' + texte(1,5) = + > '(''Nombre de '',a,'' de bord :'',i10)' + texte(1,6) = + > '(''Nombre de '',a,'' internes aux volumes :'',i10)' + texte(1,7) = + > '(''Nombre de '',a,'' de non conformite :'',i10)' + texte(1,8) = + > '(''Nombre de '',a,'' non classes :'',i10)' +c + texte(2,4) = + > '(''Number of '',a,'' in 2D regions :'',i10)' + texte(2,5) = + > '(''Number of boundary '',a,'' :'',i10)' + texte(2,6) = + > '(''Number of '',a,'' inside of volume :'',i10)' + texte(2,7) = + > '(''Number of non conformal '',a,'' :'',i10)' + texte(2,8) = + > '(''Number of '',a,'' without any place :'',i10)' +c + codret = 0 +c +c==== +c 2. appel du programme generique +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOFA', nompro +#endif + iaux = 4 + call utbofa ( iaux, numead, + > nbquto, nbheto, + > nivqua, filqua, perqua, + > hethex, hetpyr, + > volqua, pypequ, + > borqua, nbqu2d, nbqubo, + > nbquv2, nbquv3, nbquv4, nbqunc, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + iaux = 4 + write(ulsort,texte(langue,4)) mess14(langue,3,iaux), nbqu2d + write(ulsort,texte(langue,5)) mess14(langue,3,iaux), nbqubo + write(ulsort,texte(langue,6)) mess14(langue,3,iaux), nbquv2 + write(ulsort,texte(langue,7)) mess14(langue,3,iaux), nbqunc + write(ulsort,texte(langue,8)) mess14(langue,3,iaux), + > nbquto - nbqu2d - nbqubo - nbquv2 - nbqunc + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utbotr.F b/src/tool/Utilitaire/utbotr.F new file mode 100644 index 00000000..f36b4bc3 --- /dev/null +++ b/src/tool/Utilitaire/utbotr.F @@ -0,0 +1,186 @@ + subroutine utbotr ( nbtrto, nbteto, numead, + > nivtri, filtri, pertri, + > hettet, hetpyr, + > voltri, pypetr, + > bortri, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - BOrd - Triangles +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtrto . e . 1 . nombre de triangles total . +c . nbteto . e . 1 . nombre de tetraedres total . +c . numead . e . 1 . numero de la mere adoptive . +c . nivtri . e . nbtrto . niveau des triangles . +c . filtri . e . nbtrto . fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . bortri . s . nbtrto . reperage des triangles de bord . +c . . . . -1 : triangle non classe . +c . . . . 0 : triangle bidimensionnel . +c . . . . 1 : triangle au bord d'un seul tetraedre . +c . . . . 2 : triangle entre 2 tetraedres . +c . . . . 3 : triangle de non conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . sinon : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTBOTR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbtrto, nbteto, numead + integer nivtri(nbtrto) + integer filtri(nbtrto), pertri(nbtrto) + integer voltri(2,nbtrto), pypetr(2,*) + integer bortri(nbtrto) + integer hettet(*), hetpyr(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbtr2d, nbtrbo, nbtrv2, nbtrv3, nbtrv4, nbtrnc +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de '',a,'' de regions bidimensionnelles :'',i10)' + texte(1,5) = + > '(''Nombre de '',a,'' de bord :'',i10)' + texte(1,6) = + > '(''Nombre de '',a,'' internes aux volumes :'',i10)' + texte(1,7) = + > '(''Nombre de '',a,'' de non conformite :'',i10)' + texte(1,8) = + > '(''Nombre de '',a,'' non classes :'',i10)' +c + texte(2,4) = + > '(''Number of '',a,'' in 2D regions :'',i10)' + texte(2,5) = + > '(''Number of boundary '',a,'' :'',i10)' + texte(2,6) = + > '(''Number of '',a,'' inside of volume :'',i10)' + texte(2,7) = + > '(''Number of non conformal '',a,'' :'',i10)' + texte(2,8) = + > '(''Number of '',a,'' without any place :'',i10)' +c + codret = 0 +c +c==== +c 2. appel du programme generique +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTBOFA', nompro +#endif + iaux = 2 + call utbofa ( iaux, numead, + > nbtrto, nbteto, + > nivtri, filtri, pertri, + > hettet, hetpyr, + > voltri, pypetr, + > bortri, nbtr2d, nbtrbo, + > nbtrv2, nbtrv3, nbtrv4, nbtrnc, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + iaux = 2 + write(ulsort,texte(langue,4)) mess14(langue,3,iaux), nbtr2d + write(ulsort,texte(langue,5)) mess14(langue,3,iaux), nbtrbo + write(ulsort,texte(langue,6)) mess14(langue,3,iaux), nbtrv2 + write(ulsort,texte(langue,7)) mess14(langue,3,iaux), nbtrnc + write(ulsort,texte(langue,8)) mess14(langue,3,iaux), + > nbtrto - nbtr2d - nbtrbo - nbtrv2 - nbtrnc + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcach.F b/src/tool/Utilitaire/utcach.F new file mode 100644 index 00000000..4f9ab258 --- /dev/null +++ b/src/tool/Utilitaire/utcach.F @@ -0,0 +1,183 @@ + subroutine utcach ( nocham, + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques d'un CHamp +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocham . e . char8 . nom de l'objet champ . +c . nomcha . s . char64 . nom du champ . +c . nbcomp . s . 1 . nombre de composantes . +c . nbtvch . s . 1 . nombre de tableaux du champ . +c . typcha . s . 1 . edin64/edfl64 selon entier/reel . +c . adnocp . s . 1 . adresse des noms des champ et composantes . +c . adcaen . s . 1 . adresse des caracteristiques entieres . +c . adcare . s . 1 . adresse des caracteristiques reelles . +c . adcaca . s . 1 . adresse des caracteristiques caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCACH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 nocham + character*64 nomcha +c + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom du champ : '',a32)' + texte(1,5) = + >'(''. Composante '',i2,'' : '',a16,''(unite : '',a16,'')'')' +c + texte(2,4) = '(''Name of the field : '',a32)' + texte(2,5) = + >'(''. Component '',i2,'' : '',a8,''(unit : '',a8,'')'')' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Nom_Comp' ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Ree' ) + call gmprsx (nompro, nocham//'.Cham_Car' ) +#endif +c +c==== +c 2. caracteristiques de l'objet contenant le champ +c==== +c + if ( codret.eq.0 ) then +c + call gmliat ( nocham, 1, nbcomp, codre1 ) + call gmliat ( nocham, 2, nbtvch, codre2 ) + call gmliat ( nocham, 3, typcha, codre3 ) + call gmadoj ( nocham//'.Nom_Comp', adnocp, iaux, codre4 ) + call gmadoj ( nocham//'.Cham_Ent', adcaen, iaux, codre5 ) + call gmadoj ( nocham//'.Cham_Ree', adcare, iaux, codre6 ) + call gmadoj ( nocham//'.Cham_Car', adcaca, iaux, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c==== +c 3. le nom du champ +c==== +c + if ( codret.eq.0 ) then +c + iaux = 64 + call uts8ch ( smem(adnocp), iaux, nomcha, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomcha + do 31 , iaux = 1 , nbcomp + write (ulsort,texte(langue,5)) iaux, + > smem(adnocp+3+iaux)//smem(adnocp+4+iaux), + > smem(adnocp+2*nbcomp+3+iaux)//smem(adnocp+2*nbcomp+4+iaux) + 31 continue +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcafo.F b/src/tool/Utilitaire/utcafo.F new file mode 100644 index 00000000..68485871 --- /dev/null +++ b/src/tool/Utilitaire/utcafo.F @@ -0,0 +1,261 @@ + subroutine utcafo ( obfonc, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques d'une FOnction +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obfonc . e . char8 . nom de l'objet fonction . +c . typcha . s . 1 . edin32/edin64/edfl64 selon entier/reel . +c . typgeo . s . 1 . type geometrique au sens MED . +c . ngauss . s . 1 . nombre de points de Gauss . +c . nbenmx . s . 1 . nombre d'entites maximum . +c . nbvapr . s . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . nbtyas . s . 1 . nombre de types de support associes . +c . carsup . s . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . nbtafo . s . 1 . nombre de tableaux de la fonction . +c . typint . s . . type interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, . +c . . . . 3 si iso-P2 . +c . advale . s . 1 . adresse du tableau de valeurs entieres . +c . advalr . s . 1 . adresse du tableau de valeurs reelles . +c . adobch . s . 1 . adresse des noms des objets 'Champ' . +c . adprpg . s . 1 . adresse des noms des objets 'Profil', . +c . . . . 'LocaPG' et fonction aux noeuds par . +c . . . . elements eventuellement associes . +c . adtyas . s . 1 . adresse des types associes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCAFO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "meddc0.h" +c +c 0.3. ==> arguments +c + character*8 obfonc +c + integer typcha + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Impossible de lire les attributs de l''''objet '',a)' + texte(1,5) = + > '(''Impossible de lire les adresses de l''''objet '',a)' + texte(1,6) = + > '(''Impossible de lire les valeurs de l''''objet '',a)' +c + texte(2,4) = '(''Attributes of object '',a,'' cannot be read.'')' + texte(2,5) = '(''Adresses of object '',a,'' cannot be read.'')' + texte(2,6) = '(''Values of object '',a,'' cannot be read.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obfonc ) + call gmprot (nompro, obfonc//'.ValeursR', 1, 10 ) + call gmprsx (nompro, obfonc//'.InfoCham' ) + call gmprsx (nompro, obfonc//'.InfoPrPG' ) + call gmprsx (nompro, obfonc//'.TypeSuAs' ) +#endif +c + codret = 0 +c +c==== +c 2. caracteristiques de la fonction +c==== +c +c 2.1. ==> Les attributs +c + call gmliat ( obfonc, 1, typgeo, codre1 ) + call gmliat ( obfonc, 2, ngauss, codre2 ) + call gmliat ( obfonc, 3, nbenmx, codre3 ) + call gmliat ( obfonc, 4, nbvapr, codre4 ) + call gmliat ( obfonc, 5, nbtyas, codre5 ) + call gmliat ( obfonc, 6, carsup, codre6 ) + call gmliat ( obfonc, 7, nbtafo, codre7 ) + call gmliat ( obfonc, 8, typint, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,4)) obfonc + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'nbenmx', nbenmx + write (ulsort,90002) 'nbvapr', nbvapr + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'nbtafo', nbtafo + write (ulsort,90002) 'typint', typint + if ( nbtyas.gt.0 ) then + call gmprsx (nompro, obfonc//'.TypeSuAs' ) + endif + endif +#endif +c +c 2.2. ==> Les adresses +c + if ( codret.eq.0 ) then +c + call gmadoj ( obfonc//'.InfoCham', adobch, iaux, codre1 ) + call gmadoj ( obfonc//'.InfoPrPG', adprpg, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) obfonc//'.InfoCham/InfoPrPG' + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmobal ( obfonc//'.ValeursR', codre1 ) + if ( codre1.eq.0 ) then + call gmadoj ( obfonc//'.ValeursE', advale, iaux, codre2 ) + typcha = edint + elseif ( codre1.eq.2 ) then + codre1 = 0 + call gmadoj ( obfonc//'.ValeursR', advalr, iaux, codre2 ) + typcha = edfl64 + else + codre1 = 2 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typcha', typcha +#endif +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,6)) obfonc//'.ValeursR/E' + endif +c + endif +c + if ( nbtyas.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( obfonc//'.TypeSuAs', adtyas, iaux, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) obfonc//'.TypeSuAs' + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + end diff --git a/src/tool/Utilitaire/utcapf.F b/src/tool/Utilitaire/utcapf.F new file mode 100644 index 00000000..ee5c0a7b --- /dev/null +++ b/src/tool/Utilitaire/utcapf.F @@ -0,0 +1,197 @@ + subroutine utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques d'un Paquet de Fonctions +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obpafo . e . char8 . nom de l'objet du paquet de fonctions . +c . nbfopa . s . 1 . nombre de fonctions dans le paquet . +c . typgpf . s . 1 . si >0 : type geometrique s'il est unique . +c . . . . si <0 : nombre de type geometriques associe. +c . ngauss . s . 1 . nombre de points de gauss . +c . carsup . s . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . typint . s . s . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . adobfo . s . 1 . adresse des noms des objets 'Fonction' et . +c . . . . de l'eventuel paquet associe . +c . adtyge . s . 1 . adresse des types geometriques . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCAPF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 obpafo +c + integer nbfopa, typgpf, ngauss, carsup, typint + integer adobfo, adtyge +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Impossible de lire les attributs de l''''objet '',a)' + texte(1,5) = + > '(''Impossible de lire les valeurs de l''''objet '',a)' +c + texte(2,4) = '(''Attributes of object '',a,'' cannot be read.'')' + texte(2,5) = '(''Values of object '',a,'' cannot be read.'')' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) +#endif +c + codret = 0 +c +c==== +c 2. caracteristiques du paquet de fonctions +c==== +c + call gmliat ( obpafo, 1, nbfopa, codre1 ) + call gmliat ( obpafo, 2, typgpf, codre2 ) + call gmliat ( obpafo, 3, ngauss, codre3 ) + call gmliat ( obpafo, 4, carsup, codre4 ) + call gmliat ( obpafo, 5, typint, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) obpafo + endif +c +c==== +c 3. les branches +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. branches ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( obpafo//'.Fonction', adobfo, iaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) obpafo + endif +c + endif +c + if ( typgpf.lt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( obpafo//'.TypeSuAs', adtyge, iaux, codret ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) obpafo + endif +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcapg.F b/src/tool/Utilitaire/utcapg.F new file mode 100644 index 00000000..86903361 --- /dev/null +++ b/src/tool/Utilitaire/utcapg.F @@ -0,0 +1,209 @@ + subroutine utcapg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques de localisation des Points de Gauss +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . oblopg . e . char8 . nom de l'objet points de Gauss . +c . nolopg . s . char64 . nom de la localisation des Points de Gauss . +c . typgeo . s . 1 . type geometrique au sens MED . +c . ngauss . s . 1 . nombre de points de Gauss . +c . dimcpg . s . 1 . dimension des coordonnees des pts de Gauss . +c . adcono . s . 1 . adresse des coordonnees des noeuds . +c . adcopg . s . 1 . adresse des coordonnees des points de Gauss. +c . adpopg . s . 1 . adresse des poids des points de Gauss . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCAPG' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#ifdef _DEBUG_HOMARD_ +#include "gmreel.h" +#endif +#include "gmstri.h" +#include "indefs.h" +c +c 0.3. ==> arguments +c + character*8 oblopg + character*64 nolopg +c + integer typgeo, ngauss, dimcpg + integer adcono, adcopg, adpopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif + integer codre1, codre2, codre3, codre4 + integer codre0 + integer lgnoml, adnoml +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom de la localisation : '',a)' + texte(1,5) = '(/,''Objet GM de la localisation : '',a)' +c + texte(2,4) = '(''Name of the localization : '',a)' + texte(2,5) = '(/,''GM object for localization : '',a)' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, oblopg ) + call gmprsx (nompro, oblopg//'.NomLocPG' ) + call gmprsx (nompro, oblopg//'.CoorNoeu' ) + call gmprsx (nompro, oblopg//'.CoorPtGa' ) + call gmprsx (nompro, oblopg//'.PoidPtGa' ) +#endif +c +c==== +c 2. caracteristiques de la localisation +c==== +c + if ( codret.eq.0 ) then +c + call gmliat ( oblopg, 1, lgnoml, codre1 ) + call gmliat ( oblopg, 2, typgeo, codre2 ) + call gmliat ( oblopg, 3, ngauss, codre3 ) + call gmliat ( oblopg, 4, dimcpg, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) oblopg + if ( oblopg.ne.sindef ) then + call gmprsx (nompro, oblopg ) + endif + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( oblopg//'.NomLocPG', adnoml, iaux, codre1 ) + call gmadoj ( oblopg//'.CoorNoeu', adcono, iaux, codre2 ) + call gmadoj ( oblopg//'.CoorPtGa', adcopg, iaux, codre3 ) + call gmadoj ( oblopg//'.PoidPtGa', adpopg, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. le nom de la localisation +c==== +c + if ( codret.eq.0 ) then +c + if ( lgnoml.gt.0 ) then +c + call uts8ch ( smem(adnoml), lgnoml, nolopg, + > ulsort, langue, codret ) +c + else +c + nolopg = blan64 +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) nolopg + iaux = mod(typgeo,100) + call utimpg ( 2, ngauss, iaux, dimcpg, + > rmem(adcono), rmem(adcopg), rmem(1), + > ulsort, langue, codret ) + endif +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcapr.F b/src/tool/Utilitaire/utcapr.F new file mode 100644 index 00000000..e1768df6 --- /dev/null +++ b/src/tool/Utilitaire/utcapr.F @@ -0,0 +1,172 @@ + subroutine utcapr ( obprof, + > nbvapr, noprof, adlipr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques d'un PRofil +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obprof . e . char8 . nom de l'objet profil . +c . nbvapr . s . 1 . nombre de valeurs . +c . noprof . s . char64 . nom du profil . +c . adlipr . s . 1 . adresse de la liste des entites . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCAPR' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 obprof + character*64 noprof +c + integer nbvapr + integer adlipr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer lgnomp, adnomp +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nom du profil : '',a)' + texte(1,5) = '(''Longueur du nom du profil : '',i10)' +c + texte(2,4) = '(''Name of the profile : '',a)' + texte(2,5) = '(''Longueur du nom du profil : '',i10)' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obprof ) + call gmprsx (nompro, obprof//'.NomProfi' ) + call gmprot (nompro, obprof//'.ListEnti', 1, 10 ) +#endif +c +c==== +c 2. caracteristiques du profil +c==== +c + if ( codret.eq.0 ) then +c + call gmliat ( obprof, 1, lgnomp, codre1 ) + call gmliat ( obprof, 2, nbvapr, codre2 ) + call gmadoj ( obprof//'.NomProfi', adnomp, iaux, codre3 ) + call gmadoj ( obprof//'.ListEnti', adlipr, iaux, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 3. le nom du profil +c==== +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) lgnomp +#endif +c + if ( lgnomp.gt.0 ) then +c + call uts8ch ( smem(adnomp), lgnomp, noprof, + > ulsort, langue, codret ) +c + else +c + noprof = blan64 +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) noprof +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcaso.F b/src/tool/Utilitaire/utcaso.F new file mode 100644 index 00000000..8fa467d8 --- /dev/null +++ b/src/tool/Utilitaire/utcaso.F @@ -0,0 +1,216 @@ + subroutine utcaso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CAracteristiques d'une SOlution +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . e . char8 . nom de l'objet solution . +c . nbcham . s . 1 . nombre de champs associes . +c . nbpafo . s . 1 . nombre d'inf. sur les paquets de fonctions . +c . nbprof . s . 1 . nombre de profils associes . +c . nblopg . s . 1 . nombre de localisations de points de Gauss . +c . adinch . s . 1 . adresse de l'information sur les champs . +c . adinpf . s . 1 . adresse de l'inf. sur paquets de fonctions . +c . adinpr . s . 1 . adresse de l'information sur les profils . +c . adinlg . s . 1 . adresse de l'information sur les . +c . . . . localisations de points de Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCASO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nocsol +c + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + character*08 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Erreur en recuperant '',a)' +c + texte(2,4) = '(''Error while getting '',a)' +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) + call gmprsx (nompro, nocsol//'.InfoLoPG' ) +#endif +c +c==== +c 2. caracteristiques de la solution +c==== +c +c 2.1. ==> les nombres caracteristiques +c + if ( codret.eq.0 ) then +c + call gmliat ( nocsol, 1, nbcham, codre1 ) + call gmliat ( nocsol, 2, nbpafo, codre2 ) + call gmliat ( nocsol, 3, nbprof, codre3 ) + call gmliat ( nocsol, 4, nblopg, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( codret.ne.0 ) then + saux08 = 'Attribut' + endif +c + endif +c +c 2.2. ==> l'information sur les champs +c + if ( codret.eq.0 ) then +c + if ( nbcham.gt.0 ) then +c + call gmadoj ( nocsol//'.InfoCham', adinch, iaux, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoCham' + endif +c + endif +c + endif +c +c 2.3. ==> l'information sur les paquets de fonctions +c + if ( codret.eq.0 ) then +c + if ( nbpafo.gt.0 ) then +c + call gmadoj ( nocsol//'.InfoPaFo', adinpf, iaux, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoPaFo' + endif +c + endif +c + endif +c +c 2.4. ==> l'information sur les profils +c + if ( codret.eq.0 ) then +c + if ( nbprof.gt.0 ) then +c + call gmadoj ( nocsol//'.InfoProf', adinpr, iaux, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoProf' + endif +c + endif +c + endif +c +c 2.5. ==> les localisations de points de Gauss +c + if ( codret.eq.0 ) then +c + if ( nblopg.ne.0 ) then + call gmadoj ( nocsol//'.InfoLoPG', adinlg, iaux, codret ) + if ( codret.ne.0 ) then + saux08 = 'InfoLoPG' + endif + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) saux08 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utchen.F b/src/tool/Utilitaire/utchen.F new file mode 100644 index 00000000..5ffae384 --- /dev/null +++ b/src/tool/Utilitaire/utchen.F @@ -0,0 +1,158 @@ + subroutine utchen ( chaine, entier, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - convertit une CHaine de caractere en ENtier +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chaine . e .char*(*). chaine de caractere . +c . entier . s . 1 . entier associe . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c . . . . 2 : le nombre est trop grand . +c . . . . 3 : type de cadrage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCHEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer entier +c + character*(*) chaine +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lgchai +c + character*5 fmtent +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Chaine a convertir : '',a)' + texte(1,5) = '(''La chaine est blanche.'')' +c + texte(2,4) = '(''String to convert : '',a)' + texte(2,5) = '(''The string is blank.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) chaine +#endif +c +c==== +c 2. decodage +c==== +c + codret = 0 +c +c 2.1. ==> longueur reelle de la chaine +c + call utlgut ( lgchai, chaine, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'lgchai', lgchai +#endif +c +c 2.2. ==> decodage +c + if ( codret.eq.0 ) then +c + if ( lgchai.eq.0 ) then + codret = 22 + else + fmtent = '(I )' + if ( lgchai.lt.10 ) then + write(fmtent(3:3),'(i1)') lgchai + else + write(fmtent(3:4),'(i2)') lgchai + endif + read (chaine,fmtent) entier + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) chaine + if ( codret.eq.22 ) then + write (ulsort,texte(langue,5)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utchnu.F b/src/tool/Utilitaire/utchnu.F new file mode 100644 index 00000000..c1975276 --- /dev/null +++ b/src/tool/Utilitaire/utchnu.F @@ -0,0 +1,290 @@ + subroutine utchnu ( option, nbenti, nounum, + > dim1, dim2, table, + > tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CHangement de NUmerotation d'une table +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . type de renumerotation . +c . . . . 1 : changement de l'indice de la table . +c . . . . 2 : changement du contenu de la table . +c . . . . 3 : changement de l'indice et du contenu . +c . nbenti . e . 1 . nombre d'entites . +c . nounum . e . nbenti . nouveau numero des entites . +c . dim1 . e . 1 . 1ere dimension de la table a renumeroter . +c . dim2 . e . 1 . 2nde dimension de la table a renumeroter . +c . table . es .dim1dim2. table a renumeroter . +c . tabaux . a .dim1dim2. tableau auxiliaire pour les options 1 et 3 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvais choix d'option . +c . . . . 2 : mauvaises dimensions . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCHNU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option + integer nbenti + integer dim1, dim2 + integer table(dim1,dim2) + integer nounum(0:nbenti) + integer tabaux(dim1,dim2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer diment +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre d''''entites :'',i10)' + texte(1,5) = '(''Option'',i10,'' impossible.'')' + texte(1,6) = '(''Dimension'',i2,'' :'',i10)' + texte(1,7) = + > '(''Une dimension doit etre egale au nombre d''''entites.'')' + texte(1,8) = '(''Changement de l''''indice de la table'')' + texte(1,9) = '(''Changement du contenu de la table'')' + texte(1,10) = '(''Changement de l''''indice et du contenu'')' +c + texte(2,4) = '(''Number of entities :'',i10)' + texte(2,5) = '(''Option'',i10,'' impossible.'')' + texte(2,6) = '(''Dimension #'',i2,'' :'',i10)' + texte(2,7) = + > '(''One should be equal to the number of entities.'')' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbenti + write (ulsort,texte(langue,6)) 1, dim1 + write (ulsort,texte(langue,6)) 2, dim2 +#endif +c +c==== +c 2. Controles +c==== +c 2.1. ==> Option +c + if ( option.le.0 .or. option.ge.4 ) then +c + write (ulsort,texte(langue,5)) option + codret = 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,7+option)) + endif +#endif +c +c 2.2. ==> Les dimensions +c + if ( codret.eq.0 ) then +c + if ( option.eq.1 .or. option.eq.3 ) then +c + if ( dim1.eq.nbenti ) then + diment = 1 + elseif ( dim2.eq.nbenti ) then + diment = 2 + else + write (ulsort,texte(langue,4)) nbenti + write (ulsort,texte(langue,6)) 1, dim1 + write (ulsort,texte(langue,6)) 2, dim2 + write (ulsort,texte(langue,7)) + codret = 2 + endif +c + endif +c + endif +c +c==== +c 3. Renumerotation +c==== +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,*) '==> diment = ', diment +c +c 3.1. ==> Stockage de la table au depart +c + if ( option.eq.1 .or. option.eq.3 ) then +c + if ( diment.eq.1 ) then +c + do 311 , jaux = 1 , dim2 + do 312 , iaux = 1 , nbenti + tabaux(iaux,jaux) = table(iaux,jaux) + 312 continue + 311 continue +c + else +c + do 313 , iaux = 1 , dim1 + do 314 , jaux = 1 , nbenti + tabaux(iaux,jaux) = table(iaux,jaux) + 314 continue + 313 continue +cgn if ( dim1.eq.2 ) then +cgn write (ulsort,*) table(1,108482), table(2,108482) +cgn write (ulsort,*) table(1,109114), table(2,109114) +cgn write (ulsort,*) table(1,109215), table(2,109215) +cgn endif +c + endif +c + endif +c +c 3.2. ==> Bascule +c +c 3.2.1. ==> Changement de l'indice +c + if ( option.eq.1 ) then +c + if ( diment.eq.1 ) then +cgn write (ulsort,*) '3211' +c + do 3211 , jaux = 1 , dim2 +cgn write (ulsort,*) '. jaux =', jaux + do 3212 , iaux = 1 , nbenti +cgn write (ulsort,*) '.. taux(',iaux,',',jaux,')',tabaux(iaux,jaux) + table(nounum(iaux),jaux) = tabaux(iaux,jaux) + 3212 continue + 3211 continue +c + else +c +cgn write (ulsort,*) '3211' + do 3213 , iaux = 1 , dim1 +cgn write (ulsort,*) '. iaux =', iaux + do 3214 , jaux = 1 , nbenti +cgn write (ulsort,*) '.. taux(',iaux,',',jaux,')',tabaux(iaux,jaux) + table(iaux,nounum(jaux)) = tabaux(iaux,jaux) + 3214 continue + 3213 continue +c + endif +c +c 3.2.2. ==> Changement du contenu +c + elseif ( option.eq.2 ) then +c + do 3221 , iaux = 1 , dim1 +cgn write (ulsort,*) '. iaux =', iaux + do 3222 , jaux = 1 , dim2 +cgn write (ulsort,*) '.. table(',iaux,',',jaux,')',table(iaux,jaux) + table(iaux,jaux) = nounum(table(iaux,jaux)) + 3222 continue + 3221 continue +c +c 3.2.3. ==> Changement de l'indice et du contenu +c + elseif ( option.eq.3 ) then +c + if ( diment.eq.1 ) then +c + do 3231 , jaux = 1 , dim2 + do 3232 , iaux = 1 , nbenti + table(nounum(iaux),jaux) = nounum(tabaux(iaux,jaux)) + 3232 continue + 3231 continue +c + else +c + do 3233 , iaux = 1 , dim1 + do 3234 , jaux = 1 , nbenti + table(iaux,nounum(jaux)) = nounum(tabaux(iaux,jaux)) + 3234 continue + 3233 continue +c + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utchre.F b/src/tool/Utilitaire/utchre.F new file mode 100644 index 00000000..2bd01ef3 --- /dev/null +++ b/src/tool/Utilitaire/utchre.F @@ -0,0 +1,213 @@ + subroutine utchre ( chaine, valeur, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - convertit une CHaine de caractere en REel +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chaine . e .char*(*). chaine de caractere . +c . valeur . s . 1 . reel associe . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c . . . . 2 : probleme au decodage . +c . . . . 3 : la chaine est blanche . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCHRE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + double precision valeur +c + character*(*) chaine +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer exposa, decima, sigman, sigexp + integer lgchai +c + character*1 lettre +c + logical chiffr, point, expo, moins +c + double precision mantis +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Chaine a convertir : '',a)' + texte(1,5) = '(''==> valeur : '',g15.8)' + texte(1,6) = '(''La chaine est blanche.'')' +c + texte(2,4) = '(''String to convert : '',a)' + texte(2,5) = '(''==> value : '',g15.8)' + texte(2,6) = '(''String is empty.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) chaine +#endif +c +c==== +c 2. decodage +c==== +c + codret = 0 +c +c 2.1. ==> longueur reelle de la chaine +c + call utlgut ( lgchai, chaine, + > ulsort, langue, codret ) + if (codret.eq.0) then + if ( lgchai.eq.0 ) then + write (ulsort,texte(langue,6)) + codret = 3 + endif + endif +c +c 2.2. ==> decodage +c + if ( codret.eq.0 ) then +c + chiffr = .false. + point = .false. + expo = .false. + moins = .false. +c + mantis = 0.D0 + exposa = 0 + decima = 0 + sigman = 1 + sigexp = 1 +c + do 22 , iaux = 1 , lgchai +c + lettre = chaine(iaux:iaux) +c + if ( lettre .eq. '0' .or. lettre .eq. '1' .or. + > lettre .eq. '2' .or. lettre .eq. '3' .or. + > lettre .eq. '4' .or. lettre .eq. '5' .or. + > lettre .eq. '6' .or. lettre .eq. '7' .or. + > lettre .eq. '8' .or. lettre .eq. '9' ) then + chiffr = .true. + read(lettre,'(i1)') jaux + elseif ( lettre .eq. '.') then + point = .true. + elseif ( lettre .eq. 'e' .or. lettre .eq. 'E' .or. + > lettre .eq. 'd' .or. lettre .eq. 'D' ) then + expo = .true. + elseif ( lettre .eq. '-') then + moins = .true. + elseif ( lettre .eq. '+' ) then + goto 22 + else + codret = 2 + endif +c + if ( chiffr ) then + if ( .not.point .and. .not.expo) then + mantis = 10.D0 * mantis + dble(jaux) + elseif ( .not.expo ) then + decima = decima - 1 + mantis = mantis + dble(jaux) * 10.D0**decima + else + exposa = 10*exposa + jaux + endif + chiffr = .false. + elseif ( moins ) then + if ( .not.expo ) then + sigman = -1 + else + sigexp = -1 + endif + moins = .false. + endif +c + 22 continue +c + valeur = dble(sigman)*mantis * 10.d0**(sigexp*exposa) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) valeur +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) chaine +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utchs8.F b/src/tool/Utilitaire/utchs8.F new file mode 100644 index 00000000..bf5ff355 --- /dev/null +++ b/src/tool/Utilitaire/utchs8.F @@ -0,0 +1,175 @@ + subroutine utchs8 ( chacar, lgchac, tabch8, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - transfere une CHaine dans un tableau de String*8 +c -- -- - - +c +c Remarque : on transfere stricto sensu le nombre de caracteres +c demandes, sans se preoccuper de savoir s'il y a des +c blancs ou des "mauvais" caracteres. +c Remarque : si on est oblige d'entamer une nouvelle case du tableau, +c on complete a droite par des blancs. +c +c Exemple : +c +c chacar = 'Sous le pont Mirabeau coule la Seine' +c 123456789012345678901234567890123456 +c lgchac = 36 +c 12345678 +c devient : tabch8 (1) = 'Sous le ' +c tabch8 (2) = 'pont Mir' +c tabch8 (3) = 'abeau co' +c tabch8 (4) = 'ule la S' +c tabch8 (5) = 'eine ' +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chacar . e .char*(*). chaine de caractere . +c . lgchac . e . 1 . nombre de caracteres a transferer . +c . tabch8 . s . * . tableau a remplir . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCHS8' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgchac +c + character*8 tabch8(*) + character*(*) chacar +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lencha, nbchar, nbpack +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Chaine a transferer : '')' + texte(1,5) = '(''La chaine est declaree en char*'',i4)' + texte(1,6) = '(''mais on veut transferer '',i4,'' caracteres !'')' +c + texte(2,4) = '(''String to convert : '')' + texte(2,5) = '(''The string is declared as char*'',i4)' + texte(2,6) = '(''but, '',i4,'' characters must be moved !'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,*) chacar +#endif +c +c==== +c 2. verification de la longueur +c==== +c + codret = 0 +c + lencha = len(chacar) + if ( lgchac.gt.lencha ) then + codret = 1 + endif +c +c==== +c 3. transfert +c==== +c + if ( codret.eq.0 ) then +c + nbchar = mod(lgchac,8) + nbpack = ( lgchac - nbchar ) / 8 +c + jaux = 1 + do 31 , iaux = 1 , nbpack + tabch8(iaux) = chacar(jaux:jaux+7) + jaux = jaux + 8 + 31 continue +c + if ( nbchar.gt.0 ) then +c 12345678 + tabch8(nbpack+1) = ' ' + tabch8(nbpack+1)(1:nbchar) = chacar(jaux:jaux+nbchar-1) + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + write (ulsort,*) chacar + write (ulsort,texte(langue,5)) lencha + write (ulsort,texte(langue,6)) lgchac + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcnar.F b/src/tool/Utilitaire/utcnar.F new file mode 100644 index 00000000..0fa723b4 --- /dev/null +++ b/src/tool/Utilitaire/utcnar.F @@ -0,0 +1,182 @@ + subroutine utcnar ( somare, hetare, famare, decare, + > filare, merare, arehom, np2are, + > aretri, arequa, + > posifa, facare, + > ancare, nouare, nounoe, + > nbtrre, nbqure, nbarre, + > ancfil, ancmer ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des ARetes +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, triangle ou +c tetraedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e/s .2*nouvar. numeros des extremites d'arete . +c . hetare . e/s . nouvar . historique de l'etat des aretes . +c . decare . e/s .0:nbarto. table des decisions sur les aretes . +c . famare . e/s . nouvar . famille des aretes . +c . filare . e/s . nouvar . premiere fille des aretes . +c . merare . e/s . nouvar . mere des aretes . +c . arehom . e . nouvar . ensemble des aretes homologues . +c . np2are . e/s . nouvar . numero des noeuds p2 milieux d'aretes . +c . aretri . e/s .nouvtr*3. numeros des 3 aretes des triangles . +c . arequa . e/s .nouvqu*4. numeros des 4 aretes des quadrangles . +c . posifa . e/s .0:nbarto. pointeur sur tableau facare . +c . facare . e/s . nbfaar . liste des faces contenant une arete . +c . ancare . e . nouvar . anciens numeros des aretes conservees . +c . nouare . e .0:nouvar. nouveaux numeros des aretes conservees . +c . nounoe . e .0:nouvno. nouveaux numeros des noeuds conserves . +c . nbtrre . e . 1 . nombre de triangles restants . +c . nbqure . e . 1 . nombre de quadrangles restants . +c . nbarre . e . 1 . nombre d'aretes restantes . +c . ancfil . aux . nbarto . ancien tableau des filles . +c . ancmer . aux . nbarto . ancien tableau des meres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "envca1.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer nbtrre, nbqure, nbarre +c + integer somare(2,nouvar), hetare(nouvar) + integer famare(nouvar), decare(0:nbarto) +c + integer filare(nouvar), merare(nouvar) + integer arehom(nouvar) + integer np2are(nouvar) +c + integer aretri(nouvtr,3), arequa(nouvqu,4) + integer posifa(0:nbarto), facare(nbfaar) +c + integer ancare(nouvar), nouare(0:nouvar) + integer nounoe(0:nouvno) +c + integer ancfil(nbarto), ancmer(nbarto) +c +c 0.4. ==> variables locales +c + integer larete +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c==== +c 1. remise a jour des numerotations des aretes +c reconstruction des correspondances directes +c==== +c +c 1.1. ==> stockage des anciens tableaux de filiation +c + do 11 ,larete = 1 , nbarto + ancfil(larete) = filare(larete) + ancmer(larete) = merare(larete) + 11 continue +c +c 1.2. ==> transfert +c + do 12 , larete = 1 , nbarre +c + somare(1,larete) = nounoe(somare(1,ancare(larete))) + somare(2,larete) = nounoe(somare(2,ancare(larete))) +c + if ( ancare(larete).ne.larete ) then +c + hetare(larete) = hetare(ancare(larete)) + famare(larete) = famare(ancare(larete)) + decare(larete) = decare(ancare(larete)) +c + endif +c + filare(larete) = nouare(ancfil(ancare(larete))) + merare(larete) = nouare(ancmer(ancare(larete))) +c + if ( degre .eq. 2 ) then + np2are(larete) = nounoe(np2are(ancare(larete))) + endif +c + 12 continue +c +c 1.3. ==> traitement des homologues +c + if ( homolo.ge.2 ) then +c + do 13 , larete = 1 , nbarre + if ( arehom(ancare(larete)) .ge. 0 ) then + arehom(larete) = nouare(arehom(ancare(larete))) + else + arehom(larete) = - nouare(abs(arehom(ancare(larete)))) + endif + 13 continue +c + endif +c +c==== +c 2. reconstruction des correspondances inverses +c==== +c + call utfaa1 ( nbarre, nbtrre, nbqure, + > nouvar, nouvtr, nouvqu, + > aretri, arequa, + > nbfaar, posifa ) +c + call utfaa2 ( nbtrre, nbqure, + > nouvtr, nouvqu, + > aretri, arequa, + > nbfaar, posifa, facare ) +c + end diff --git a/src/tool/Utilitaire/utcnhe.F b/src/tool/Utilitaire/utcnhe.F new file mode 100644 index 00000000..4f04ad1e --- /dev/null +++ b/src/tool/Utilitaire/utcnhe.F @@ -0,0 +1,156 @@ + subroutine utcnhe ( quahex, coquhe, hethex, famhex, + > filhex, perhex, ninhex, + > anchex, nouhex, + > nouqua, nbhere, + > ancfil, ancper ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des Hexaedres +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, quadrangle ou +c hexaedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . quahex . e/s .nouvhf*6. numeros des 4 quadrangles des hexaedres . +c . coquhe . e/s .nouvhf*6. code des 4 quadrangles des hexaedres . +c . hethex . e/s . nouvhe . historique de l'etat des hexaedres . +c . famhex . e/s . nouvhe . famille des hexaedres . +c . filhex . e/s . nouvhe . premier fils des hexaedres . +c . perhex . e/s . nouvhe . pere des hexaedres . +c . ninhex . e/s . nouvhe . noeud interne a l'hexaedre . +c . anchex . e . nouvhe . anciens numeros des hexaedres conserves . +c . nouhex . e .0:nouvhe. nouveaux numeros des hexaedres conserves . +c . nouqua . e .0:nouvqu. nouveaux numeros des quadrangles conserves . +c . nbhere . e . 1 . nombre de hexaedres restants . +c . ancfil . aux . nbheto . ancien tableau des fils . +c . ancper . aux . nbheto . ancien tableau des peres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nouvnb.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer quahex(nouvhf,6), coquhe(nouvhf,6) + integer hethex(nouvhe), famhex(nouvhe) + integer perhex(nouvhe), filhex(nouvhe), ninhex(nouvhe) + integer anchex(nouvhe), nouhex(0:nouvhe) + integer nouqua(0:nouvqu) + integer ancfil(nbheto), ancper(nbheto) +c + integer nbhere +c +c 0.4. ==> variables locales +c + integer lehexa, lequad +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +#include "impr03.h" +c==== +c 1. stockage des anciens tableaux de filiation +c==== +c + do 11 ,lehexa = 1 , nbheto + ancfil(lehexa) = filhex(lehexa) + ancper(lehexa) = perhex(lehexa) + 11 continue +c +c==== +c 2. transfert +c==== +c + do 21 , lehexa = 1 , nbhere +c + if ( anchex(lehexa).ne.lehexa ) then +c + do 211, lequad = 1 , 6 + quahex(lehexa,lequad) = nouqua(quahex(anchex(lehexa),lequad)) + coquhe(lehexa,lequad) = coquhe(anchex(lehexa),lequad) + 211 continue +c + hethex(lehexa) = hethex(anchex(lehexa)) + famhex(lehexa) = famhex(anchex(lehexa)) +c + else +c + do 212, lequad = 1 , 6 + quahex(lehexa,lequad) = nouqua(quahex(anchex(lehexa),lequad)) + 212 continue +c + endif +c + filhex(lehexa) = nouhex(ancfil(anchex(lehexa))) + perhex(lehexa) = nouhex(ancper(anchex(lehexa))) +c + 21 continue +c +c==== +c 3. traitement des eventuels noeuds internes +c==== +c + if ( mod(mailet,5).eq.0 ) then +c + do 31 , lehexa = 1 , nbhere +c + if ( anchex(lehexa).ne.lehexa ) then + ninhex(lehexa) = ninhex(anchex(lehexa)) + endif +c + 31 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utcnno.F b/src/tool/Utilitaire/utcnno.F new file mode 100644 index 00000000..f82204c5 --- /dev/null +++ b/src/tool/Utilitaire/utcnno.F @@ -0,0 +1,205 @@ + subroutine utcnno ( option, + > coonoe, + > hetnoe, famnoe, arenoe, noehom, + > nnoeca, nnoeho, + > nintri, + > ninqua, + > nouare, nounoe, nbnold ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des NOeuds +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, triangle ou +c tetraedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des compactages . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : noeuds internes aux triangles . +c . . . . 3 : noeuds internes aux quadrangles . +c . . . . 5 : homologues . +c . . . . 7 : renumerotation . +c . coonoe . e/s .nouvno*3. coordonnees des noeuds . +c . hetnoe . e/s . nouvno . historique de l'etat des noeuds . +c . famnoe . e/s . nouvno . caracteristiques des noeuds . +c . arenoe . e/s . nouvno . arete liee a un nouveau noeud . +c . nintri . e/s . nouvtr . noeud interne au triangle . +c . ninqua . e/s . nouvqu . noeud interne au quadrangle . +c . nouare . e .0:nouvar. nouveaux numeros des aretes conservees . +c . nounoe . e .0:nouvno. nouveaux numeros des noeuds conserves . +c . nbnold . e . 1 . nombre de noeuds anciens . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'UTCNNO' ) +#endif +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer option +c + double precision coonoe(nouvno,sdim) + integer hetnoe(nouvno), famnoe(nouvno) + integer arenoe(nouvno), noehom(nouvno) + integer nnoeca(nouvtr), nnoeho(*) + integer nintri(nouvtr) + integer ninqua(nouvqu) + integer nouare(0:*) + integer nounoe(0:*) +c + integer nbnold +c +c 0.4. ==> variables locales +c + integer iaux + integer lenoeu +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c==== +c 1. remise a jour des numerotations des noeuds +c==== +c + do 10 , lenoeu = 1 , nbnold +c + if ( nounoe(lenoeu).ne.0 ) then +c + if ( nounoe(lenoeu).ne.lenoeu ) then +c + do 11, iaux = 1 , sdim + coonoe(nounoe(lenoeu),iaux) = coonoe(lenoeu,iaux) + 11 continue +c + hetnoe(nounoe(lenoeu)) = hetnoe(lenoeu) + famnoe(nounoe(lenoeu)) = famnoe(lenoeu) +c + endif +c + arenoe(nounoe(lenoeu)) = nouare(arenoe(lenoeu)) +c + endif +c + 10 continue +c +c==== +c 2. traitement des noeuds internes +c==== +c + if ( mod(option,2).eq.0 ) then +c + do 21 , iaux = 1 , nouvtr +c + if ( nintri(iaux).ne.0 ) then + nintri(iaux) = nounoe(nintri(iaux)) + endif +c + 21 continue +c + endif +c + if ( mod(option,3).eq.0 ) then +c + do 22 , iaux = 1 , nouvqu +c + if ( ninqua(iaux).ne.0 ) then + ninqua(iaux) = nounoe(ninqua(iaux)) + endif +c + 22 continue +c + endif +c +c==== +c 3. Traitements des homologues +c==== +c + if ( mod(option,5).eq.0 ) then +c + do 30 , lenoeu = 1 , nbnold +c + if ( nounoe(lenoeu).ne.0 ) then +c + if ( noehom(lenoeu) .ge. 0 ) then + noehom(nounoe(lenoeu)) = nounoe(noehom(lenoeu)) + else + noehom(nounoe(lenoeu)) = - nounoe(abs(noehom(lenoeu))) + endif +c + endif +c + 30 continue +c + endif +c +c==== +c 4. traitement des renumerotations +c==== +c + if ( mod(option,7).eq.0 ) then +c + do 40 , lenoeu = 1 , nbnold +c + if ( nounoe(lenoeu).ne.0 ) then + nnoeca(nounoe(lenoeu)) = nnoeca(lenoeu) + nnoeho(nnoeca(lenoeu)) = lenoeu + endif +c + 40 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utcnpe.F b/src/tool/Utilitaire/utcnpe.F new file mode 100644 index 00000000..e1f0603a --- /dev/null +++ b/src/tool/Utilitaire/utcnpe.F @@ -0,0 +1,145 @@ + subroutine utcnpe ( facpen, cofape, hetpen, fampen, + > filpen, perpen, ancpen, noupen, + > noutri, nouqua, nbpere, + > ancfil, ancper ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des Pentaedres +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, tria/quad ou +c pentaedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . facpen . e/s .nouvpf*5. numeros des 5 faces des pentaedres . +c . cofape . e/s .nouvpf*5. code des 5 faces des pentaedres . +c . hetpen . e/s . nouvpe . historique de l'etat des pentaedres . +c . fampen . e/s . nouvpe . famille des pentaedres . +c . filpen . e/s . nouvpe . premier fils des pentaedres . +c . perpen . e/s . nouvpe . pere des pentaedres . +c . ancpen . e . nouvpe . anciens numeros des pentaedres conserves . +c . noupen . e .0:nouvpe. nouveaux numeros des pentaedres conserves . +c . noutri . e .0:nouvtr. nouveaux numeros des triangles conserves . +c . nouqua . e .0:nouvqu. nouveaux numeros des quadrangles conserves . +c . nbpere . e . 1 . nombre de pentaedres restants . +c . ancfil . aux . nbpeto . ancien tableau des fils . +c . ancper . aux . nbpeto . ancien tableau des peres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer facpen(nouvpf,5), cofape(nouvpf,5) + integer hetpen(nouvpe), fampen(nouvpe) + integer perpen(nouvpe), filpen(nouvpe) + integer ancpen(nouvpe), noupen(0:nouvpe) + integer noutri(0:nouvtr) + integer nouqua(0:nouvqu) + integer ancfil(nbpeto), ancper(nbpeto) +c + integer nbpere +c +c 0.4. ==> variables locales +c + integer lepent + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c==== +c 1. remise a jour des numerotations des pentaedres +c==== +c +c 1.1. ==> stockage des anciens tableaux de filiation +c + do 11 ,lepent = 1 , nbpeto + ancfil(lepent) = filpen(lepent) + ancper(lepent) = perpen(lepent) + 11 continue +c +c 1.2. ==> transfert +c + do 12 , lepent = 1 , nbpere +c + if ( ancpen(lepent).ne.lepent ) then +c + do 1211, iaux = 1, 2 + facpen(lepent,iaux) = noutri(facpen(ancpen(lepent),iaux)) + cofape(lepent,iaux) = cofape(ancpen(lepent),iaux) + 1211 continue + do 1212, iaux = 3, 5 + facpen(lepent,iaux) = nouqua(facpen(ancpen(lepent),iaux)) + cofape(lepent,iaux) = cofape(ancpen(lepent),iaux) + 1212 continue +c + hetpen(lepent) = hetpen(ancpen(lepent)) + fampen(lepent) = fampen(ancpen(lepent)) +c + else +c + do 1221, iaux = 1, 2 + facpen(lepent,iaux) = noutri(facpen(ancpen(lepent),iaux)) + 1221 continue + do 1222, iaux = 3, 5 + facpen(lepent,iaux) = nouqua(facpen(ancpen(lepent),iaux)) + 1222 continue +c + endif +c + filpen(lepent) = noupen(ancfil(ancpen(lepent))) + perpen(lepent) = noupen(ancper(ancpen(lepent))) +c + 12 continue +c + end diff --git a/src/tool/Utilitaire/utcnqu.F b/src/tool/Utilitaire/utcnqu.F new file mode 100644 index 00000000..a0a7366c --- /dev/null +++ b/src/tool/Utilitaire/utcnqu.F @@ -0,0 +1,264 @@ + subroutine utcnqu ( option, + > hetqua, famqua, decfac, nivqua, + > filqua, perqua, + > hexqua, ninqua, + > nqueca, nqueho, + > ancqua, nouqua, nouare, arequa, + > nbqure, + > ancfil, ancper ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des QUadrangles +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, triangle, +c quadrangle ou tetraedre) son ancien numero est toujours +c superieur ou egal a son numero courant : ancent(i) >= i. +c En effet, la suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des compactages . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 3 : noeuds internes aux quadrangles . +c . . . . 5 : homologues . +c . . . . 7 : renumerotation . +c . . . . 11 : relation volu/face pour l'extrusion . +c . hetqua . e/s . nouvqu . historique de l'etat des quadrangles . +c . famqua . e/s . nouvqu . famille des quadrangles . +c . decfac . e/s . -nbquto. decision sur les faces (tria. + qua.) . +c . . . :nbtrto. . +c . nivqua . e/s . nouvqu . niveau des quadrangles . +c . filqua . e/s . nouvqu . premier fils des quadrangles . +c . perqua . e/s . nouvqu . pere des quadrangles . +c . hexqua . e/s . nbquto . hexaedre sur un quadrangle de la face avant. +c . ninqua . e/s . nouvqu . noeud interne au quadrangle . +c . ancqua . e . nouvqu . anciens numeros des quadrangles conserves . +c . nouqua . e .0:nouvqu. nouveaux numeros des quadrangles conserves . +c . nouare . e .0:nouvar. nouveaux numeros des aretes conservees . +c . arequa . e/s .nouvqu*4. numeros des 4 aretes des quadrangles . +c . nbqure . e . 1 . nombre de quadrangles restants . +c . ancfil . aux . nbquto . ancien tableau des fils . +c . ancper . aux . nbquto . ancien tableau des peres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#ifdef _DEBUG_HOMARD_ + character*6 nompro + parameter ( nompro = 'UTCNQU' ) +#endif +c +c 0.2. ==> communs +c +#include "nomber.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer option + integer nbqure +c + integer decfac(-nbquto:nbtrto) + integer hetqua(nouvqu), famqua(nouvqu) + integer nivqua(nouvqu) + integer filqua(nouvqu), perqua(nouvqu) + integer hexqua(nouvqu), ninqua(nouvqu) + integer nqueca(nouvqu), nqueho(requac) + integer ancqua(nouvqu), nouqua(0:nouvqu) + integer nouare(0:nouvar), arequa(nouvqu,4) + integer ancfil(nbquto), ancper(nbquto) +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad, larete +c +c 0.5. ==> initialisations +c +c==== +c 1. messages +c==== +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (1,*) 'entree de ',nompro + do 1105 , lequad = 1 , nouvqu + write (1,90001) 'quadrangle', lequad, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4) + 1105 continue +#endif +c ______________________________________________________________________ +c +cgn do 300 , lequad = 1 , nbqure +cgn if ( ancqua(lequad).eq.1 .or. ancqua(lequad).eq.3 .or. +cgn > ancqua(lequad).eq.4 .or. ancqua(lequad).eq.5 .or. +cgn > ancqua(lequad).eq.6) then +cgn write(1,*),'ancqua(',lequad,') =',ancqua(lequad) +cgn write(1,*),'filqua(ancqua(',lequad,')) =', +cgn >filqua(ancqua(lequad)),nouqua(filqua(ancqua(lequad))) +cgn write(1,*),'perqua(ancqua(',lequad,')) =', +cgn >perqua(ancqua(lequad)),nouqua(perqua(ancqua(lequad))) +cgn write(1,*),' ' +cgn endif +cgn 300 continue +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains quadrangles ont des peres adoptifs de numero +c negatif. Il ne faut pas transferer leur numero +c +c==== +c 1. remise a jour des numerotations des quadrangles +c reconstruction des correspondances directes +c==== +c +c 1.1. ==> stockage des anciens tableaux de filiation +c + do 11 ,lequad = 1 , nbquto + ancfil(lequad) = filqua(lequad) + ancper(lequad) = perqua(lequad) + 11 continue +c +c 1.2. ==> transfert +c + do 12 , lequad = 1 , nbqure +c + do 121, larete = 1 , 4 + arequa(lequad,larete) = nouare(arequa(ancqua(lequad),larete)) + 121 continue +c + if ( ancqua(lequad).ne.lequad ) then +c + hetqua(lequad) = hetqua(ancqua(lequad)) + famqua(lequad) = famqua(ancqua(lequad)) +cgn print *,'-lequad, -ancqua(lequad)',-lequad, -ancqua(lequad) + decfac(-lequad) = decfac(-ancqua(lequad)) + nivqua(lequad) = nivqua(ancqua(lequad)) +c + endif +c + filqua(lequad) = nouqua(ancfil(ancqua(lequad))) + if ( ancper(ancqua(lequad)).gt.0 ) then + perqua(lequad) = nouqua(ancper(ancqua(lequad))) + else + perqua(lequad) = ancper(ancqua(lequad)) + endif +c + 12 continue +c +c 1.3. ==> traitement des noeuds internes +c + if ( mod(option,3).eq.0 ) then +c + do 13 , lequad = 1 , nbqure +c + if ( ancqua(lequad).ne.lequad ) then + ninqua(lequad) = ninqua(ancqua(lequad)) + endif +c + 13 continue +c + endif +c +c 1.4. ==> traitement des homologues +c +cgn if ( mod(option,5).eq.0 ) then +cgn do 301 , lequad = 1 , nbqure +cgn if ( lequad.eq.1 .or. lequad.eq.4 .or. +cgn > lequad.eq.3 .or. lequad.eq.6 .or. +cgn > lequad.eq.5) then +cgn write(1,*),'ancqua(',lequad,') =',ancqua(lequad) +cgn write(1,*),'filqua(',lequad,') =',filqua(lequad) +cgn write(1,*),'perqua(',lequad,') =',perqua(lequad) +cgn write(1,*),' ' +cgn endif +cgn 301 continue +cgn endif +c +c 1.5. ==> traitement des renumerotations +c + if ( mod(option,7).eq.0 ) then +c + do 151 , iaux = 1 , requac + nqueho(iaux) = 0 + 151 continue +c + do 152 , lequad = 1 , nbqure +c + if ( ancqua(lequad).ne.lequad ) then + nqueca(lequad) = nqueca(ancqua(lequad)) + endif + nqueho(nqueca(lequad)) = lequad +c + 152 continue +c + endif +c +c 1.6. ==> traitement des hexaedres pour l'extrusion +c + if ( mod(option,11).eq.0 ) then +c + do 16 , lequad = 1 , nbqure +c + if ( ancqua(lequad).ne.lequad ) then + hexqua(lequad) = hexqua(ancqua(lequad)) + endif +c + 16 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (1,*) 'sortie de ',nompro + do 1103 , lequad = 1 , nouvqu + write (1,90001) 'quadrangle', lequad, + > arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4) + 1103 continue +#endif + end diff --git a/src/tool/Utilitaire/utcnte.F b/src/tool/Utilitaire/utcnte.F new file mode 100644 index 00000000..c4c09bb6 --- /dev/null +++ b/src/tool/Utilitaire/utcnte.F @@ -0,0 +1,138 @@ + subroutine utcnte ( tritet, cotrte, hettet, famtet, + > filtet, pertet, anctet, noutet, + > noutri, nbtere, + > ancfil, ancper ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des TEtraedres +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, triangle ou +c tetraedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tritet . e/s .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e/s .nouvtf*4. code des 4 triangles des tetraedres . +c . hettet . e/s . nouvte . historique de l'etat des tetraedres . +c . famtet . e/s . nouvte . famille des tetraedres . +c . filtet . e/s . nouvte . premier fils des tetraedres . +c . pertet . e/s . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . anctet . e . nouvte . anciens numeros des tetraedres conserves . +c . noutet . e .0:nouvte. nouveaux numeros des tetraedres conserves . +c . noutri . e .0:nouvtr. nouveaux numeros des triangles conserves . +c . nbtere . e . 1 . nombre de tetraedres restants . +c . ancfil . aux . nbteto . ancien tableau des fils . +c . ancper . aux . nbteto . ancien tableau des peres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nouvnb.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + integer tritet(nouvtf,4), cotrte(nouvtf,4) + integer hettet(nouvte), famtet(nouvte) + integer pertet(nouvte), filtet(nouvte) + integer anctet(nouvte), noutet(0:nouvte) + integer noutri(0:nouvtr) + integer ancfil(nbteto), ancper(nbteto) +c + integer nbtere +c +c 0.4. ==> variables locales +c + integer letetr, letria +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c==== +c 1. remise a jour des numerotations des tetraedres +c==== +c +c 1.1. ==> stockage des anciens tableaux de filiation +c + do 11 ,letetr = 1 , nbteto + ancfil(letetr) = filtet(letetr) + ancper(letetr) = pertet(letetr) + 11 continue +c +c 1.2. ==> transfert +c + do 12 , letetr = 1 , nbtere +c + if ( anctet(letetr).ne.letetr ) then +c + do 121, letria = 1 , 4 + tritet(letetr,letria) = noutri(tritet(anctet(letetr),letria)) + cotrte(letetr,letria) = cotrte(anctet(letetr),letria) + 121 continue +c + hettet(letetr) = hettet(anctet(letetr)) + famtet(letetr) = famtet(anctet(letetr)) +c + else +c + do 122, letria = 1 , 4 + tritet(letetr,letria) = noutri(tritet(anctet(letetr),letria)) + 122 continue +c + endif +c + filtet(letetr) = noutet(ancfil(anctet(letetr))) + pertet(letetr) = noutet(ancper(anctet(letetr))) +c + 12 continue +c + end diff --git a/src/tool/Utilitaire/utcntr.F b/src/tool/Utilitaire/utcntr.F new file mode 100644 index 00000000..b9b37adc --- /dev/null +++ b/src/tool/Utilitaire/utcntr.F @@ -0,0 +1,242 @@ + subroutine utcntr ( option, + > hettri, famtri, decfac, nivtri, + > filtri, pertri, + > pentri, nintri, homtri, + > ntreca, ntreho, + > anctri, noutri, nouare, aretri, + > nbtrre, + > ancfil, ancper ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Compactage de la Numerotation des TRiangles +c -- - - -- +c ______________________________________________________________________ +c +c remarque hyper-importante : +c quelle que soit l'entite (noeud, arete, triangle ou +c tetraedre) son ancien numero est toujours superieur ou +c egal a son numero courant : ancent(i) >= i. En effet, la +c suppression d'entites entraine des trous dans +c la numerotation et tout le but des programmes utcnxx est +c de supprimer ces trous. +c donc quand on fait tab(i) = tab(ancent(i)), on est certain +c que tab(ancent(i)) n'a pas encore ete modifie dans +c la boucle sur i croissant. c'est donc bien la bonne +c valeur, c'est-a-dire l'ancienne, que l'on met a la +c nouvelle place. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage des compactages . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : noeuds internes aux triangles . +c . . . . 5 : homologues . +c . . . . 7 : renumerotation . +c . . . . 11 : relation volu/face pour l'extrusion . +c . hettri . e/s . nouvtr . historique de l'etat des triangles . +c . famtri . e/s . nouvtr . famille des triangles . +c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . nivtri . e/s . nouvtr . niveau des triangles . +c . filtri . e/s . nouvtr . premier fils des triangles . +c . pertri . e/s . nouvtr . pere des triangles . +c . pentri . e/s . nouvtr . pentaedre sur un triangle de la face avant . +c . nintri . e/s . nouvtr . noeud interne au triangle . +c . homtri . e/s . nouvtr . ensemble des triangles homologues . +c . anctri . e . nouvtr . anciens numeros des triangles conserves . +c . noutri . e .0:nouvtr. nouveaux numeros des triangles conserves . +c . nouare . e .0:nouvar. nouveaux numeros des aretes conservees . +c . aretri . e/s .nouvtr*3. numeros des 3 aretes des triangles . +c . nbtrre . e . 1 . nombre de triangles restants . +c . ancfil . aux . nbtrto . ancien tableau des fils . +c . ancper . aux . nbtrto . ancien tableau des peres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCNTR' ) +c +c 0.2. ==> communs +c +#include "nomber.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer option + integer nbtrre +c + integer decfac(-nbquto:nbtrto) + integer hettri(nouvtr), famtri(nouvtr) + integer nivtri(nouvtr) + integer filtri(nouvtr), pertri(nouvtr) + integer pentri(nouvtr), nintri(nouvtr), homtri(nouvtr) + integer ntreca(nouvtr), ntreho(retrac) + integer anctri(nouvtr), noutri(0:nouvtr) + integer nouare(0:nouvar), aretri(nouvtr,3) + integer ancfil(nbtrto), ancper(nbtrto) +c +c 0.4. ==> variables locales +c + integer iaux + integer letria, larete +c +c 0.5. ==> initialisations +c +c==== +c 1. messages +c==== +c +#include "impr03.h" +c +cgn print 90002,nompro//' - option',option +cgn print 90002,'nbtrre',nbtrre +cgn print 90002,'retrac',retrac +cgn print 91020,anctri +c +c ______________________________________________________________________ +c +c a partir de maintenant, on travaille avec le nouveau nombre d'entites +c du maillage, i.e. uniquement le nombre d'entites n'ayant pas ete +c marquees "a disparaitre". il faut neanmoins conserver le nombre +c d'entites avant disparitions pour pouvoir, a la fin des remises a +c jours des numerotations, compacter les tableaux en memoire. +c +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains triangles ont des peres adoptifs de numero +c negatif. Il ne faut pas transferer leur numero +c Le cas des peres negatif parce que quadrangle de conformite +c n'existe plus a ce stade : ces triangles ont ete detruits +c en amont +c +c==== +c 1. remise a jour des numerotations des triangles +c reconstruction des correspondances directes +c==== +c +c 1.1. ==> stockage des anciens tableaux de filiation +c + do 11 ,letria = 1 , nbtrto + ancfil(letria) = filtri(letria) + ancper(letria) = pertri(letria) + 11 continue +c +c 1.2. ==> transfert +c + do 12 , letria = 1 , nbtrre +c + do 121, larete = 1 , 3 + aretri(letria,larete) = nouare(aretri(anctri(letria),larete)) + 121 continue +c + if ( anctri(letria).ne.letria ) then +c + hettri(letria) = hettri(anctri(letria)) + famtri(letria) = famtri(anctri(letria)) + decfac(letria) = decfac(anctri(letria)) + nivtri(letria) = nivtri(anctri(letria)) +c + endif +c + filtri(letria) = noutri(ancfil(anctri(letria))) + if ( ancper(anctri(letria)).gt.0 ) then + pertri(letria) = noutri(ancper(anctri(letria))) + else + pertri(letria) = ancper(anctri(letria)) + endif +c + 12 continue +c +c 1.3. ==> traitement des noeuds internes +c + if ( mod(option,2).eq.0 ) then +c + do 13 , letria = 1 , nbtrre +c + if ( anctri(letria).ne.letria ) then + nintri(letria) = nintri(anctri(letria)) + endif +c + 13 continue +c + endif +c +c 1.4. ==> traitement des homologues +c + if ( mod(option,5).eq.0 ) then +c + do 14 , letria = 1 , nbtrre + if ( homtri(anctri(letria)) .ge. 0 ) then + homtri(letria) = noutri(homtri(anctri(letria))) + else + homtri(letria) = - noutri(abs(homtri(anctri(letria)))) + endif + 14 continue +c + endif +c +c 1.5. ==> traitement des renumerotations +c + if ( mod(option,7).eq.0 ) then +c + do 151 , iaux = 1 , retrac + ntreho(iaux) = 0 + 151 continue +c + do 152 , letria = 1 , nbtrre +c + if ( anctri(letria).ne.letria ) then + ntreca(letria) = ntreca(anctri(letria)) + endif + if ( ntreca(letria).gt.0 ) then + ntreho(ntreca(letria)) = letria + endif +c + 152 continue +c + endif +c +c 1.6. ==> traitement des pentaedres pour l'extrusion +c + if ( mod(option,11).eq.0 ) then +c + do 16 , letria = 1 , nbtrre +c + if ( anctri(letria).ne.letria ) then + pentri(letria) = pentri(anctri(letria)) + endif +c + 16 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utcohe.F b/src/tool/Utilitaire/utcohe.F new file mode 100644 index 00000000..08a75e00 --- /dev/null +++ b/src/tool/Utilitaire/utcohe.F @@ -0,0 +1,250 @@ + subroutine utcohe ( lehexa, bilan, + > coonoe, + > somare, + > arequa, + > quahex, coquhe, arehex, + > hethex, filhex, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - COntroles de HExaedres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . bilan . s . 1 . 0 : tout va bien . +c . . . . 1 : probleme . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOHE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lehexa, bilan + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer hethex(nbheto) + integer filhex(nbheto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbfils + integer som1, som2, som3, som4 + integer freain, etat +c + double precision prmixt, prmixf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Examen du '',a,i10)' +c + texte(2,4) = '(''.. Examination of '',a,'' # '',i10)' +c +c==== +c 2. Controle de l'hexaedre +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Controle hexaedre ; codret = ', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,6), lehexa +#endif +c + etat = mod(hethex(lehexa),1000) +cgn write (ulsort,*) ' etat =',etat +c + if ( etat.eq.0 ) then +c + codret = 1 +c + elseif ( etat.eq.8 ) then +c + bilan = 0 +c +c 2.1. ==> Produit mixte de l'hexaedre +c + som1 = 1 + som2 = 2 + som3 = 6 + som4 = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPMHE', nompro +#endif + call utpmhe ( lehexa, prmixt, + > som1, som2, som3, som4, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +cgn write(ulsort,*) lehexa,prmixt +c +c 2.2. ==> Parcours des differents situations +c + nbfils = 7 + freain = filhex(lehexa) +cgn write(ulsort,*) ' freain =',freain +c + do 22 , iaux = 1 , 8 +c + if ( iaux.eq.1 ) then + som1 = 1 + som2 = 2 + som3 = 6 + som4 = 4 + elseif ( iaux.eq.2 ) then + som1 = 6 + som2 = 1 + som3 = 5 + som4 = 7 + elseif ( iaux.eq.3 ) then + som1 = 5 + som2 = 6 + som3 = 2 + som4 = 8 + elseif ( iaux.eq.4 ) then + som1 = 2 + som2 = 5 + som3 = 1 + som4 = 3 + elseif ( iaux.eq.5 ) then + som1 = 3 + som2 = 4 + som3 = 8 + som4 = 2 + elseif ( iaux.eq.6 ) then + som1 = 8 + som2 = 3 + som3 = 7 + som4 = 5 + elseif ( iaux.eq.7 ) then + som1 = 7 + som2 = 8 + som3 = 4 + som4 = 6 + else + som1 = 4 + som2 = 7 + som3 = 3 + som4 = 1 + endif +c + do 221 , jaux = freain , freain+nbfils + kaux = jaux + call utpmhe ( kaux, prmixf, + > som1, som2, som3, som4, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +cgn write(ulsort,*) jaux,prmixf + if ( prmixt*prmixf.le.0.d0 ) then + bilan = 1 + goto 29 + endif + 221 continue +c +cgn write(ulsort,*) ' ' + 22 continue +c + endif +c + 29 continue +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcoma.F b/src/tool/Utilitaire/utcoma.F new file mode 100644 index 00000000..d458fac7 --- /dev/null +++ b/src/tool/Utilitaire/utcoma.F @@ -0,0 +1,391 @@ + subroutine utcoma ( nomail, optimp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - verification de la COnformite du MAillage +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . optimp . e . 1 . option d'impression des non-conformites : . +c . . . . 0 : pas d'impression . +c . . . . non nul : impression . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans la recherche de tableaux . +c . . . . 11 : pb. de conformite sur les triangles . +c . . . . 21 : pb. de conformite sur les tetras . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer optimp +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbarto, nbtrto, nbquto + integer nbteto, nbheto, nbpyto, nbpeto + integer nbteca, nbheca, nbpyca, nbpeca + integer nbtecf, nbhecf, nbpycf, nbpecf +c + integer psomar, phetar + integer paretr, phettr + integer parequ, phetqu + integer ptrite, phette, pcotrt, parete + integer pquahe, phethe, pcoquh, parehe + integer pfacpy, phetpy, pcofay, parepy + integer pfacpe, phetpe, pcofap, parepe +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Impossible de recuperer les tableaux.'')' + texte(1,5) = '(''Probleme de conformite sur les '',a,''.'')' + texte(1,6) = '(''Le maillage est de type non-conforme.'')' +c + texte(2,4) = '(''Arrays cannot be found.'')' + texte(2,5) = '(a,'' with hanging nodes.'')' + texte(2,6) = '(''Mesh is hanging-node type.'')' +c +#include "impr03.h" +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c +cgn write (ulsort,90003) 'structures', +cgn > nhnoeu, nhmapo, nharet, nhtria, nhquad, +cgn > nhtetr, nhhexa, nhpyra, nhpent +cgn call gmprsx(nompro,nhquad) +cgn call gmprsx(nompro,nhpyra) +cgn call gmprsx(nompro,nhpyra//'.InfoSupp') + endif +c +c 2.2. ==> le maillage est declare non conforme +c + if ( codret.eq.0 ) then +c + if ( ( maconf.gt.0 ) .or. ( maconf.eq.-2 ) ) then +c + write (ulsort,texte(langue,6)) +c + endif +c + endif +c +c==== +c 3. analyse +c==== +c + if ( maconf.le.2 ) then +c +c 3.1. ==> Recherche des tableaux +c + if ( codret.eq.0 ) then +c + call gmliat ( nharet, 1, nbarto, codre1 ) + call gmliat ( nhtria, 1, nbtrto, codre2 ) + call gmliat ( nhquad, 1, nbquto, codre3 ) + call gmliat ( nhtetr, 1, nbteto, codre4 ) + call gmliat ( nhhexa, 1, nbheto, codre5 ) + call gmliat ( nhpyra, 1, nbpyto, codre6 ) + call gmliat ( nhpent, 1, nbpeto, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 , + > codre6, codre7 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhtetr, 2, nbteca, codre1 ) + call gmliat ( nhhexa, 2, nbheca, codre2 ) + call gmliat ( nhpyra, 2, nbpyca, codre3 ) + call gmliat ( nhpent, 2, nbpeca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbteca, nbheca, nbpyca, nbpeca', + > nbteca, nbheca, nbpyca, nbpeca +#endif +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro +#endif + call utad02 ( iaux, nharet, + > phetar, psomar, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + if ( nbtrto.ne.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbquto.ne.0 ) then +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux , jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( nbteto.ne.0 ) then +c + iaux = 26 + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + iaux = 26 + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + iaux = 26 + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + iaux = 26 + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux , jaux, + > jaux, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2. ==> Analyse +c + if ( codret.eq.0 ) then +c + iaux = maconf +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCONF', nompro +#endif + call utconf ( nbarto, nbtrto, nbquto, + > nbteto, nbheto, nbpyto, nbpeto, + > nbteca, nbheca, nbpyca, nbpeca, + > nbtecf, nbhecf, nbpycf, nbpecf, + > imem(phetar), + > imem(phettr), imem(paretr), + > imem(phetqu), imem(parequ), + > imem(phette), imem(ptrite), imem(pcotrt), + > imem(phethe), imem(pquahe), imem(pcoquh), + > imem(phetpy), imem(pfacpy), imem(pcofay), + > imem(phetpe), imem(pfacpe), imem(pcofap), + > iaux, optimp, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.2 ) then + write (ulsort,texte(langue,4)) + else +#ifdef _DEBUG_HOMARD_ +c +#else + if ( optimp.ne.0 ) then +#endif + write (ulsort,texte(langue,5)) mess14(langue,3,codret) +#ifdef _DEBUG_HOMARD_ +c +#else +c + endif +#endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcomp.F b/src/tool/Utilitaire/utcomp.F new file mode 100644 index 00000000..c0f7423b --- /dev/null +++ b/src/tool/Utilitaire/utcomp.F @@ -0,0 +1,114 @@ + subroutine utcomp ( ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - COMPactage des tableaux +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOMP' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,3x,''COMPACTAGE DES TABLEAUX'',/,3x,23(''-''),/)' +c + texte(2,4) = '(/,3x,''ARRAY COMPRESSION'',/,3x,17(''-''),/)' +c +c=== +c 2. travail +c=== +#ifdef _DEBUG_HOMARD_ +c +c 2.1. ==> impression de l'entete du chapitre +c + write (ulsort,texte(langue,4)) +#endif +c +c 2.2. ==> elimination des trous inutilises +c + call gmcmpr ( codret ) +c +c 2.3. ==> bilan +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utconf.F b/src/tool/Utilitaire/utconf.F new file mode 100644 index 00000000..3a0dc60b --- /dev/null +++ b/src/tool/Utilitaire/utconf.F @@ -0,0 +1,1019 @@ + subroutine utconf ( nbarto, nbtrto, nbquto, + > nbteto, nbheto, nbpyto, nbpeto, + > nbteca, nbheca, nbpyca, nbpeca, + > nbtecf, nbhecf, nbpycf, nbpecf, + > hetare, + > hettri, aretri, + > hetqua, arequa, + > hettet, tritet, cotrte, + > hethex, quahex, coquhe, + > hetpyr, facpyr, cofapy, + > hetpen, facpen, cofape, + > optnco, optimp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - verification de la CONFormite du maillage +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbarto . historique de l'etat des aretes . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . hetpyr . e . nbpyto . historique de l'etat des pyramides . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . optnco . e . 1 . option des non-conformites : . +c . . . . 0 : le maillage doit etre 100% conforme . +c . . . . 1 : au minimum 2 aretes non coupees par fac. +c . . . . 2 : 1 seul noeud pendant par arete . +c . . . . -1 : le maillage doit etre 100% conforme . +c . . . . -2 : 1 seule arete coupee par maille 2D . +c . optimp . e . 1 . option d'impression des non-conformites : . +c . . . . 0 : pas d'impression . +c . . . . non nul : impression . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : pb. de conformite sur les triangles . +c . . . . 3 : pb. de conformite sur les tetraedres . +c . . . . 4 : pb. de conformite sur les quadrangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCONF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbarto, nbtrto, nbquto + integer nbteto, nbheto, nbpyto, nbpeto + integer nbteca, nbheca, nbpyca, nbpeca + integer nbtecf, nbhecf, nbpycf, nbpecf + integer hetare(nbarto) + integer hettri(nbtrto), aretri(nbtrto,3) + integer hetqua(nbquto), arequa(nbquto,4) + integer hettet(nbteto), tritet(nbtecf,4), cotrte(nbtecf,4) + integer hethex(nbheto), quahex(nbhecf,6), coquhe(nbhecf,6) + integer hetpyr(nbpyto), facpyr(nbpycf,5), cofapy(nbpycf,5) + integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5) + integer optnco, optimp +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbtrnc, nbqunc + integer nbtenc, nbhenc, nbpync, nbpenc + integer entite, letria, lequad + integer larete, etat, bilanc + integer iaux, jaux + integer listar(12) + integer nbard2, nbarde + integer nbtrd2, nbtrd4 + integer nbqud3, nbqud4 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. impression +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Les mailles doivent avoir au maximum 1 arete coupee.'')' + texte(1,5) = '(''Le maillage doit etre 100% conforme.'')' + texte(1,6) = texte(1,5) + texte(1,7) = + >'(''Les mailles doivent avoir au minimum 2 aretes non coupees.'')' + texte(1,8) = + > '(''Les aretes actives peuvent avoir un noeud pendant.'')' + texte(1,9) = + > '(/,''Le maillage a plus d''''un point de non-conformite.'')' + texte(1,10) = + > '(/,''Les '',a,''n''''ont pas de probleme de non-conformite.'')' + texte(1,11) = + > '(/,''ATTENTION : le maillage n''''est pas conforme.'')' + texte(1,12) = '(''Le '',a,i10,'' a un probleme de conformite.'')' + texte(1,13) = + > '(2x,a,i1,'' : numero = '',i10,'', etat = '',i4)' + texte(1,14) = + > '(''Nombre de '',a,'' actifs a problemes : '',i10,/)' + texte(1,15) = '(''Son etat vaut '',i10)' + texte(1,16) = '(''Nombre de '',a,'' : '',i10)' + texte(1,20) = '(''Examen du '',a,i10)' +c + texte(2,4) = '(''Meshes whould have at max 1 cut edge.'')' + texte(2,5) = '(''Mesh should be 100% conformal.'')' + texte(2,6) = texte(2,5) + texte(2,7) = '(''Meshes should have at min 2 non cut edges.'')' + texte(2,8) = '(''Active edges could have one hanging node.'')' + texte(2,9) = '(/,''Mesh contains more than 1 hanging node.'')' + texte(2,10) = '(/,''No conformity problem with '', a)' + texte(2,11) = '(/,''CAUTION : mesh contains hanging nodes.'')' + texte(2,12) = + > '(''The active '',a,'' # '',i10,'' has a conformity problem'')' + texte(2,13) = + > '(2x,a,i1,'' : # '',i10,'', state = '',i4)' + texte(2,14) = + > '(''Number of active '',a,'' with problems : '',i10,/)' + texte(2,15) = '(''Its state is equal to '',i10)' + texte(2,16) = '(''Number of '',a,'' : '',i10)' + texte(2,20) = '(''Examination of the'',a,i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,6+optnco)) +#endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,16)) mess14(langue,3,2), nbtrto + write(ulsort,texte(langue,16)) mess14(langue,3,4), nbquto + write(ulsort,texte(langue,16)) mess14(langue,3,3), nbteto + write(ulsort,texte(langue,16)) mess14(langue,3,5), nbpyto + write(ulsort,texte(langue,16)) mess14(langue,3,6), nbheto + write(ulsort,texte(langue,16)) mess14(langue,3,7), nbpeto +#endif +c +c==== +c 2. verification de la conformite des triangles +c==== +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) '2. verif triangles, codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + nbtrnc = 0 +c + do 20 , entite = 1 , nbtrto +c + etat = mod (hettri(entite),10) +c + if ( etat.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,2), entite +#endif +c +c 2.1. ==> Decompte du nombre d'aretes actives +c + nbard2 = 0 + nbarde = 0 + do 21 , jaux = 1 , 3 + iaux = mod (hetare(aretri(entite,jaux)),10) + if ( iaux.eq.2 ) then + nbard2 = nbard2 + 1 + elseif ( iaux.ne.0 ) then + nbarde = nbarde + 1 + endif + 21 continue + bilanc = max ( nbard2, nbarde ) +cgn print *,mess14(langue,1,1), entite, ':',nbard2, nbarde +c +c 2.2. ==> S'il y a au moins une arete inactive, precision pour le cas +c non conforme +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c +c 2.2.1. ==> optnco = 1 : autorise 1 seule arete coupee par maille +c + if ( optnco.eq.1 ) then +c + if ( nbard2.le.1 .and. nbarde.eq.0 ) then + bilanc = 0 + endif +c +c 2.2.2. ==> optnco = 2 : autorise 1 seul noeud pendant par arete +c + else +c + if ( nbarde.eq.0 ) then + bilanc = 0 + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 2.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then + nbtrnc = nbtrnc + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,12)) mess14(langue,1,2), + > entite + write(ulsort,texte(langue,15)) hettri(entite) + do 23 , iaux = 1 , 3 + larete = aretri(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,1), + > iaux, larete, hetare(larete) + 23 continue + endif + endif +c + endif +c + 20 continue +c + if ( nbtrnc.ne.0 ) then + codret = 2 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,2), nbtrnc + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,2) +#endif + endif +c + endif +c +c==== +c 3. verification de la conformite des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. verif quadrangles ; codret', codret +#endif +c + if ( nbquto.ne.0 ) then +c + nbqunc = 0 +c + do 30 , entite = 1 , nbquto +c + etat = mod ( hetqua(entite),100) +c + if ( etat.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,4), entite +#endif +c +c 3.1. ==> Decompte du nombre d'aretes actives +c + nbard2 = 0 + nbarde = 0 + do 31 , jaux = 1 , 4 + iaux = mod (hetare(arequa(entite,jaux)),10) + if ( iaux.eq.2 ) then + nbard2 = nbard2 + 1 + elseif ( iaux.ne.0 ) then + nbarde = nbarde + 1 + endif + 31 continue + bilanc = max ( nbard2, nbarde ) +cgn print *,mess14(langue,1,1), entite, ':',nbard2, nbarde +c +c 3.2. ==> S'il y a au moins une arete inactive, precision pour le cas +c non conforme +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c +c 3.2.1. ==> optnco = 1 : au maximum 2 aretes coupees +c + if ( optnco.eq.1 ) then +c + if ( nbard2.le.2 .and. nbarde.eq.0 ) then + bilanc = 0 + endif +c +c 3.2.2. ==> optnco = 2 : autorise 1 seul noeud pendant par arete +c + else +c + if ( nbarde.eq.0 ) then + bilanc = 0 + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 3.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then + nbqunc = nbqunc + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,12)) mess14(langue,1,4), + > entite + write(ulsort,texte(langue,15)) hetqua(entite) + do 33 , iaux = 1 , 4 + larete = arequa(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,1), + > iaux, larete, hetare(larete) + 33 continue + endif + endif +c + endif +c + 30 continue +c + if ( nbqunc.ne.0 ) then + codret = 4 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,4), nbqunc + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,4) +#endif + endif +c + endif +c +c==== +c 4. verification de la conformite des tetraedres +c On ne controle pas pour l'option "1 noeud pendant" car c'est pris +c en compte par les faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. verif tetraedres ; codret', codret +#endif +c + if ( nbteto.ne.0 .and. optnco.le.1 ) then +c + nbtenc = 0 +c + do 40 , entite = 1 , nbtecf +c + etat = mod (hettet(entite) , 100 ) +c + if ( etat.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,3), entite +#endif +c +c 4.1. ==> Decompte du nombre de faces actives +c + nbtrd2 = 0 + nbtrd4 = 0 + do 41 , jaux = 1 , 4 + iaux = mod (hettri(tritet(entite,jaux)),10) + if ( iaux.ge.1 .and. iaux.le.3 ) then + nbtrd2 = nbtrd2 + 1 + elseif ( iaux.ge.4 .and. iaux.le.8 ) then + nbtrd4 = nbtrd4 + 1 + elseif ( iaux.eq.9 ) then + nbtrd4 = nbtrd4 + 2 + endif + 41 continue +cgn print *,mess14(langue,1,3), entite, ':',nbtrd2, nbtrd4 + bilanc = max ( nbtrd2, nbtrd4 ) +c +c 4.2. ==> S'il y a au moins une face inactive, precision pour le cas +c non conforme +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c +c 4.2.1. ==> optnco = 1, on autorise : +c - 1 triangle coupe en 4, les 3 autres aretes non coupees +c ou - 1 ou 2 triangles coupes en 2, 1 seule arete coupee +c + if ( optnco.eq.1 ) then +c + if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 ) .or. + > ( nbtrd2.le.2 .and. nbtrd4.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARTE', nompro +#endif + call utarte ( entite, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) + iaux = 0 + do 42 , jaux = 1 , 6 + if ( mod(hetare(listar(jaux)),10).ne.0 ) then + iaux = iaux + 1 + endif + 42 continue +c + if ( nbtrd4.eq.0 ) then + if ( iaux.eq.1 ) then + bilanc = 0 + endif + else + if ( iaux.eq.3 ) then + bilanc = 0 + endif + endif +c + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 4.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then +c + nbtenc = nbtenc + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,12)) mess14(langue,1,3), + > entite + write(ulsort,texte(langue,15)) hettet(entite) + do 431 , iaux = 1 , 4 + letria = tritet(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,2), + > iaux, letria, hettri(letria) + do 4311 , jaux = 1 , 3 + larete = aretri(letria,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 4311 continue + 431 continue + endif +c + endif +c + endif +c + 40 continue +c + if ( nbtenc.ne.0 ) then + codret = 3 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,3), nbtenc + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,3) +#endif + endif +c + endif +c +c==== +c 5. verification de la conformite des pyramides +c On ne controle pas pour l'option "1 noeud pendant" car c'est pris +c en compte par les faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. verif pyramides ; codret', codret +#endif +c + if ( nbpyto.ne.0 .and. optnco.le.1 ) then +c + nbpync = 0 +c + do 50 , entite = 1 , nbpycf +c + etat = mod ( hetpyr(entite) , 100 ) +c + if ( etat.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,5), entite +#endif +c +c 5.1. ==> Decompte du nombre de faces actives +c + nbtrd2 = 0 + nbtrd4 = 0 + do 51 , jaux = 1 , 4 + iaux = mod (hettri(facpyr(entite,jaux)),10) + if ( iaux.ge.1 .and. iaux.le.3 ) then + nbtrd2 = nbtrd2 + 1 + elseif ( iaux.ge.4 .and. iaux.le.8 ) then + nbtrd4 = nbtrd4 + 1 + elseif ( iaux.eq.9 ) then + nbtrd4 = nbtrd4 + 2 + endif + 51 continue + nbqud3 = 0 + nbqud4 = 0 + iaux = mod (hetqua(facpyr(entite,5)),100) + if ( iaux.eq.4 ) then + nbqud4 = 1 + elseif ( iaux.eq.99 ) then + nbqud4 = 2 + elseif ( iaux.ne.0 ) then + nbqud3 = 1 + endif +c +c 5.2. ==> S'il y a au moins une face inactive, precision pour le cas +c non conforme +c On autorise : +c - 1 face coupee en 4, les autres aretes non coupees +c - 1 ou 2 triangles coupes en 2, 1 seule arete coupee +c - 1 quadrangle coupe en 3, 1 seule arete coupee +c - 1 triangle coupe en 2 et 1 quadrangle coupe en 3, +c 1 seule arete coupee +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c + if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 .and. + > nbqud3.eq.0 .and. nbqud4.eq.0 ) .or. + > ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.0 .and. nbqud4.eq.1 ) .or. + > ( nbtrd2.le.2 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.0 .and. nbqud4.eq.0 ) .or. + > ( nbtrd2.le.1 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.1 .and. nbqud4.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPY', nompro +#endif + call utarpy ( entite, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) + iaux = 0 + do 52 , jaux = 1 , 8 + if ( mod(hetare(listar(jaux)),10).ne.0 ) then + iaux = iaux + 1 + endif + 52 continue +c + if ( nbtrd4.eq.0 .and. nbqud4.eq.0 ) then + if ( iaux.eq.1 ) then + bilanc = 0 + endif + elseif ( nbtrd4.eq.1 ) then + if ( iaux.eq.3 ) then + bilanc = 0 + endif + elseif ( nbqud4.eq.1 ) then + if ( iaux.eq.4 ) then + bilanc = 0 + endif + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 5.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then + nbpync = nbpync + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,12)) mess14(langue,1,5), + > entite + write(ulsort,texte(langue,15)) hetpyr(entite) + do 531 , iaux = 1 , 4 + letria = facpyr(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,2), + > iaux, letria, hettri(letria) + do 5311 , jaux = 1 , 3 + larete = aretri(letria,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 5311 continue + 531 continue + lequad = facpyr(entite,5) + write(ulsort,texte(langue,13)) mess14(langue,2,4), + > 1, lequad, hetqua(lequad) + do 532 , jaux = 1 , 4 + larete = arequa(lequad,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 532 continue + endif + endif +c + endif +c + 50 continue +c + if ( nbpync.ne.0 ) then + codret = 5 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,5), nbpync + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,5) +#endif + endif +c + endif +c +c==== +c 6. verification de la conformite des hexaedres +c On ne controle pas pour l'option "1 noeud pendant" car c'est pris +c en compte par les faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. verif hexaedres ; codret', codret +#endif +c + if ( nbheto.ne.0 .and. optnco.le.1 ) then +c + nbhenc = 0 +c + do 60 , entite = 1 , nbhecf +c + etat = mod(hethex(entite),1000) +c + if ( etat.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,6), entite +#endif +c +c 6.1. ==> Decompte du nombre de faces actives +c + nbqud3 = 0 + nbqud4 = 0 + do 61 , jaux = 1 , 6 + iaux = mod (hetqua(quahex(entite,jaux)),100) + if ( iaux.eq.4 ) then + nbqud4 = nbqud4 + 1 + elseif ( iaux.eq.99 ) then + nbqud4 = nbqud4 + 2 + elseif ( iaux.ne.0 ) then + nbqud3 = nbqud3 + 1 + endif + 61 continue + bilanc = max ( nbqud3, nbqud4 ) +c +c 6.2. ==> S'il y a au moins une face inactive, precision pour le cas +c non conforme +c On autorise : +c - 1 face coupee en 4, les autres aretes non coupees +c - 1 ou 2 quadrangles coupes en 3, 1 seule arete coupee +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c + if ( ( nbqud3.eq.0 .and. nbqud4.eq.1 ) .or. + > ( nbqud3.le.2 .and. nbqud4.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARHE', nompro +#endif + call utarhe ( entite, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) + iaux = 0 + do 62 , jaux = 1 , 12 + if ( mod(hetare(listar(jaux)),10).ne.0 ) then + iaux = iaux + 1 + endif + 62 continue +c + if ( nbqud4.eq.0 ) then + if ( iaux.eq.1 ) then + bilanc = 0 + endif + else + if ( iaux.eq.4 ) then + bilanc = 0 + endif + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 6.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then + nbhenc = nbhenc + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,12)) mess14(langue,1,6), + > entite + write(ulsort,texte(langue,15)) hethex(entite) + do 631 , iaux = 1 , 6 + lequad = quahex(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,4), + > iaux, lequad, hetqua(lequad) + do 6311 , jaux = 1 , 4 + larete = arequa(lequad,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 6311 continue + 631 continue + endif + endif +c + endif +c + 60 continue +c + if ( nbhenc.ne.0 ) then + codret = 6 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,6), nbhenc + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,6) +#endif + endif +c + endif +c +c==== +c 7. verification de la conformite des pentaedres +c On ne controle pas pour l'option "1 noeud pendant" car c'est pris +c en compte par les faces +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. verif pentaedres ; codret', codret +#endif +c + if ( nbpeto.ne.0 .and. optnco.le.1 ) then +c + nbpenc = 0 +c + do 70 , entite = 1 , nbpecf +c + etat = mod ( hetpen(entite) , 100 ) +c + if ( etat.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,20)) mess14(langue,1,7), entite +#endif +c +c 7.1. ==> Decompte du nombre de faces actives +c + nbtrd2 = 0 + nbtrd4 = 0 + do 711 , jaux = 1 , 2 + iaux = mod (hettri(facpen(entite,jaux)),10) + if ( iaux.ge.1 .and. iaux.le.3 ) then + nbtrd2 = nbtrd2 + 1 + elseif ( iaux.ge.4 .and. iaux.le.8 ) then + nbtrd4 = nbtrd4 + 1 + elseif ( iaux.eq.9 ) then + nbtrd4 = nbtrd4 + 2 + endif + 711 continue + nbqud3 = 0 + nbqud4 = 0 + do 721 , jaux = 3, 5 + iaux = mod (hetqua(facpen(entite,jaux)),100) + if ( iaux.eq.4 ) then + nbqud4 = nbqud4 + 1 + elseif ( iaux.eq.99 ) then + nbqud4 = nbqud4 + 2 + elseif ( iaux.ne.0 ) then + nbqud3 = nbqud3 + 1 + endif + 721 continue + bilanc = max ( nbtrd2, nbtrd4, nbqud3, nbqud4 ) +c +c 7.2. ==> S'il y a au moins une face inactive, precision pour le cas +c non conforme +c On autorise : +c - 1 face coupee en 4, les autres aretes non coupees +c - 1 ou 2 triangles coupes en 2, 1 seule arete coupee +c - 1 ou 2 quadrangles coupes en 3, 1 seule arete coupee +c - 1 triangle coupe en 2 et 1 quadrangle coupe en 3, +c 1 seule arete coupee +c + if ( optnco.ne.0 .and. bilanc.ge.1 ) then +c + if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 .and. + > nbqud3.eq.0 .and. nbqud4.eq.0 ) .or. + > ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.0 .and. nbqud4.eq.1 ) .or. + > ( nbtrd2.le.2 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.0 .and. nbqud4.eq.0 ) .or. + > ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and. + > nbqud3.le.2 .and. nbqud4.eq.0 ) .or. + > ( nbtrd2.le.1 .and. nbtrd4.eq.0 .and. + > nbqud3.eq.1 .and. nbqud4.eq.0 ) ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTARPE', nompro +#endif + call utarpe ( entite, + > nbquto, nbpeto, + > arequa, facpen, cofape, + > listar ) + iaux = 0 + do 72 , jaux = 1 , 9 + if ( mod(hetare(listar(jaux)),10).ne.0 ) then + iaux = iaux + 1 + endif + 72 continue +c + if ( nbtrd4.eq.0 .and. nbqud4.eq.0 ) then + if ( iaux.eq.1 ) then + bilanc = 0 + endif + elseif ( nbtrd4.eq.1 ) then + if ( iaux.eq.3 ) then + bilanc = 0 + endif + elseif ( nbqud4.eq.1 ) then + if ( iaux.eq.4 ) then + bilanc = 0 + endif + endif +c + endif +c + endif +cgn print *,mess14(langue,1,3), entite, ':',bilanc +c +c 7.3. ==> Bilan avec impression eventuelle +c + if ( bilanc.ne.0 ) then + nbpenc = nbpenc + 1 + if ( optimp.ne.0 ) then + write(ulsort,texte(langue,20)) mess14(langue,1,7), + > entite + write(ulsort,texte(langue,15)) hetpen(entite) + do 731 , iaux = 1 , 2 + letria = facpen(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,2), + > iaux, letria, hettri(letria) + do 7311 , jaux = 1 , 3 + larete = aretri(letria,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 7311 continue + 731 continue + do 732 , iaux = 3 , 5 + lequad = facpen(entite,iaux) + write(ulsort,texte(langue,13)) mess14(langue,2,4), + > iaux-2, lequad, hetqua(lequad) + do 7321 , jaux = 1 , 4 + larete = arequa(lequad,jaux) + write(ulsort,texte(langue,13)) + > ' '//mess14(langue,2,1), + > jaux, larete, hetare(larete) + 7321 continue + 732 continue + endif + endif +c + endif +c + 70 continue +c + if ( nbpenc.ne.0 ) then + codret = 7 +#ifdef _DEBUG_HOMARD_ + if ( optimp.ne.0 ) then +#else + if ( ulsort.ne.0 ) then +#endif + if ( optnco.eq.0 ) then + write(ulsort,texte(langue,11)) + else + write(ulsort,texte(langue,9)) + endif + write(ulsort,texte(langue,14)) mess14(langue,3,7), nbpenc + endif +#ifdef _DEBUG_HOMARD_ + else + write(ulsort,texte(langue,10)) mess14(langue,3,7) +#endif + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c +#ifdef _DEBUG_HOMARD_ + if ( ulsort.ne.0 ) then +#else + if ( optimp.ne.0 ) then +#endif +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcoq2.F b/src/tool/Utilitaire/utcoq2.F new file mode 100644 index 00000000..9be454c3 --- /dev/null +++ b/src/tool/Utilitaire/utcoq2.F @@ -0,0 +1,230 @@ + subroutine utcoq2 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, + > aifj, aifl, ni, + > akfj, akfl, nk, + > saiaj, sajak, sakal, salai, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - decoupage de COnformite d'un Quadrangle +c -- -- - +c en 2 quadrangles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbaret . historique de l'etat des aretes . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . filare . e . nbaret . premiere fille des aretes . +c .a1,..,a4. e . 1 . les numeros d'arete du quadrangle . +c . numdec . s . 1 . numero local de l'arete decoupee . +c . ai . s . 1 . l'arete du quadrangle qui est decoupee . +c .aj,ak,al. s . 1 . les 3 autres aretes dans l'ordre oriente . +c . aifj . s . 1 . fille de ai allant vers saiaj . +c . aifl . s . 1 . fille de ai allant vers salai . +c . ni . s . 1 . milieu de l'arete ai . +c . akfj . s . 1 . fille de ak allant vers sajak . +c . akfl . s . 1 . fille de ak allant vers sakal . +c . nk . s . 1 . milieu de l'arete ak . +c . saiaj . s . 1 . sommet commun aux aretes i et j . +c . sajak . s . 1 . sommet commun aux aretes j et k . +c . sakal . s . 1 . sommet commun aux aretes k et l . +c . salai . s . 1 . sommet commun aux aretes l et i . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c saiaj aifj ai/ni aifl salai +c ._____________________________________________. +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c aj . nq1 .anink nq2 . al +c . . . +c . . . +c . . . +c . . . +c . . . +c . . . +c ._____________________________________________. +c sajak akfj ak/nk akfl sakal +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOQ2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer hetare(*), somare(2,*), filare(*) + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer aifj, aifl, ni + integer akfj, akfl, nk + integer saiaj, sajak, sakal, salai +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer arete(4) + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) ='(''Impossible de trouver l''''arete coupee.''))' +c + texte(2,10) ='(''Cut edge cannot be found.'')' +c + codret = 0 +c +c==== +c 2. recherche du numero local de la premiere arete coupee +c==== +c + arete(1) = a1 + arete(2) = a2 + arete(3) = a3 + arete(4) = a4 +c + do 20 , iaux = 1 , 4 + if ( mod(hetare(arete(iaux)),10).eq.2 ) then + numdec = iaux + goto 21 + endif + 20 continue +c + write (ulsort,texte(langue,10)) + codret = 1 +c + 21 continue +c +c==== +c 3. les numeros globaux des noeuds et des aretes +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> la premiere arete coupee +c + ai = arete(numdec) +c +c 3.2. ==> les autres aretes sont dans le meme ordre de rotation +c + iaux = per1a4(1,numdec) + aj = arete(iaux) +c + iaux = per1a4(1,iaux) + ak = arete(iaux) +c + iaux = per1a4(1,iaux) + al = arete(iaux) +c +c 3.3. ==> les sommets du quadrangle +c + call utsoqu ( somare, ai, aj, ak, al, + > saiaj, sajak, sakal, salai ) +c +c 3.4. ==> le decoupage de l'arete ai +c + iaux = filare(ai) + if ( somare(1,iaux).eq.saiaj ) then + aifj = iaux + aifl = iaux + 1 + else + aifj = iaux + 1 + aifl = iaux + endif +c + ni = somare(2,aifj) +c +c 3.5. ==> le decoupage de l'arete ak +c + iaux = filare(ak) + if ( somare(1,iaux).eq.sajak ) then + akfj = iaux + akfl = iaux + 1 + else + akfj = iaux + 1 + akfl = iaux + endif +c + nk = somare(2,akfj) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcoq3.F b/src/tool/Utilitaire/utcoq3.F new file mode 100644 index 00000000..01d00b31 --- /dev/null +++ b/src/tool/Utilitaire/utcoq3.F @@ -0,0 +1,225 @@ + subroutine utcoq3 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, afij, afil, + > saiaj, sajak, sakal, salai, ni, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - decoupage de COnformite d'un Quadrangle +c -- -- - +c en 3 triangles +c - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbaret . historique de l'etat des aretes . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . filare . e . nbaret . premiere fille des aretes . +c .a1,..,a4. e . 1 . les numeros d'arete du quadrangle . +c . numdec . s . 1 . numero local de l'arete decoupee . +c . ai . s . 1 . l'arete du quadrangle qui est decoupee . +c .aj,ak,al. s . 1 . les 3 autres aretes dans l'ordre oriente . +c . afij . s . 1 . fille de ai allant vers saiaj . +c . afil . s . 1 . fille de ai allant vers salai . +c . saiaj . s . 1 . sommet commun aux aretes i et j . +c . sajak . s . 1 . sommet commun aux aretes j et k . +c . sakal . s . 1 . sommet commun aux aretes k et l . +c . salai . s . 1 . sommet commun aux aretes l et i . +c . ni . s . 1 . milieu de l'arete ai . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c saiaj afij ai/ni afil salai +c ._____________________________________________. +c . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c . nf2 . . nf3 . +c . . . . +c . . . . +c . . . . +c aj . . . . al +c . .anijk anikl. . +c . . . . +c . . . . +c . . . . +c . . . . +c . . nf1 . . +c . . . . +c . . . . +c . . . . +c . . . . +c . . . . +c ._____________________________________________. +c sajak ak sakal +c +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOQ3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer hetare(*), somare(2,*), filare(*) + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer afij, afil + integer saiaj, sajak, sakal, salai + integer ni +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer arete(4) + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) ='(''Impossible de trouver l''''arete coupee.''))' +c + texte(2,10) ='(''Cut edge cannot be found.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. recherche du numero local de l'arete coupee +c==== +c + arete(1) = a1 + arete(2) = a2 + arete(3) = a3 + arete(4) = a4 +c + do 20 , iaux = 1 , 4 + if ( mod(hetare(arete(iaux)),10).eq.2 ) then + numdec = iaux + goto 21 + endif + 20 continue +c + write (ulsort,texte(langue,10)) + codret = 1 +c + 21 continue +cgn write (ulsort,90002) 'numdec', numdec +c +c==== +c 3. les numeros globaux des noeuds et des aretes +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> l'arete coupee +c + ai = arete(numdec) +c +c 3.2. ==> les autres aretes sont dans le meme ordre de rotation +c + iaux = per1a4(1,numdec) + aj = arete(iaux) +c + iaux = per1a4(1,iaux) + ak = arete(iaux) +c + iaux = per1a4(1,iaux) + al = arete(iaux) +c +c 3.3. ==> les sommets du quadrangle +c + call utsoqu ( somare, ai, aj, ak, al, + > saiaj, sajak, sakal, salai ) +c +c 3.4. ==> le decoupage de l'arete ai +c + iaux = filare(ai) + if ( somare(1,iaux).eq.saiaj ) then + afij = iaux + afil = iaux + 1 + else + afij = iaux + 1 + afil = iaux + endif +c + ni = somare(2,afij) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcoq5.F b/src/tool/Utilitaire/utcoq5.F new file mode 100644 index 00000000..d685da56 --- /dev/null +++ b/src/tool/Utilitaire/utcoq5.F @@ -0,0 +1,249 @@ + subroutine utcoq5 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, + > aifj, aifl, ni, + > ajfi, ajfk, nj, + > saiaj, sajak, sakal, salai, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - decoupage de COnformite d'un Quadrangle +c -- -- - +c en 3 quadrangles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hetare . e . nbaret . historique de l'etat des aretes . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . filare . e . nbaret . premiere fille des aretes . +c .a1,..,a4. e . 1 . les numeros d'arete du quadrangle . +c . numdec . s . 1 . numero local de l'arete decoupee . +c . ai . s . 1 . l'arete du quadrangle qui est decoupee . +c .aj,ak,al. s . 1 . les 3 autres aretes dans l'ordre oriente . +c . aifj . s . 1 . fille de ai allant vers saiaj . +c . aifl . s . 1 . fille de ai allant vers salai . +c . ni . s . 1 . milieu de l'arete ai . +c . ajfi . s . 1 . fille de aj allant vers saiaj . +c . ajfk . s . 1 . fille de aj allant vers sajak . +c . nj . s . 1 . milieu de l'arete aj . +c . saiaj . s . 1 . sommet commun aux aretes i et j . +c . sajak . s . 1 . sommet commun aux aretes j et k . +c . sakal . s . 1 . sommet commun aux aretes k et l . +c . salai . s . 1 . sommet commun aux aretes l et i . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c saiaj aifj ai/ni aifl salai +c ._____________________________________________. +c . . . +c . . . +c . . . +c . .anin0 . +c ajfi . nq1 . . +c . . . +c . . . +c . . . +c . anjn0 . . +c aj/nj .----------------------.n0 nq3 . al +c . . . +c . . . +c . . . +c . . . +c ajfk . nq2 . . +c . ankln0 . . +c . . . +c . . . +c . . . +c ._____________________________________________. +c sajak ak sakal +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOQ5' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +c +c 0.3. ==> arguments +c + integer hetare(*), somare(2,*), filare(*) + integer numdec + integer a1, a2, a3, a4 + integer ai, aj, ak, al + integer aifj, aifl, ni + integer ajfi, ajfk, nj + integer saiaj, sajak, sakal, salai +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer arete(4) + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) ='(''Impossible de trouver l''''arete coupee.''))' +c + texte(2,10) ='(''Cut edge cannot be found.'')' +c + codret = 0 +c +c==== +c 2. recherche du numero local de la premiere arete coupee +c==== +c + arete(1) = a1 + arete(2) = a2 + arete(3) = a3 + arete(4) = a4 +cgn write(ulsort,*) a1,hetare(a1) +cgn write(ulsort,*) a2,hetare(a2) +cgn write(ulsort,*) a3,hetare(a3) +cgn write(ulsort,*) a4,hetare(a4) +c + jaux = 0 + kaux = 0 + do 20 , iaux = 1 , 4 + if ( mod(hetare(arete(iaux)),10).eq.2 ) then + if ( jaux.eq.0 ) then + jaux = iaux + else + kaux = iaux + endif + endif + 20 continue +c +cgn write (ulsort,*) jaux, kaux + if ( kaux.eq.0 ) then + write (ulsort,texte(langue,10)) + codret = 1 + elseif ( jaux.eq.1 .and. kaux.eq.4 ) then + numdec = 4 + else + numdec = jaux + endif +c +c==== +c 3. les numeros globaux des noeuds et des aretes +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> la premiere arete coupee +c + ai = arete(numdec) +c +c 3.2. ==> les autres aretes sont dans le meme ordre de rotation +c + iaux = per1a4(1,numdec) + aj = arete(iaux) +c + iaux = per1a4(1,iaux) + ak = arete(iaux) +c + iaux = per1a4(1,iaux) + al = arete(iaux) +c +c 3.3. ==> les sommets du quadrangle +c + call utsoqu ( somare, ai, aj, ak, al, + > saiaj, sajak, sakal, salai ) +c +c 3.4. ==> le decoupage de l'arete ai +c + iaux = filare(ai) + if ( somare(1,iaux).eq.saiaj ) then + aifj = iaux + aifl = iaux + 1 + else + aifj = iaux + 1 + aifl = iaux + endif +c + ni = somare(2,aifj) +c +c 3.5. ==> le decoupage de l'arete aj +c + iaux = filare(aj) + if ( somare(1,iaux).eq.saiaj ) then + ajfi = iaux + ajfk = iaux + 1 + else + ajfi = iaux + 1 + ajfk = iaux + endif +c + nj = somare(2,ajfi) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcorn.F b/src/tool/Utilitaire/utcorn.F new file mode 100644 index 00000000..0bad3c03 --- /dev/null +++ b/src/tool/Utilitaire/utcorn.F @@ -0,0 +1,235 @@ + subroutine utcorn ( lenoeu, lequad, larete, + > coonoe, + > somare, filare, + > cfaare, famare, + > arequa, filqua, + > cfaqua, famqua, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - COntroles - Reprise d'un Noeud +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lenoeu . e . 1 . noeud dont les coordonnees sont a changer . +c . lequad . e . 1 . quadrangle dont lenoeu est centre (si >0) . +c . larete . e . 1 . arete dont lenoeu est centre (si >0) . +c . coonoe . es . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . famare . es . nbarto . famille des aretes . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCORN' ) +c +#include "nblang.h" +#include "cofina.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lenoeu, lequad, larete + integer somare(2,nbarto), filare(nbarto) + integer cfaare(nctfar,nbfare), famare(nbarto) + integer arequa(nbquto,4), filqua(nbquto) + integer cfaqua(nctfqu,nbfqua), famqua(nbquto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer noeud1, noeud2, noeud3, noeud4 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,7) = '(''... Reprise du '',a,i10)' + texte(1,8) = '(''... Au milieu du '',a,i10)' +c + texte(2,7) = '(''... Correction of '',a,i10)' + texte(2,8) = '(''... Center of '',a,i10)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,-1), lenoeu +#endif +c +c==== +c 2. Noeud au milieu d'un quadrangle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Noeud quadrangle ; codret = ', codret +#endif +c + if ( lequad.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad +#endif +c +c 2.1. ==> Retour au milieu +c + call utsoqu ( somare, arequa(lequad,1), arequa(lequad,2), + > arequa(lequad,3), arequa(lequad,4), + > noeud1, noeud2, noeud3, noeud4 ) +c + do 21 , iaux = 1 , sdim + coonoe(lenoeu,iaux) = + > 0.25d0*(coonoe(noeud1,iaux)+coonoe(noeud2,iaux) + > +coonoe(noeud3,iaux)+coonoe(noeud4,iaux)) + 21 continue +c +c 2.2. ==> Le quadrangle ne doit plus etre considere en sf, ni ses fils +c + jaux = cfaqua(cosfin,famqua(lequad)) + famqua(lequad) = jaux + do 22 , iaux = 0 , 3 + jaux = cfaqua(cosfin,famqua(filqua(lequad)+iaux)) + famqua(filqua(lequad)+iaux) = jaux + 22 continue +c + endif +c +c==== +c 3. Noeud au milieu d'une arete +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Noeud arete ; codret = ', codret +#endif +c + if ( larete.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,1), larete +#endif +c +c 3.1. ==> Retour au milieu +c + noeud1 = somare(1,larete) + noeud2 = somare(2,larete) + do 31 , iaux = 1 , sdim + coonoe(lenoeu,iaux) = + > 0.5d0*(coonoe(noeud1,iaux)+coonoe(noeud2,iaux)) + 31 continue +c +c 3.2. ==> L'arete ne doit plus etre consideree en sf ni ses filles +c + jaux = cfaare(cosfin,famare(larete)) + famare(larete) = jaux + do 32 , iaux = 0 , 1 + jaux = cfaare(cosfin,famare(filare(larete)+iaux)) + famare(filare(larete)+iaux) = jaux + 32 continue +c + endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcote.F b/src/tool/Utilitaire/utcote.F new file mode 100644 index 00000000..f452989a --- /dev/null +++ b/src/tool/Utilitaire/utcote.F @@ -0,0 +1,207 @@ + subroutine utcote ( letetr, bilan, + > coonoe, + > somare, + > aretri, + > tritet, cotrte, aretet, + > hettet, filtet, + > ulsort, langue, codret) +c ______________________________________________________________________ +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - COntroles de TEtraedres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . bilan . s . 1 . 0 : tout va bien . +c . . . . 1 : probleme . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . *sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . x : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCOTE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer letetr, bilan + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer hettet(nbteto) + integer filtet(nbteto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nbfils + integer freain, etat +c + double precision prmixt, prmixf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''.. Examen du '',a,i10)' + texte(1,5) = '(''.. Le '',a,i10,'' est actif.'')' +c + texte(2,4) = '(''.. Examination of '',a,'' # '',i10)' + texte(2,5) = '(''.. The '',a,'' # '',i10,'' is active.'')' +c +#include "impr03.h" +c +c==== +c 2. Controle du tetraedre +c Le tetraedre et ses fils doivent avoir la meme orientation, +c sinon c'est que un des noeuds a traverse le bord +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Controle tetraedre ; codret = ', codret +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,3), letetr +#endif +c + etat = mod(hettet(letetr),100) +cgn write (ulsort,90002) 'etat', etat +c + if ( etat.eq.0 ) then +c + codret = 1 +c + else +c + bilan = 0 +c +c 2.1. ==> Produit mixte du tetraedre +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPMTE', nompro +#endif + call utpmte ( letetr, prmixt, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +cgn write(ulsort,*) letetr,prmixt +c +c 2.2. ==> Les fils +c + if ( etat.le.26 ) then + nbfils = 1 + elseif ( etat.le.47 ) then + nbfils = 3 + else + nbfils = 7 + endif +cgn write(ulsort,*) ' ',etat + freain = filtet(letetr) + do 221 , iaux = freain , freain+nbfils + jaux = iaux + call utpmte ( jaux, prmixf, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +cgn write(ulsort,*) ' ',iaux,prmixf + if ( prmixt*prmixf.le.0.d0 ) then + bilan = 1 + goto 29 + endif + 221 continue +c + endif +c + 29 continue +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,5)) mess14(langue,1,3), letetr +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcrhi.F b/src/tool/Utilitaire/utcrhi.F new file mode 100644 index 00000000..c0a6f63c --- /dev/null +++ b/src/tool/Utilitaire/utcrhi.F @@ -0,0 +1,583 @@ + subroutine utcrhi ( nbclas, rclass, iclass, histog, + > nbval, typval, rval, ival, + > titcou, xlow, ulbila, ulxmgr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - CReation d'un HIstogramme +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbclas . e . 1 . nombre de classes a affecter . +c . rclass . e .0:nbclas. limites des classes si reel . +c . iclass . e .0:nbclas. limites des classes si entier . +c . histog . s . nbclas . histogramme resultant . +c . nbval . e . 1 . nombre de valeurs a classer . +c . typval . e . 1 . 1 : valeurs entieres . +c . . . . 2 : valeurs reelles . +c . rval . e . nbval . valeurs reelles a classer . +c . ival . e . nbval . valeurs entieres a classer . +c . titcou . e . char*8 . titre des courbes . +c . xlow . e . 1 . limite basse pour les valeurs . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulxmgr . e . 1 . unite logique pour le fichier xmgrace . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCRHI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbclas, nbval, typval + integer iclass(0:nbclas), histog(nbclas) + integer ival(*) +c + double precision rclass(0:nbclas) + double precision rval(*) + double precision xlow +c + integer ulbila, ulxmgr + integer ulsort, langue, codret +c + character*8 titcou(*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer ivamax, ivamin + integer p10max, p10min, p10dec + integer nrocou +c + real raux, raux1 + real x1, x2, y1, y2 +c + double precision rvamax, rvamin, epsilo, val10 + double precision rvamoy, rvecty +c + logical prem + logical ecart +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) + character*58 mess58(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de classes : '',i8)' + texte(1,5) = '(''Nombre de valeurs a classer : '',i8)' + texte(1,6) = '(''Limite basse pour les valeurs :'',g15.6)' + texte(1,7) = '(''Classe'',i3,'' : '',g25.7)' +c + texte(2,4) = '(''Number of classes : '',i8)' + texte(2,5) = '(''Number of values to sort : '',i8)' + texte(2,6) = '(''Low limit for values :'',g15.6)' + texte(2,7) = '(''Class'',i3,'' : '',g25.7)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbclas + write (ulsort,texte(langue,5)) nbval + write (ulsort,texte(langue,6)) xlow + do 1100 , iaux = 0 , nbclas + write (ulsort,texte(langue,7)) iaux, rclass(iaux) + 1100 continue +#endif +c +c 1234567890123456789012345678901234567890123456789012345678 + mess58(1,1) = + > ' Fonction de repartition ' + mess58(1,2) = + > ' Valeurs * Nombre de mailles ' + mess58(1,3) = + > ' Mini < < Maxi * par classe * cumul ' + mess58(1,4) = + > ' * en % . nombre * en % . nombre ' +c 123458789012345678901234567890123456789012345678901234 +c + mess58(2,1) = + > ' Fonction of repartition ' + mess58(2,2) = + > ' Values * Number of meshes ' + mess58(2,3) = + > ' Mini < < Maxi * per class * total ' + mess58(2,4) = + > ' * in % . number * in % . number ' +c +10200 format( 5x,64('*')) +c +11100 format(5x,'* ',a58,' *') +c +13101 format( + >5x,'* Minimum : ',i11, ' Maximum : ',i15, ' *') +13102 format( + >5x,'* Minimum : ',g12.5,' Maximum : ',g12.5,' *') +13103 format( + >5x,'* Moyenne : ',g12.5,' Ecart-type : ',g12.5,' *') +13203 format( + >5x,'* Mean : ',g12.5,' Std deviation : ',g12.5,' *') +c +21200 format( + > '@map font 0 to "Helvetica", "Helvetica"', + >/,'@map color 1 to (0, 0, 0), "black"', + >/,'@map color 2 to (255, 0, 0), "red"', + >/,'@map color 4 to (0, 0, 255), "blue"') +c +21210 format( + > '#', + >/,'@ title "',4a8,'"', + >/,'@ title font 0', + >/,'@ title size 1.00000', + >/,'@ title color 4') +21220 format( + > '#', + >/,'@with g',i1) +21230 format( + > '@ s0 type XY', + >/,'@ s0 skip 0', + >/,'@ s0 linestyle 1', + >/,'@ s0 linewidth 1', + >/,'@ s0 color 2', + >/,'@ s0 fill 6', + >/,'@ s0 fill color 2') +21240 format( + > '@ world xmin ',g12.5, + >/,'@ xaxis bar color 2', + >/,'@ xaxis bar linestyle 1', + >/,'@ xaxis bar linewidth 1.0', + >/,'@ xaxis label "',a,'"', + >/,'@ xaxis label char size 0.80', + >/,'@ xaxis label font 0', + >/,'@ xaxis label color 4', + >/,'@ xaxis ticklabel font 0', + >/,'@ xaxis ticklabel char size 0.8') +21241 format( + > '@ yaxis bar color 2', + >/,'@ yaxis bar linestyle 1', + >/,'@ yaxis bar linewidth 1.0', + >/,'@ yaxis label "Pourcentage de mailles"', + >/,'@ yaxis label char size 0.80', + >/,'@ yaxis label font 0', + >/,'@ yaxis label color 4', + >/,'@ yaxis ticklabel font 0', + >/,'@ yaxis ticklabel char size 0.8') +21250 format(1x,g13.7,3x,g13.7) +c +21260 format(5x, + >'* ',f8.3,' < ',f8.3,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *') +21261 format(5x, + >'* ',g8.3,' < ',g8.3,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *') +21262 format(5x, + >'*', f9.2,' <', f9.2,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *') +21263 format(5x, + >'*', g9.2,' <', g9.2,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *') +21270 format(5x, + >'* ',f8.3,' < inf. *',f6.2,' .',i10,' * 100.00 .',i10,' *') +21280 format( + > '#', + >/,'@g',i1,' on') +c +c 1.2. ==> variables locales +c + codret = 0 +c + if ( ulxmgr.gt.0 ) then + prem = .true. + elseif ( ulxmgr.lt.0 ) then + prem = .false. + ulxmgr = - ulxmgr + else + codret = 1 + endif +c +c==== +c 2. classement +c=== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. classement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 2.1. ==> preparation du classement +c + do 21 , jaux = 1 , nbclas + histog(jaux) = 0 + 21 continue +c +c 2.2. ==> recherche des extrema et rangement des valeurs en entier +c + if ( typval.eq.1 ) then +c + ivamin = ival(1) + ivamax = ival(1) +c + do 22 , iaux = 1 , nbval +c + ivamin = min ( ivamin , ival(iaux) ) + ivamax = max ( ivamax , ival(iaux) ) +c + do 221 , jaux = 1 , nbclas + if ( ival(iaux).ge.iclass(jaux-1) .and. + > ival(iaux).lt.iclass(jaux) ) then + histog(jaux) = histog(jaux) + 1 + goto 222 + endif + 221 continue +c + 222 continue +c + 22 continue +c + p10min = 0 + p10max = 0 +c +c 2.3. ==> recherche des extrema et rangement des valeurs en reel +c on elargit temporairement les bornes inferieure, rclass(0), +c et superieure, rclass(nbclas), pour etre certain de ne rien +c rater dans le classement. +c + elseif ( typval.eq.2 ) then +c + epsilo = 1.d-5*(rclass(nbclas)-rclass(0)) + rclass(0) = rclass(0) - epsilo + rclass(nbclas) = rclass(nbclas) + epsilo +c + rvamin = rval(1) + rvamax = rval(1) + rvamoy = 0.d0 + rvecty = 0.d0 +c + do 23 , iaux = 1 , nbval +c + rvamin = min ( rvamin , rval(iaux) ) + rvamax = max ( rvamax , rval(iaux) ) + rvamoy = rvamoy + rval(iaux) + rvecty = rvecty + rval(iaux)**2 +c + do 231 , jaux = 1 , nbclas + if ( rval(iaux).ge.rclass(jaux-1) .and. + > rval(iaux).lt.rclass(jaux) ) then + histog(jaux) = histog(jaux) + 1 + goto 232 + endif + 231 continue +c + 232 continue +c + 23 continue +c + rvamoy = rvamoy / dble(nbval) + rvecty = sqrt ( rvecty/ dble(nbval) - rvamoy**2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) 'rvamin', rvamin + write (ulsort,90004) 'rvamax', rvamax + write (ulsort,90004) 'rvamoy', rvamoy + write (ulsort,90004) 'rvecty', rvecty +#endif +c + rclass(0) = rclass(0) + epsilo + rclass(nbclas) = rclass(nbclas) - epsilo +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPD10', nompro +#endif + call utpd10 ( rclass(0), val10, p10min, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90024) 'rclass', 0, rclass(0) + write (ulsort,*) '=> val10 =', val10, ', p10min =', p10min +#endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPD10', nompro +#endif + call utpd10 ( rclass(nbclas), val10, p10max, + > ulsort, langue, codret ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90024) 'rclass', nbclas, rclass(nbclas) + write (ulsort,*) '=> val10 =', val10, ', p10max =', p10max +#endif + endif +c +c 2.4. ==> erreur sinon +c + else +c + codret = 1 +c + endif +c + endif +c +c==== +c 3. Impression sur la sortie standard et sur un fichier +c a exploiter par xmgrace +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Impression ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + nrocou = 0 +c + write (ulbila,10200) + if ( typval.eq.1 ) then + write (ulbila,13101) ivamin, ivamax + p10dec = 0 + else + write (ulbila,13102) dble(rvamin), dble(rvamax) + if ( langue.eq.1 ) then + write (ulbila,13103) dble(rvamoy), dble(rvecty) + else + write (ulbila,13203) dble(rvamoy), dble(rvecty) + endif + if ( p10max.lt.0 .or. p10max.gt.3 ) then + p10dec = p10max-1 + elseif ( p10max.eq.0 .and. p10min.lt.-1 ) then + p10dec = p10min-2 + else + p10dec = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'p10max', p10max, ', p10min', p10min + write (ulsort,90002) '==> p10dec', p10dec +#endif + if ( p10dec.ne.0 ) then + mess58(langue,4)(4:9) = '* 10**' + if ( p10dec.le.-100 ) then + write (mess58(langue,4)(10:13),'(i4)') p10dec + elseif ( p10dec.le.-10 ) then + write (mess58(langue,4)(10:12),'(i3)') p10dec + elseif ( p10dec.le.-1 ) then + write (mess58(langue,4)(10:11),'(i2)') p10dec + elseif ( p10dec.le.9 ) then + write (mess58(langue,4)(10:10),'(i1)') p10dec + elseif ( p10dec.le.99 ) then + write (mess58(langue,4)(10:11),'(i2)') p10dec + else + write (mess58(langue,4)(10:13),'(i4)') p10dec + endif + endif + if ( abs(p10max-p10min).le.3 ) then + ecart = .true. + else + ecart = .false. + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,99001) 'ecart', ecart +#endif + endif + write (ulbila,10200) +c + write (ulbila,11100) mess58(langue,1) + write (ulbila,11100) mess58(langue,2) + write (ulbila,11100) mess58(langue,3) + write (ulbila,11100) mess58(langue,4) + write (ulbila,10200) +c + if ( ulxmgr.ne.ulbila ) then + if ( prem ) then + write (ulxmgr,21200) + write (ulxmgr,21210) (titcou(iaux), iaux = 1 , 4 ) + write (ulxmgr,21220) nrocou + write (ulxmgr,21230) + write (ulxmgr,21240) xlow, titcou(5) + write (ulxmgr,21241) + write (ulxmgr,21280) nrocou + endif + endif +c + if ( typval.eq.1 ) then + x2 = real(iclass(0)) + else + x2 = real(rclass(0)) + endif + if ( ulxmgr.ne.ulbila ) then + write (ulxmgr,21250) x2, 0. + endif + raux1 = x2 +cgn write (ulsort,90004) 'raux1', raux1 +c + iaux= 0 + raux = 100. / real(nbval) + do 31 , jaux = 1 , nbclas + x1 = x2 + y1 = real(histog(jaux)) * raux + if ( typval.eq.1 ) then + x2 = real(iclass(jaux)) + else + x2 = real(rclass(jaux)) + endif + iaux = iaux + histog(jaux) + y2 = real(iaux) * raux + if ( raux1.ge.0. ) then + if ( ecart ) then + write (ulbila,21260) + > x1*10.**(-p10dec), x2*10.**(-p10dec), + > y1, histog(jaux), y2, iaux + else + write (ulbila,21261) + > x1*10.**(-p10dec), x2*10.**(-p10dec), + > y1, histog(jaux), y2, iaux + endif + else + if ( ecart ) then + write (ulbila,21262) + > x1*10.**(-p10dec), x2*10.**(-p10dec), + > y1, histog(jaux), y2, iaux + else + write (ulbila,21263) + > x1*10.**(-p10dec), x2*10.**(-p10dec), + > y1, histog(jaux), y2, iaux + endif + endif + if ( ulxmgr.ne.ulbila ) then + write (ulxmgr,21250) x1, y1 + write (ulxmgr,21250) x2, y1 + endif + 31 continue + if ( ulxmgr.ne.ulbila ) then + write (ulxmgr,21250) x2, 0. + endif +c + if ( iaux.lt.nbval ) then +c + iaux = nbval - iaux + y1 = real(iaux) * raux + write (ulbila,21270) x2*10.**(-p10dec), y1, iaux, nbval +c + endif +c + write (ulbila,10200) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end +ctest program toto +ctest implicit none +ctest integer nbclas, nbval, typval +ctest parameter (nbclas=30) +ctest parameter (nbval=100) +ctestc +ctest integer iclass(0:nbclas), histog(nbclas) +ctest double precision rclass(0:nbclas) +ctest double precision xlow +ctest double precision rval(nbval) +ctest integer ival(nbval) +ctestc +ctest integer ulbila, ulxmgr +ctest integer ulsort, langue, codret +ctest character*8 titcou(10) +ctestc +ctest integer n +ctest rclass(0) = 1.d0 +ctest do 2111 , n = 1 , 10 +ctest rclass(n) = rclass(n-1) + 0.1d0 +ctest 2111 continue +ctest do 2112 , n = 11 , 26 +ctest rclass(n) = rclass(n-1) + 0.5d0 +ctest 2112 continue +ctest rclass(27) = 15.d0 +ctest rclass(28) = 20.d0 +ctest rclass(29) = 50.d0 +ctest rclass(30) = 100.d0 +ctestc +ctest typval = 2 +ctest langue = 1 +ctest ulbila = 41 +ctest ulxmgr = 42 +ctest ulsort = 6 +ctest xlow = 1.d0 +ctest do 12 ,n=1,nbval +ctest rval(n) = 1.d0 + dble(n)/10.d0 +ctest 12 continue +ctest titcou(1) = '12345678' +ctest titcou(2) = '9 ... 16' +ctest titcou(3) = '17 .. 24' +ctest titcou(4) = '25... 32' +ctest titcou(5) = '33 ' +ctest titcou(7) = '49 ' +ctest titcou(8) = '57... 64' +ctest titcou(9) = '65... 72' +ctestc +ctest call utcrhi ( nbclas, rclass, iclass, histog, +ctest > nbval, typval, rval, ival, +ctest > titcou, xlow, ulbila, ulxmgr, +ctest > ulsort, langue, codret ) +ctestc +ctest end diff --git a/src/tool/Utilitaire/utcrpg.F b/src/tool/Utilitaire/utcrpg.F new file mode 100644 index 00000000..8b4bc433 --- /dev/null +++ b/src/tool/Utilitaire/utcrpg.F @@ -0,0 +1,281 @@ + subroutine utcrpg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, carsup, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - CReation d'une localisation des Points de Gauss +c - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . oblopg . s . char8 . nom de l'objet points de Gauss . +c . nolopg . s . char64 . nom de la localisation cree . +c . typgeo . e . 1 . type geometrique au sens MED . +c . ngauss . e . 1 . nombre de points de Gauss . +c . dimcpg . e . 1 . dimension des coordonnees des pts de Gauss . +c . carsup . e . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par element . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCRPG' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmreel.h" +#ifdef _DEBUG_HOMARD_ +#include "indefi.h" +#endif +#include "indefs.h" +c +c 0.3. ==> arguments +c + integer typgeo, ngauss, dimcpg, carsup +c + character*8 oblopg + character*64 nolopg +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer adcono, adcopg, adpopg +c + integer nbmess + parameter ( nbmess = 100 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Creation d''''une localisation de points de Gauss'')' + texte(1,5) = '(''Objet GM de la localisation : '',a)' + texte(1,6) = '(''Nom de la localisation : '',a)' + texte(1,10) = '(''On ne sait pas faire aujourd''''hui.'')' +c + texte(2,4) = '(''Creation of a localization for Gauss points'')' + texte(2,5) = '(''GM object for localization : '',a)' + texte(2,6) = '(''Name for localization : '',a)' + texte(2,10) = '(''Cannot be constructed today.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup +#endif +c +c==== +c 2. creation +c==== +c +c 2.1. ==> creation du nom de la localisation +c + if ( codret.eq.0 ) then +c + if ( carsup.eq.1 ) then +c + nolopg = blan64 + if ( typgeo.eq.edtri3 ) then + nolopg(1:32) = 'TRIA3___ELNO____________________' + elseif ( typgeo.eq.edtri6 ) then + nolopg(1:32) = 'TRIA6___ELNO____________________' + else + codret = -1 + endif +c + else +c + codret = -1 +c + endif +c + endif +c +c 2.2. ==> allocation de la localisation +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPG', nompro +#endif +c + call utalpg ( oblopg, + > nolopg, typgeo, ngauss, dimcpg, + > adcono, adcopg, adpopg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.iindef ) then +#else + if ( codret.ne.0 ) then +#endif + write (ulsort,texte(langue,5)) oblopg + if ( oblopg.ne.sindef ) then + call gmprsx (nompro, oblopg ) + call gmprsx (nompro, oblopg//'.NomLocPG' ) + endif + endif +c + endif +c +c 2.3. ==> Les valeurs +c + if ( codret.eq.0 ) then +c +c 2.3.1. ==> Aux noeuds par element +c + if ( carsup.eq.1 ) then +c +c 2.3.1.1. ==> Le triangle a 3 noeuds +c + if ( typgeo.eq.edtri3 ) then + rmem(adcono ) = 0.0d0 + rmem(adcono+ 1) = 0.0d0 + rmem(adcono+ 2) = 1.0d0 + rmem(adcono+ 3) = 0.0d0 + rmem(adcono+ 4) = 0.0d0 + rmem(adcono+ 5) = 1.0d0 + jaux = 2*ngauss-1 + do 23111 , iaux = 0 , jaux + rmem(adcopg+iaux) = rmem(adcono+iaux) +23111 continue + jaux = ngauss-1 + do 23112 , iaux = 0 , jaux + rmem(adpopg+iaux) = 1.d0 +23112 continue +c +c 2.3.1.2. ==> Le triangle a 6 noeuds +c + elseif ( typgeo.eq.edtri6 ) then + rmem(adcono ) = 0.0d0 + rmem(adcono+ 1) = 0.0d0 + rmem(adcono+ 2) = 1.0d0 + rmem(adcono+ 3) = 0.0d0 + rmem(adcono+ 4) = 0.0d0 + rmem(adcono+ 5) = 1.0d0 + rmem(adcono+ 6) = 0.5d0 + rmem(adcono+ 7) = 0.0d0 + rmem(adcono+ 8) = 0.5d0 + rmem(adcono+ 9) = 0.5d0 + rmem(adcono+10) = 0.0d0 + rmem(adcono+11) = 0.5d0 + jaux = 2*ngauss-1 + do 23121 , iaux = 0 , jaux + rmem(adcopg+iaux) = rmem(adcono+iaux) +23121 continue + jaux = ngauss-1 + do 23122 , iaux = 0 , jaux + rmem(adpopg+iaux) = 1.d0 +23122 continue +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) oblopg + if ( oblopg.ne.sindef ) then + call gmprsx (nompro, oblopg//'.CoorNoeu' ) + call gmprsx (nompro, oblopg//'.CoorPtGa' ) + call gmprsx (nompro, oblopg//'.PoidPtGa' ) + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nolopg + iaux = mod(typgeo,100) + jaux = (typgeo-iaux) / 100 + call utimpg ( 2, ngauss, iaux, jaux, + > rmem(adcono), rmem(adcopg), rmem(1), + > ulsort, langue, codret ) +#endif +c + endif +c +c==== +c 3. la fin +c==== + + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) + if ( codret.lt.0 ) then + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,texte(langue,11+codret)) + codret = abs(codret) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcte1.F b/src/tool/Utilitaire/utcte1.F new file mode 100644 index 00000000..71d2c648 --- /dev/null +++ b/src/tool/Utilitaire/utcte1.F @@ -0,0 +1,243 @@ + subroutine utcte1 ( ntorig, typnom, option, + > ntconv, adconv, nbconv, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Conversion de Tableau Entier - action 1 +c -- - - - - +c +c On retourne un tableau entier qui contient : +c . soit 0 si le critere n'est pas satisfait, +c . soit le rang correspondant si le critere est satisfait +c . si abs(option) = 1 : on retient les valeurs non nulles +c . si abs(option) = 2 : on retient les valeurs strictement positives +c . si abs(option) = 3 : on retient les valeurs strictement negatives +c . si option > 0 : ce rang est celui dans le tableau initial +c . si option < 0 : ce rang est le numero d'apparition de la valeur +c +c Exemples : tableau d'origine : ( 0, 13, 0, -1, 4, -3, 0, 1 ) +c +c option 1 : filtre les valeurs non nulles, selon le rangement initial +c tableau converti : ( 2, 4, 5, 6, 8, 0, 0, 0) +c option -1 : filtre les valeurs non nulles, selon l'ordre d'apparition +c tableau converti : ( 0, 1, 0, 2, 3, 4, 0, 5) +c option 2 : filtre les valeurs > 0, selon le rangement initial +c tableau converti : ( 2, 5, 8, 0, 0, 0, 0, 0) +c option -2 : filtre les valeurs > 0, selon l'ordre d'apparition +c tableau converti : ( 0, 1, 0, 0, 2, 0, 0, 3) +c option 3 : filtre les valeurs < 0, selon le rangement initial +c tableau converti : ( 4, 6, 0, 0, 0, 0, 0, 0) +c option -3 : filtre les valeurs < 0, selon l'ordre d'apparition +c tableau converti : ( 0, 0, 0, 1, 0, 2, 0, 0) +c +c remarque : l'action elle-meme est faite dans utcte3 +c ici, on traite les allocations de tableau +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ntorig . e . * . objet contenant le tableau a convertir . +c . typnom . e . 1 . 0 : le nom du tableau converti est a creer . +c . . . . automatiquement . +c . . . . 1 : le nom est impose a l'appel . +c . option . e . 1 . option de la conversion . +c . . . . abs(option) = 1 : les valeurs non nulles . +c . . . . abs(option) = 2 : les valeurs > 0 . +c . . . . abs(option) = 3 : les valeurs < 0 . +c . . . . option > 0 : rang dans le tableau initial . +c . . . . option < 0 : numero d'apparition . +c . ntconv . es . * . objet contenant le tableau converti . +c . adconv . s . 1 . adresse du tableau converti . +c . nbconv . s . 1 . nombre de valeurs filtrees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . -3 : probleme sur le tableau a convertir . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCTE1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*(*) ntorig, ntconv +c + integer typnom, option + integer adconv + integer nbconv +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer adorig, nborig + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Conversion du tableau entier : '',a)' + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande de type de nom :'',i8)' + texte(1,6) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,7) = '(''Probleme sur le tableau original.'')' + texte(1,8) = '(''Probleme pour allouer le tableau converti.'')' +c + texte(2,10) = '(''Conversion of integer array : '',a)' + texte(2,4) = '(''Option :'',i4)' + texte(2,5) = '(''Bad request for the name :'',i8)' + texte(2,6) = '(''Bad request for the option :'',i8)' + texte(2,7) = '(''Problem with the origin array.'')' + texte(2,8) = '(''Problem while allocating object '')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) ntorig + write (ulsort,texte(langue,4)) option +#endif +c +c==== +c 2. prealables +c==== +c +c 2.1. ==> caracteristiques du tableau a convertir +c + call gmadoj ( ntorig, adorig, nborig, codret ) +c + if ( codret.ne.0 ) then + codret = -3 + endif +c +c 2.2. ==> allocation du tableau converti +c + if ( codret.eq.0 ) then +c + if ( typnom.eq.0 ) then +c + call gmalot ( ntconv, 'entier ', nborig, adconv, codret ) + codret = abs(codret) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( ntconv, 'entier ', nborig, adconv, codret ) + codret = abs(codret) +c + else +c + codret = -1 +c + endif +c + endif +c +c==== +c 3. conversion +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,15) + call gmprot (nompro, ntorig, 1, 15 ) + if ( nborig.gt.15 ) then + call gmprot (nompro, ntorig, nborig-iaux+2, nborig ) + endif +#endif +c + call utcte3 ( option, nborig, imem(adorig), + > nbconv, imem(adconv), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,15) + call gmprot (nompro, ntconv, 1, 15 ) + if ( nborig.gt.15 ) then + call gmprot (nompro, ntconv, nborig-iaux+2, nborig ) + endif +#endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) ntorig + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,5)) typnom + elseif ( codret.eq.-2 ) then + write (ulsort,texte(langue,6)) option + elseif ( codret.eq.-3 ) then + write (ulsort,texte(langue,7)) + else + write (ulsort,texte(langue,8)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utcte2.F b/src/tool/Utilitaire/utcte2.F new file mode 100644 index 00000000..2504198b --- /dev/null +++ b/src/tool/Utilitaire/utcte2.F @@ -0,0 +1,269 @@ + subroutine utcte2 ( ntorig, typnom, option, + > ntconv, adconv, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Conversion de Tableau Entier - action 2 +c -- - - - - +c +c On retourne un tableau entier qui contient : +c . soit 0 si le critere n'est pas satisfait, +c . soit le rang correspondant si le critere est satisfait +c . si option = 1 : on retient les valeurs non nulles +c . si option = 2 : on retient les valeurs strictement positives +c . si option = 3 : on retient les valeurs strictement negatives +c +c Exemples : tableau d'origine : ( 0, 13, 0, -1, 4, -3, 0, 1 ) +c +c option 1 : ordonne les valeurs non nulles +c tableau converti : ( 0, 5, 0, 2, 4, 1, 0, 3) +c option 2 : ordonne les valeurs > 0 +c tableau converti : ( 0, 3, 0, 0, 2, 0, 0, 1) +c option 3 : ordonne les valeurs < 0 +c tableau converti : ( 0, 0, 0, 2, 0, 1, 0, 0) +c +c remarque : l'action elle-meme est faite dans utcte4 +c ici, on traite les allocations de tableau +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ntorig . e . * . objet contenant le tableau a convertir . +c . typnom . e . 1 . 0 : le nom du tableau converti est a creer . +c . . . . automatiquement . +c . . . . 1 : le nom est impose a l'appel . +c . option . e . 1 . option de la conversion . +c . . . . option = 1 : les valeurs non nulles . +c . . . . option = 2 : les valeurs > 0 . +c . . . . option = 3 : les valeurs < 0 . +c . ntconv . es . * . objet contenant le tableau converti . +c . adconv . s . 1 . adresse du tableau converti . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . -3 : probleme sur le tableau a convertir . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCTE2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*(*) ntorig, ntconv +c + integer typnom, option + integer adconv +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2 + integer codre0 + integer iaux + integer adtra1, adtra2 + integer adorig, nborig +c + character*8 ntrav1, ntrav2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Conversion du tableau entier : '',a)' + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande de type de nom :'',i8)' + texte(1,6) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,7) = '(''Probleme sur le tableau original.'')' + texte(1,8) = '(''Probleme pour allouer le tableau converti.'')' +c + texte(2,10) = '(''Conversion of integer array : '',a)' + texte(2,4) = '(''Option :'',i4)' + texte(2,5) = '(''Bad request for the name :'',i8)' + texte(2,6) = '(''Bad request for the option :'',i8)' + texte(2,7) = '(''Problem with the origin array.'')' + texte(2,8) = '(''Problem while allocating object '')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) ntorig + write (ulsort,texte(langue,4)) option +#endif +c +c==== +c 2. prealables +c==== +c +c 2.1. ==> caracteristiques du tableau a convertir +c + call gmadoj ( ntorig, adorig, nborig, codret ) +c + if ( codret.ne.0 ) then + codret = -3 + endif +c +c 2.2. ==> allocation du tableau converti +c + if ( codret.eq.0 ) then +c + if ( typnom.eq.0 ) then +c + call gmalot ( ntconv, 'entier ', nborig, adconv, codret ) + codret = abs(codret) +c + elseif ( typnom.eq.1 ) then +c + call gmaloj ( ntconv, 'entier ', nborig, adconv, codret ) + codret = abs(codret) +c + else +c + codret = -1 +c + endif +c + endif +c +c 2.3. ==> tableaux de travail +c + if ( codret.eq.0 ) then +c + call gmalot ( ntrav1, 'entier ', nborig, adtra1, codre1 ) + call gmalot ( ntrav2, 'entier ', nborig, adtra2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 3. conversion +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,25) + call gmprot (nompro, ntorig, 1, iaux ) + if ( nborig.gt.25 ) then + call gmprot (nompro, ntorig, nborig-24, nborig ) + endif +#endif +c + iaux = nborig +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCTE4', nompro +#endif + call utcte4 ( option, iaux, imem(adorig), + > imem(adconv), + > imem(adtra1), imem(adtra2), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,25) + call gmprot (nompro, ntconv, 1, iaux ) + if ( nborig.gt.25 ) then + call gmprot (nompro, ntconv, nborig-24, nborig ) + endif +#endif +c + endif +c +c==== +c 4. menage +c==== +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1, codre1 ) + call gmlboj ( ntrav2, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) ntorig + if ( codret.eq.-1 ) then + write (ulsort,texte(langue,5)) typnom + elseif ( codret.eq.-2 ) then + write (ulsort,texte(langue,6)) option + elseif ( codret.eq.-3 ) then + write (ulsort,texte(langue,7)) + else + write (ulsort,texte(langue,8)) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utcte3.F b/src/tool/Utilitaire/utcte3.F new file mode 100644 index 00000000..cdb6fc63 --- /dev/null +++ b/src/tool/Utilitaire/utcte3.F @@ -0,0 +1,257 @@ + subroutine utcte3 ( option, nborig, tborig, + > nbconv, tbconv, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Conversion de Tableau Entier - action 3 +c -- - - - - +c +c On retourne un tableau entier qui contient : +c . soit 0 si le critere n'est pas satisfait, +c . soit le rang correspondant si le critere est satisfait +c . si abs(option) = 1 : on retient les valeurs non nulles +c . si abs(option) = 2 : on retient les valeurs strictement positives +c . si abs(option) = 3 : on retient les valeurs strictement negatives +c . si option > 0 : ce rang est celui dans le tableau initial +c . si option < 0 : ce rang est le numero d'apparition de la valeur +c +c Exemples : tableau d'origine : ( 0, 13, 0, -1, 4, -3, 0, 1 ) +c +c option 1 : filtre les valeurs non nulles, selon le rangement initial +c tableau converti : ( 2, 4, 5, 6, 8, 0, 0, 0) +c option -1 : filtre les valeurs non nulles, selon l'ordre d'apparition +c tableau converti : ( 0, 1, 0, 2, 3, 4, 0, 5) +c option 2 : filtre les valeurs > 0, selon le rangement initial +c tableau converti : ( 2, 5, 8, 0, 0, 0, 0, 0) +c option -2 : filtre les valeurs > 0, selon l'ordre d'apparition +c tableau converti : ( 0, 1, 0, 0, 2, 0, 0, 3) +c option 3 : filtre les valeurs < 0, selon le rangement initial +c tableau converti : ( 4, 6, 0, 0, 0, 0, 0, 0) +c option -3 : filtre les valeurs < 0, selon l'ordre d'apparition +c tableau converti : ( 0, 0, 0, 1, 0, 2, 0, 0) +c +c remarque : l'action elle-meme est faite ici +c on peut enrober ce traitement par utcte1, pour gerer +c des allocations de tableau +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de la conversion . +c . . . . abs(option) = 1 : les valeurs non nulles . +c . . . . abs(option) = 2 : les valeurs > 0 . +c . . . . abs(option) = 3 : les valeurs < 0 . +c . . . . option > 0 : rang dans le tableau initial . +c . . . . option < 0 : numero d'apparition . +c . nborig . e . 1 . nombre de valeurs dasn le tableau original . +c . tborig . e . nborig . tableau original a convertir . +c . tbconv . s . nborig . tableau converti . +c . nbconv . s . 1 . nombre de valeurs filtrees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . -3 : probleme sur le tableau a convertir . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCTE3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option + integer nborig, nbconv + integer tborig(nborig), tbconv(nborig) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +#ifdef _DEBUG_HOMARD_ + integer jaux +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,6) = '(''Tableau '',a,'', de'',i8,'' a'',i8,'' : '',10i8)' + texte(1,7) = '(''Nombre de valeurs filtrees : '',i8)' +c + texte(2,4) = '(''Option :'',i4)' + texte(2,5) = '(''Bad request for the option :'',i8)' + texte(2,6) = '(a,'' array, '',a,'' : '',10i8)' + texte(2,7) = '(''Number of filtered values : '',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) option +#endif +c + codret = 0 +c +c==== +c 2. conversion +c==== +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'initial', 1, iaux, + > (tborig(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'initial', nborig-iaux+2,nborig, + > (tborig(iaux),iaux=nborig-iaux+2,nborig) + endif +#endif +c + nbconv = 0 +c +c 2.0. ==> mise a zero par defaut +c + do 20 , iaux = 1 , nborig + tbconv(iaux) = 0 + 20 continue +c +c 2.1. ==> on considere toutes les valeurs non nulles +c + if ( abs(option).eq.1 ) then +c + do 21 , iaux = 1 , nborig +c + if ( tborig(iaux).ne.0 ) then + nbconv = nbconv + 1 + if ( option.gt.0 ) then + tbconv(nbconv) = iaux + else + tbconv(iaux) = nbconv + endif + endif +c + 21 continue +c +c 2.2. ==> on considere toutes les valeurs non nulles et positives +c + elseif ( abs(option).eq.2 ) then +c + do 22 , iaux = 1 , nborig +c + if ( tborig(iaux).gt.0 ) then + nbconv = nbconv + 1 + if ( option.gt.0 ) then + tbconv(nbconv) = iaux + else + tbconv(iaux) = nbconv + endif + endif +c + 22 continue +c +c 2.3. ==> on considere toutes les valeurs non nulles et positives +c + elseif ( abs(option).eq.3 ) then +c + do 23 , iaux = 1 , nborig +c + if ( tborig(iaux).lt.0 ) then + nbconv = nbconv + 1 + if ( option.gt.0 ) then + tbconv(nbconv) = iaux + else + tbconv(iaux) = nbconv + endif + endif +c + 23 continue +c +c 2.4. ==> erreur +c + else +c + codret = -2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbconv + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'final ', 1, iaux, + > (tbconv(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'final ', nborig-iaux+2,nborig, + > (tbconv(iaux),iaux=nborig-iaux+2,nborig) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,5)) option +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcte4.F b/src/tool/Utilitaire/utcte4.F new file mode 100644 index 00000000..112aab84 --- /dev/null +++ b/src/tool/Utilitaire/utcte4.F @@ -0,0 +1,312 @@ + subroutine utcte4 ( option, nborig, tborig, + > tbconv, + > tbaux1, classt, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Conversion de Tableau Entier - action 4 +c -- - - - - +c +c On retourne un tableau entier qui contient : +c . soit 0 si le critere n'est pas satisfait, +c . soit le rang correspondant si le critere est satisfait +c . si option = 1 : on retient les valeurs non nulles +c . si option = 2 : on retient les valeurs strictement positives +c . si option = 3 : on retient les valeurs strictement negatives +c +c Exemples : tableau d'origine : ( 0, 13, 0, -1, 4, -3, 0, 1 ) +c +c option 1 : ordonne les valeurs non nulles +c tableau converti : ( 0, 5, 0, 2, 4, 1, 0, 3) +c option 2 : ordonne les valeurs > 0 +c tableau converti : ( 0, 3, 0, 0, 2, 0, 0, 1) +c option 3 : ordonne les valeurs < 0 +c tableau converti : ( 0, 0, 0, 2, 0, 1, 0, 0) +c +c remarque : l'action elle-meme est faite ici +c on peut enrober ce traitement par utcte2, pour gerer +c des allocations de tableau +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de la conversion . +c . . . . option = 1 : les valeurs non nulles . +c . . . . option = 2 : les valeurs > 0 . +c . . . . option = 3 : les valeurs < 0 . +c . . . . option > 0 : rang dans le tableau initial . +c . . . . option < 0 : numero d'apparition . +c . nborig . e . 1 . nombre de valeurs dasn le tableau original . +c . tborig . e . nborig . tableau original a convertir . +c . tbconv . s . nborig . tableau converti . +c . tbaux1 . aux . nborig . tableau auxiliaire 1 . +c . classt . aux . nborig . tableau auxiliaire 2 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . -3 : probleme sur le tableau a convertir . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCTE4' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option + integer nborig + integer tborig(nborig), tbconv(nborig) + integer tbaux1(nborig), classt(nborig) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer vmin, vmax + integer nbvalm, nbvalp +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,6) = + >'(''Tableau '',a,'', de'',i13,'' a'',i13,'' : '',5i13,/,50x,5i13)' + texte(1,7) = '(''Nombre de valeurs '',a,'' : '',i13)' + texte(1,8) = '(''Valeur '',a,'' : '',i13)' +c + texte(2,4) = '(''Option :'',i4)' + texte(2,5) = '(''Bad request for the option :'',i8)' + texte(2,6) = + >'(''Array '',a,'', from'',i13,'' to'',i13,'' :'',5i13,/,49x,5i13)' + texte(2,7) = '(''Number of values '',a,'' : '',i13)' + texte(2,8) = '(''Value '',a,'' : '',i13)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) option +#endif +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'initial', 1, iaux, + > (tborig(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'initial', nborig-iaux+1,nborig, + > (tborig(iaux),iaux=nborig-iaux+1,nborig) + endif +#endif +c +c==== +c 2. creation du tableau epure +c==== +c + nbvalm = 0 + nbvalp = 0 +c +c 2.0. ==> mise a zero par defaut +c + do 20 , iaux = 1 , nborig + tbaux1(iaux) = 0 + 20 continue +c +c 2.1. ==> on considere toutes les valeurs non nulles +c + if ( option.eq.1 ) then +c + do 21 , iaux = 1 , nborig +c + if ( tborig(iaux).lt.0 ) then + nbvalm = nbvalm + 1 + tbaux1(iaux) = tborig(iaux) + elseif ( tborig(iaux).gt.0 ) then + nbvalp = nbvalp + 1 + tbaux1(iaux) = tborig(iaux) + endif +c + 21 continue +c +c 2.2. ==> on considere toutes les valeurs non nulles et positives +c + elseif ( option.eq.2 ) then +c + do 22 , iaux = 1 , nborig +c + if ( tborig(iaux).gt.0 ) then + nbvalp = nbvalp + 1 + tbaux1(iaux) = tborig(iaux) + endif +c + 22 continue +c +c 2.3. ==> on considere toutes les valeurs non nulles et positives +c + elseif ( option.eq.3 ) then +c + do 23 , iaux = 1 , nborig +c + if ( tborig(iaux).lt.0 ) then + nbvalm = nbvalm + 1 + tbaux1(iaux) = tborig(iaux) + endif +c + 23 continue +c +c 2.4. ==> erreur +c + else +c + codret = -2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( option.eq.1 .or. option.eq.3 ) then + write (ulsort,texte(langue,7)) '< 0', nbvalm + endif + if ( option.eq.1 .or. option.eq.2 ) then + write (ulsort,texte(langue,7)) '> 0', nbvalp + endif + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'filtre ', 1, iaux, + > (tbaux1(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'filtre ', + > nborig-iaux+1, nborig, + > (tbaux1(iaux),iaux=nborig-iaux+1,nborig) + endif +#endif +c +c==== +c 3. tri du tableau epure +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTRII', nompro +#endif + call uttrii ( classt, vmin, vmax, + > nborig, tbaux1, + > ulsort, langue, codret) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) 'mini', vmin + write (ulsort,texte(langue,8)) 'maxi', vmax + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'classt ', 1, iaux, + > (classt(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'classt ', nborig-iaux+1,nborig, + > (classt(jaux),jaux=nborig-iaux+1,nborig) + endif +#endif +c + endif +c +c==== +c 4. rangement final +c==== +c + if ( codret.eq.0 ) then +c + do 40 , iaux = 1 , nborig + tbconv(iaux) = 0 + 40 continue +c + do 41 , iaux = 1 , nbvalm + tbconv(classt(iaux)) = iaux + 41 continue +c + jaux = nborig - nbvalp + 1 + kaux = nbvalm + 1 - jaux + do 42 , iaux = jaux , nborig + tbconv(classt(iaux)) = iaux + kaux + 42 continue +c +#ifdef _DEBUG_HOMARD_ + iaux = min(nborig,10) + write (ulsort,texte(langue,6)) 'tbconv ', 1, iaux, + > (tbconv(jaux),jaux=1,iaux) + if ( nborig.gt.10 ) then + write (ulsort,texte(langue,6)) 'tbconv ', nborig-iaux+1,nborig, + > (tbconv(jaux),jaux=nborig-iaux+1,nborig) + endif +#endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,5)) option +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utcvne.F b/src/tool/Utilitaire/utcvne.F new file mode 100644 index 00000000..1ec4f66f --- /dev/null +++ b/src/tool/Utilitaire/utcvne.F @@ -0,0 +1,148 @@ + subroutine utcvne ( nretap, nrsset, textet, lgtext, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ConVertit le Numero d'Etape +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nretap . e . 1 . numero d'etape en entier . +c . nrsset . e . 1 . numero de sous-etape en entier . +c . textet . s .char*(*). textet : nretap.nrsset. . +c . lgtext . s . 1 . longueur du textet . +c . codret . s . 1 . 0 : pas de probleme . +c . . . . 1 : conversion impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTCVNE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nretap, nrsset, lgtext + integer codret +c + character*(*) textet +c +c 0.4. ==> variables locales +c + integer iaux, lgtx00 + integer ulsort, langue +c + character*3 c3aux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr01.h" +c +c==== +c 1. decodage +c==== +c + call gusost ( ulsort ) + langue = 1 +c +c 1.1. ==> filtrage initial +c s'il est negatif, c'est une erreur +c + if ( nretap.le.0 ) then + codret = 1 + endif +c + lgtext = 0 + lgtx00 = len(textet) +c +c 1.2. ==> conversion en entier +c + if ( codret.eq.0 ) then +c + call utench ( nretap, 'g', iaux, c3aux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + lgtext = iaux+1 + textet (1:lgtext) = c3aux(1:iaux)//'.' +c + endif +c +c 1.3. ==> numero de sous-etape +c s'il est negatif, on ne mentionne rien +c + if ( nrsset.ge.0 ) then +c + if ( codret.eq.0 ) then +c + call utench ( nrsset, 'g', iaux, c3aux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + textet (lgtext+1:lgtext+iaux+1) = c3aux(1:iaux)//'.' + lgtext = lgtext+iaux+1 +c + endif +c + endif +c +c==== +c 2. bilan +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + textet = ' ' + lgtext = 1 +c + endif +c + do 21 , iaux = lgtext+1 , lgtx00 + textet(iaux:iaux) = ' ' + 21 continue +c + end diff --git a/src/tool/Utilitaire/utdhcl.F b/src/tool/Utilitaire/utdhcl.F new file mode 100644 index 00000000..ba5b64df --- /dev/null +++ b/src/tool/Utilitaire/utdhcl.F @@ -0,0 +1,140 @@ + subroutine utdhcl ( nummoi, numjou, numheu, nummin, numsec, + > numann, datheu, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure d'une forme compacte en une forme longue +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numjou . s . 1 . numero du jour . +c . numheu . s . 1 . numero de l'heure . +c . nummin . s . 1 . numero de la minute . +c . numsec . s . 1 . numero de la seconde . +c . numann . e . 1 . numero de l'annee . +c . datheu . e . 1 . nombre de secondes depuis le debut de l'an . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu + integer numann + integer nummoi, numjou, numheu, nummin, numsec + integer codret +c +c 0.4. ==> variables locales +c + integer nbjour + integer iaux, jaux, naux +c + integer lonmoi (12) +c +c==== +c 1. initialisation +c==== +c + codret = 0 +c + lonmoi (1) = 31 + if ( mod(numann,4).eq.0 ) then + lonmoi (2) = 29 + else + lonmoi (2) = 28 + endif + lonmoi (3) = 31 + lonmoi (4) = 30 + lonmoi (5) = 31 + lonmoi (6) = 30 + lonmoi (7) = 31 + lonmoi (8) = 31 + lonmoi (9) = 30 + lonmoi (10) = 31 + lonmoi (11) = 30 + lonmoi (12) = 31 +c +c==== +c 2. mise en forme +c==== +c +c 2.1. ==> cumul du nombre de jours pleins passes depuis le debut +c de l'annee, puis du nombre d'heures pleines depuis +c le debut du jour, etc +c + iaux = mod(datheu,86400) + nbjour = (datheu-iaux)/86400 + 1 +c + if ( iaux.ne.0 ) then +c + jaux = iaux + iaux = mod(jaux,3600) + numheu = (jaux-iaux)/3600 +c + jaux = iaux + iaux = mod(jaux,60) + nummin = (jaux-iaux)/60 +c + numsec = iaux +c + else +c + numheu = 0 + nummin = 0 + numsec = 0 +c + endif +c +c 2.2. ==> decodage du numero du jour +c + nummoi = 1 + numjou = 1 +c + naux = 0 + do 22 iaux = 1 , 12 + naux = naux + lonmoi(iaux) + if ( naux.ge.nbjour ) then + nummoi = iaux + numjou = nbjour - naux + lonmoi(iaux) + goto 23 + endif + 22 continue +c + if ( numheu .eq. 0 ) then + numann = numann + 1 + else + codret = 1 + endif +c + 23 continue +c + end diff --git a/src/tool/Utilitaire/utdhco.F b/src/tool/Utilitaire/utdhco.F new file mode 100644 index 00000000..a12b41cc --- /dev/null +++ b/src/tool/Utilitaire/utdhco.F @@ -0,0 +1,67 @@ + subroutine utdhco ( numann, datheu ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c donne la date et l'heure sous forme courte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numann . s . 1 . numero de l'annee . +c . datheu . s . 1 . nombre de seconde depuis le debut de l'an . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer numann, datheu +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numjos + integer numheu, nummin, numsec + integer codret +c +c==== +c 1. acquisition de la date +c==== +c + call dmjohe ( numann, nummoi, numjou, numjos, + > numheu, nummin, numsec ) +c +c==== +c 2. mise en forme courte +c==== +c + call utdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c + end diff --git a/src/tool/Utilitaire/utdhcu.F b/src/tool/Utilitaire/utdhcu.F new file mode 100644 index 00000000..88816795 --- /dev/null +++ b/src/tool/Utilitaire/utdhcu.F @@ -0,0 +1,136 @@ + subroutine utdhcu ( dateus, heurus, + > datheu, numann, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure d'une forme compacte en une forme US +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dateus . s . ch9 . date au format americain 'dd-mon-yy' . +c . datheu . e . 1 . nombre de secondes depuis le debut de l'an . +c . numann . e . 1 . numero de l'annee (complet) . +c . heurus . s . ch8 . heure au format americain 'hh:mm:ss' . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu, numann + integer codret +c + character*9 dateus + character*8 heurus +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numheu, nummin, numsec +c + character*3 tabmon (12) +c +c==== +c 1. les constantes +c==== +c + tabmon (1) = 'Jan' + tabmon (2) = 'Feb' + tabmon (3) = 'Mar' + tabmon (4) = 'Apr' + tabmon (5) = 'May' + tabmon (6) = 'Jun' + tabmon (7) = 'Jul' + tabmon (8) = 'Aug' + tabmon (9) = 'Sep' + tabmon (10) = 'Oct' + tabmon (11) = 'Nov' + tabmon (12) = 'Dec' +c +c==== +c 2. appel du programme generique +c==== +c + if ( codret.eq.0 ) then +c + call utdhcl ( nummoi, numjou, numheu, nummin, numsec, + > numann, datheu, + > codret ) +c + endif +c +c==== +c 3. mise en forme +c==== +c +c 3.1. ==> initialisation +c + dateus = '01-Jan-00' + heurus = '00:00:00' +c +c 3.2. ==> date +c + if ( numjou.le.9 .and. numjou.gt.1 ) then + write ( dateus (2:2),'(i1)' ) numjou + else if ( numjou.gt.9 .and. numjou.le.31 ) then + write ( dateus (1:2),'(i2)' ) numjou + endif +c + dateus (4:6) = tabmon(mod(nummoi-1,12)+1) +c + numann = mod ( numann , 100 ) + if ( numann.le.9 ) then + write ( dateus (9:9),'(i1)' ) numann + else + write ( dateus (8:9),'(i2)' ) numann + endif +c +c 3.3. ==> heure +c + if ( numheu.le.9 .and. numheu.gt.0 ) then + write ( heurus (2:2),'(i1)' ) numheu + else if ( numheu.gt.9 .and. numheu.le.23 ) then + write ( heurus (1:2),'(i2)' ) numheu + endif +c + if ( nummin.le.9 .and. nummin.gt.0 ) then + write ( heurus (5:5),'(i1)' ) nummin + else if ( nummin.gt.9 .and. nummin.le.59 ) then + write ( heurus (4:5),'(i2)' ) nummin + endif +c + if ( numsec.le.9 .and. numsec.gt.0 ) then + write ( heurus (8:8),'(i1)' ) numsec + else if ( numsec.gt.9 .and. numsec.le.59 ) then + write ( heurus (7:8),'(i2)' ) numsec + endif +c + end diff --git a/src/tool/Utilitaire/utdhex.F b/src/tool/Utilitaire/utdhex.F new file mode 100644 index 00000000..be5188d8 --- /dev/null +++ b/src/tool/Utilitaire/utdhex.F @@ -0,0 +1,199 @@ + subroutine utdhex ( lehexa, diamet, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'un HEXaedre +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un hexaedre, le diametre est le maximum des longueurs des +c aretes et des diagonales +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero du tetraedre a examiner . +c . diamet . s . 1 . qualite . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,3) +c + integer lehexa + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c +c 0.4. ==> variables locales +c + integer s1, s2, s3, s4, s5, s6, s7,s8 +c + integer listar(12), listso(8) + integer iaux +c + double precision var(3) + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision ar7, ar8, ar9, ar10, ar11, ar12 + double precision ad1, ad2, ad3, ad4 +c +c 0.5. ==> initialisations +c +c==== +c 1. les aretes et les sommets de l'hexaedre +c==== +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + s1 = listso(1) + s2 = listso(2) + s3 = listso(3) + s4 = listso(4) + s5 = listso(5) + s6 = listso(6) + s7 = listso(7) + s8 = listso(8) +c +c==== +c 2. les carres des longueurs des 12 aretes et des 4 diagonales +c==== +c + var(1) = coonoe(s2,1) - coonoe(s1,1) + var(2) = coonoe(s2,2) - coonoe(s1,2) + var(3) = coonoe(s2,3) - coonoe(s1,3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s1,1) + var(2) = coonoe(s4,2) - coonoe(s1,2) + var(3) = coonoe(s4,3) - coonoe(s1,3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s3,1) - coonoe(s2,1) + var(2) = coonoe(s3,2) - coonoe(s2,2) + var(3) = coonoe(s3,3) - coonoe(s2,3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s3,1) + var(2) = coonoe(s4,2) - coonoe(s3,2) + var(3) = coonoe(s4,3) - coonoe(s3,3) + ar4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s1,1) + var(2) = coonoe(s6,2) - coonoe(s1,2) + var(3) = coonoe(s6,3) - coonoe(s1,3) + ar5 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s2,1) + var(2) = coonoe(s5,2) - coonoe(s2,2) + var(3) = coonoe(s5,3) - coonoe(s2,3) + ar6 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s7,1) - coonoe(s4,1) + var(2) = coonoe(s7,2) - coonoe(s4,2) + var(3) = coonoe(s7,3) - coonoe(s4,3) + ar7 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s8,1) - coonoe(s3,1) + var(2) = coonoe(s8,2) - coonoe(s3,2) + var(3) = coonoe(s8,3) - coonoe(s3,3) + ar8 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s5,1) + var(2) = coonoe(s6,2) - coonoe(s5,2) + var(3) = coonoe(s6,3) - coonoe(s5,3) + ar9 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s7,1) - coonoe(s6,1) + var(2) = coonoe(s7,2) - coonoe(s6,2) + var(3) = coonoe(s7,3) - coonoe(s6,3) + ar10 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s8,1) - coonoe(s5,1) + var(2) = coonoe(s8,2) - coonoe(s5,2) + var(3) = coonoe(s8,3) - coonoe(s5,3) + ar11 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s8,1) - coonoe(s7,1) + var(2) = coonoe(s8,2) - coonoe(s7,2) + var(3) = coonoe(s8,3) - coonoe(s7,3) + ar12 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s8,1) - coonoe(s1,1) + var(2) = coonoe(s8,2) - coonoe(s1,2) + var(3) = coonoe(s8,3) - coonoe(s1,3) + ad1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s7,1) - coonoe(s2,1) + var(2) = coonoe(s7,2) - coonoe(s2,2) + var(3) = coonoe(s7,3) - coonoe(s2,3) + ad2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s3,1) + var(2) = coonoe(s6,2) - coonoe(s3,2) + var(3) = coonoe(s6,3) - coonoe(s3,3) + ad3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s5,1) + var(2) = coonoe(s4,2) - coonoe(s5,2) + var(3) = coonoe(s4,3) - coonoe(s5,3) + ad4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max( ar1, ar2, ar3, ar4, ar5, ar6, + > ar7, ar8, ar9, ar10, ar11, ar12, + > ad1, ad2, ad3, ad4 ) + diamet = sqrt(diamet) +c + end diff --git a/src/tool/Utilitaire/utdhfc.F b/src/tool/Utilitaire/utdhfc.F new file mode 100644 index 00000000..f3c10339 --- /dev/null +++ b/src/tool/Utilitaire/utdhfc.F @@ -0,0 +1,216 @@ + subroutine utdhfc ( datheu, numann, + > datefr, heurfr, + > codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure +c de la forme Francaise en une forme compacte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . datheu . s . 1 . nombre de secondeS depuis le debut de l'an . +c . numann . s . 1 . numero de l'annee (complet) . +c . datefr . e . ch8 . date au format francais 'jj/mm/aa' . +c . heurfr . e . ch8 . heure au format francais 'hh:mm:ss' . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu, numann + integer codret +c + character*8 datefr + character*8 heurfr +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numheu, nummin, numsec +c +c==== +c 1. determination des differents numeros +c remarque : on suppose que l'on ne prendra pas des objets +c anterieurs a 1970 et qu'apres 2070, on aura recode ... +c==== +c + if ( index('123',datefr(1:1)).gt.0 .and. + > index('0123456789',datefr(2:2)).gt.0 ) then +c + read ( datefr (1:2),'(i2)' ) numjou +c + if ( numjou.gt.31 ) then + numjou = 1 + codret = 1 + endif +c + else if ( index(' 0',datefr(1:1)).gt.0 .and. + > index('123456789',datefr(2:2)).gt.0 ) then +c + read ( datefr (2:2),'(i1)' ) numjou +c + else if ( datefr(2:2).eq.' ' .and. + > index('123456789',datefr(1:1)).gt.0 ) then +c + read ( datefr (1:1),'(i1)' ) numjou +c + else + numjou = 1 + codret = 1 + endif +c + if ( index(' 01',datefr(4:4)).gt.0 .and. + > index('0123456789',datefr(5:5)).gt.0 ) then +c + read ( datefr (4:5),'(i2)' ) nummoi +c + if ( nummoi.le.0 .or. nummoi.gt.12 ) then + nummoi = 1 + codret = 1 + endif +c + else if ( datefr(5:5).eq.' ' .and. + > index('123456789',datefr(4:4)).gt.0 ) then +c + read ( datefr (4:4),'(i1)' ) nummoi +c + else + nummoi = 1 + codret = 1 + endif +c + if ( index('0123456789',datefr(7:7)).gt.0 .and. + > index('0123456789',datefr(8:8)).gt.0 ) then +c + read ( datefr (7:8),'(i2)' ) numann + if ( numann.lt.70 ) then + numann = 2000 + numann + else + numann = 1900 + numann + endif +c + else + numann = 1970 + codret = 1 + endif +c +c apres la date, on s'occupe maintenant de l'heure : +c + if ( index(' 012',heurfr(1:1)).gt.0 .and. + > index('0123456789',heurfr(2:2)).gt.0 ) then +c + read ( heurfr (1:2),'(i2)' ) numheu +c + if (numheu.gt.23) then + numheu = 0 + codret = 1 + endif +c + else if ( heurfr(2:2).eq.' ' .and. + > index('0123456789',heurfr(1:1)).gt.0 ) then +c + read ( heurfr (1:1),'(i1)' ) numheu +c + else +c + numheu = 0 + codret = 1 +c + endif +c + if ( index(' 012345',heurfr(4:4)).gt.0 .and. + > index('0123456789',heurfr(5:5)).gt.0 ) then +c + read ( heurfr (4:5),'(i2)' ) nummin +c + if (nummin.gt.59) then + nummin = 0 + codret = 1 + endif +c + else if ( heurfr(5:5).eq.' ' .and. + > index('0123456789',heurfr(4:4)).gt.0 ) then +c + read ( heurfr (4:4),'(i1)' ) nummin +c + else +c + nummin = 0 + codret = 1 +c + endif +c + if ( index(' 012345',heurfr(7:7)).gt.0 .and. + > index('0123456789',heurfr(8:8)).gt.0 ) then +c + read ( heurfr (7:8),'(i2)' ) numsec +c + if (numsec.gt.59) then + numsec = 0 + codret = 1 + endif +c + else if ( heurfr(8:8).eq.' ' .and. + > index('0123456789',heurfr(7:7)).gt.0 ) then +c + read ( heurfr (7:7),'(i1)' ) numsec +c + if (numsec.gt.59) then + numsec = 0 + codret = 1 + endif +c + else +c + numsec = 0 + codret = 1 +c + endif +c +c==== +c 2. appel du programme generique +c==== +c + if ( codret.eq.0 ) then +c + call utdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c + else +c + datheu = 0 +c + endif +c + end diff --git a/src/tool/Utilitaire/utdhlc.F b/src/tool/Utilitaire/utdhlc.F new file mode 100644 index 00000000..0aab402f --- /dev/null +++ b/src/tool/Utilitaire/utdhlc.F @@ -0,0 +1,121 @@ + subroutine utdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure d'une forme longue en une forme compacte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . datheu . s . 1 . nombre de secondes depuis le debut de l'an . +c . numann . e . 1 . numero de l'annee (complet: exemple 1996) . +c . numjou . e . 1 . numero du jour . +c . numheu . e . 1 . numero de l'heure . +c . nummin . e . 1 . numero de la minute . +c . numsec . e . 1 . numero de la seconde . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu + integer numann + integer nummoi, numjou, numheu, nummin, numsec + integer codret +c +c 0.4. ==> variables locales +c + integer nbjour + integer iaux, naux +c + integer lonmoi (12) +c +c==== +c 1. initialisation +c==== +c + codret = 0 +c + lonmoi (1) = 31 + lonmoi (2) = 28 + lonmoi (3) = 31 + lonmoi (4) = 30 + lonmoi (5) = 31 + lonmoi (6) = 30 + lonmoi (7) = 31 + lonmoi (8) = 31 + lonmoi (9) = 30 + lonmoi (10) = 31 + lonmoi (11) = 30 + lonmoi (12) = 31 +c +c==== +c 2. mise en forme +c==== +c +c 2.2. ==> cumul du nombre de jours pleins passes depuis le debut +c de l'annee +c + nbjour = 0 +c + naux = nummoi - 1 +c + if ( naux.lt.0 .or. naux.gt.11 ) then + codret = 1 + endif +c + do 22 iaux = 1 , naux + nbjour = nbjour + lonmoi(mod(iaux-1,12)+1) + 22 continue +c + if ( mod(numann,4).eq.0 .and. nummoi.gt.2 ) then + nbjour = nbjour + 1 + endif +c +c 2.3. ==> cumul du nombre de jours pleins passes depuis le debut +c du mois +c + nbjour = nbjour + numjou - 1 +c +cc if ( numheu.lt.24 ) then +cc nbjour = nbjour - 1 +cc endif +c +c 2.4. ==> calcul du nombre de secondes depuis le debut de l'annee +c + datheu = numsec + + > nummin*60 + + > numheu*3600 + + > nbjour*86400 +c + end diff --git a/src/tool/Utilitaire/utdhlg.F b/src/tool/Utilitaire/utdhlg.F new file mode 100644 index 00000000..99162a23 --- /dev/null +++ b/src/tool/Utilitaire/utdhlg.F @@ -0,0 +1,169 @@ + subroutine utdhlg ( ladate, langue ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c donne la date et l'heure sous forme longue +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ladate . s . 1 . date et heure sous forme longue . +c . langue . s . 1 . langue retenue . +c . . . . 1 : francais, 2 : anglais . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer langue +c + character*48 ladate +c +c 0.4. ==> variables locales +c + integer numann, nummoi, numjou, numjos + integer numheu, nummin, numsec +c + integer ideb, ifin + integer langlo +c +c 0.5. ==> initialisations +c +#include "utjomo.h" +c +c_______________________________________________________________________c +c==== +c 1. acquisition de la date +c==== +c + call dmjohe ( numann, nummoi, numjou, numjos, + > numheu, nummin, numsec ) +c +c==== +c 2. mise en forme +c==== +c +c 2.1. ==> initialisation +c +c 123456789012345678901234567890123456789012345678 + ladate = ' ' +c + if ( langue.ge.1 .and. langue.le.nblang ) then + langlo = langue + else + langlo = 1 + endif +c +c 2.2. ==> nom et numero du jour +c + if ( numjos.le.0 ) then + ifin = -1 + else + ifin = lgnomj(langlo,numjos) + ladate (1:ifin) = nomjou(langlo,numjos) + endif +c + ideb = ifin+2 + if ( numjou.le.9 ) then + ifin = ideb + write ( ladate (ideb:ifin),'(i1)' ) numjou + else + ifin = ideb + 1 + write ( ladate (ideb:ifin),'(i2)' ) numjou + endif +c +c 2.3. ==> nom du mois +c + if (nummoi.gt.0) then + ideb = ifin + 2 + ifin = ideb + lgnomm(langlo,mod(nummoi-1,12)+1) - 1 + ladate (ideb:ifin) = nommoi(langlo,mod(nummoi-1,12)+1) + endif +c +c 2.4. ==> numero de l'annee +c + ideb = ifin + 2 + ifin = ideb + 3 + write ( ladate (ideb:ifin),'(i4)' ) numann +c +c 2.5. ==> heure +c + ideb = ifin + 2 + if ( langlo.eq.1 ) then + ifin = ideb + 1 + ladate (ideb:ifin) = 'a ' + else + ifin = ideb + 2 + ladate (ideb:ifin) = 'at ' + endif +c + ideb = ifin + 1 + if ( numheu.le.9 ) then + ifin = ideb + write ( ladate (ideb:ifin),'(i1)' ) numheu + else + ifin = ideb + 1 + write ( ladate (ideb:ifin),'(i2)' ) numheu + endif +c + ideb = ifin + 1 + ifin = ideb + 2 + ladate (ideb:ifin) = ' h ' +c + ideb = ifin + 1 + if ( nummin.le.9 ) then + ifin = ideb + write ( ladate (ideb:ifin),'(i1)' ) nummin + else + ifin = ideb + 1 + write ( ladate (ideb:ifin),'(i2)' ) nummin + endif +c + ideb = ifin + 1 + ifin = ideb + 3 + ladate (ideb:ifin) = ' mn ' +c + ideb = ifin + 1 + if ( numsec.le.9 ) then + ifin = ideb + write ( ladate (ideb:ifin),'(i1)' ) numsec + else + ifin = ideb + 1 + write ( ladate (ideb:ifin),'(i2)' ) numsec + endif +c + ideb = ifin + 1 + ifin = ideb + 1 + ladate (ideb:ifin) = ' s' +c + end diff --git a/src/tool/Utilitaire/utdhuc.F b/src/tool/Utilitaire/utdhuc.F new file mode 100644 index 00000000..e8c75bdd --- /dev/null +++ b/src/tool/Utilitaire/utdhuc.F @@ -0,0 +1,225 @@ + subroutine utdhuc ( datheu, numann, + > dateus, heurus, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c convertit la date et l'heure d'une forme US en une forme compacte +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . datheu . s . 1 . nombre de secondes depuis le debut de l'an . +c . numann . s . 1 . numero de l'annee (complet: exemple 1996) . +c . dateus . e . ch9 . date au format americain 'dd-mon-yy' . +c . heurus . e . ch8 . heure au format americain 'hh:mm:ss' . +c . codret . s . 1 . code de retour . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer datheu, numann + integer codret +c + character*9 dateus + character*8 heurus +c +c 0.4. ==> variables locales +c + integer nummoi, numjou, numheu, nummin, numsec + integer iaux +c + character*3 tabmon (12) +c +c==== +c 1. les constantes +c==== +c + tabmon (1) = 'Jan' + tabmon (2) = 'Feb' + tabmon (3) = 'Mar' + tabmon (4) = 'Apr' + tabmon (5) = 'May' + tabmon (6) = 'Jun' + tabmon (7) = 'Jul' + tabmon (8) = 'Aug' + tabmon (9) = 'Sep' + tabmon (10) = 'Oct' + tabmon (11) = 'Nov' + tabmon (12) = 'Dec' +c +c==== +c 2. determination des differents numeros +c remarque : on suppose que l'on ne prendra pas des maillages +c anterieurs a 1970 et qu'apres 2070, on aura recode ... +c==== +c +c 2.1 la date : +c + if ( index('0123456789',dateus(8:8)).gt.0 .and. + > index('0123456789',dateus(9:9)).gt.0 ) then +c + read ( dateus (8:9),'(i2)' ) numann + if ( numann.lt.70 ) then + numann = 2000 + numann + else + numann = 1900 + numann + endif +c + codret = 0 +c + else +c + numann = 1970 + codret = 1 +c + endif +c + do 21 iaux = 1 , 12 + if ( dateus (4:6).eq.tabmon(iaux) ) then + nummoi = iaux + goto 22 + endif + 21 continue + nummoi = 1 + codret = 1 +c + 22 continue +c + if ( index(' 0123',dateus(1:1)).gt.0 .and. + > index('0123456789',dateus(2:2)).gt.0 ) then +c + read ( dateus (1:2),'(i2)' ) numjou +c + if ( numjou.le.0 .or. numjou.gt.31 ) then + numjou = 1 + codret = 1 + endif +c + else if ( dateus(2:2).eq.' ' .and. + > index('123456789',dateus(1:1)).gt.0 ) then +c + read ( dateus (1:1),'(i1)' ) numjou +c + else +c + numjou = 1 + codret = 1 +c + endif +c +c ---------------------- +c +c 2.2 l'heure : +c + if ( index(' 012',heurus(1:1)).gt.0 .and. + > index('0123456789',heurus(2:2)).gt.0 ) then +c + read ( heurus (1:2),'(i2)' ) numheu +c + if (numheu.gt.23) then + numheu = 0 + codret = 1 + endif +c + else if ( heurus(2:2).eq.' ' .and. + > index('0123456789',heurus(1:1)).gt.0 ) then +c + read ( heurus (1:1),'(i1)' ) numheu +c + else +c + numheu = 0 + codret = 1 +c + endif +c + if ( index(' 012345',heurus(4:4)).gt.0 .and. + > index('0123456789',heurus(5:5)).gt.0 ) then +c + read ( heurus (4:5),'(i2)' ) nummin +c + if (nummin.gt.59) then + nummin = 0 + codret = 1 + endif +c + else if ( heurus(5:5).eq.' ' .and. + > index('0123456789',heurus(4:4)).gt.0 ) then +c + read ( heurus (4:4),'(i1)' ) nummin +c + else +c + nummin = 0 + codret = 1 +c + endif +c + if ( index(' 012345',heurus(7:7)).gt.0 .and. + > index('0123456789',heurus(8:8)).gt.0 ) then +c + read ( heurus (7:8),'(i2)' ) numsec +c + if (numsec.gt.59) then + numsec = 0 + codret = 1 + endif +c + else if ( heurus(8:8).eq.' ' .and. + > index('0123456789',heurus(7:7)).gt.0 ) then +c + read ( heurus (7:7),'(i1)' ) numsec +c + else +c + numsec = 0 + codret = 1 +c + endif +c +c==== +c 3. appel du programme generique +c==== +c + if ( codret.eq.0 ) then +c + call utdhlc ( datheu, numann, + > nummoi, numjou, numheu, nummin, numsec, + > codret ) +c + else +c + datheu = 0 +c + endif +c + end diff --git a/src/tool/Utilitaire/utdhus.F b/src/tool/Utilitaire/utdhus.F new file mode 100644 index 00000000..0852cd88 --- /dev/null +++ b/src/tool/Utilitaire/utdhus.F @@ -0,0 +1,124 @@ + subroutine utdhus ( dateus, heurus ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c donne la date et l'heure sous forme americaine +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dateus . s . ch9 . date au format americain 'dd-mon-yy' . +c . heurus . s . ch8 . heure au format americain 'hh:mm:ss' . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*9 dateus + character*8 heurus +c +c 0.4. ==> variables locales +c + integer numann, nummoi, numjou, numjos + integer numheu, nummin, numsec +c + character*3 tabmon (12) +c +c==== +c 1. les constantes +c==== +c + tabmon (1) = 'Jan' + tabmon (2) = 'Feb' + tabmon (3) = 'Mar' + tabmon (4) = 'Apr' + tabmon (5) = 'May' + tabmon (6) = 'Jun' + tabmon (7) = 'Jul' + tabmon (8) = 'Aug' + tabmon (9) = 'Sep' + tabmon (10) = 'Oct' + tabmon (11) = 'Nov' + tabmon (12) = 'Dec' +c +c==== +c 2. acquisition de la date +c==== +c + call dmjohe ( numann, nummoi, numjou, numjos, + > numheu, nummin, numsec ) +c +c==== +c 3. mise en forme +c==== +c +c 3.1. ==> initialisation +c + dateus = '0d-Mon-0y' + heurus = '0h:0m:0s' +c +c 3.2. ==> date +c + if ( numjou.le.9 ) then + write ( dateus (2:2),'(i1)' ) numjou + else + write ( dateus (1:2),'(i2)' ) numjou + endif +c + dateus (4:6) = tabmon(abs(mod(nummoi-1,12))+1) +c + numann = mod ( numann , 100 ) + if ( numann.le.9 ) then + write ( dateus (9:9),'(i1)' ) numann + else + write ( dateus (8:9),'(i2)' ) numann + endif +c +c 3.3. ==> heure +c + if ( numheu.le.9 ) then + write ( heurus (2:2),'(i1)' ) numheu + else + write ( heurus (1:2),'(i2)' ) numheu + endif +c + if ( nummin.le.9 ) then + write ( heurus (5:5),'(i1)' ) nummin + else + write ( heurus (4:5),'(i2)' ) nummin + endif +c + if ( numsec.le.9 ) then + write ( heurus (8:8),'(i1)' ) numsec + else + write ( heurus (7:8),'(i2)' ) numsec + endif +c + end diff --git a/src/tool/Utilitaire/utdiag.F b/src/tool/Utilitaire/utdiag.F new file mode 100644 index 00000000..763cc8ff --- /dev/null +++ b/src/tool/Utilitaire/utdiag.F @@ -0,0 +1,217 @@ + subroutine utdiag ( lepere, + > filtet, tritet, aretri, + > arenoe, somare, cotrte, + > ardiag, decoup, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Recherche de l'arete DIAGonale d'un tetraedre decoupe +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepere . e . 1 . tetraedre pere dont on veut la diagonale . +c . filtet . e . nouvte . premier fils des tetraedres . +c . tritet . e .nouvtf*4. numeros des 4 triangles des tetraedres . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . arenoe . e . nouvno . arete liee a un nouveau noeud . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . cotrte . e .nouvtf*4. code des 4 triangles des tetraedres . +c . ardiag . s . 1 . numero de l'arete diagonale de decoupe . +c . decoup . s . 1 . type de decoupe du tetraedre (85, 86 ou 87). +c . codret . s . 1 . code de retour, 0 si ok, (no tetra) si pb . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c +c 0.2. ==> communs +c +#include "nouvnb.h" +#include "i1i2i3.h" +#include "indefi.h" +c +c 0.3. ==> arguments +c + integer lepere, ardiag, decoup + integer filtet(nouvte), tritet(nouvtf,4), aretri(nouvtr,3) + integer arenoe(nouvno), somare(2,nouvar), cotrte(nouvtf,4) + integer codret +c +c 0.4. ==> variables locales +c + integer lefils, letria, numfac, iaux + integer larete, numare, nbarte, aretet + integer a1, a2, a3, a4, a5, a6 + integer listar(6) +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c remarque importante : le tetraedre teste est suppose vraiment decoupe, +c --------------------- donc le test de cet etat doit etre fait avant +c l'entree dans cette routine ! +c +c==== +c 1. recherche de la diagonale de decoupe du tetraedre +c (recherche de l'arete commune des fils no 5 et 7 du bloc interne) +c==== +c +c pour cela, on etablit la liste des aretes du tetraedre no 5 dans +c "listar" en parcourant les 3 premieres faces (la quatrieme +c contient obligatoirement des aretes deja decrites), puis on +c parcours de la meme maniere les 3 premieres faces du tetraedre +c no 7 en regardant si chaque arete n'existe pas dans la liste. +c celle qui existe est l'arete diagonale. Les boucles "do" sont +c court-circuitees pour une recherche d'efficacite mais cet +c avantage reste a verifier +c + do 320 , iaux = 1 , 6 + listar(iaux) = 0 + 320 continue +c +c 1.1 recherche de la liste des aretes du fils no 5 +c + lefils = filtet(lepere) + 4 +c + nbarte = 0 + do 340 , numfac = 1 , 3 +c + letria = tritet(lefils,numfac) +c + do 342 , numare = 1 , 3 +c + larete = aretri(letria,numare) +c + do 344 , iaux = 1 , nbarte +c +c si l'arete existe deja dans la liste, on passe a la +c suivante +c + if ( larete.eq.listar(iaux) ) then + goto 342 + endif + 344 continue +c +c sinon on la stocke +c + nbarte = nbarte + 1 + listar(nbarte) = larete +c + 342 continue +c + 340 continue +c +c 1.2 recherche d'une arete commune dans le fils no 7 +c + ardiag = iindef + lefils = filtet(lepere) + 6 +c + do 350 , numfac = 1 , 3 +c + letria = tritet(lefils,numfac) +c + do 352 , numare = 1 , 3 +c + larete = aretri(letria,numare) +c + do 354 , iaux = 1 , nbarte +c +c si l'arete existe deja dans la liste, elle est donc +c commune et c'est l'arete diagonale. on arrete +c + if ( larete.eq.listar(iaux) ) then + ardiag = larete + goto 360 + endif +c + 354 continue +c + 352 continue +c + 350 continue +c + 360 continue +c +c==== +c 2. recherche du type de decoupe du tetraedre (85, 86 ou 87) +c==== +c +c 2.1 determination de l'arete du tetraedre "lepere" supportant le +c premier noeud de l'arete "ardiag". on a alors une arete de type +c a1, a2, a3, a4, a5 ou a6. +c + aretet = arenoe(somare(1,ardiag)) +c +c 2.2 on utilise les codes de faces du tetraedre "lepere" pour obtenir +c le rang de chaque arete (de numero local a1 a a6) dans le +c rangement "aretri". on a alors le numero global de chaque arete, +c a comparer avec le numero global "aretet" de l'arete du tetraedre +c supportant le premier noeud de l'arete de decoupe diagonale. +c + decoup = 0 +c +c 2.2.1 numero global de l'arete a1 (face f3, premiere arete i1) +c ou de l'arete a6 (face f1, troisieme arete i3) +c + a1 = aretri(tritet(lepere,3),i1(cotrte(lepere,3))) + a6 = aretri(tritet(lepere,1),i3(cotrte(lepere,1))) +c + if (( a1.eq.aretet ).or.( a6.eq.aretet )) then + decoup = 85 + endif +c +c 2.2.2 numero global de l'arete a2 (face f2, premiere arete i1) +c ou de l'arete a5 (face f1, seconde arete i2) +c + a2 = aretri(tritet(lepere,2),i1(cotrte(lepere,2))) + a5 = aretri(tritet(lepere,1),i2(cotrte(lepere,1))) +c + if (( a2.eq.aretet ).or.( a5.eq.aretet )) then + decoup = 86 + endif +c +c 2.2.3 numero global de l'arete a3 (face f2, seconde arete i2) +c ou de l'arete a4 (face f1, premiere arete i1) +c + a3 = aretri(tritet(lepere,2),i2(cotrte(lepere,2))) + a4 = aretri(tritet(lepere,1),i1(cotrte(lepere,1))) +c + if (( a3.eq.aretet ).or.( a4.eq.aretet )) then + decoup = 87 + endif +c +c 2.3 verification que la decoupe a ete trouvee +c + if ( decoup.eq.0 ) then + codret = lepere + endif +c + end diff --git a/src/tool/Utilitaire/utdich.F b/src/tool/Utilitaire/utdich.F new file mode 100644 index 00000000..d4879396 --- /dev/null +++ b/src/tool/Utilitaire/utdich.F @@ -0,0 +1,159 @@ + subroutine utdich ( chain1, chain2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - teste la DIfference entre 2 CHaines de caracteres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chain1 . e .char*(*). chaine de caractere 1 a comparer . +c . chain2 . e .char*(*). chaine de caractere 2 a comparer . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : chaines identiques . +c . . . . 1 : longueurs identiques, contenu different. +c . . . . 2 : longueurs differentes . +c . . . . 10 : probleme de comparaison . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTDICH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) chain1, chain2 +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux + integer lg1, lg2 +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Chaine'',i2,'' a comparer :'')' + texte(1,4) = '(''Longueur de la chaine'',i2,'' = '',i8)' + texte(1,5) = '(''La chaine est vide.'')' +c + texte(2,10) = '(''String #'',i2,'' :'')' + texte(2,4) = '(''Length of #'',i2,'' : '',i8)' + texte(2,5) = '(''The string is empty.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) 1 + write (ulsort,*) chain1 + write (ulsort,texte(langue,10)) 2 + write (ulsort,*) chain2 +#endif +c + iaux = -1 +c +c==== +c 2. mesure des longueurs +c==== +c + call utlgut ( lg1, chain1, ulsort, langue, codret ) + if ( codret.eq.0 ) then + call utlgut ( lg2, chain2, ulsort, langue, codret ) + endif +c +c==== +c 3. comparaison +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 1, lg1 + write (ulsort,texte(langue,4)) 2, lg2 +#endif +c + if ( lg1.eq.lg2 ) then + if ( chain1(1:lg1).eq.chain2(1:lg2) ) then + iaux = 0 + else + iaux = 1 + endif + else + iaux = 2 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c + if ( iaux.ge.0 ) then + codret = iaux + else + codret = 10 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utdpen.F b/src/tool/Utilitaire/utdpen.F new file mode 100644 index 00000000..2d9a9101 --- /dev/null +++ b/src/tool/Utilitaire/utdpen.F @@ -0,0 +1,190 @@ + subroutine utdpen ( lepent, diamet, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'un PENtaedre +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un pentaedre, le diametre est le maximum des longueurs des +c aretes et des diagonales +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du tetraedre a examiner . +c . diamet . s . 1 . qualite . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,3) +c + integer lepent + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c +c 0.4. ==> variables locales +c + integer s1, s2, s3, s4, s5, s6 +c + integer listar(9), listso(6) + integer iaux +c + double precision var(3) + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision ar7, ar8, ar9 + double precision ad1, ad2, ad3, ad4, ad5, ad6 +c +c==== +c 1. les aretes et les sommets du pentaedre +c==== +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c + s1 = listso(1) + s2 = listso(2) + s3 = listso(3) + s4 = listso(4) + s5 = listso(5) + s6 = listso(6) +c +c==== +c 2. les carres des longueurs des 9 aretes et des 6 diagonales +c==== +c + var(1) = coonoe(s3,1) - coonoe(s1,1) + var(2) = coonoe(s3,2) - coonoe(s1,2) + var(3) = coonoe(s3,3) - coonoe(s1,3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s2,1) - coonoe(s1,1) + var(2) = coonoe(s2,2) - coonoe(s1,2) + var(3) = coonoe(s2,3) - coonoe(s1,3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s3,1) - coonoe(s2,1) + var(2) = coonoe(s3,2) - coonoe(s2,2) + var(3) = coonoe(s3,3) - coonoe(s2,3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s6,1) + var(2) = coonoe(s4,2) - coonoe(s6,2) + var(3) = coonoe(s4,3) - coonoe(s6,3) + ar4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s5,1) + var(2) = coonoe(s4,2) - coonoe(s5,2) + var(3) = coonoe(s4,3) - coonoe(s5,3) + ar5 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s6,1) + var(2) = coonoe(s5,2) - coonoe(s6,2) + var(3) = coonoe(s5,3) - coonoe(s6,3) + ar6 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s1,1) + var(2) = coonoe(s4,2) - coonoe(s1,2) + var(3) = coonoe(s4,3) - coonoe(s1,3) + ar7 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s2,1) + var(2) = coonoe(s5,2) - coonoe(s2,2) + var(3) = coonoe(s5,3) - coonoe(s2,3) + ar8 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s3,1) + var(2) = coonoe(s6,2) - coonoe(s3,2) + var(3) = coonoe(s6,3) - coonoe(s3,3) + ar9 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s1,1) + var(2) = coonoe(s5,2) - coonoe(s1,2) + var(3) = coonoe(s5,3) - coonoe(s1,3) + ad1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s1,1) + var(2) = coonoe(s6,2) - coonoe(s1,2) + var(3) = coonoe(s6,3) - coonoe(s1,3) + ad2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s2,1) + var(2) = coonoe(s4,2) - coonoe(s2,2) + var(3) = coonoe(s4,3) - coonoe(s2,3) + ad3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s6,1) - coonoe(s2,1) + var(2) = coonoe(s6,2) - coonoe(s2,2) + var(3) = coonoe(s6,3) - coonoe(s2,3) + ad4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s3,1) + var(2) = coonoe(s4,2) - coonoe(s3,2) + var(3) = coonoe(s4,3) - coonoe(s3,3) + ad5 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s3,1) + var(2) = coonoe(s5,2) - coonoe(s3,2) + var(3) = coonoe(s5,3) - coonoe(s3,3) + ad6 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max( ar1, ar2, ar3, ar4, ar5, ar6, + > ar7, ar8, ar9, + > ad1, ad2, ad3, ad4, ad5, ad6 ) + diamet = sqrt(diamet) +c + end diff --git a/src/tool/Utilitaire/utdpyr.F b/src/tool/Utilitaire/utdpyr.F new file mode 100644 index 00000000..34d04a7a --- /dev/null +++ b/src/tool/Utilitaire/utdpyr.F @@ -0,0 +1,191 @@ + subroutine utdpyr ( lapyra, diamet, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'une PYRamide +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un pyramide, le diametre est le maximum des longueurs des +c aretes et des diagonales de la base +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . diamet . s . 1 . qualite . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,3) +c + integer lapyra + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c +c 0.4. ==> variables locales +c + integer s1, s2, s3, s4, s5 +c + integer listar(8), listso(5) + integer iaux +c + double precision var(3) + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision ar7, ar8 + double precision ad1, ad2 +c +c 0.5. ==> initialisations +c +c S5 +c x +c . . . . +c . . . . +c . . a4. . +c . . . . +c . . x . . +c a1 . . . S4 . .a3 +c . . . . . +c . . . . +c . . . a7 . . +c . .a8 . . . +c . . . . . +c S1 . .a2 . . +c x . . . . +c a5 . . . +c x--------------------------------------------------------x +c S2 a6 S3 +c La face f5 est le quadrangle. +c La face fi, i<5, est le triangle s'appuyant sur l'arete ai. +c +c==== +c 1. les aretes et les sommets de la pyramide +c==== +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c + s1 = listso(1) + s2 = listso(2) + s3 = listso(3) + s4 = listso(4) + s5 = listso(5) +c +c==== +c 2. les carres des longueurs des 8 aretes et des +c diagonales du quadrangle +c==== +c +c 2.1. ==> les aretes +c + var(1) = coonoe(s5,1) - coonoe(s1,1) + var(2) = coonoe(s5,2) - coonoe(s1,2) + var(3) = coonoe(s5,3) - coonoe(s1,3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s2,1) + var(2) = coonoe(s5,2) - coonoe(s2,2) + var(3) = coonoe(s5,3) - coonoe(s2,3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s3,1) + var(2) = coonoe(s5,2) - coonoe(s3,2) + var(3) = coonoe(s5,3) - coonoe(s3,3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s5,1) - coonoe(s4,1) + var(2) = coonoe(s5,2) - coonoe(s4,2) + var(3) = coonoe(s5,3) - coonoe(s4,3) + ar4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s2,1) - coonoe(s1,1) + var(2) = coonoe(s2,2) - coonoe(s1,2) + var(3) = coonoe(s2,3) - coonoe(s1,3) + ar5 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s3,1) - coonoe(s2,1) + var(2) = coonoe(s3,2) - coonoe(s2,2) + var(3) = coonoe(s3,3) - coonoe(s2,3) + ar6 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s3,1) + var(2) = coonoe(s4,2) - coonoe(s3,2) + var(3) = coonoe(s4,3) - coonoe(s3,3) + ar7 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s1,1) - coonoe(s4,1) + var(2) = coonoe(s1,2) - coonoe(s4,2) + var(3) = coonoe(s1,3) - coonoe(s4,3) + ar8 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c +c 2.2. ==> les diagonales de la base +c + var(1) = coonoe(s3,1) - coonoe(s1,1) + var(2) = coonoe(s3,2) - coonoe(s1,2) + var(3) = coonoe(s3,3) - coonoe(s1,3) + ad1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(s4,1) - coonoe(s2,1) + var(2) = coonoe(s4,2) - coonoe(s2,2) + var(3) = coonoe(s4,3) - coonoe(s2,3) + ad2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max( ar1, ar2, ar3, ar4, ar5, ar6, + > ar7, ar8, ad1, ad2 ) + diamet = sqrt(diamet) +c + end diff --git a/src/tool/Utilitaire/utdqua.F b/src/tool/Utilitaire/utdqua.F new file mode 100644 index 00000000..d411b362 --- /dev/null +++ b/src/tool/Utilitaire/utdqua.F @@ -0,0 +1,164 @@ + subroutine utdqua ( lequad, diamet, + > coonoe, somare, arequa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'un QUAdrangle +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un quadrangle, le diametre est le maximum des longueurs des +c aretes et des diagonales +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . numero du quadrangle a examiner . +c . diamet . s . 1 . diametre du quadrangle . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), arequa(nbquto,4) +c + integer lequad +c +c 0.4. ==> variables locales +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c + double precision var(3) + double precision ar1, ar2, ar3, ar4, ad1, ad2 +c +c 0.5. ==> initialisations +c +c==== +c 1. les sommets +c==== +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c==== +c 2. les carres des longueurs des 4 aretes et des 2 diagonales +c==== +c +c 2.1. ==> en dimension 2 +c + if ( sdim.eq.2 ) then +c + var(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1) + var(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2) + ar1 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + var(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + ar2 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(sa3a4,1) - coonoe(sa2a3,1) + var(2) = coonoe(sa3a4,2) - coonoe(sa2a3,2) + ar3 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1) + var(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2) + ar4 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1) + var(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2) + ad1 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(sa3a4,1) - coonoe(sa1a2,1) + var(2) = coonoe(sa3a4,2) - coonoe(sa1a2,2) + ad2 = var(1)*var(1) + var(2)*var(2) +c + else +c + var(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1) + var(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2) + var(3) = coonoe(sa1a2,3) - coonoe(sa4a1,3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + var(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + var(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(sa3a4,1) - coonoe(sa2a3,1) + var(2) = coonoe(sa3a4,2) - coonoe(sa2a3,2) + var(3) = coonoe(sa3a4,3) - coonoe(sa2a3,3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1) + var(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2) + var(3) = coonoe(sa4a1,3) - coonoe(sa3a4,3) + ar4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(sa2a3,1) - coonoe(sa4a1,1) + var(2) = coonoe(sa2a3,2) - coonoe(sa4a1,2) + var(3) = coonoe(sa2a3,3) - coonoe(sa4a1,3) + ad1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(sa3a4,1) - coonoe(sa1a2,1) + var(2) = coonoe(sa3a4,2) - coonoe(sa1a2,2) + var(3) = coonoe(sa3a4,3) - coonoe(sa1a2,3) + ad2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + endif +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max ( ar1, ar2, ar3, ar4, ad1, ad2 ) + diamet = sqrt(diamet) +cgn print *, ar1, ar2, ar3, ar4, ad1, ad2, ' ==> ', diamet +c + end diff --git a/src/tool/Utilitaire/utdtet.F b/src/tool/Utilitaire/utdtet.F new file mode 100644 index 00000000..b2d35113 --- /dev/null +++ b/src/tool/Utilitaire/utdtet.F @@ -0,0 +1,136 @@ + subroutine utdtet ( letetr, diamet, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'un TETraedre +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un tetraedre, le diametre est la longueur maximale des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . diamet . s . 1 . qualite . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,3) +c + integer letetr + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) +c +c 0.4. ==> variables locales +c + integer listar(6), listso(4) + integer iaux +c + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision var(3) +cc +c 0.5. ==> initialisations +c +c ______________________________________________________________________ +c +c==== +c 1. les aretes et les sommets de ce tetraedre +c==== +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c +c==== +c 2. les carres des longueurs des 6 aretes +c==== +c + var(1) = coonoe(listso(2),1) - coonoe(listso(1),1) + var(2) = coonoe(listso(2),2) - coonoe(listso(1),2) + var(3) = coonoe(listso(2),3) - coonoe(listso(1),3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(listso(3),1) - coonoe(listso(1),1) + var(2) = coonoe(listso(3),2) - coonoe(listso(1),2) + var(3) = coonoe(listso(3),3) - coonoe(listso(1),3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(listso(4),1) - coonoe(listso(1),1) + var(2) = coonoe(listso(4),2) - coonoe(listso(1),2) + var(3) = coonoe(listso(4),3) - coonoe(listso(1),3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(listso(3),1) - coonoe(listso(2),1) + var(2) = coonoe(listso(3),2) - coonoe(listso(2),2) + var(3) = coonoe(listso(3),3) - coonoe(listso(2),3) + ar4 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(listso(4),1) - coonoe(listso(2),1) + var(2) = coonoe(listso(4),2) - coonoe(listso(2),2) + var(3) = coonoe(listso(4),3) - coonoe(listso(2),3) + ar5 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(listso(4),1) - coonoe(listso(3),1) + var(2) = coonoe(listso(4),2) - coonoe(listso(3),2) + var(3) = coonoe(listso(4),3) - coonoe(listso(3),3) + ar6 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max ( ar1, ar2, ar3, ar4, ar5, ar6 ) + diamet = sqrt(diamet) +cgn print *, ar1, ar2, ar3, ar4, ar5, ar6, ' ==> ', diamet +c + end diff --git a/src/tool/Utilitaire/utdtri.F b/src/tool/Utilitaire/utdtri.F new file mode 100644 index 00000000..f6758f52 --- /dev/null +++ b/src/tool/Utilitaire/utdtri.F @@ -0,0 +1,134 @@ + subroutine utdtri ( letria, diamet, + > coonoe, somare, aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Diametre d'un TRIangle +c -- - --- +c ______________________________________________________________________ +c +c Le diametre d'une maille est la longueur du plus grand segment que +c l'on peut tracer a l'interieur de cette maille. +c Pour un triangle, le diametre est la longueur maximale des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . numero du triangle a examiner . +c . diamet . s . 1 . diametre . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision diamet, coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), aretri(nbtrto,3) +c + integer letria +c +c 0.4. ==> variables locales +c + integer a1, a2, a3 +c + double precision ar1, ar2, ar3 + double precision var(3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes +c==== +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +c==== +c 2. les carres des longueurs des 3 aretes +c==== +c +c 2.1. ==> en dimension 2 +c + if ( sdim.eq.2 ) then +c + var(1) = coonoe(somare(2,a1),1) - coonoe(somare(1,a1),1) + var(2) = coonoe(somare(2,a1),2) - coonoe(somare(1,a1),2) + ar1 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(somare(2,a2),1) - coonoe(somare(1,a2),1) + var(2) = coonoe(somare(2,a2),2) - coonoe(somare(1,a2),2) + ar2 = var(1)*var(1) + var(2)*var(2) +c + var(1) = coonoe(somare(2,a3),1) - coonoe(somare(1,a3),1) + var(2) = coonoe(somare(2,a3),2) - coonoe(somare(1,a3),2) + ar3 = var(1)*var(1) + var(2)*var(2) +c +c 2.2. ==> en dimension 3 +c + else +c + var(1) = coonoe(somare(2,a1),1) - coonoe(somare(1,a1),1) + var(2) = coonoe(somare(2,a1),2) - coonoe(somare(1,a1),2) + var(3) = coonoe(somare(2,a1),3) - coonoe(somare(1,a1),3) + ar1 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(somare(2,a2),1) - coonoe(somare(1,a2),1) + var(2) = coonoe(somare(2,a2),2) - coonoe(somare(1,a2),2) + var(3) = coonoe(somare(2,a2),3) - coonoe(somare(1,a2),3) + ar2 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + var(1) = coonoe(somare(2,a3),1) - coonoe(somare(1,a3),1) + var(2) = coonoe(somare(2,a3),2) - coonoe(somare(1,a3),2) + var(3) = coonoe(somare(2,a3),3) - coonoe(somare(1,a3),3) + ar3 = var(1)*var(1) + var(2)*var(2) + var(3)*var(3) +c + endif +c +c==== +c 3. diametre +c on ne prend la racine carre qu'ici pour economiser du temps calcul +c==== +c + diamet = max ( ar1, ar2, ar3 ) + diamet = sqrt(diamet) +cgn print *, ar1, ar2, ar3, ' ==> ', diamet +c + end diff --git a/src/tool/Utilitaire/uteare.F b/src/tool/Utilitaire/uteare.F new file mode 100644 index 00000000..f9ad564f --- /dev/null +++ b/src/tool/Utilitaire/uteare.F @@ -0,0 +1,209 @@ + subroutine uteare ( nbarto, nbnoto, somare, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des AREtes +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbarto . e . 1 . nombre d'aretes a examiner . +c . nbnoto . e . 1 . nombre de sommets enregistres . +c . somare . e .nbarto*2. numeros des extremites d'arete . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : nombre de problemes rencontres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTEARE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbarto, nbnoto + integer somare(2,*) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre0 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(5x,''Controle des '',i10,'' aretes.'')' + texte(1,6) = '(''Arete :'',i10)' + texte(1,7) = '(''Sommets :'',2i10,/)' + texte(1,8) = '(''Les deux sommets sont confondus.'')' + texte(1,9) = '(''Le numero du sommet'',i2,'' est mauvais.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des aretes'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,5) = '(5x,''Control of '',i10,'' edges.'')' + texte(2,6) = '(''Edge :'',i10)' + texte(2,7) = '(''Vertices :'',2i10,/)' + texte(2,8) = '(''Nodes are similar.'')' + texte(2,9) = '(''Wrong number for vertice #'',i2)' + texte(2,16) = '(5x,''No problem with edge definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,5)) nbarto +c +c==== +c 2. verification +c==== +c + codret = 0 + jaux = 3*nbnoto +c + do 21 , iaux = 1 , nbarto +c + codre0 = 0 +c +c 2.1. ==> les deux sommets doivent etre differents +c + if ( somare(1,iaux).eq.somare(2,iaux) ) then + codre0 = 1 + write (ulsort,texte(langue,8)) + write (ulbila,texte(langue,8)) +c +c 2.2. ==> le numero de noeud est forcement positif +c + elseif ( somare(1,iaux).le.0 ) then + codre0 = 2 + write (ulsort,texte(langue,9)) 1 + write (ulbila,texte(langue,9)) 1 + elseif ( somare(2,iaux).le.0 ) then + codre0 = 3 + write (ulsort,texte(langue,9)) 2 + write (ulbila,texte(langue,9)) 2 +c +c 2.3. ==> le numero est borne : on ne connait pas toujours precisement +c le maximum, mais on est sur que c'est inferieur a 3 fois le +c nombre de noeuds actuel. Cela permet de pieger les +c debordements de tableau +c + elseif ( somare(1,iaux).gt.jaux ) then + codre0 = 4 + write (ulsort,texte(langue,9)) 1 + write (ulbila,texte(langue,9)) 1 + elseif ( somare(2,iaux).gt.jaux ) then + codre0 = 5 + write (ulsort,texte(langue,9)) 2 + write (ulbila,texte(langue,9)) 2 + endif +c + if ( codre0.ne.0 ) then + codret = codret + 1 + write (ulsort,texte(langue,6)) iaux + write (ulbila,texte(langue,6)) iaux + write (ulsort,texte(langue,7)) somare(1,iaux), somare(2,iaux) + write (ulbila,texte(langue,7)) somare(1,iaux), somare(2,iaux) + endif +c + 21 continue +c +c 2.2. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utecf0.F b/src/tool/Utilitaire/utecf0.F new file mode 100644 index 00000000..571761b3 --- /dev/null +++ b/src/tool/Utilitaire/utecf0.F @@ -0,0 +1,576 @@ + subroutine utecf0 ( maextr, typenh, nbento, + > nbfaen, nbfcf1, nbfcf2, + > nctfen, ncffen, ncxfen, ncefen, + > fament, cfaent, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ECriture des Codes de Familles d'entites - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . typenh . e . 1 . type d'entites . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 3 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbento . e . 1 . nombre d'entites . +c . nbfaen . e . 1 . nombre de familles enregistrees . +c . nbfcf1 . e . 1 . nombre de familles pour la conformite - 1 . +c . nbfcf2 . e . 1 . nombre de familles pour la conformite - 2 . +c . nctfen . e . 1 . nombre total de caracteristiques familles . +c . ncefen . e . 1 . nombre de caracteristiques d'equivalence . +c . ncffen . e . 1 . nombre fige de caracteristiques . +c . fament . e . nbento . famille des entites . +c . cfaent . e . nctfen*. codes des familles d'entites . +c . . . nbfaen . 1 : famille MED . +c . . . . si maille-point : . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . si arete : . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si triangle : . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 3 : famille des aretes internes apres raf. +c . . . . + l : appartenance a l'equivalence l . +c . . . . si quadrangle : . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 3 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . + l : appartenance a l'equivalence l . +c . . . . si tetraedre, hexaedre, pyramide, pentaedre. +c . . . . 2 : type de mailles . +c . . . . si hexaedre : . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 3 : famille des pyramides de conformite . +c . . . . si extrusion et noeud/arete/tria/quad : . +c . . . . n+1 : famille du noeud extrude . +c . . . . n+2 : famille de l'arete perpendiculaire . +c . . . . si extrusion et triangle ou quadrangle : . +c . . . . n+3 : code de la face dans le volume . +c . . . . si extrusion : . +c . . . . n+3/4 : position de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTECF0' ) +c +#include "nblang.h" +#include "coftex.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer maextr + integer typenh, nbento + integer nbfaen, nbfcf1, nbfcf2 + integer nctfen, ncffen, ncxfen, ncefen + integer fament(nbento) + integer cfaent(nctfen,nbfaen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbmi01, nbmi21, nbmx20, nbmx40, nbmxxx + integer iaux, jaux, kaux + integer nbenfa + integer lgstar(-1:7) +c + character*80 saux80 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data lgstar / 33, 53, 93, 63, 43, 83, 43, 63, 63 / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,5x,123(''-''),/,/,5x,''Description des familles des '',a)' + texte(1,5) = '(5x,''Nombre de familles : '',i8)' + texte(1,6) = '(5x,''Nombre de codes par famille : '',i3)' +c + texte(2,4) = + > '(/,5x,123(''-''),/,/,5x,''Description of families of '',a)' + texte(2,5) = '(5x,''Number of families : '',i8)' + texte(2,6) = '(5x,''Number of codes per family: '',i3)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. En tete +c==== +c + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbfaen + write (ulsort,texte(langue,6)) nctfen +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nctfen, ncffen, ncxfen, ncefen', + > nctfen, ncffen, ncxfen, ncefen +#endif +c +c==== +c 3. Les familles +c==== +c + if ( nbfaen.gt.0 ) then +c +c 3.1. ==> les caracteristiques de base +c 3.1.1. ==> sans extrusion +c + if ( maextr.eq.0 ) then +c + if ( nbfcf1.eq.0 .and. nbfcf2.eq.0 ) then + kaux = 2 + else + kaux = 0 + endif +c + if ( typenh.eq.-1 ) then + write (ulsort,11001) + write (ulsort,20090) + elseif ( typenh.eq.0 ) then + write (ulsort,11003) + write (ulsort,30090) + elseif ( typenh.eq.1 ) then + write (ulsort,11007) + write (ulsort,40090) + elseif ( typenh.eq.2 ) then + write (ulsort,11004) + write (ulsort,50090) + elseif ( typenh.eq.3 .or. typenh.eq.5 ) then + write (ulsort,11002) + write (ulsort,60090) mess14(1,3,typenh)(1:10) + elseif ( typenh.eq.4 ) then + write (ulsort,11006) + write (ulsort,70090) + elseif ( typenh.eq.6 .or. typenh.eq.7 ) then + if ( nbfcf1.eq.0 .and. nbfcf2.eq.0 ) then + write (ulsort,11002) + write (ulsort,60090) mess14(1,3,typenh)(1:10) + kaux = 2 + else + write (ulsort,11004) + write (ulsort,80090) mess14(1,3,typenh)(1:10) + endif + endif +c + do 311, iaux = 1, nbfaen +c + nbenfa = 0 + do 312, jaux = 1, nbento + if ( fament(jaux).eq.iaux ) then + nbenfa = nbenfa + 1 + endif + 312 continue + if ( typenh.eq.-1 ) then + write (ulsort,12001) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.0 ) then + write (ulsort,12003) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.1 ) then + write (ulsort,12007) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.2 ) then + write (ulsort,12004) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.3 .or. typenh.eq.5 ) then + write (ulsort,12002) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.4 ) then + write (ulsort,12006) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + elseif ( typenh.eq.6 .or. typenh.eq.7 ) then + if ( kaux.eq.0 ) then + write (ulsort,12004) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen) + else + write (ulsort,12002) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen-kaux) + endif + endif +c + 311 continue +c + if ( typenh.eq.6 .or. typenh.eq.7 ) then + if ( kaux.ne.0 ) then + kaux = -2 + endif + endif +c +c 3.1.2. ==> avec extrusion +c Remarque : ce sont seulement des noeuds, aretes, +c triangles, quadrangles +c + else +c + if ( typenh.eq.-1 ) then + write (ulsort,11004) + write (ulsort,20091) + kaux = 3 + elseif ( typenh.eq.1 ) then + write (ulsort,11010) + write (ulsort,40091) + kaux = 3 + elseif ( typenh.eq.2 ) then + write (ulsort,11008) + write (ulsort,50091) + kaux = 4 + elseif ( typenh.eq.4 ) then + write (ulsort,11010) + write (ulsort,70091) + kaux = 4 + elseif ( typenh.eq.6 ) then + write (ulsort,11003) + write (ulsort,80091) mess14(1,3,typenh)(1:10) + kaux = 1 + elseif ( typenh.eq.7 ) then + write (ulsort,11002) + write (ulsort,60090) mess14(1,3,typenh)(1:10) + kaux = 2 + endif +c + do 313, iaux = 1, nbfaen +c + nbenfa = 0 + do 314, jaux = 1, nbento + if ( fament(jaux).eq.iaux ) then + nbenfa = nbenfa + 1 + endif + 314 continue + if ( typenh.eq.-1 ) then + write (ulsort,12005) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen) + elseif ( typenh.eq.1 ) then + write (ulsort,12010) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen) + elseif ( typenh.eq.2 ) then + write (ulsort,12008) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen) + elseif ( typenh.eq.4 ) then + write (ulsort,12010) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen) + elseif ( typenh.eq.6 ) then + write (ulsort,12004) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen-kaux) + elseif ( typenh.eq.7 ) then + write (ulsort,12004) iaux, nbenfa, + > (cfaent(jaux,iaux),jaux=1,ncffen-kaux) + endif +c + 313 continue +c + if ( typenh.eq.6 ) then + kaux = -1 + elseif ( typenh.eq.7 ) then + kaux = -2 + endif +c + endif +c +c 3.1.3. ==> Ligne finale du tableau +c + saux80 = '(5x, (''*''))' + write(saux80(5:7),'(i3)') lgstar(typenh) + kaux*10 + write (ulsort,saux80) +c +c 3.2. ==> les eventuelles equivalences +c + if ( ncefen.gt.0 ) then +c + nbmi01 = ncffen + 1 + nbmi21 = nbmi01 + 20 + nbmx20 = ncffen + 20 + nbmx40 = nbmx20 + 20 + nbmxxx = nctfen + write (ulsort,10020) (jaux,jaux=nbmi01,nbmx20) + do 33, iaux = 1, nbfaen + if ( ncefen.le.20 ) then + write (ulsort,10091) iaux, + > (cfaent(jaux,iaux),jaux=nbmi01,nbmxxx), + > (-1,jaux=nbmxxx+1,nbmx20) + else + write (ulsort,10091) iaux, + > (cfaent(jaux,iaux),jaux=nbmi01,nbmx20) + write (ulsort,10092) iaux, + > (cfaent(jaux,iaux),jaux=nbmi21,nbmxxx), + > (-1,jaux=nbmxxx+1,nbmx40) + endif + 33 continue + write (ulsort,10093) +c + endif +c + endif +c +c==== +c 4. formats +c==== +c +c formats communs +c --------------- +10020 format( + >/,5x,74('*'), + >/,5x,'* Num. code*',20i3,' *', + >/,5x,74('*'), + >/,5x,'* Num. de * Equivalence 0:non, 1:oui,', + > ' -1:equivalence non definie *', + >/,5x,'* Famille * 1 2 3 3 5 6 7 8 9 10', + > ' 11 12 13 14 15 16 17 18 19 20 *', + >/,5x,74('*')) +10091 format( + > 5x,'*',i8,' *',20i3,' *') +10092 format( + > 5x,'*',8x,' *',20i3,' *') +10093 format( + > 5x,74('*')) +c +11001 format( + >/,5x,33('*'), + >/,5x,'* Numero du code : * 1 *', + >/,5x,33('*')) +11002 format( + >/,5x,43('*'), + >/,5x,'* Numero du code : * 1 * 2 *' + >/,5x,43('*')) +11003 format( + >/,5x,53('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *' + >/,5x,53('*')) +11004 format( + >/,5x,63('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *', + > ' 4 *', + >/,5x,63('*')) +11006 format( + >/,5x,83('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *', + > ' 4 * 5 * 6 *', + >/,5x,83('*')) +11007 format( + >/,5x,93('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *', + > ' 4 * 5 * 6 * 7 *', + >/,5x,93('*')) +11008 format( + >/,5x,103('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *', + > ' 4 * 5 * 6 * 7 * 8 *', + >/,5x,103('*')) +11010 format( + >/,5x,123('*'), + >/,5x,'* Numero du code : * 1 * 2 * 3 *', + > ' 4 * 5 * 6 * 7 * 8 *', + > ' 9 * 10 *', + >/,5x,123('*')) +c +12001 format( + > 5x,'*',i8,' *',i10, ' *',i8 ,' *') +12002 format( + > 5x,'*',i8,' *',i10, 2(' *',i8),' *') +12003 format( + > 5x,'*',i8,' *',i10, 3(' *',i8),' *') +12004 format( + > 5x,'*',i8,' *',i10, 4(' *',i8),' *') +12005 format( + > 5x,'*',i8,' *',i10, 5(' *',i8),' *') +12006 format( + > 5x,'*',i8,' *',i10, 6(' *',i8),' *') +12007 format( + > 5x,'*',i8,' *',i10, 7(' *',i8),' *') +12008 format( + > 5x,'*',i8,' *',i10, 8(' *',i8),' *') +12010 format( + > 5x,'*',i8,' *',i10,10(' *',i8),' *') +c +c formats pour les familles de noeuds +c ----------------------------------- +20090 format( + > 5x,'* Num. de * Nombre * Famille *', + >/,5x,'* Famille * de noeuds * MED *', + >/,5x,33('*')) +20091 format( + > 5x,'* Num. de * Nombre * Famille * Famille * Famille *', + > ' Position*', + >/,5x,'* Famille * de noeuds * MED *no. tran.*ligne ex.*', + > ' *', + >/,5x,63('*')) +c +c formats pour les familles de mailles-points +c ------------------------------------------- +30090 format( + > 5x,'* Num. de * Nombre * Famille * Type * Famille *' + >/,5x,'* Famille * ma.points * MED * * sommets *', + >/,5x,53('*')) +c +c formats pour les familles d'aretes +c ---------------------------------- +40090 format( + > 5x,'* Num. de * Nombre * Famille * Type * Orient. *', + > ' Famille * Numero * Famille * Numero *', + >/,5x,'* Famille * d''aretes * MED * * *', + > ' or. inv * ligne fr*front ina* surf. fr*', + >/,5x,93('*')) +40091 format( + > 5x,'* Num. de * Nombre * Famille * Type * Orient. *', + > ' Famille * Numero * Famille * Numero *', + > ' Famille * Famille * Position*', + >/,5x,'* Famille * d''aretes * MED * * *', + > ' or. inv * ligne fr*front ina* surf. fr*', + > 'ar. tran.* quad ex.* *', + >/,5x,123('*')) +c +c formats pour les familles de triangles +c -------------------------------------- +50090 format( + > 5x,'* Num. de * Nombre * Famille * Type * Numero *', + > ' Fa. aret*', + >/,5x,'* Famille * triangles * MED * * surface*', + > ' surface *', + >/,5x,63('*')) +50091 format( + > 5x,'* Num. de * Nombre * Famille * Type * Numero *', + > ' Fa. aret*', + > ' Famille * Famille * Code * Position*', + >/,5x,'* Famille * triangles * MED * * surface*', + > ' surface *', + > 'tr. tran.* pent ex.*tria/pent* *', + >/,5x,103('*')) +c +c formats pour les familles de tetraedres, pyramides +c -------------------------------------------------- +60090 format( + > 5x,'* Num. de * Nombre * Famille * Type *', + >/,5x,'* Famille * ',a10, '* MED * *', + >/,5x,43('*')) +c +c formats pour les familles de quadrangles +c ---------------------------------------- +70090 format( + > 5x,'* Num. de * Nombre * Famille * Type * Numero *', + > ' Fa. aret* Fa. tria* Famille *', + >/,5x,'* Famille * de quads. * MED * * surface*', + > ' surface * confor. *front ina*', + >/,5x,83('*')) +70091 format( + > 5x,'* Num. de * Nombre * Famille * Type * Numero *', + > ' Fa. aret* Fa. tria* Famille *', + > ' Fa. q tr* Fa. h ex* Code * Position*', + >/,5x,'* Famille * quads. * MED * * surface*', + > ' surface * confor. *front ina*', + > '/normale1*/normale2*quad h/p * *', + >/,5x,123('*')) +c +c formats pour les familles d'hexaedres, pentaedres +c ------------------------------------------------- +80090 format( + > 5x,'* Num. de * Nombre * Famille * Type * Famille *', + > ' Famille *', + >/,5x,'* Famille * ',a10, '* MED * * tetr. *', + > ' pyra. *', + >/,5x,63('*')) +80091 format( + > 5x,'* Num. de * Nombre * Famille * Type * Famille *', + >/,5x,'* Famille * ',a10, '* MED * * pent. *', + >/,5x,53('*')) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utecfe.F b/src/tool/Utilitaire/utecfe.F new file mode 100644 index 00000000..21199b96 --- /dev/null +++ b/src/tool/Utilitaire/utecfe.F @@ -0,0 +1,431 @@ + subroutine utecfe ( maextr, + > famnoe, cfanoe, + > fammpo, cfampo, + > famare, cfaare, + > famtri, cfatri, + > famqua, cfaqua, + > famtet, cfatet, + > famhex, cfahex, + > fampyr, cfapyr, + > fampen, cfapen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ECriture des Codes de Familles d'Entites +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . famnoe . e . nbnoto . famille des noeuds . +c . cfanoe . e . nctfno*. codes des familles des noeuds . +c . . . nbfnoe . 1 : famille MED . +c . . . . si extrusion : . +c . . . . 2 : famille du noeud extrude . +c . . . . 3 : famille de l'arete perpendiculaire . +c . . . . 4 : position du noeud . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . fammpo . e . nbmpto . famille des mailles-points . +c . cfampo . e . nctfmp*. codes des familles des mailles-points . +c . . . nbfmpo . 1 : famille MED . +c . . . . 2 : type de maille-point . +c . . . . 3 : famille des sommets . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . famare . e . nbarto . famille des aretes . +c . cfaare . e . nctfar*. codes des familles des aretes . +c . . . nbfare . 1 : famille MED . +c . . . . 2 : type de segment . +c . . . . 3 : orientation . +c . . . . 4 : famille d'orientation inverse . +c . . . . 5 : numero de ligne de frontiere . +c . . . . > 0 si concernee par le suivi de frontiere. +c . . . . <= 0 si non concernee . +c . . . . 6 : famille frontiere active/inactive . +c . . . . 7 : numero de surface de frontiere . +c . . . . si extrusion : . +c . . . . 8 : famille de l'arete extrudee . +c . . . . 9 : famille du quadrangle perpendiculaire. +c . . . . 10 : position de l'arete . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . famtri . e . nbtrto . famille des triangles . +c . cfatri . e . nctftr*. codes des familles des triangles . +c . . . nbftri . 1 : famille MED . +c . . . . 2 : type de triangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . si extrusion : . +c . . . . 5 : famille du triangle extrude . +c . . . . 6 : famille du pent. perpendiculaire . +c . . . . 7 : code du triangle dans le pentaedre . +c . . . . 8 : position du triangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . famqua . e . nbquto . famille des quadrangles . +c . cfaqua . e . nctfqu*. codes des familles des quadrangles . +c . . . nbfqua . 1 : famille MED . +c . . . . 2 : type de quadrangle . +c . . . . 3 : numero de surface de frontiere . +c . . . . 4 : famille des aretes internes apres raf. +c . . . . 5 : famille des triangles de conformite . +c . . . . 6 : famille de sf active/inactive . +c . . . . Pour un quadrangle a l'avant : . +c . . . . 7 : famille du quadrangle extrude . +c . . . . 8 : famille du volume perpendiculaire . +c . . . . Pour un quadrangle perpendiculaire : . +c . . . . 7 : sens de la 1ere compos. de la normale. +c . . . . 8 : sens de la 2eme compos. de la normale. +c . . . . 9 : code du quadrangle dans hexa ou penta. +c . . . . 10 : position du quadrangle . +c . . . . si equivalence : . +c . . . . + l : appartenance a l'equivalence l . +c . famtet . e . nbteto . famille des tetraedres . +c . cfatet . e . nctfte*. codes des familles des tetraedres . +c . . . nbftet . 1 : famille MED . +c . . . . 2 : type de tetraedres . +c . famhex . e . nbheto . famille des hexaedres . +c . cfahex . e . nctfhe*. codes des familles des hexaedres . +c . . . nbfhex . 1 : famille MED . +c . . . . 2 : type d'hexaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . . . . si extrusion : . +c . . . . 3 : famille des pentaedres de conformite . +c . fampyr . e . nbpyto . famille des pyramides . +c . cfapyr . e . nctfpy*. codes des familles des pyramides . +c . . . nbfpyr . 1 : famille MED . +c . . . . 2 : type de pyramides . +c . fampen . e . nbpeto . famille des pentaedres . +c . cfapen . e . nctfpe*. codes des familles des pentaedres . +c . . . nbfpen . 1 : famille MED . +c . . . . 2 : type de pentaedres . +c . . . . 3 : famille des tetraedres de conformite . +c . . . . 4 : famille des pyramides de conformite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTECFE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "dicfen.h" +#include "nbfami.h" +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer maextr + integer famnoe(nbnoto), cfanoe(nctfno,nbfnoe) + integer fammpo(nbmpto), cfampo(nctfmp,nbfmpo) + integer famare(nbarto), cfaare(nctfar,nbfare) + integer famtri(nbtrto), cfatri(nctftr,nbftri) + integer famqua(nbquto), cfaqua(nctfqu,nbfqua) + integer famtet(nbteto), cfatet(nctfte,nbftet) + integer famhex(nbheto), cfahex(nctfhe,nbfhex) + integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr) + integer fampen(nbpeto), cfapen(nctfpe,nbfpen) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. liste des familles de noeuds +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_NO', nompro +#endif + iaux = -1 + jaux = 1 + call utecf0 ( maextr, iaux, nbnoto, + > nbfnoe, jaux, jaux, + > nctfno, ncffno, ncxfno, ncefno, + > famnoe, cfanoe, + > ulsort, langue, codret ) +c +c==== +c 3. Liste eventuelle des familles de mailles-points +c==== +c + if ( codret.eq.0 ) then +c + if ( nbfmpo.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_MP', nompro +#endif + iaux = 0 + jaux = -1 + kaux = 0 + call utecf0 ( maextr, iaux, nbmpto, + > nbfmpo, jaux, jaux, + > nctfmp, ncffmp, kaux, ncefmp, + > fammpo, cfampo, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Liste des familles d'aretes +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_AR', nompro +#endif + iaux = 1 + jaux = -1 + call utecf0 ( maextr, iaux, nbarto, + > nbfare, jaux, jaux, + > nctfar, ncffar, ncxfar, ncefar, + > famare, cfaare, + > ulsort, langue, codret ) +c + endif +c +c==== +c 5. Liste eventuelle des familles de triangles +c==== +c + if ( codret.eq.0 ) then +c + if ( nbftri.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_TR', nompro +#endif + iaux = 2 + jaux = -1 + call utecf0 ( maextr, iaux, nbtrto, + > nbftri, jaux, jaux, + > nctftr, ncfftr, ncxftr, nceftr, + > famtri, cfatri, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. Liste eventuelle des familles de quadrangles +c==== +c + if ( codret.eq.0 ) then +c + if ( nbfqua.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_QU', nompro +#endif + iaux = 4 + jaux = -1 + call utecf0 ( maextr, iaux, nbquto, + > nbfqua, nbftri, jaux, + > nctfqu, ncffqu, ncxfqu, ncefqu, + > famqua, cfaqua, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 7. liste eventuelle des familles de tetraedres +c==== +c + if ( codret.eq.0 ) then +c + if ( nbftet.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_TE', nompro +#endif + iaux = 3 + jaux = -1 + kaux = 0 + call utecf0 ( maextr, iaux, nbteto, + > nbftet, jaux, jaux, + > nctfte, ncffte, kaux, kaux, + > famtet, cfatet, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 8. liste eventuelle des familles d'hexaedres +c==== +c + if ( codret.eq.0 ) then +c + if ( nbfhex.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_HE', nompro +#endif + iaux = 6 + kaux = 0 + call utecf0 ( maextr, iaux, nbheto, + > nbfhex, nbftet, nbfpyr, + > nctfhe, ncffhe, kaux, kaux, + > famhex, cfahex, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 9. liste eventuelle des familles de pyramides +c==== +c + if ( codret.eq.0 ) then +c + if ( nbfpyr.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_PY', nompro +#endif + iaux = 5 + jaux = -1 + kaux = 0 + call utecf0 ( maextr, iaux, nbpyto, + > nbfpyr, jaux, jaux, + > nctfpy, ncffpy, kaux, kaux, + > fampyr, cfapyr, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 10. liste eventuelle des familles de pentaedres +c==== +c + if ( codret.eq.0 ) then +c + if ( nbfpen.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTECF0_PE', nompro +#endif + iaux = 7 + kaux = 0 + call utecf0 ( maextr, iaux, nbpeto, + > nbfpen, nbftet, nbfpyr, + > nctfpe, ncffpe, kaux, kaux, + > fampen, cfapen, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 11. la fin +c==== +c + if ( codret.eq.0 ) then +c + 1100 format(/,5x,123('-'),/) + write (ulsort,1100) +c + endif +c +c==== +c 12. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utehex.F b/src/tool/Utilitaire/utehex.F new file mode 100644 index 00000000..bd72bbb4 --- /dev/null +++ b/src/tool/Utilitaire/utehex.F @@ -0,0 +1,292 @@ + subroutine utehex ( nbheto, nbhfal, nbhaal, nbqual, + > somare, arequa, + > quahex, coquhe, arehex, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des HEXaedres +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbheto . e . 1 . nombre de hexaedres a examiner . +c . nbhfal . e . 1 . nombre de hexas par faces pour les allocs . +c . nbhaal . e . 1 . nbre de hexas par aretes pour les allocs . +c . nbqual . e . 1 . nombre de quadrangles pour les allocations . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. code des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logitee d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logitee de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTEHEX' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbheto, nbhfal, nbhaal, nbqual + integer somare(2,*) + integer arequa(nbqual,4) + integer quahex(nbhfal,6), coquhe(nbhfal,6), arehex(nbhaal,12) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux + integer lehexa, lehex0 + integer f1, f2, f3, f4, f5, f6 + integer listar(12), listso(8) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(5x,''Controle des '',i10,'' hexaedres.'')' + texte(1,7) = + > '(''L''''hexaedre '',i10,'' a des '',a,'' identiques :'',12i10)' + texte(1,10) = + > '(''Les aretes de l''''hexaedre '',i10,'' ne se suivent pas.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des hexaedres'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,6) = '(5x,''Control of '',i10,'' hexahedrons.'')' + texte(2,7) = + > '(''Hexahedron # '',i10,'' has got similar '',a,'':'',12i10)' + texte(2,10) = + > '(''Edges of hexahedron '',i10,'' are not following.'')' + texte(2,16) = '(5x,''No problem with hexaedra definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,6)) nbheto +c + codret = 0 +c +c==== +c 2. verification +c==== +c + do 20 , lehex0 = 1 , nbheto +c + lehexa = lehex0 +c + codre0 = 0 +c +c 2.1. ==> les faces doivent etre differentes ... +c + if ( lehexa.le.nbhfal ) then +c + f1 = quahex(lehexa,1) + f2 = quahex(lehexa,2) + f3 = quahex(lehexa,3) + f4 = quahex(lehexa,4) + f5 = quahex(lehexa,5) + f6 = quahex(lehexa,6) +c + if ( f1.eq.f2 .or. + > f1.eq.f3 .or. + > f1.eq.f4 .or. + > f1.eq.f5 .or. + > f1.eq.f6 .or. + > f2.eq.f3 .or. + > f2.eq.f4 .or. + > f2.eq.f5 .or. + > f2.eq.f6 .or. + > f3.eq.f4 .or. + > f3.eq.f5 .or. + > f3.eq.f6 .or. + > f4.eq.f5 .or. + > f4.eq.f6 .or. + > f5.eq.f6 ) then + codre0 = 1 + write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,8), + > f1, f2, f3, f4, f5, f6 + write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,8), + > f1, f2, f3, f4, f5, f6 + endif +c + endif +c +c 2.2. ==> les aretes doivent etre differentes ... +c + if ( codre0.eq.0 ) then +c + call utashe ( lehexa, + > nbqual, nbhfal, nbhaal, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + endif +c + if ( codre0.eq.0 ) then +c + do 22 , iaux = 1 , 11 + do 221 , jaux = iaux+1 , 12 + if ( listar(iaux).eq.listar(jaux) ) then + codre0 = 1 + endif + 221 continue + 22 continue +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,1), + > (listar(iaux),iaux=1,12) + write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,1), + > (listar(iaux),iaux=1,12) + endif +c + endif +c +c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ... +c + if ( codre0.eq.0 ) then +c + iaux = 6 + jaux = 12 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( iaux, lehexa, jaux, listar, somare, + > ulbila, ulsort, langue, codre0 ) +c + endif +c +c 2.4. ==> les sommets doivent etre differents ... +c + if ( codre0.eq.0 ) then +c + do 24 , iaux = 1 , 7 + do 241 , jaux = iaux+1 , 8 + if ( listso(iaux).eq.listso(jaux) ) then + codre0 = 1 + endif + 241 continue + 24 continue +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,-1), + > (listso(iaux),iaux=1,8) + write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,-1), + > (listso(iaux),iaux=1,8) + endif +c + endif +c +c 2.5. ==> cumul des erreurs +c + codret = codret + codre0 +c + 20 continue +c +c 2.6. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utench.F b/src/tool/Utilitaire/utench.F new file mode 100644 index 00000000..61fb61fe --- /dev/null +++ b/src/tool/Utilitaire/utench.F @@ -0,0 +1,300 @@ + subroutine utench ( entier, cadrag, lgchac, chacar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - convertit un ENtier en CHaine de caractere +c -- -- -- +c +c Si la chaine fournie est plus longue que le nombre de chiffres a +c ecrire, on complete par des blancs a droite ou a gauche, ou des 0 +c a gauche selon le type de cadrage demande. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . entier . e . 1 . entier a convertir . +c . cadrag . e . char*1 . type de cadrage d'entier ecrit . +c . . . . g/G : le nombre est cadre a gauche : '83 '. +c . . . . d/D : le nombre est cadre a droite : ' 83'. +c . . . . et on complete par des blancs . +c . . . . 0 : le nombre est cadre a droite et on . +c . . . . complete par des 0 : '0083' . +c . . . . _ : le nombre est cadre a droite et on . +c . . . . complete par des _ : '__83' . +c . lgchac . s . 1 . longueur de la chaine obtenue . +c . chacar . s .char*(*). chaine de caractere . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c . . . . 2 : le nombre est trop grand . +c . . . . 3 : type de cadrage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTENCH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer entier, lgchac +c + character*1 cadrag + character*(*) chacar +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, lgch00 +c + logical cadgau, negati +c + character*1 saux01 + character*5 fmt +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Cadrage voulu : '',a1)' + texte(1,5) = '(''La chaine est trop petite : longueur = '',i4)' + texte(1,6) = '(''Il faudrait au moins '',i4,'' places.'')' + texte(1,7) = '(''Le nombre est trop grand.'')' + texte(1,8) = '(''Le type de cadrage est mauvais : '',a1)' + texte(1,9) = '(''Longueur de la chaine obtenue : '',i8)' + texte(1,10) = '(''Chaine obtenue : '',a,/)' + texte(1,20) = '(''Entier a convertir : '',i8)' +c + texte(2,4) = '(''Choice : '',a1)' + texte(2,5) = '(''The string is too short : length = '',i4)' + texte(2,6) = '(''At less'',i4,'' places are needed.'')' + texte(2,7) = '(''The integer is too big.'')' + texte(2,8) = '(''Bad choice : '',a1)' + texte(2,9) = '(''Lenght of chain : '',i8)' + texte(2,10) = '(''Chain : '',a,/)' + texte(2,20) = '(''Integer to convert : '',i8)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) entier + write (ulsort,texte(langue,4)) cadrag +#endif +c +c==== +c 2. decodage +c==== +c + codret = 0 +c +c 2.1. ==> type de cadrage +c + if ( cadrag.eq.'d' .or. cadrag.eq.'D' .or. + > cadrag.eq.'0' .or. cadrag.eq.'_' ) then + cadgau = .false. + elseif ( cadrag.eq.'g' .or. cadrag.eq.'G' ) then + cadgau = .true. + else + codret = 3 + endif +c +c 2.2. ==> point de depart +c + lgch00 = len(chacar) + kaux = entier +c +c 2.3. ==> si le numero est strictement negatif, il faut inserer - +c + if ( codret.eq.0 ) then +c + if ( kaux.lt.0 ) then + lgchac = 1 + if ( lgch00.le.1 ) then + codret = 1 + endif + if ( codret.eq.0 ) then + negati = .true. + kaux = - kaux + endif + else + lgchac = 0 + negati = .false. + endif +c + endif +c +c 2.4. ==> nombre de chiffres de l'entier a convertir et ecriture +c + if ( codret.eq.0 ) then +c +c 2.4.1. ==> si le numero est nul : on le traite tout de suite car cela +c simplifie l'algorithme general +c + if ( kaux.eq.0 ) then +c + if ( lgch00.eq.0 ) then + codret = 1 + endif + if ( codret.eq.0 ) then + if ( cadgau ) then + chacar(1:1) = '0' + else + chacar(lgch00:lgch00) = '0' + endif + lgchac = 1 + endif +c +c 2.4.2. ==> pour un nombre non nul, le puissance de 10 immediatement +c superieure equivaut au nombre de chiffres. +c + else +c + jaux = 0 + do 2421 , iaux = 1 , 99 + if ( kaux.lt.10**iaux ) then + jaux = iaux + goto 2422 + endif + 2421 continue +c + 2422 continue +c + if ( jaux.eq.0 ) then + codret = 2 + elseif ( lgchac+jaux.gt.lgch00 ) then + codret = 1 + lgchac = lgchac+jaux + else + fmt = '(I ' + if ( jaux.lt.10 ) then + write(fmt(3:3),'(i1)') jaux + fmt(4:4) = ')' + else + write(fmt(3:4),'(i2)') jaux + fmt(5:5) = ')' + endif + if ( cadgau ) then + write (chacar(lgchac+1:lgchac+jaux),fmt) kaux + if ( negati ) then + chacar(lgchac:lgchac) = '-' + endif + else + write (chacar(lgch00-jaux+1:lgch00),fmt) kaux + if ( negati ) then + chacar(lgch00-jaux:lgch00-jaux) = '-' + endif + endif + lgchac = lgchac+jaux + endif +c + endif +c + endif +c +c 2.5. ==> complement avec des blancs ou des zeros +c + if ( codret.eq.0 ) then +c + if ( cadgau ) then + saux01 = ' ' + jaux = lgchac+1 + kaux = lgch00 + else + if ( cadrag.eq.'0' ) then + saux01 = '0' + elseif ( cadrag.eq.'_' ) then + saux01 = '_' + else + saux01 = ' ' + endif + jaux = 1 + kaux = lgch00-lgchac + lgchac = lgch00 + endif +c + do 25 , iaux = jaux, kaux + chacar(iaux:iaux) = saux01 + 25 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) lgchac + write (ulsort,texte(langue,10)) chacar +#endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,20)) entier + if ( codret.eq.1 ) then + write (ulsort,texte(langue,5)) lgch00 + write (ulsort,texte(langue,6)) lgchac + elseif ( codret.eq.2 ) then + write (ulsort,texte(langue,7)) + elseif ( codret.eq.3 ) then + write (ulsort,texte(langue,8)) cadrag + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utepen.F b/src/tool/Utilitaire/utepen.F new file mode 100644 index 00000000..b84e4584 --- /dev/null +++ b/src/tool/Utilitaire/utepen.F @@ -0,0 +1,278 @@ + subroutine utepen ( nbpeto, nbpfal, nbpaal, nbqual, + > somare, + > arequa, + > facpen, cofape, arepen, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des PENtaedres +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpeto . e . 1 . nombre de pentaedres a examiner . +c . nbpfal . e . 1 . nombre de pents par faces pour les allocs . +c . nbpaal . e . 1 . nbre de pents par aretes pour les allocs . +c . nbqual . e . 1 . nombre de quadrangles pour les allocations . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. code des 9 aretes des pentaedres . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logitee d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logitee de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTEPEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbpeto, nbpfal, nbpaal, nbqual + integer somare(2,*) + integer arequa(nbqual,4) + integer facpen(nbpfal,5), cofape(nbpfal,5), arepen(nbpaal,9) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux + integer lepent, lepen0 + integer f1, f2, f3, f4, f5 + integer listar(9), listso(6) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(5x,''Controle des '',i10,'' pentaedres.'')' + texte(1,7) = + > '(''Le pentaedre '',i10,'' a des '',a,'' identiques :'',12i10)' + texte(1,10) = + > '(''Les aretes du pentaedre '',i10,'' ne se suivent pas.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des pentaedres'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,6) = '(5x,''Control of '',i10,'' pentahedrons.'')' + texte(2,7) = + > '(''Pentahedron # '',i10,'' has got similar '',a,'':'',12i10)' + texte(2,10) = + > '(''Edges of pentahedron '',i10,'' are not following.'')' + texte(2,16) = '(5x,''No problem with pentahedrons definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,6)) nbpeto +c +c 1.3. ==> constantes +c + codret = 0 +c +c==== +c 2. verification +c==== +c + do 20 , lepen0 = 1 , nbpeto +c + lepent = lepen0 +c + codre0 = 0 +c +c 2.1. ==> les faces doivent etre differentes ... +c + f1 = facpen(lepent,1) + f2 = facpen(lepent,2) + f3 = facpen(lepent,3) + f4 = facpen(lepent,4) + f5 = facpen(lepent,5) +c + if ( f1.eq.f2 ) then + codre0 = 1 + write (ulsort,texte(langue,7)) lepent, mess14(langue,3,2), + > f1, f2 + write (ulbila,texte(langue,7)) lepent, mess14(langue,3,2), + > f1, f2 + endif +c + if ( f3.eq.f4 .or. + > f3.eq.f5 .or. + > f4.eq.f5 ) then + codre0 = 1 + write (ulsort,texte(langue,7)) lepent, mess14(langue,3,4), + > f3, f4, f5 + write (ulbila,texte(langue,7)) lepent, mess14(langue,3,4), + > f3, f4, f5 + endif +c +c 2.2. ==> les aretes doivent etre differentes ... +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTASPE', nompro +#endif + call utaspe ( lepent, + > nbqual, nbpfal, nbpaal, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c + do 22 , iaux = 1 , 8 + do 221 , jaux = iaux+1 , 9 + if ( listar(iaux).eq.listar(jaux) ) then + codre0 = 1 + endif + 221 continue + 22 continue +c + endif +c +c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ... +c + if ( codre0.eq.0 ) then +c + iaux = 7 + jaux = 9 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( iaux, lepent, jaux, listar, somare, + > ulbila, ulsort, langue, codre0 ) +c + endif +c +c 2.4. ==> les sommets doivent etre differents ... +c + if ( codre0.eq.0 ) then +c + do 24 , iaux = 1 , 5 + do 241 , jaux = iaux+1 , 6 + if ( listso(iaux).eq.listso(jaux) ) then + codre0 = 1 + endif + 241 continue + 24 continue +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,7)) lepent, mess14(langue,3,-1), + > (listso(iaux),iaux=1,6) + write (ulbila,texte(langue,7)) lepent, mess14(langue,3,-1), + > (listso(iaux),iaux=1,6) + endif +c + endif +c +c 2.5. ==> cumul des erreurs +c + codret = codret + codre0 +c + 20 continue +c +c 2.6. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utepyr.F b/src/tool/Utilitaire/utepyr.F new file mode 100644 index 00000000..5bdee9e7 --- /dev/null +++ b/src/tool/Utilitaire/utepyr.F @@ -0,0 +1,287 @@ + subroutine utepyr ( nbpyto, nbyfal, nbyaal, nbtral, + > somare, aretri, + > facpyr, cofapy, arepyr, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des PYRamides +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpyto . e . 1 . nombre de pyramides a examiner . +c . nbyfal . e . 1 . nbre de pyras par faces pour les allocs . +c . nbyaal . e . 1 . nbre de pyras par aretes pour les allocs . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbyaal*8. numeros des 8 aretes des pyramides . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logitee d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logitee de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTEPYR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbpyto, nbyfal, nbyaal, nbtral + integer somare(2,*) + integer aretri(nbtral,4) + integer facpyr(nbyfal,5), cofapy(nbyfal,5), arepyr(nbyaal,8) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux + integer nbpyal + integer lapyra, lapyr0 + integer f1, f2, f3, f4 + integer listar(8), listso(5) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(5x,''Controle des '',i10,'' pyramides.'')' + texte(1,7) = + > '(''La pyramide '',i10,'' a des '',a,'' identiques :'',12i10)' + texte(1,10) = + > '(''Les aretes de la pyramide '',i10,'' ne se suivent pas.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des pyramides'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,6) = '(5x,''Control of '',i10,'' pyramids.'')' + texte(2,7) = + > '(''Pyramid # '',i10,'' has got similar '',a,'':'',12i10)' + texte(2,10) = + > '(''Edges of pyramid '',i10,'' are not following.'')' + texte(2,16) = '(5x,''No problem with pyramid definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,6)) nbpyto +cgn write (ulsort,*) nbyfal, nbyaal +c +c 1.3. ==> constantes +c + codret = 0 +c +c==== +c 2. verification +c==== +c + nbpyal = nbyfal + nbyaal +c + do 20 , lapyr0 = 1 , nbpyto +c + lapyra = lapyr0 +c + codre0 = 0 +c +c 2.1. ==> les faces doivent etre differentes ... +c + if ( lapyra.le.nbyfal ) then +c + f1 = facpyr(lapyra,1) + f2 = facpyr(lapyra,2) + f3 = facpyr(lapyra,3) + f4 = facpyr(lapyra,4) +c + if ( f1.eq.f2 .or. + > f1.eq.f3 .or. + > f1.eq.f4 .or. + > f2.eq.f3 .or. + > f2.eq.f4 .or. + > f3.eq.f4 ) then + codre0 = 1 + write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,2), + > f1, f2, f3, f4 + write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,2), + > f1, f2, f3, f4 + endif +c + endif +c +c 2.2. ==> les aretes doivent etre differentes ... +c + if ( codre0.eq.0 ) then +c + call utaspy ( lapyra, + > nbtral, nbyfal, nbyaal, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c + endif +c + if ( codre0.eq.0 ) then +c + do 221 , iaux = 1 , 7 + do 222 , jaux = iaux+1 , 8 + if ( listar(iaux).eq.listar(jaux) ) then + codre0 = 1 + endif + 222 continue + 221 continue +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,1), + > (listar(iaux),iaux=1,8) + write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,1), + > (listar(iaux),iaux=1,8) + endif +c + endif +c +c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ... +c + if ( codre0.eq.0 ) then +c + iaux = 5 + jaux = 8 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( iaux, lapyra, jaux, listar, somare, + > ulbila, ulsort, langue, codre0 ) +c + endif +c +c 2.4. ==> les sommets doivent etre differents ... +c + if ( codre0.eq.0 ) then +c + do 24 , iaux = 1 , 4 + do 241 , jaux = iaux+1 , 5 + if ( listso(iaux).eq.listso(jaux) ) then + codre0 = 1 + endif + 241 continue + 24 continue +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,-1), + > (listso(iaux),iaux=1,5) + write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,-1), + > (listso(iaux),iaux=1,5) + endif +c + endif +c +c 2.5. ==> cumul des erreurs +c + codret = codret + codre0 +c + 20 continue +c +c 2.6. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utequa.F b/src/tool/Utilitaire/utequa.F new file mode 100644 index 00000000..4b7b89d6 --- /dev/null +++ b/src/tool/Utilitaire/utequa.F @@ -0,0 +1,510 @@ + subroutine utequa ( nbquto, nbqual, nbnoal, sdim, + > coonoe, somare, arequa, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des QUAdrangles +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbquto . e . 1 . nombre de quadrangles a examiner . +c . nbqual . e . 1 . nombre de quadrangles pour les allocations . +c . nbnoal . e . 1 . nombre de noeuds pour les allocations . +c . sdim . e . 1 . dimension du maillage . +c . coonoe . e . nbnoal . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTEQUA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbquto, nbqual, nbnoal, sdim + integer somare(2,*) + integer arequa(nbqual,4) +c + double precision coonoe(nbnoal,sdim) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux, kaux, laux + integer ulaux + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer listar(4) +c + double precision v1(3), v2(3), v3(3), v4(3) + double precision v12(3), v34(3) + double precision daux +c + character*1 saux01(3) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data saux01 / 'x', 'y', 'z' / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(5x,''Controle des '',i10,1x,a)' + texte(1,6) = '(a,'' numero '',i10)' + texte(1,7) = '(''Les '',a,'' sont :'',4i10)' + texte(1,8) = '(''Les '',a,'' sont confondus :'',4i10)' + texte(1,10) = '(''Le '',a,'' est croise.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des quadrangles'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,5) = '(5x,''Control of '',i10,1x,a)' + texte(2,6) = '(a,'' # '',i10)' + texte(2,7) = '(''The '',a,'' are :'',4i10)' + texte(2,8) = '(''The '',a,'' are similar :'',4i10)' + texte(2,10) = '(''The '',a,'' is overlapped.'')' + texte(2,16) = '(5x,''No problem with quadrangle definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c + 1000 format('Arete a',i1,' :',i10,' de',i10,' a',i10) + 1001 format('Noeud',i10,' :', 3(2x,a,' =',g12.5) ) +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,5)) nbquto, mess14(langue,3,4) +c +c 1.3. ==> constantes +c + codret = 0 +c +c==== +c 2. verification +c==== +c +ccc do 20 , iaux = 1 , nbquto + do 20 , iaux = 1 , 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,2,4), iaux +#endif +c + codre0 = 0 +c +c 2.1. ==> les aretes doivent etre differentes ... +c + a1 = arequa(iaux,1) + a2 = arequa(iaux,2) + a3 = arequa(iaux,3) + a4 = arequa(iaux,4) +c + if ( a1.eq.a2 .or. + > a1.eq.a3 .or. + > a1.eq.a4 .or. + > a2.eq.a3 .or. + > a2.eq.a4 .or. + > a3.eq.a4 ) then + codre0 = 1 + write (ulsort,texte(langue,6)) mess14(langue,2,4), iaux + write (ulsort,texte(langue,8)) mess14(langue,3,1), a1,a2,a3,a4 + write (ulbila,texte(langue,6)) mess14(langue,2,4), iaux + write (ulbila,texte(langue,8)) mess14(langue,3,1), a1,a2,a3,a4 + endif +c +c 2.2. ==> les aretes doivent se suivre ... +c + if ( codre0.eq.0 ) then +c + listar(1) = a1 + listar(2) = a2 + listar(3) = a3 + listar(4) = a4 + jaux = 4 + kaux = 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( jaux, iaux, kaux, listar, somare, + > ulbila, ulsort, langue, codre0 ) +c + endif +c +c 2.3. ==> les sommets doivent etre differents ... +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOQU', nompro +#endif + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + if ( sa1a2.eq.sa2a3 .or. + > sa1a2.eq.sa3a4 .or. + > sa1a2.eq.sa4a1 .or. + > sa2a3.eq.sa3a4 .or. + > sa2a3.eq.sa4a1 .or. + > sa1a2.eq.sa4a1 ) then +c + codre0 = 1 +c + if ( ulsort.ne.ulbila ) then + jaux = 2 + else + jaux = 1 + endif +c + do 23 , kaux = 1 , jaux +c + if ( kaux.eq.1 ) then + ulaux = ulsort + else + ulaux = ulbila + endif +c + write (ulaux,texte(langue,8)) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 + write(ulaux,*) 'a1',somare(1,a1),somare(2,a1) + write(ulaux,*) coonoe(somare(1,a1),1),coonoe(somare(1,a1),2) + > ,coonoe(somare(1,a1),3) + write(ulaux,*) coonoe(somare(2,a1),1),coonoe(somare(2,a1),2) + > ,coonoe(somare(2,a1),3) + write(ulaux,*) 'a2',somare(1,a2),somare(2,a2) + write(ulaux,*) coonoe(somare(1,a2),1),coonoe(somare(1,a2),2) + > ,coonoe(somare(1,a2),3) + write(ulaux,*) coonoe(somare(2,a2),1),coonoe(somare(2,a2),2) + > ,coonoe(somare(2,a2),3) + write(ulaux,*) 'a3',somare(1,a3),somare(2,a3) + write(ulaux,*) coonoe(somare(1,a3),1),coonoe(somare(1,a3),2) + > ,coonoe(somare(1,a3),3) + write(ulaux,*) coonoe(somare(2,a3),1),coonoe(somare(2,a3),2) + > ,coonoe(somare(2,a3),3) + write(ulaux,*) 'a4',somare(1,a4),somare(2,a4) + write(ulaux,*) coonoe(somare(1,a4),1),coonoe(somare(1,a4),2) + > ,coonoe(somare(1,a4),3) + write(ulaux,*) coonoe(somare(2,a4),1),coonoe(somare(2,a4),2) + > ,coonoe(somare(2,a4),3) + write(ulaux,*) coonoe(sa1a2,1), coonoe(sa1a2,2), + > coonoe(sa1a2,3) + write(ulaux,*) coonoe(sa2a3,1), coonoe(sa2a3,2), + > coonoe(sa2a3,3) + write(ulaux,*) coonoe(sa3a4,1), coonoe(sa3a4,2), + > coonoe(sa3a4,3) + write(ulaux,*) coonoe(sa4a1,1), coonoe(sa4a1,2), + > coonoe(sa4a1,3) +c + 23 continue +c + endif +c + endif +c +c 2.4. ==> il ne faut pas croiser ... +c pour cela, il faut que les deux produits vectoriels +c a1xa2 et a3xa4 soient dans la meme orientation. On teste +c si leur produit scalaire est >0 +c Remarque : cela suppose que le quadrangle est plan +c +c sa4a1 a4 sa3a4 sa4a1 sa2a3 +c ._______. . . +c . . .. .. +c . . . .a4 . . +c a1. .a3 a1. . . .a3 +c . . . . . +c . . . . . . +c . . . . . . +c . . .. a2 .. +c ._______. . . +c sa1a2 a2 sa2a3 sa1a2 sa3a4 +c +c + if ( codre0.eq.0 ) then +c + if ( sdim.eq.2 ) then +c + v1(1) = coonoe(sa4a1,1) - coonoe(sa1a2,1) + v1(2) = coonoe(sa4a1,2) - coonoe(sa1a2,2) +c + v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) +c + v3(1) = coonoe(sa2a3,1) - coonoe(sa3a4,1) + v3(2) = coonoe(sa2a3,2) - coonoe(sa3a4,2) +c + v4(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1) + v4(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2) +c +c v12 represente le produit vectoriel a1xa2. +c + v12(3) = v1(1)*v2(2) - v1(2)*v2(1) +c +c v34 represente le produit vectoriel a3xa4. +c + v34(3) = v3(1)*v4(2) - v3(2)*v4(1) +c + daux = v12(3)*v34(3) +c +#ifdef _DEBUG_HOMARD_ + if ( iaux.eq.1 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 + write (ulsort,1001) sa1a2, + > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim) + write (ulsort,1001) sa2a3, + > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim) + write (ulsort,1001) sa3a4, + > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim) + write (ulsort,1001) sa4a1, + > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim) + write (ulsort,*) ' ' + write (ulsort,1789) 'v1', v1(1), v1(2) + write (ulsort,1789) 'v2', v2(1), v2(2) + write (ulsort,1789) 'v3', v3(1), v3(2) + write (ulsort,1789) 'v4', v4(1), v4(2) + write (ulsort,*) ' ' + write (ulsort,1789) 'v12(3) = ', v12(3) + write (ulsort,1789) 'v34(3) = ', v34(3) + write (ulsort,1789) ' ==> daux =',daux + endif + 1789 format(a,' : ',2g13.5,a,g13.5) +#endif +c + else +c + v1(1) = coonoe(sa4a1,1) - coonoe(sa1a2,1) + v1(2) = coonoe(sa4a1,2) - coonoe(sa1a2,2) + v1(3) = coonoe(sa4a1,3) - coonoe(sa1a2,3) +c + v2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + v2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + v2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) +c + v3(1) = coonoe(sa2a3,1) - coonoe(sa3a4,1) + v3(2) = coonoe(sa2a3,2) - coonoe(sa3a4,2) + v3(3) = coonoe(sa2a3,3) - coonoe(sa3a4,3) +c + v4(1) = coonoe(sa4a1,1) - coonoe(sa3a4,1) + v4(2) = coonoe(sa4a1,2) - coonoe(sa3a4,2) + v4(3) = coonoe(sa4a1,3) - coonoe(sa3a4,3) +c +c v12 represente le produit vectoriel a1xa2. +c + v12(1) = v1(2)*v2(3) - v1(3)*v2(2) + v12(2) = v1(3)*v2(1) - v1(1)*v2(3) + v12(3) = v1(1)*v2(2) - v1(2)*v2(1) +c +c v34 represente le produit vectoriel a3xa4. +c + v34(1) = v3(2)*v4(3) - v3(3)*v4(2) + v34(2) = v3(3)*v4(1) - v3(1)*v4(3) + v34(3) = v3(1)*v4(2) - v3(2)*v4(1) +c + daux = v12(1)*v34(1) + v12(2)*v34(2) + v12(3)*v34(3) +c +#ifdef _DEBUG_HOMARD_ + if ( iaux.eq.1 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 + write (ulsort,1001) sa1a2, + > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim) + write (ulsort,1001) sa2a3, + > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim) + write (ulsort,1001) sa3a4, + > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim) + write (ulsort,1001) sa4a1, + > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim) + write (ulsort,*) ' ' + write (ulsort,1792) 'v1', v1(1), v1(2) + write (ulsort,1792) 'v2', v2(1), v2(2) + write (ulsort,1792) 'v3', v3(1), v3(2) + write (ulsort,1792) 'v4', v4(1), v4(2) + write (ulsort,*) ' ' + write (ulsort,1792) 'v12(1) = ', v12(1) + write (ulsort,1792) 'v12(2) = ', v12(2) + write (ulsort,1792) 'v12(3) = ', v12(3) + write (ulsort,1792) 'v34(1) = ', v34(1) + write (ulsort,1792) 'v34(2) = ', v34(2) + write (ulsort,1792) 'v34(3) = ', v34(3) + write (ulsort,1792) ' ==> daux =',daux + endif + 1792 format(a,' : ',2g13.5,a,g13.5) +#endif +c + endif +c + if ( daux.le.0.d0 ) then +c + codre0 = 1 +c + if ( ulsort.ne.ulbila ) then + jaux = 2 + else + jaux = 1 + endif +c + do 24 , kaux = 1 , jaux +c + if ( kaux.eq.1 ) then + ulaux = ulsort + else + ulaux = ulbila + endif +c + write (ulaux,texte(langue,6)) mess14(langue,2,4), iaux + write (ulaux,texte(langue,7)) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 + write (ulaux,texte(langue,10)) mess14(langue,1,4) + write(ulaux,1001) sa1a2, + > (saux01(laux),coonoe(sa1a2,laux),laux=1,sdim) + write(ulaux,1001) sa2a3, + > (saux01(laux),coonoe(sa2a3,laux),laux=1,sdim) + write(ulaux,1001) sa3a4, + > (saux01(laux),coonoe(sa3a4,laux),laux=1,sdim) + write(ulaux,1001) sa4a1, + > (saux01(laux),coonoe(sa4a1,laux),laux=1,sdim) +cgn write(ulaux,*) coonoe(sa1a2,1), coonoe(sa1a2,2), +cgn > coonoe(sa1a2,3) +cgn write(ulaux,*) coonoe(sa2a3,1), coonoe(sa2a3,2), +cgn > coonoe(sa2a3,3) +cgn write(ulaux,*) coonoe(sa3a4,1), coonoe(sa3a4,2), +cgn > coonoe(sa3a4,3) +cgn write(ulaux,*) coonoe(sa4a1,1), coonoe(sa4a1,2), +cgn > coonoe(sa4a1,3) + write(ulaux,1000) 1,a1,somare(1,a1),somare(2,a1) +cgn write(ulaux,1001) somare(1,a1),coonoe(somare(1,a1),1), +cgn > coonoe(somare(1,a1),2),coonoe(somare(1,a1),3) +cgn write(ulaux,1001) somare(2,a1),coonoe(somare(2,a1),1), +cgn > coonoe(somare(2,a1),2),coonoe(somare(2,a1),3) + write(ulaux,1000) 2,a2,somare(1,a2),somare(2,a2) +cgn write(ulaux,1001) somare(1,a2),coonoe(somare(1,a2),1), +cgn > coonoe(somare(1,a2),2),coonoe(somare(1,a2),3) +cgn write(ulaux,1001) somare(2,a2),coonoe(somare(2,a2),1), +cgn > coonoe(somare(2,a2),2),coonoe(somare(2,a2),3) + write(ulaux,1000) 3,a3,somare(1,a3),somare(2,a3) +cgn write(ulaux,1001) somare(1,a3), coonoe(somare(1,a3),1), +cgn > coonoe(somare(1,a3),2),coonoe(somare(1,a3),3) +cgn write(ulaux,1001) somare(2,a3), coonoe(somare(2,a3),1), +cgn > coonoe(somare(2,a3),2),coonoe(somare(2,a3),3) + write(ulaux,1000) 4,a4,somare(1,a4),somare(2,a4) +cgn write(ulaux,1001) somare(1,a4), coonoe(somare(1,a4),1), +cgn > coonoe(somare(1,a4),2),coonoe(somare(1,a4),3) +cgn write(ulaux,1001) somare(2,a4), coonoe(somare(2,a4),1), +cgn > coonoe(somare(2,a4),2),coonoe(somare(2,a4),3) +c + 24 continue +c + endif +c + endif +c +c 2.5. ==> cumul des erreurs +c + codret = codret + codre0 +c + 20 continue +c +c 2.6. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utetet.F b/src/tool/Utilitaire/utetet.F new file mode 100644 index 00000000..b2f59cac --- /dev/null +++ b/src/tool/Utilitaire/utetet.F @@ -0,0 +1,182 @@ + subroutine utetet ( nbteto, nbtfal, nbtaal, nbtral, + > somare, aretri, + > tritet, cotrte, aretet, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des TETraedres +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbteto . e . 1 . nombre de tetraedres a examiner . +c . nbtfal . e . 1 . nombre de tetrs par faces pour les allocs . +c . nbtaal . e . 1 . nbre de tetrs par aretes pour les allocs . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logitee d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logitee de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTETET' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbteto, nbtfal, nbtaal, nbtral + integer somare(2,*) + integer aretri(nbtral,3) + integer tritet(nbtfal,4), cotrte(nbtfal,4), aretet(nbtaal,6) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(5x,''Controle des '',i10,'' tetraedres.'')' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des tetraedres'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,6) = '(5x,''Control of '',i10,'' tetraedres.'')' + texte(2,16) = '(5x,''No problem with tetraedra definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,6)) nbteto +c +c==== +c 2. verification +c==== +c + codre0 = 0 +c + do 20 , iaux = 1 , nbteto +c +c 2.1. ==> analyse du tetraedre courant +c + jaux = iaux + call utvte0 ( jaux, nbtfal, nbtaal, nbtral, + > somare, aretri, + > tritet, cotrte, aretet, + > ulbila, + > ulsort, langue, codret ) +c +c 2.2. ==> cumul des erreurs +c + codre0 = codre0 + codret +c + 20 continue +c +c 2.6. ==> Bilan +c + if ( codre0.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c + codret = codre0 +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utetri.F b/src/tool/Utilitaire/utetri.F new file mode 100644 index 00000000..9061599c --- /dev/null +++ b/src/tool/Utilitaire/utetri.F @@ -0,0 +1,229 @@ + subroutine utetri ( nbtrto, nbtral, + > aretri, somare, + > nmprog, avappr, ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Examen des TRIangles +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtrto . e . 1 . nombre de triangles a examiner . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTETRI' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbtrto, nbtral + integer aretri(nbtral,3) + integer somare(2,*) +c + character*(*) nmprog +c + integer avappr +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux, kaux + integer a1, a2, a3 + integer sa1a2, sa2a3, sa3a1 + integer listar(3) +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,6) = '(5x,''Controle des '',i10,'' triangles.'')' + texte(1,7) = + > '(''Le triangle '',i10,'' a des aretes confondues :'',3i10)' + texte(1,8) = + > '(''Le triangle '',i10,'' a des noeuds confondus :'',3i10)' + texte(1,16) = + > '(5x,''Pas de probleme dans la definition des triangles'',/)' + texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)' + texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)' + texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)' + texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)' +c + texte(2,6) = '(5x,''Control of '',i10,'' triangles.'')' + texte(2,7) = + > '(''Edges of triangle # '',i10,'' are similar :'',3i10)' + texte(2,8) = + > '(''Nodes of triangle # '',i10,'' are similar :'',3i10)' + texte(2,16) = '(5x,''No problem with triangle definition'',/)' + texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)' + texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)' + texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)' + texte(2,20) = '(/,''.. After calling '',a,'' :'',/)' +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,18+avappr)) nmprog + else + write (ulsort,texte(langue,17)) nmprog, avappr + endif +#endif + write (ulsort,texte(langue,6)) nbtrto +c + codret = 0 +c +c==== +c 2. verification +c==== +c + do 20 , iaux = 1 , nbtrto +c + codre0 = 0 +c +c 2.1. ==> les aretes doivent etre differentes ... +c + a1 = aretri(iaux,1) + a2 = aretri(iaux,2) + a3 = aretri(iaux,3) +c + if ( a1.eq.a2 .or. + > a2.eq.a3 .or. + > a3.eq.a1 ) then + codre0 = 1 + write (ulsort,texte(langue,7)) iaux, a1, a2, a3 + write (ulbila,texte(langue,7)) iaux, a1, a2, a3 + endif +c +c 2.2. ==> les aretes doivent se suivre ... +c + if ( codre0.eq.0 ) then +c + listar(1) = a1 + listar(2) = a2 + listar(3) = a3 + jaux = 2 + kaux = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( jaux, iaux, kaux, listar, somare, + > ulbila, ulsort, langue, codre0 ) +c + endif +c +c 2.3. ==> les sommets doivent etre differents ... +c + if ( codre0.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSOTR', nompro +#endif + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + if ( sa1a2.eq.sa2a3 .or. + > sa1a2.eq.sa3a1 .or. + > sa2a3.eq.sa3a1 ) then + codre0 = 1 + write (ulsort,texte(langue,8)) iaux, sa1a2, sa2a3, sa3a1 + write (ulbila,texte(langue,8)) iaux, sa1a2, sa2a3, sa3a1 + endif +c + endif +c +c 2.4. ==> cumul des erreurs +c + codret = codret + codre0 +c + 20 continue +c +c 2.4. ==> tout va bien +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,16)) + write (ulbila,texte(langue,16)) + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfaa1.F b/src/tool/Utilitaire/utfaa1.F new file mode 100644 index 00000000..b600ac43 --- /dev/null +++ b/src/tool/Utilitaire/utfaa1.F @@ -0,0 +1,122 @@ + subroutine utfaa1 ( nbarto, nbtrto, nbquto, + > nbaral, nbtral, nbqual, + > aretri, arequa, + > nbfaar, posifa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - voisinage FAce-Aretes - phase 1 +c -- -- - - +c ______________________________________________________________________ +c +c determine le nombre de faces voisines de chaque arete +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbarto . e . 1 . nombre d'aretes a examiner . +c . nbtrto . e . 1 . nombre de triangles a examiner . +c . nbquto . e . 1 . nombre de quadrangles a examiner . +c . nbaral . e . 1 . nombre d'aretes pour les allocations . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . nbqual . e . 1 . nombre de quadrangles pour les allocations . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nbfaar . s . 1 . nombre cumule de faces par arete . +c . posifa . s .0:nbarto. pointeur sur tableau facare . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbarto, nbtrto, nbquto, nbfaar + integer nbaral, nbtral, nbqual + integer aretri(nbtral,3), arequa(nbqual,4) + integer posifa(0:nbaral) +c +c 0.4. ==> variables locales +c + integer laface, larete +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque face et on incremente de 1 le nombre de +c faces voisines de ses 3 aretes +c +c au depart : +c posifa(0) = 0 +c posifa(i) = 0 +c +c a l'arrivee : +c posifa(0) = 0 +c posifa(i) = nombre de faces voisines de l'arete i +c==== +c + do 11 , larete = 0 , nbarto + posifa(larete) = 0 + 11 continue +c + do 12 , laface = 1 , nbtrto + posifa(aretri(laface,1)) = posifa(aretri(laface,1)) + 1 + posifa(aretri(laface,2)) = posifa(aretri(laface,2)) + 1 + posifa(aretri(laface,3)) = posifa(aretri(laface,3)) + 1 + 12 continue +c + do 13 , laface = 1 , nbquto + posifa(arequa(laface,1)) = posifa(arequa(laface,1)) + 1 + posifa(arequa(laface,2)) = posifa(arequa(laface,2)) + 1 + posifa(arequa(laface,3)) = posifa(arequa(laface,3)) + 1 + posifa(arequa(laface,4)) = posifa(arequa(laface,4)) + 1 + 13 continue +c +c==== +c 2. on initialise le pointeur dans le tableau des voisins +c +c au depart : +c posifa(0) = 0 +c posifa(i) = nombre de faces voisines de l'arete i +c +c a l'arrivee : +c posifa(0) = 0 +c posifa(i) = position de la derniere voisine de l'arete i-1 +c = nombre cumule de voisines pour les (i-1) 1eres aretes +c==== +c + do 21 , larete = 1 , nbarto + posifa(larete) = posifa(larete) + posifa(larete-1) + 21 continue +c + nbfaar = posifa(nbarto) +c + do 22 , larete = nbarto , 1 , -1 + posifa(larete) = posifa(larete-1) + 22 continue +c + end diff --git a/src/tool/Utilitaire/utfaa2.F b/src/tool/Utilitaire/utfaa2.F new file mode 100644 index 00000000..dd6acaac --- /dev/null +++ b/src/tool/Utilitaire/utfaa2.F @@ -0,0 +1,123 @@ + subroutine utfaa2 ( nbtrto, nbquto, + > nbtral, nbqual, + > aretri, arequa, + > nbfaar, posifa, facare ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - voisinage FAce-Aretes - phase 2 +c -- -- - - +c ______________________________________________________________________ +c +c determine les faces voisines de chaque arete +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtrto . e . 1 . nombre de triangles a examiner . +c . nbquto . e . 1 . nombre de quadrangles a examiner . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . nbqual . e . 1 . nombre de quadrangles pour les allocations . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nbfaar . e . 1 . nombre cumule de faces par arete . +c . posifa . e/s .0:nbaret. pointeur sur tableau facare . +c . facare . s . nbfaar . liste des faces contenant une arete . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtrto, nbquto, nbfaar + integer nbtral, nbqual + integer aretri(nbtral,3), arequa(nbqual,4) + integer posifa(0:*), facare(nbfaar) +c +c 0.4. ==> variables locales +c + integer laface, larete +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque face et on indique qu'elle est voisine de +c ses aretes : on incremente le pointeur posifa(i) et on +c memorise la face dans facare a la place posifa(i) : +c . pour un triangle, c'est le numero HOMARD du triangle +c . pour un quadrangle, c'est l'oppose du numero HOMARD du quadrangle +c +c au depart : +c posifa(0) = 0 +c posifa(i) = position de la derniere voisine de l'arete i-1 +c = nombre cumule de voisines pour les (i-1) 1eres aretes +c +c a l'arrivee : +c posifa(0) = 0 +c posifa(i) = position de la derniere voisine de l'arete i +c = nombre cumule de voisines pour les i premieres aretes +c==== +c + do 11 , laface = 1 , nbtrto +c + larete = aretri(laface,1) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = laface +c + larete = aretri(laface,2) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = laface +c + larete = aretri(laface,3) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = laface +c + 11 continue +c + do 12 , laface = 1 , nbquto +c + larete = arequa(laface,1) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = -laface +c + larete = arequa(laface,2) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = -laface +c + larete = arequa(laface,3) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = -laface +c + larete = arequa(laface,4) + posifa(larete) = posifa(larete) + 1 + facare(posifa(larete)) = -laface +c + 12 continue +c + end diff --git a/src/tool/Utilitaire/utfam1.F b/src/tool/Utilitaire/utfam1.F new file mode 100644 index 00000000..d46f82aa --- /dev/null +++ b/src/tool/Utilitaire/utfam1.F @@ -0,0 +1,148 @@ + subroutine utfam1 ( typenh, nhenfa, pcfaen, + > nctfen, nbfold, nbfnew, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - FAMilles - phase 1 +c -- --- - +c Ajustement du tableau des codes des familles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenfa . e . char*8 . nom de l'objet de la famille de l'entite . +c . pcfaen . s . 1 . adresses des codes . +c . nctfen . e . 1 . nombre total de caracteristiques . +c . nbfold . e . 1 . ancien nombre de familles des entites . +c . nbfnew . e . 1 . nouveau nombre de familles des entites . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFAM1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, pcfaen + integer nctfen, nbfold, nbfnew +c + character*8 nhenfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Ajustement du tableau des codes de familles des '',a)' +c + texte(2,4) = + > '(''Resizing of arrays for family codes of '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) +#endif +c +c==== +c 2. ajustement des tableaux +c==== +c + call gmmod ( nhenfa//'.Codes', pcfaen, + > nctfen, nctfen, nbfold, nbfnew, codre1 ) + call gmecat ( nhenfa, 1, nbfnew, codre2 ) + call gmecat ( nhenfa, 2, nctfen, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfam2.F b/src/tool/Utilitaire/utfam2.F new file mode 100644 index 00000000..7d6fc3d0 --- /dev/null +++ b/src/tool/Utilitaire/utfam2.F @@ -0,0 +1,199 @@ + subroutine utfam2 ( typenh, nhenfa, nctfen, nbfnew, + > pcfaen, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - FAMilles - phase 2 +c -- --- - +c Creation/Allongement du tableau des codes des familles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : aretes . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nhenfa . e . char*8 . nom de l'objet de la famille de l'entite . +c . nctfen . e . 1 . nombre de caracteristique des f. entite . +c . nbfnew . e . 1 . nombre de familles . +c . pcfaen . s . 1 . codes des familles de l'entite . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFAM2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, nctfen, nbfnew + integer pcfaen +c + character*8 nhenfa +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer codre1, codre2, codre3 + integer nbfold +c + logical existe +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Allocation des familles pour extruder les '',a)' +c + texte(2,4) = + > '(''Allocation of arrays for family of extruded '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,90002) 'nctfen', nctfen + write (ulsort,90002) 'nbfnew', nbfnew + call gmprsx ( nompro, nhenfa ) +#endif +c + codret = 0 +c +c==== +c 2. Le tableau existe-t-il ? +c==== +c + call gmobal ( nhenfa//'.Codes', codre0 ) + if ( codre0.eq.0 ) then + existe = .False. + elseif ( codre0.eq.2 ) then + existe = .True. + else + codret = abs(codre0) + endif +c +c==== +c 3. creation/allongement des tableaux +c==== +c 3.1. ==> Allongement +c + if ( existe ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( nhenfa//'.Codes', pcfaen, iaux, codre0 ) + codret = max( abs(codre0), codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbfold = iaux/nctfen +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbfold', nbfold +#endif +c + call utfam1 ( typenh, nhenfa, pcfaen, + > nctfen, nbfold, nbfnew, + > ulsort, langue, codret) +c + endif +c +c 3.2. ==> Creation +c + else +c + if ( codret.eq.0 ) then +c + iaux = nctfen*nbfnew + call gmaloj ( nhenfa//'.Codes', ' ', iaux, pcfaen, codre0 ) +c + codret = max( abs(codre0), codret ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfia1.F b/src/tool/Utilitaire/utfia1.F new file mode 100644 index 00000000..c883de32 --- /dev/null +++ b/src/tool/Utilitaire/utfia1.F @@ -0,0 +1,368 @@ + subroutine utfia1 ( nbfich, lgtanf, + > nfconf, lfconf, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : fait le decompte des fichiers du calcul et de la longueur +c des noms (UNIX, ou autre OS) de ces fichiers +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfich . s . 1 . nombre de fichiers dans la configuration . +c . lgtanf . s . 1 . longueur tableau des noms de fichiers . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme de decodage des noms . +c . . . . 7 : impossible de decoder le $HOME . +c . . . . : (ou une autre variable d'environnement). +c . . . . 9 : probleme avec le fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFIA1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfich, lgtanf + integer lfconf + integer ulsort, langue, codret +c + character*(*) nfconf +c +c 0.4. ==> variables locales +c + integer ulconf + integer codre0, codre1 + integer iaux, jaux, kaux + integer ideb1, ideb2, ideb3, ideb4, ideb5 + integer ifin1, ifin2, ifin3, ifin4, ifin5 + integer lgnova, lgnout +c + integer lgmax +c + character*400 ligne, ligbla + character*400 nomvar, nomuti + character*1 commen +c + logical varenv +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + parameter ( lgmax = 400 ) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr03.h" +c +c 1.1. ==> constantes +c + codre0 = 0 +c + commen = '#' +c + do 1 , iaux = 1 , lgmax + ligbla (iaux:iaux) = ' ' + 1 continue +c +c 1.2. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Dans le fichier de configuration'')' + texte(1,5) = '(''Le mot-cle a plus de 8 caracteres :'')' + texte(1,6) = '(''Le nom d''''objet a plus de 8 caracteres :'')' + texte(1,7) = + > '(''L''''information supplementaire a plus de 8 caracteres :'' + > )' +c + texte(2,4) = '(''In the configuration file'')' + texte(2,5) = + > '(''The size of the keyword is greater than 8 :'')' + texte(2,6) = + > '(''The size of the object name is greater than 8 :'')' + texte(2,7) = + > '(''The size of the supplementary information is greater than + >8 :'')' +c +c 1.3. ==> initialisation pour ne plus avoir de messages ftnchek +c + nomvar = ligbla +c +c==== +c 2. ouverture du fichier de configuration +c==== +c + nbfich = 0 + lgtanf = 0 +c + if ( codret.eq.0 ) then + call guoufs ( nfconf, lfconf, ulconf, codret ) + endif +c + if ( codret.eq.0 ) then + call gurbbu ( ulconf, codret ) + if ( codret.ne.0 ) then + codret = 9 + endif + else + codret = 9 + endif +c +c==== +c 3. comptage du nombre de fichiers enregistres et de la longueur +c cumulee de leurs noms +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. comptage ; codret = ', codret +#endif +c +30000 format (a400) +c + if ( codret.eq.0 ) then +c + 30 continue +c + ligne = ligbla +c + read ( ulconf, 30000, end=40, err=40 ) ligne +c +c nettoyage eventuel de la ligne lue (caract. non impr.): +c + call dmcpch( ligne, len(ligne), ligne, jaux ) +c +c 3.1. ==> on ne tient compte ni des lignes blanches, ni +c des commentaires +c + if ( ligne.eq.ligbla .or. ligne(1:1).eq.commen ) then +c + goto 30 +c + else +c +c 3.2. ==> recherche des positions des mots +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGFIA3', nompro +#endif + call ugfia3 ( ligne, + > ideb1, ifin1, ideb2, ifin2, + > ideb3, ifin3, ideb4, ifin4, + > ulsort, langue, codret ) + codre0 = max(codre0, codret) +c +c 3.3. ==> archivage des informations +c +c 3.3.1. ==> controle +c +c 3.3.1.1. ==> le mot-cle a au plus 8 caracteres. +c + if ( (ifin1-ideb1).gt.7 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) + write (ulsort,*) nfconf(1:lfconf) + write (ulsort,*) ligne + write (ulsort,texte(langue,5)) + write (ulsort,*) ligne(ideb1:ifin1) + codre0 = 3 + endif +c +c 3.3.1.2. ==> le nom d'objet, s'il existe, a au plus 8 caracteres. +c + if ( ideb3.gt.0 ) then + if ( (ifin2-ideb2).gt.7 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) + write (ulsort,*) nfconf(1:lfconf) + write (ulsort,*) ligne + write (ulsort,texte(langue,6)) + write (ulsort,*) ligne(ideb2:ifin2) + codre0 = 3 + endif + endif +c +c 3.3.1.3. ==> l'information supplementaire, si elle existe, +c a au plus 8 caracteres. +c + if ( ideb4.gt.0 ) then + if ( (ifin4-ideb4).gt.7 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) + write (ulsort,*) nfconf(1:lfconf) + write (ulsort,*) ligne + write (ulsort,texte(langue,7)) + write (ulsort,*) ligne(ideb4:ifin4) + codre0 = 3 + endif + endif +c +c 3.3.2. ==> decodage +c + if ( ideb3.gt.0 ) then + ideb5 = ideb3 + ifin5 = ifin3 + else + ideb5 = ideb2 + ifin5 = ifin2 + endif +c + 330 continue + if ( ifin5.gt.ideb5+1 .and. + > ligne(ideb5:ideb5+1).eq.'./' ) then + ideb5 = ideb5+2 + goto 330 + endif +c +c on explore tous les caracteres +c + kaux = 0 + varenv = .false. + lgnova = 0 +c + do 331 , iaux = ideb5, ifin5 +c + if ( ligne(iaux:iaux).eq.'$' ) then +c + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre1 ) + if ( codre1.ne.0 .and. codre0.eq.0 ) then + codre0 = 7 + endif + kaux = kaux + max(0,lgnout) + endif + varenv = .true. + lgnova = 0 +c + elseif ( ligne(iaux:iaux).eq.'.' .or. + > ligne(iaux:iaux).eq.'-' .or. + > ligne(iaux:iaux).eq.'/' ) then + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre1 ) + if ( codre1.ne.0 .and. codre0.eq.0 ) then + codre0 = 7 + endif + kaux = kaux + max(0,lgnout) + varenv = .false. + endif + kaux = kaux + 1 +c + else + if ( varenv ) then + lgnova = lgnova + 1 + nomvar(lgnova:lgnova) = ligne(iaux:iaux) + if ( iaux.eq.ifin5 ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre1 ) + if ( codre1.ne.0 .and. codre0.eq.0 ) then + codre0 = 7 + endif + kaux = kaux + max(0,lgnout) + endif + else + kaux = kaux + 1 + endif + endif +c + 331 continue +c +c 3.3.2.3. ==> Cumul des longueurs +c + if ( mod(kaux,8).eq.0 ) then + lgtanf = lgtanf + (kaux/8) + else + lgtanf = lgtanf + ((kaux-mod(kaux,8))/8) + 1 + endif +c + nbfich = nbfich + 1 +c + endif +c +c 3.4. ==> ligne suivante +c + goto 30 +c + endif +c +c==== +c 4. fin +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. fin ; codret = ', codret +#endif +c + 40 continue +c + if ( codret.eq.0 ) then + call gufefi ( nfconf, lfconf, codret ) + if ( codret.ne.0 ) then + codret = 9 + endif + endif +c + if ( codret.eq.0 .and. codre0.ne.0 ) then + codret = codre0 + endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfia2.F b/src/tool/Utilitaire/utfia2.F new file mode 100644 index 00000000..88f52efc --- /dev/null +++ b/src/tool/Utilitaire/utfia2.F @@ -0,0 +1,360 @@ + subroutine utfia2 ( nbfich, lgtanf, + > nomref, + > lgnofi, poinno, nomufi, nomstr, infsup, + > nfconf, lfconf, ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : acquerir les noms des fichiers concernes par un calcul +c +c note: on s'attend, dans le fichier de configuration, a trouver des +c noms de fichiers "a la UNIX". Ces noms de fichiers sont +c convertis par dmnfcv, a la fin de ce sous-programme, +c pour etre acceptables par le systeme +c d'exploitation courant (par exemple WINDOWS). +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfich . e . 1 . nombre de fichiers dans la configuration . +c . lgtanf . e . 1 . longueur tableau des noms de fichiers . +c . nomref . s . nbfich . nom de reference des fichiers . +c . lgnofi . s . nbfich . longueurs des noms des fichiers . +c . poinno . s .0:nbfich. pointeur dans le tableau des noms . +c . nomufi . s . lgtanf . noms des fichiers . +c . nomstr . s . nbfich . nom terminaux des objets stockes . +c . infsup . s . nbfich . informations supplementaires . +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme de decodage des noms . +c . . . . 7 : impossible de decoder une variable . +c . . . . d'environnement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFIA2' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbfich, lgtanf + integer lfconf + integer lgnofi(nbfich), poinno(0:nbfich) + integer ulsort, langue, codret +c + character*(*) nfconf + character*8 nomref(nbfich), nomufi(lgtanf), nomstr(nbfich) + character*8 infsup(nbfich) +c +c 0.4. ==> variables locales +c + integer ulconf + integer codre0 + integer iaux, jaux, kaux + integer ideb1, ideb2, ideb3, ideb4, ideb5 + integer ifin1, ifin2, ifin3, ifin4, ifin5 + integer lgnova, lgnout +c + integer lgmax +c + integer nrofic +c + character*400 ligne, ligbla, ligaux + character*400 nomvar, nomuti + character*8 motcle + character*1 commen +c + logical varenv +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + parameter ( lgmax = 400 ) +c +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> constantes +c + codre0 = 0 +c + commen = '#' +c + do 1 , iaux = 1 , lgmax + ligbla (iaux:iaux) = ' ' + 1 continue +c +c 1.2. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.3. ==> initialisation pour ne plus avoir de messages ftnchek +c + nomvar = ligbla +c +c 1.4. ==> ouverture du fichier de configuration +c + call guoufs ( nfconf, lfconf, ulconf, codret ) +c + if ( codret.eq.0 ) then + call gurbbu ( ulconf, codret ) + endif +c +c==== +c 2. lecture par une boucle sur les lignes +c remarque : les verifications ont ete faites dans la premiere +c phase traitee par utfia1 +c==== +c + nrofic = 0 + poinno(nrofic) = 0 +c + 2 continue +c + ligne = ligbla +c + read ( ulconf, 20400, end=30, err=30 ) ligne +c +c nettoyage eventuel de la ligne lue (caract. non impr.): +c + call dmcpch( ligne, len(ligne), ligne, jaux ) +c +c 2.1. ==> on ne tient compte ni des lignes blanches, ni +c des commentaires +c + if ( ligne.eq.ligbla .or. ligne(1:1).eq.commen ) then +c + goto 2 +c + else +c +c 2.2. ==> recherche des positions des mots +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGFIA3', nompro +#endif + call ugfia3 ( ligne, + > ideb1, ifin1, ideb2, ifin2, + > ideb3, ifin3, ideb4, ifin4, + > ulsort, langue, codret ) +c + endif +c +c 2.3. ==> archivage +c + if ( codret.eq.0 ) then +c + nrofic = nrofic + 1 +c +c 2.3.1. ==> mot-cle +c + motcle = blan08 + motcle(1:ifin1+1-ideb1) = ligne(ideb1:ifin1) + nomref(nrofic) = motcle +c +c 2.3.2. ==> nom de l'objet eventuellement +c + if ( ideb3.gt.0 ) then + motcle = blan08 + motcle(1:ifin2+1-ideb2) = ligne(ideb2:ifin2) + nomstr(nrofic) = motcle + endif +c +c 2.3.3. ==> informations supplementaires eventuellement +c + if ( ideb4.gt.0 ) then + motcle = blan08 + motcle(1:ifin4+1-ideb4) = ligne(ideb4:ifin4) + infsup(nrofic) = motcle + endif +c +c 2.3.4. ==> decodage +c + if ( ideb3.gt.0 ) then + ideb5 = ideb3 + ifin5 = ifin3 + else + ideb5 = ideb2 + ifin5 = ifin2 + endif +c + 230 continue + if ( ifin5.gt.ideb5+1 .and. + > ligne(ideb5:ideb5+1).eq.'./' ) then + ideb5 = ideb5+2 + goto 230 + endif +c +c on explore tous les caracteres +c + kaux = 0 + varenv = .false. + lgnova = 0 + ligaux = ligbla +c + do 231 , iaux = ideb5, ifin5 +c + if ( ligne(iaux:iaux).eq.'$' ) then +c + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre0 = 7 + endif + if ( kaux.lt.len(ligaux) .and. lgnout.gt.0 ) then + lgnout = min( len(ligaux)-kaux, lgnout ) + ligaux(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + endif + varenv = .true. + lgnova = 0 +c + elseif ( ligne(iaux:iaux).eq.'.' .or. + > ligne(iaux:iaux).eq.'-' .or. + > ligne(iaux:iaux).eq.'/' ) then + if ( varenv ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre0 = 7 + endif + if ( kaux.lt.len(ligaux) .and. lgnout.gt.0 ) then + lgnout = min( len(ligaux)-kaux, lgnout ) + ligaux(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + varenv = .false. + endif + if ( kaux.lt.len(ligaux) ) then + kaux = kaux + 1 + ligaux(kaux:kaux) = ligne(iaux:iaux) + endif +c + else + if ( varenv ) then + lgnova = lgnova + 1 + nomvar(lgnova:lgnova) = ligne(iaux:iaux) + if ( iaux.eq.ifin5 ) then + call dmvaen ( nomvar, lgnova, nomuti, lgnout, + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codre0 = 7 + endif + if ( kaux.lt.len(ligaux) .and. lgnout.gt.0 ) then + lgnout = min( len(ligaux)-kaux, lgnout ) + ligaux(kaux+1:kaux+lgnout) = nomuti(1:lgnout) + kaux = kaux + lgnout + endif + endif + else + if ( kaux.lt.len(ligaux) ) then + kaux = kaux + 1 + ligaux(kaux:kaux) = ligne(iaux:iaux) + endif + endif +c + endif +c + codret = max ( codret , codre0 ) +c + 231 continue +c +c conversion eventuelle du nom du fichier trouve dans le +c fichier de configuration: sous UNIX, dmnfcv ne fait RIEN ... +c sous WINDOWS, on change les / en \ ... +c + if ( kaux.gt.0 ) then + call dmnfcv( ligaux, kaux ) + endif +c +c 2.3.4. ==> archivage +c + iaux = poinno(nrofic-1) + 1 + call utchs8 ( ligaux, kaux, nomufi(iaux), + > ulsort, langue, codre0 ) + if ( codre0.ne.0 ) then + codret = 3 + endif +c + lgnofi(nrofic) = kaux +c + if ( mod(kaux,8).eq.0 ) then + iaux = kaux/8 + else + iaux = ((kaux-mod(kaux,8))/8) + 1 + endif +c + poinno(nrofic) = poinno(nrofic-1) + iaux +c + endif +c +c 2.4. ==> ligne suivante +c + endif +c + goto 2 +c +c==== +c 3. fin +c==== +c + 30 continue +c + if ( codret.eq.0 ) then + call gufefi ( nfconf, lfconf, codret ) + endif +c +20400 format (a400) +c + end diff --git a/src/tool/Utilitaire/utfiac.F b/src/tool/Utilitaire/utfiac.F new file mode 100644 index 00000000..3e1c9f24 --- /dev/null +++ b/src/tool/Utilitaire/utfiac.F @@ -0,0 +1,265 @@ + subroutine utfiac ( nfconf, lfconf, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : acquerir les noms des fichiers et des objets structures +c concernes par un calcul +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme dans l'allocation des tables . +c . . . . 3 : probleme de decodage des noms . +c . . . . 5 : deuxieme appel au programme . +c . . . . 7 : impossible de decoder une variable . +c . . . . d'environnement . +c . . . . 9 : probleme avec le fichier . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFIAC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer iaux + integer adnore, adlono, adpono, adnofi, adnoos, adinsu + integer nbfich, lgtanf + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8, codre9, codre0 +c + logical prem +c + character*8 nomaux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Un seul appel a ce programme est autorise.'')' + texte(1,5) = '(''Probleme avec le fichier de configuration'')' + texte(1,6) = '(''Objet '',a8,'' : allocation impossible.'')' + texte(1,7) = '(''Objet '',a8,'' : remplissage impossible.'')' +c + texte(2,4) = '(''Only one call to this subroutine is allowed.'')' + texte(2,5) = '(''Problem with the configuration file'')' + texte(2,6) = '(''Object '',a8,'' : allocation impossible.'')' + texte(2,7) = '(''Object '',a8,'' : filling is impossible.'')' +c +c==== +c 2. verification du nombre de passage +c==== +c + if ( prem ) then + prem = .false. + else + write (ulsort,texte(langue,4)) + codret = 5 + endif +c +c==== +c 3. comptage du nombre de fichiers enregistres et de la longueur +c cumulee de leurs noms +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. comptage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + codre1 = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIA1', nompro +#endif + call utfia1 ( nbfich, lgtanf, + > nfconf, lfconf, ulsort, langue, codre1 ) +c + if ( codre1.eq.3 .or. codre1.eq.7 ) then + codret = codre1 + else if ( codre1.eq.9 ) then + codret = 9 + write (ulsort,texte(langue,5)) + if ( lfconf.gt.0 .and. len(nfconf).gt.0 ) then + write (ulsort,*) nfconf(1:min(lfconf,len(nfconf))) + else + write (ulsort,*) + endif + else + codret = 0 + endif +c + endif +c +c==== +c 4. allocation de l'objet structure correspondant +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. allocation ; codret = ', codret +#endif +c + nomaux = osliob +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'nomaux = ', nomaux + write (ulsort,*) 'nbfich = ', nbfich + write (ulsort,*) 'lgtanf = ', lgtanf +#endif +c + call gmaloj ( nomaux, 'FichExec', 0, iaux, codre1 ) +c + call gmecat ( nomaux, 1, nbfich, codre2 ) + call gmecat ( nomaux, 2, lgtanf, codre3 ) +c + call gmaloj ( nomaux//'.NomRefer', ' ', nbfich, adnore, codre4 ) + call gmaloj ( nomaux//'.LongNomF', ' ', nbfich, adlono, codre5 ) + iaux = nbfich + 1 + call gmaloj ( nomaux//'.PosiNomF', ' ', iaux, adpono, codre6 ) + call gmaloj ( nomaux//'.NomUFich', ' ', lgtanf, adnofi, codre7 ) + call gmaloj ( nomaux//'.NomObjSt', ' ', nbfich, adnoos, codre8 ) + call gmaloj ( nomaux//'.InfoSupp', ' ', nbfich, adinsu, codre9 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, codre6, + > codre7, codre8, codre9 ) + codre0 = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, codre6, + > codre7, codre8, codre9 ) +c + if ( codre0.ne.0 ) then + write (ulsort,texte(langue,6)) nomaux + codret = 2 + endif +c + endif +c +c==== +c 5. Remplissage de la structure +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. remplissage ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + codre2 = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIA2', nompro +#endif + call utfia2 ( nbfich, lgtanf, + > smem(adnore), imem(adlono), + > imem(adpono), smem(adnofi), + > smem(adnoos), smem(adinsu), + > nfconf, lfconf, ulsort, langue, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro,nomaux//'.NomRefer') + call gmprsx (nompro,nomaux//'.LongNomF') + call gmprsx (nompro,nomaux//'.PosiNomF') + call gmprsx (nompro,nomaux//'.NomUFich') + call gmprsx (nompro,nomaux//'.NomObjSt') + call gmprsx (nompro,nomaux//'.InfoSupp') + endif +#endif +c + endif +c +c==== +c 6. fin +c==== +c + if ( codret.eq.0 ) then + if ( codre1.eq.3 ) then + codret = 3 + else + if ( codre2.ne.0 ) then + write (ulsort,texte(langue,7)) nomaux + codret = codre2 + endif + endif + endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfihe.F b/src/tool/Utilitaire/utfihe.F new file mode 100644 index 00000000..36c3d0b6 --- /dev/null +++ b/src/tool/Utilitaire/utfihe.F @@ -0,0 +1,120 @@ + subroutine utfihe ( lehexa, + > hethex, filhex, fhpyte, + > nbfite, filste, + > nbfihe, filshe, + > nbfipy, filspy ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : les FIls d'un HExaedre coupe +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . nbfite . s . 1 . nombre de fils de type tetraedre . +c . filste . s . 1 . fils aine tetraedre s'il existe, 0 sinon . +c . nbfihe . s . 1 . nombre de fils de type hexaedre . +c . filshe . s . 1 . fils aine hexaedre s'il existe, 0 sinon . +c . nbfipy . s . 1 . nombre de fils de type pyramide . +c . filspy . s . 1 . fils aine pyramide s'il existe, 0 sinon . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer lehexa + integer hethex(*), filhex(*), fhpyte(2,*) + integer nbfite, filste + integer nbfihe, filshe + integer nbfipy, filspy +c +c 0.4. ==> variables locales +c + integer iaux + integer bindec +c +#include "impr03.h" +c +c==== +c 1. Nombre de fils +c==== +c + iaux = mod(hethex(lehexa),1000) + bindec = chbiet(iaux) +#ifdef _DEBUG_HOMARD_ + write (*,90015) 'etat', iaux, ' ==> code binaire', bindec +#endif +c + nbfite = chnte(bindec) + nbfihe = chnhe(bindec) + nbfipy = chnpy(bindec) +c +c==== +c 2. Les fils +c==== +c + iaux = filhex(lehexa) +c + if ( nbfite.gt.0 ) then + filste = fhpyte(2,-iaux) + else + filste = 0 + endif +c + if ( nbfihe.gt.0 ) then + filshe = iaux + else + filshe = 0 + endif +c + if ( nbfipy.gt.0 ) then + filspy = fhpyte(1,-iaux) + else + filspy = 0 + endif +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'hexaedre', lehexa + write (*,90006) 'fils hexaedres - nombre', nbfihe, '-', filshe + write (*,90006) 'fils pyramides - nombre', nbfipy, '-', filspy + write (*,90006) 'fils tetraedres - nombre', nbfite, '-', filste +#endif +c + end diff --git a/src/tool/Utilitaire/utfin1.F b/src/tool/Utilitaire/utfin1.F new file mode 100644 index 00000000..cc8d4b60 --- /dev/null +++ b/src/tool/Utilitaire/utfin1.F @@ -0,0 +1,203 @@ + subroutine utfin1 ( mctyob, numero, + > nombre, nomfic, lnomfi, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : renvoyer le nom unix complet correspondant a un fichier +c de nom symbolique donne +c remarque : si la variable nomfic est trop grande, elle est completee +c par des blancs. C'est uts8ch qui le fait. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . mctyob . e . ch8 . nom symbolique du type d'objet . +c . numero . e . 1 . numero du fichier voulu . +c . nombre . s . 1 . nombre de fichiers correspondants a ce type. +c . nomfic . s . ch* . nom unix du fichier associe . +c . lnomfi . s . 1 . longueur du nom unix du fichier associe . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : pas de nom dans la base . +c . . . . 3 : mauvais numero . +c . . . . 4 : la chaine prevue est trop courte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFIN1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 mctyob + character*(*) nomfic +c + integer numero, nombre, lnomfi + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer adnore, adlono, adpono, adnofi, adnoos + integer nbfich + integer iaux, nrofic, poinnf +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + lnomfi = 0 + nombre = 0 +c +c==== +c 1. messages +c si on recherche le fichier de la liste standard, il faut +c imprimer sur la sortie standard. +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Mot-cle symbolique '',a8,'', numero '',i6)' + texte(1,4) = + > '(''Il est present '',i5,'' fois dans la configuration.'')' + texte(1,11) = '(''La configuration est perdue ?'')' + texte(1,12) = + > '(''Ce mot-cle est inconnu dans la configuration.'')' + texte(1,13) = '(''Le numero voulu est impossible.'')' + texte(1,14) = '(''La chaine prevue est trop courte.'')' +c + texte(2,10) = '(''Symbolic keyword '',a8,'', rank '',i6)' + texte(2,4) = + > '(''It is present '',i5,'' times in configuration.'')' + texte(2,11) = '(''Configuration is lost ?'')' + texte(2,12) = '(''This keyword is unknown in configuration.'')' + texte(2,13) = '(''The wanted rank is impossible.'')' + texte(2,14) = '(''String is too short.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mctyob, numero +#endif +c +c==== +c 2. recherche des adresses des objets GM lies aux noms des fichiers +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD80', nompro +#endif + call utad80 ( nbfich, + > adnore, adlono, adpono, adnofi, adnoos, + > ulsort, langue, codret ) +c +c==== +c 3. recherche du nom de fichier +c==== +c +c 3.1. ==> recherche du nom symbolique : +c on compte combien il y en a au total (nombre) +c on repere l'indice (nrofic) correspondant a celui demande (numero) +c + if ( codret.eq.0 ) then +c + nrofic = 0 +c + do 31 , iaux = 1 , nbfich + if ( smem(adnore+iaux-1).eq.mctyob ) then + nombre = nombre + 1 + if ( nombre.eq.numero ) then + nrofic = iaux + endif + endif + 31 continue +c + if ( nombre.eq.0 ) then + codret = 2 + else if ( nrofic.eq.0 ) then + codret = 3 + endif +c + endif +c +c 3.2. ==> transfert du nom +c + if ( codret.eq.0 ) then +c + poinnf = imem(adpono+nrofic-1) + lnomfi = imem(adlono+nrofic-1) +c + call uts8ch ( smem(adnofi+poinnf), lnomfi, nomfic, + > ulsort, langue, codret ) +c + if ( codret.eq.1 ) then + codret = 4 + endif +c + endif +c +c==== +c 4. les erreurs +c==== +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.ne.0 ) then +c + iaux = 10 + codret + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) mctyob, numero + write (ulsort,texte(langue,4)) nombre + write (ulsort,texte(langue,iaux)) +c + endif +c +#endif +c + end diff --git a/src/tool/Utilitaire/utfin2.F b/src/tool/Utilitaire/utfin2.F new file mode 100644 index 00000000..54faef03 --- /dev/null +++ b/src/tool/Utilitaire/utfin2.F @@ -0,0 +1,195 @@ + subroutine utfin2 ( mctyob, option, nomfic, lnomfi, + > nbrmin, nbrmax, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : renvoyer le nom unix complet correspondant a un fichier +c de nom symbolique donne +c remarque : si la variable nomfic est trop grande, elle est completee +c par des blancs +c remarque : utfino et utfin2 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . mctyob . e . ch8 . nom symbolique du type de fichier . +c . option . e . 1 . 0 : le nom est renvoye tel quel . +c . . . . 1 : les minuscules deviennent majuscules . +c . . . . 2 : les majuscules deviennent minuscules . +c . . . . si negatif, on interdit tout caractere . +c . . . . non alphabetique . +c . nbrmin . e . 1 . nombre minimal de mots possibles . +c . nbrmax . e . 1 . nombre maximal de mots possibles . +c . nomfic . s . ch* . nom unix du fichier associe . +c . lnomfi . s . 1 . longueur du nom unix du fichier associe . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : pas de nom dans la base . +c . . . . 3 : le nombre de mots-cles est incorrect . +c . . . . 4 : la chaine prevue est trop courte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFIN2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*8 mctyob + character*(*) nomfic +c + integer option, lnomfi + integer nbrmin, nbrmax + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer numero, nombre, ulmess +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "motcle.h" +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c si on recherche le fichier de la liste standard, il faut +c imprimer sur la sortie standard. +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Mot-cle symbolique '',a8,)' + texte(1,5) = '(1x,''La configuration est perdue.'')' + texte(1,6) = + > '(''Il est present '',i5,'' fois dans la configuration.'')' + texte(1,7) = '(''On voudrait entre'',i5,'' et'',i5)' + texte(1,8) = '(i4,'' fichiers possibles.'')' +c + texte(2,4) = '(''Symbolic keyword '',a8,'', rank '',i6)' + texte(2,5) = '(1x,''The configuration is lost.'')' + texte(2,6) = + > '(''It is present '',i5,'' times in configuration.'')' + texte(2,7) = '(''Asked: between'',i5,'' and'',i5)' + texte(2,8) = '(i4,'' available files.'')' +c + if ( mctyob.eq.mclist ) then + call gusost ( ulmess ) + else + ulmess = ulsort + endif +c +c==== +c 2. appel de l'utilitaire : on n'est interesse que par le premier +c fichier ou le mot-cle apparait +c code retour : 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c 3 : mauvais numero +c 4 : la chaine nomfic est trop courte +c==== +c + numero = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN1', nompro +#endif + call utfin1 ( mctyob, numero, + > nombre, nomfic, lnomfi, + > ulmess, langue, codret ) +cgn write (*,texte(langue,4)) mctyob +cgn write(*,*)'nombre',nombre +cgn write(*,*)'codret',codret +c + if ( codret.eq.3 ) then + codret = 2 + endif +c + if ( codret.eq.0 ) then + if ( nombre.lt.nbrmin .or. nombre.gt.nbrmax ) then + codret = 3 + endif + endif +c +#ifdef _DEBUG_HOMARD_ +c + if ( codret.ne.0 ) then +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulmess,texte(langue,4)) mctyob + if ( codret.eq.1 ) then + write (ulmess,texte(langue,5)) + elseif ( codret.eq.3 ) then + write (ulmess,texte(langue,6)) nombre + write (ulmess,texte(langue,7)) nbrmin, nbrmax + else + call utosme ( mctyob, ulsort, langue ) + write (ulmess,texte(langue,8)) nombre + endif +c + endif +c +#endif +c +c==== +c 3. conversion eventuelle +c==== +c + if ( codret.eq.0 ) then +c + if ( option.ne.0 ) then +c + call utmnmj ( option, nomfic, iaux, + > ulmess, langue, codret ) +c + endif +c + endif +cgn write(*,*)'==> codret',codret +c + end diff --git a/src/tool/Utilitaire/utfino.F b/src/tool/Utilitaire/utfino.F new file mode 100644 index 00000000..056ef522 --- /dev/null +++ b/src/tool/Utilitaire/utfino.F @@ -0,0 +1,177 @@ + subroutine utfino ( mctyob, option, nomfic, lnomfi, + > optimp, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : renvoyer le nom unix complet correspondant a un fichier +c de nom symbolique donne +c remarque : si la variable nomfic est trop grande, elle est completee +c par des blancs +c remarque : utfino et utfin2 sont des clones +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . mctyob . e . ch8 . nom symbolique du type de fichier . +c . option . e . 1 . 0 : le nom est renvoye tel quel . +c . . . . 1 : les minuscules deviennent majuscules . +c . . . . 2 : les majuscules deviennent minuscules . +c . . . . si negatif, on interdit tout caractere . +c . . . . non alphabetique . +c . nomfic . s . ch* . nom unix du fichier associe . +c . lnomfi . s . 1 . longueur du nom unix du fichier associe . +c . optimp . e . 1 . 0 : pas d'affichage de message . +c . . . . 1 : affichage de message d'erreur . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : pas de nom dans la base . +c . . . . 4 : la chaine prevue est trop courte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFINO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*8 mctyob + character*(*) nomfic + integer optimp +c + integer option, lnomfi + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer numero, nombre, ulmess +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +#include "motcle.h" +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c si on recherche le fichier de la liste standard, il faut +c imprimer sur la sortie standard. +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(1x,''La configuration est perdue.'')' + texte(1,4) = + > '(1x,''Objet '',a8,'' : '',i4,'' fichiers possibles.'')' +c + texte(2,10) = '(1x,''The configuration is lost.'')' + texte(2,4) = + > '(1x,''Object '',a8,'' : '',i4,'' available files.'')' +c + if ( mctyob.eq.mclist ) then + call gusost ( ulmess ) + else + ulmess = ulsort + endif +c +c==== +c 2. appel de l'utilitaire : on n'est interesse que par le premier +c fichier ou le mot-cle apparait +c code retour : 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c 3 : mauvais numero +c 4 : la chaine nomfic est trop courte +c==== +c + numero = 1 +c + call utfin1 ( mctyob, numero, + > nombre, nomfic, lnomfi, + > ulmess, langue, codret ) +c + if ( codret.eq.3 ) then + codret = 2 + endif +c + if ( codret.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro +#else + if ( optimp.gt.0 ) then +#endif + write (ulsort,texte(langue,2)) codret + if ( codret.eq.1 ) then + write (ulmess,texte(langue,10)) + else + call utosme ( mctyob, ulsort, langue ) + write (ulmess,texte(langue,4)) mctyob, nombre + endif +#ifdef _DEBUG_HOMARD_ +c +#else + endif +#endif +c + endif +c +c==== +c 3. conversion eventuelle +c==== +c + if ( codret.eq.0 ) then +c + if ( option.ne.0 ) then +c + call utmnmj ( option, nomfic, iaux, + > ulmess, langue, codret ) +c + endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utflt0.F b/src/tool/Utilitaire/utflt0.F new file mode 100644 index 00000000..4fc2cb39 --- /dev/null +++ b/src/tool/Utilitaire/utflt0.F @@ -0,0 +1,147 @@ + subroutine utflt0 ( somare, aretes, + > champ, flux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - FLux a travers un Triangle - 0 +c -- -- - - +c Calcule le flux d'une grandeur a travers un triangle par la somme +c de la grandeur le long des aretes +c Variante de utfltr quand le champ est deja une circulation +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . aretes . e . 3 . numeros des 3 aretes du triangle . +c . champ . e . 3 . champ sur les 3 aretes du triangle . +c . flux . s . 1 . le flux . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFLT0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer somare(2,*) + integer aretes(3) +c + double precision champ(3) + double precision flux +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer orient(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Orientations des aretes +c==== +c + call utorat ( somare, + > aretes(1), aretes(2), aretes(3), + > orient(1), orient(2), orient(3) ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Aretes ', aretes + write (ulsort,90002) '. Orientations', orient +#endif +c +c==== +c 3. Parcours des aretes +c==== +c + flux = 0.d0 +c + do 31 , iaux = 1 , 3 +c +cgn write (ulsort,90004) 'champ',champ(iaux),orient(iaux)*champ(iaux) + flux = flux + dble(orient(iaux))*champ(iaux) +c + 31 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) '==> Flux', flux +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfltr.F b/src/tool/Utilitaire/utfltr.F new file mode 100644 index 00000000..36be2af6 --- /dev/null +++ b/src/tool/Utilitaire/utfltr.F @@ -0,0 +1,193 @@ + subroutine utfltr ( option, coonoe, somare, aretes, + > champ, flux, lgaret, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - FLux a travers un TRiangle +c -- -- -- +c Calcule le flux d'une grandeur a travers un triangle par la somme +c des circulations de la grandeur le long des aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 0 : le champ est deja une circulation . +c . . . . 1 : on doit multiplier par la longueur . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . aretes . e . 3 . numeros des 3 aretes du triangle . +c . champ . e . 3 . champ sur les 3 aretes du triangle . +c . flux . s . 1 . le flux . +c . lgaret . s . 3 . longueur des 3 aretes du triangle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFLTR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer option + integer somare(2,*) + integer aretes(3) +c + double precision coonoe(nbnoto,sdim) + double precision champ(3) + double precision flux, lgaret(3) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer larete, som1, som2 + integer orient(3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Orientations des aretes +c==== +c + call utorat ( somare, + > aretes(1), aretes(2), aretes(3), + > orient(1), orient(2), orient(3) ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '. Aretes ', aretes + write (ulsort,90002) '. Orientations', orient +#endif +c +c==== +c 3. Parcours des aretes +c==== +c + flux = 0.d0 +c +c 3.1. ==> Le champ est deja une circulation +c + if ( option.eq.0 ) then +c + do 31 , iaux = 1 , 3 +c +cgn write (ulsort,90004) 'champ',champ(iaux),orient(iaux)*champ(iaux) + flux = flux + dble(orient(iaux))*champ(iaux) +c + 31 continue +c +c 3.2. ==> Le champ doit etre multiplie par la longueur +c + else +c + do 32 , iaux = 1 , 3 +c + larete = aretes(iaux) +c + som1 = somare(1,larete) + som2 = somare(2,larete) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90012) '. Sommets de l''arete', larete, som1,som2 + write (ulsort,90024) '.. Sommet', + > som1, (coonoe(som1,jaux),jaux =1,sdim) + write (ulsort,90024) '.. Sommet', + > som2, (coonoe(som2,jaux),jaux =1,sdim) +#endif +c + lgaret(iaux) = 0.d0 + do 310 , jaux = 1, sdim + lgaret(iaux) = lgaret(iaux) + > + (coonoe(som2,jaux) - coonoe(som1,jaux))**2 + 310 continue + lgaret(iaux) = sqrt(lgaret(iaux)) + write (ulsort,90004) 'champ, distance', champ(iaux), + > lgaret(iaux), dble(orient(iaux))*lgaret(iaux)*champ(iaux) + flux = flux + dble(orient(iaux))*champ(iaux) +c + 32 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90004) '==> Flux', flux +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfmgr.F b/src/tool/Utilitaire/utfmgr.F new file mode 100644 index 00000000..504fba03 --- /dev/null +++ b/src/tool/Utilitaire/utfmgr.F @@ -0,0 +1,198 @@ + subroutine utfmgr ( nomgro, nbfmgr, nrofam, + > nbfmed, numfam, + > grfmpo, grfmtl, grfmtb, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : quelle Famille MED pour un GRoupe ? +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomgro . e . char* . nom du groupe a chercher . +c . nbfmgr . s . 1 . nombre de familles MED trouvees . +c . nrofam . s . nbfmgr . numeros des familles MED trouvees . +c . nbfmed . e . 1 . nombre de familles MED . +c . numfam . e . nbfmed . numeros des familles MED . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10ngrouc. table des groupes des familles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFMGR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) nomgro +c + integer nbfmgr, nrofam(*) + integer nbfmed + integer numfam(nbfmed) + integer grfmpo(0:nbfmed) + integer grfmtl(*) +c + character*8 grfmtb(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nfam, ngro, nbgrou + integer lnogro, lnogrf +c + character*80 nomgrf +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Recherche du groupe : '',a)' +c + texte(2,5) = '(''Looking for group: '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomgro +#endif +c + codret = 0 +c +c==== +c 2. longueur du nom du groupe +c==== +c + call utlgut ( lnogro, nomgro, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'lnogro', lnogro +#endif +c +c==== +c 3. Explorations de toutes les familles +c==== +c + nbfmgr = 0 +c + do 31 , nfam = 1 , nbfmed +c + if ( codret.eq.0 ) then +c + nbgrou = ( grfmpo(nfam) - grfmpo(nfam-1) ) / 10 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90001) 'famille', nfam, numfam(nfam) + write(ulsort,90002) 'nbgrou', nbgrou +#endif +c +c 3.1. ==> Explorations de tous les groupes associes a la famille +c + do 311 , ngro = 1 , nbgrou +c + iaux = grfmpo(nfam-1) + 1 + 10*(ngro-1) + lnogrf = 0 + do 3111 , jaux = 1 , 10 + lnogrf = lnogrf + grfmtl(iaux+jaux-1) + 3111 continue +cgn write(ulsort,90002) 'lnogrf', lnogrf +c + if ( lnogrf.eq.lnogro ) then +c + call uts8ch ( grfmtb(iaux), lnogrf, nomgrf, + > ulsort, langue, codret ) +cgn write(ulsort,90003) 'Groupe ', nomgrf(1:lnogrf) +c + if ( nomgrf(1:lnogrf).eq.nomgro(1:lnogro) ) then + nbfmgr = nbfmgr + 1 + nrofam(nbfmgr) = numfam(nfam) + goto 31 + endif +c + endif +c + 311 continue +c + endif +c + 31 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'numeros des familles MED trouvees' + write(ulsort,91020) (nrofam(iaux), iaux = 1 , nbfmgr) +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utfmlg.F b/src/tool/Utilitaire/utfmlg.F new file mode 100644 index 00000000..3b8c5a3a --- /dev/null +++ b/src/tool/Utilitaire/utfmlg.F @@ -0,0 +1,201 @@ + subroutine utfmlg ( nbfmed, ngrouc, + > grfmpo, grfmtl, grfmtb, + > nbgrfm, nomgro, lgnogr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Famille MED : Liste des Groupes +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfmed . e . 1 . nombre de familles MED . +c . ngrouc . e . 1 . nombre cumule de groupes dans les familles . +c . grfmpo . e .0:nbfmed. pointeur des groupes des familles . +c . grfmtl . e . * . taille des groupes des familles . +c . grfmtb . e .10nbgroc. table des groupes des familles . +c . nbgrfm . s . 1 . nombre de groupes . +c . nomgro . s .char*(*). noms des groupes (paquets de 10char8) . +c . lgnogr . s . * . longueur des noms des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTFMLG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfmed, ngrouc + integer grfmpo(0:nbfmed) + integer grfmtl(*) + integer nbgrfm, lgnogr(ngrouc) +c + character*8 grfmtb(*) + character*8 nomgro(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nfam, ngro, nbgrou + integer lnogrf +c + character*80 nomgrf, nomgrl +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Explorations de toutes les familles, s'il y a des groupes +c==== +c + nbgrfm = 0 +c + if ( ngrouc.gt.0 ) then +c + do 21 , nfam = 1 , nbfmed +c + if ( codret.eq.0 ) then +c + nbgrou = ( grfmpo(nfam) - grfmpo(nfam-1) ) / 10 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nfam', nfam + write(ulsort,90002) 'nbgrou', nbgrou +#endif +c +c 2.1. ==> Explorations de tous les groupes associes a la famille +c + do 211 , ngro = 1 , nbgrou +c +c 2.1.1. ==> Longueur du nom +c + iaux = grfmpo(nfam-1) + 1 + 10*(ngro-1) + lnogrf = 0 + do 2111 , jaux = 1 , 10 + lnogrf = lnogrf + grfmtl(iaux+jaux-1) + 2111 continue +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'ngro / lnogrf', ngro, lnogrf +#endif +c +c 2.1.2. ==> Le nom +c + call uts8ch ( grfmtb(iaux), lnogrf, nomgrf, + > ulsort, langue, codret ) +cgn write(ulsort,90003) 'Groupe ', nomgrf(1:lnogrf) +c +c 2.1.3. ==> Le nom est-il deja enregistre ? +c + do 2113 , jaux = 1 , nbgrfm + if ( lnogrf.eq.lgnogr(jaux) ) then + kaux = 10*(jaux-1) + 1 + call uts8ch ( nomgro(kaux), lnogrf, nomgrl, + > ulsort, langue, codret ) +cgn write(ulsort,90003) '. Groupe ', nomgrl(1:lnogrf) + if ( nomgrf(1:lnogrf).eq.nomgrl(1:lnogrf) ) then + goto 219 + endif + endif + 2113 continue +c +c 2.1.4. ==> Enregistrement d'un nouveau nom +c + nbgrfm = nbgrfm + 1 + lgnogr(nbgrfm) = lnogrf + kaux = 10*(nbgrfm-1) + 1 + call utchs8 ( nomgrf, 80, nomgro(kaux), + > ulsort, langue, codret ) +c + 219 continue +c + 211 continue +c + endif +c + 21 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbgrfm', nbgrfm +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uthcac.F b/src/tool/Utilitaire/uthcac.F new file mode 100644 index 00000000..e1b38f04 --- /dev/null +++ b/src/tool/Utilitaire/uthcac.F @@ -0,0 +1,81 @@ + subroutine uthcad ( bindec, nbaret, aredec ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Hexaedre coupe par Conformite - Aretes Coupees +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . bindec . e . 1 . binaire du decoupage . +c . nbaret . s . 1 . nombre d'aretes coupees . +c . aredec . s . 12 . numeros locaux des aretes coupees . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c#include "hexcf0.h" +#include "hexcf1.h" +c +c 0.3. ==> arguments +c + integer bindec + integer nbaret, aredec(12) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + character*3 saux03 +c +c==== +c 1. traitement +c==== +c + nbaret = 0 + jaux = 1 + do 11 , iaux = 1 , 12 +c +cgn print *, charde(bindec)(jaux:jaux+3) + saux03 = charde(bindec)(jaux:jaux+3) + if ( saux03.ne.' ' ) then + read(saux03,'(i3)') aredec(iaux) + nbaret = nbaret + 1 + jaux = jaux + 3 + else + goto 12 + endif +c + 11 continue +c + 12 continue +cgn print *, 'Nombre d aretes coupees :', nbaret +cgn print *, 'aredec =', (aredec(iaux),iaux=1,nbaret) +c + end diff --git a/src/tool/Utilitaire/uthcai.F b/src/tool/Utilitaire/uthcai.F new file mode 100644 index 00000000..1f08690c --- /dev/null +++ b/src/tool/Utilitaire/uthcai.F @@ -0,0 +1,288 @@ + subroutine uthcai ( lehexa, bindec, + > aretri, + > arequa, + > quahex, coquhe, arehex, + > filhex, fhpyte, + > tritet, cotrte, aretet, + > facpyr, cofapy, arepyr, + > areint ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Hexaedre coupe par Conformite - Aretes Internes +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . bindec . e . 1 . binaire du decoupage . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . areint . s . nbarhi . les aretes internes a l'hexaedre . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombte.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer lehexa, bindec + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer filhex(nbheto), fhpyte(2,nbheco) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer areint(*) +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer f1hp, lequad + integer listar(12), listaf(12) + integer nbarmx, nbarhi + integer nbfipy, filspy + integer nbfite, filste + integer nbfihe, filshe +c +#include "impr03.h" +c +c==== +c 1. Les aretes externes de l'hexaedre +c==== +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c +c==== +c 2. Les aretes internes de l'hexaedre +c On examine les aretes de chaque fils. Si elle est interne, on +c l'ajoute a la liste. On s'arrete quand le compte est bon +c==== +c + nbarmx = nbarto - nbarin + nbarhi = 0 +c +c 2.1. ==> nombre de fils +c + nbfihe = chnhe(bindec) + nbfipy = chnpy(bindec) + nbfite = chnte(bindec) +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'bindec', bindec + write (*,90002) 'nbfihe', nbfihe + write (*,90002) 'nbfipy', nbfipy + write (*,90002) 'nbfite', nbfite +#endif +c + f1hp = filhex(lehexa) +cgn write (*,90002) 'f1hp', f1hp +c +c 2.2. ==> Examen des pyramides +c + if ( nbfipy.ne.0 ) then +c + filspy = fhpyte(1,-f1hp) +cgn write (*,90002) 'filspy', bindec + do 22 , kaux = 1 , nbfipy +#ifdef _DEBUG_HOMARD_ + write (*,90002) '. Pyramide', filspy +#endif + if ( filspy.le.nbpycf ) then + call utarpy ( filspy, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listaf ) + else + do 221 , iaux = 1 , 8 + listaf(iaux) = arepyr(filspy-nbpycf,iaux) + 221 continue + endif +c + do 222 , iaux = 1 , 8 + if ( listaf(iaux).gt.nbarmx ) then + do 2221 , jaux = 1 , nbarhi + if ( listaf(iaux).eq.areint(jaux) ) then + goto 222 + endif + 2221 continue + nbarhi = nbarhi + 1 + areint(nbarhi) = listaf(iaux) + if ( nbarhi.eq.chnar(bindec) ) then + goto 9999 + endif + endif + 222 continue +c + filspy = filspy + 1 +c + 22 continue +c + endif +c +c 2.3. ==> Examen des tetraedres +c + if ( nbfite.ne.0 ) then +c + filste = fhpyte(2,-f1hp) + do 23 , kaux = 1 , nbfite +#ifdef _DEBUG_HOMARD_ + write (*,90002) '. Tetraedre', filste +#endif + if ( filste.le.nbtecf ) then + call utarte ( filste, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listaf ) + else + do 231 , iaux = 1 , 4 + listaf(iaux) = aretet(filste-nbtecf,iaux) + 231 continue + endif +c + do 232 , iaux = 1 , 4 + if ( listaf(iaux).gt.nbarmx ) then + do 2321 , jaux = 1 , nbarhi + if ( listaf(iaux).eq.areint(jaux) ) then + goto 232 + endif + 2321 continue + nbarhi = nbarhi + 1 + areint(nbarhi) = listaf(iaux) + if ( nbarhi.eq.chnar(bindec) ) then + goto 9999 + endif + endif + 232 continue +c + filste = filste + 1 +c + 23 continue +c + endif +c +c 2.4. ==> Examen des hexaedres +c 2.4.1. ==> Cas du decoupage en 8 +c + if ( bindec.eq.4095 ) then +#ifdef _DEBUG_HOMARD_ + write (*,*) '. Hexaedre coupe en 8' +#endif +c + do 241 , iaux = 1 , 6 +c + if ( iaux.eq.1) then + lequad = quahex(f1hp,5) + elseif ( iaux.eq.2) then + lequad = quahex(f1hp,4) + elseif ( iaux.eq.3) then + lequad = quahex(f1hp,6) + elseif ( iaux.eq.4) then + lequad = quahex(f1hp+7,1) + elseif ( iaux.eq.5) then + lequad = quahex(f1hp+7,3) + else + lequad = quahex(f1hp+7,2) + endif + nbarhi = nbarhi + 1 + areint(nbarhi) = arequa(lequad,2) +c + 241 continue +c +c 2.4.2. ==> Cas du decoupage de conformite +c + else +c + filshe = f1hp + do 242 , kaux = 1 , nbfihe +#ifdef _DEBUG_HOMARD_ + write (*,90002) '. Hexaedre', filshe +#endif + if ( filshe.le.nbhecf ) then + call utarhe ( filshe, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listaf ) + else + do 2421 , iaux = 1 , 12 + listaf(iaux) = arehex(filshe-nbhecf,iaux) + 2421 continue + endif +c + do 2422 , iaux = 1 , 12 + if ( listaf(iaux).gt.nbarmx ) then + do 24221 , jaux = 1 , nbarhi + if ( listaf(iaux).eq.areint(jaux) ) then + goto 2422 + endif +24221 continue + nbarhi = nbarhi + 1 + areint(nbarhi) = listaf(iaux) + if ( nbarhi.eq.chnar(bindec) ) then + goto 9999 + endif + endif + 2422 continue +c + filshe = filshe + 1 +c + 242 continue +c + endif +c + 9999 continue +#ifdef _DEBUG_HOMARD_ + write (*,90002) '. Nombre d''aretes internes', nbarhi +#endif +c + end diff --git a/src/tool/Utilitaire/uthcnb.F b/src/tool/Utilitaire/uthcnb.F new file mode 100644 index 00000000..6f092641 --- /dev/null +++ b/src/tool/Utilitaire/uthcnb.F @@ -0,0 +1,139 @@ + subroutine uthcnb ( etdare, + > nbreso, nbrear, nbrepy, nbrete, nbrehe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Hexaedre, Conformite - recuperation des NomBres +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . etdare . e . 12 . etat/decision des aretes . +c . nbreso . s . 1 . nombre de sommets a creer . +c . nbrear . s . 1 . nombre d'arete a creer . +c . nbrepy . s . 1 . nombre de pyramides a creer . +c . nbrete . s . 1 . nombre de tetraedres a creer . +c . nbrehe . s . 1 . nombre d'hexaedres a creer . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTHCNB' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer etdare(12) + integer nbreso, nbrear, nbrepy, nbrete, nbrehe +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. les references +c==== +c + jaux = etdare(1) + do 20 , iaux = 2, 12 +cgn write(ulsort,90015) 'etdare(', iaux, ') :', etdare + if ( etdare(iaux).gt.0 ) then + jaux = jaux + 2**(iaux-1) + endif + 20 continue +cgn write(ulsort,90002) '==> binaire', jaux +c + nbreso = chnp1(jaux) + nbrear = chnar(jaux) + nbrepy = chnpy(jaux) + nbrete = chnte(jaux) + nbrehe = chnhe(jaux) + if ( nbreso.eq.-1 ) then + write(ulsort,90002) '==> binaire', jaux + write(ulsort,*) 'etdare', etdare + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + call dmflsh(iaux) +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uthequ.F b/src/tool/Utilitaire/uthequ.F new file mode 100644 index 00000000..3a556946 --- /dev/null +++ b/src/tool/Utilitaire/uthequ.F @@ -0,0 +1,356 @@ + subroutine uthequ ( decisi, + > nbquto, nbheto, nbhecf, nbpyto, nbpycf, + > quahex, hethex, filhex, + > fhpyte, + > facpyr, + > volqua, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - HExaedres - QUadrangles +c -- -- -- +c ______________________________________________________________________ +c +c but : etablit le tableau volqua a partir de son reciproque, quahex +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decisi . e . 1 . pilotage des voisins des quadrangles : . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . . . . a. qu'il n'y a pas de hexaedre doubles . +c . . . . b. qu'un quadrangle n'appartient pas a plus. +c . . . . de 2 hexaedres . +c . nbquto . e . 1 . nombre de quadrangles total . +c . nbheto . e . 1 . nombre d'hexaedres total . +c . nbhecf . e . 1 . nombre d'hexaedres decrits par faces . +c . nbpyto . e . 1 . nombre de pyramides total . +c . nbpycf . e . 1 . nombre de pyramides decrites par faces . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique des etats des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbhedc. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . volqua . s .nbquto*2. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme dans le controle . +c . . . . 3 : probleme de hexaedres doubles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTHEQU' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "hexcf0.h" +c +c 0.3. ==> arguments +c + integer nbquto, nbheto, nbhecf, nbpyto, nbpycf + integer filhex(nbheto), hethex(nbheto), quahex(nbhecf,6) + integer fhpyte(2,*) + integer facpyr(nbpycf,5) + integer volqua(2,nbquto) + integer decisi +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2 + integer etat, bindec, nbfipy + integer fils + integer lehexa + integer lequad, quad(6), quabis(6), quadcl(6), quabcl(6) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(/,''Le quadrangle'',i10,'' a plus de deux voisins ?'')' + texte(1,5) = '(''Hexaedres :'',3i10,/)' + texte(1,6) = + > '(/,''Les deux hexaedres suivants sont identiques.'')' + texte(1,7) = + > '(''Quadrangles du hexaedre numero :'',i10,'' : '',4i10)' +c + texte(2,4) = + > '(/,''Quadrangle'',i10,'' has more than 2 neighbours ?'')' + texte(2,5) = '(''Tetraedra :'',3i10,/)' + texte(2,6) = '(/,''The following two tetraedra are the same.'')' + texte(2,7) ='(''Quadrangles of hexahedron #'',i10,'' : '',4i10)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbquto', nbquto + write(ulsort,90002) 'nbheto', nbheto + write(ulsort,90002) 'nbhecf', nbhecf + write(ulsort,90002) 'nbpyto', nbpyto + write(ulsort,90002) 'nbpycf', nbpycf +#endif +c +c==== +c 2. liste des hexaedres s'appuyant sur chaque quadrangle +c attention : a priori, un quadrangle borde 0, 1 ou 2 hexaedres +c==== +c +c 2. ==> on regarde tous les hexaedres decrits par faces +c + do 20 , lehexa = 1 , nbhecf +c +c 2.1. ==> les quadrangles du hexaedre en cours d'examen +c + quad(1) = quahex(lehexa,1) + quad(2) = quahex(lehexa,2) + quad(3) = quahex(lehexa,3) + quad(4) = quahex(lehexa,4) + quad(5) = quahex(lehexa,5) + quad(6) = quahex(lehexa,6) +#ifdef _DEBUG_HOMARD_ + if ( lehexa.eq.-437 .or. lehexa.le.-438 ) then + write(ulsort,90015) 'quads de hexa', lehexa,' :', quad + glop = 1 + else + glop = 0 + endif +#endif +c +c 2.2. ==> quand un hexaedre est decoupe pour la mise en +c conformite, certains de ses quadrangles sont des bords de +c l'hexaedre et de ses fils. +c La convention HOMARD veut que l'on ne memorise que le fils +c dans les voisins du quadrangle. +c on va alors annuler le numero du quadrangle pour ne rien +c archiver maintenant. +c + etat = mod(hethex(lehexa),1000) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write(ulsort,90015) 'etat de hexa', lehexa,' :',etat + endif +#endif +c + if ( etat.ge.11 ) then +C + bindec = chbiet(etat) + nbfipy = chnpy(bindec) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write(ulsort,90002) 'bindec, nbfipy', bindec, nbfipy + write(ulsort,90015) 'fils de ', lehexa,' :', filhex(lehexa) + endif +#endif +c + if ( nbfipy.gt.0 ) then +c + if ( filhex(lehexa).lt.0 ) then +c + iaux = -filhex(lehexa) + fils = fhpyte(1,iaux) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write(ulsort,90002) 'fils, nbpycf', fils, nbpycf + endif +#endif +c + if ( fils.le.nbpycf ) then +c + do 22 , jaux = 1 , nbfipy + do 221 , lequad = 1 , 6 + if ( quad(lequad).eq.facpyr(fils,5) ) then + quad(lequad) = 0 + endif + 221 continue + fils = fils + 1 + 22 continue +c + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0 ) then + write(ulsort,90015) 'quads de hexa', lehexa,' :', quad + endif +#endif +c + endif +c + endif +c + endif +c +c 2.3. ==> pour chacun des 6 quadrangles encore a traiter +c + do 23 , lequad = 1 , 6 +c + if ( quad(lequad).gt.0 ) then +c +c 2.3.1. ==> aucun voisin n'existe : on met l'hexaedre courant +c comme premier voisin +c + if ( volqua(1,quad(lequad)).eq.0 ) then +c + volqua(1,quad(lequad)) = lehexa +c + else +c +c 2.3.2. ==> il existe un premier voisin +c +c 2.3.2.1. ==> en cas de controle : +c + if ( decisi.eq.2 ) then +c +c 2.3.2.1.1. ==> on verifie que le second hexaedre n'est pas identique +c au premier. Pour cela, on trie les tableaux des +c quadrangles par numero de quadrangles croissant et +c on compare. +c + if ( volqua(2,quad(lequad)).eq.0 ) then +c + if ( volqua(1,quad(lequad)).gt.0 ) then +c + quabis(1) = quahex(volqua(1,quad(lequad)),1) + quabis(2) = quahex(volqua(1,quad(lequad)),2) + quabis(3) = quahex(volqua(1,quad(lequad)),3) + quabis(4) = quahex(volqua(1,quad(lequad)),4) + quabis(5) = quahex(volqua(1,quad(lequad)),5) + quabis(6) = quahex(volqua(1,quad(lequad)),6) +c + call uttrii ( quadcl, jaux, kaux, + > 6, quad, + > ulsort, langue, codre1 ) +c + call uttrii ( quabcl, jaux, kaux, + > 6, quabis, + > ulsort, langue, codre2 ) +c + if ( codre1.eq.0 .and. codre2.eq.0 ) then + if ( quad(quadcl(1)).eq.quabis(quabcl(1)) .and. + > quad(quadcl(2)).eq.quabis(quabcl(2)) .and. + > quad(quadcl(3)).eq.quabis(quabcl(3)) .and. + > quad(quadcl(4)).eq.quabis(quabcl(4)) .and. + > quad(quadcl(5)).eq.quabis(quabcl(5)) .and. + > quad(quadcl(6)).eq.quabis(quabcl(6)) ) then + write(ulsort,texte(langue,6)) + write(ulsort,texte(langue,7)) lehexa, quad + write(ulsort,texte(langue,7)) + > volqua(1,quad(lequad)), quabis + codret = 3 + endif + else + codret = 1 + endif +c + endif +c +c 2.3.2.1.2. ==> il y a deja un second volume comme voisin de ce +c quadrangle ! +c + else +c + write(ulsort,texte(langue,4)) quad(lequad) + write(ulsort,texte(langue,5)) volqua(1,quad(lequad)), + > volqua(2,quad(lequad)), + > lehexa + codret = 3 +c + endif +c + endif +c +c 2.3.2.2. ==> il existe un premier voisin : on met l'hexaedre +c courant comme second voisin +c + volqua(2,quad(lequad)) = lehexa +c + endif +c + endif +c + 23 continue +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uthonh.F b/src/tool/Utilitaire/uthonh.F new file mode 100644 index 00000000..b1c106ab --- /dev/null +++ b/src/tool/Utilitaire/uthonh.F @@ -0,0 +1,269 @@ + subroutine uthonh ( noehom, arehom, + > homtri, quahom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - HOmologues - Nombres pour HOMARD +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . noehom . e . nbnoto . liste etendue des homologues par noeuds . +c . arehom . e . nbarto . liste etendue des homologues par aretes . +c . homtri . e . nbtrto . ensemble des triangles homologues . +c . quahom . e . nbquto . ensemble des quadrangles homologues . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTHONH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer noehom(nbnoto), arehom(nbarto) + integer homtri(nbtrto), quahom(nbquto) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(/,''Decompte des equivalences sur les '',a)' + texte(1,4) = '(''--> Ce nombre doit etre pair !'')' + texte(1,5) = + > '(8x,''. Nombre de paires :'',i10)' +c + texte(2,10) = '(/,''Description of equivalences over '',a)' + texte(2,4) = '(''--> This number should be even !'')' + texte(2,5) = + > '(8x,''. Number of pairs :'',i10)' +c + codret = 0 +c +c==== +c 2. decompte du nombre de paires de noeuds homologues +c il faut noter les cas ou un noeud est homologue de lui-meme +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,-1) +#endif +c + nbpnho = 0 +c + do 21 , iaux = 1 , nbnoto + if ( noehom(iaux).eq.iaux ) then + nbpnho = nbpnho + 2 + elseif ( noehom(iaux).ne.0 ) then + nbpnho = nbpnho + 1 + endif + 21 continue +c + if ( mod(nbpnho,2).eq.0 ) then + nbpnho = nbpnho / 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbpnho +#endif + else + write (ulsort,texte(langue,5)) nbpnho + write (ulsort,texte(langue,4)) + codret = 21 + endif +c + endif +c +c==== +c 3. decompte du nombre de paires de noeuds homologues +c il faut noter les cas ou une arete est homologue d'elle-meme +c==== +c + if ( codret.eq.0 ) then +c + nbpaho = 0 +c + if ( homolo.ge.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,1) +#endif +c + do 31 , iaux = 1 , nbarto + if ( abs(arehom(iaux)).eq.iaux ) then + nbpaho = nbpaho + 2 + elseif ( arehom(iaux).ne.0 ) then + nbpaho = nbpaho + 1 + endif + 31 continue +c + if ( mod(nbpaho,2).eq.0 ) then + nbpaho = nbpaho / 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbpaho +#endif + else + write (ulsort,texte(langue,5)) nbpaho + write (ulsort,texte(langue,4)) + codret = 31 + endif +c + endif +c + endif +c +c==== +c 4. decompte du nombre de paires de triangles homologues +c==== +c + if ( codret.eq.0 ) then +c + nbptho = 0 +c + if ( homolo.ge.3 .and. nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,2) +#endif +c + do 41 , iaux = 1 , nbtrto + if ( homtri(iaux).ne.0 ) then + nbptho = nbptho + 1 + endif + 41 continue +c + if ( mod(nbptho,2).eq.0 ) then + nbptho = nbptho / 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbptho +#endif + else + write (ulsort,texte(langue,5)) nbptho + write (ulsort,texte(langue,4)) + codret = 41 + endif +c + endif +c + endif +c +c==== +c 5. decompte du nombre de paires de quadrangles homologues +c==== +c + if ( codret.eq.0 ) then +c + nbpqho = 0 +c + if ( homolo.ge.3 .and. nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,3,4) +#endif +c + do 51 , iaux = 1 , nbquto + if ( quahom(iaux).ne.0 ) then + nbpqho = nbpqho + 1 + endif + 51 continue +c + if ( mod(nbpqho,2).eq.0 ) then + nbpqho = nbpqho / 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbpqho +#endif + else + write (ulsort,texte(langue,5)) nbpqho + write (ulsort,texte(langue,4)) + codret = 51 + endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utimpg.F b/src/tool/Utilitaire/utimpg.F new file mode 100644 index 00000000..98cc2511 --- /dev/null +++ b/src/tool/Utilitaire/utimpg.F @@ -0,0 +1,233 @@ + subroutine utimpg ( choix, ngauss, nbnorf, sdim, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - IMpressions relatives aux Points de Gauss +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . choix . e . 1 . choix des impressions . +c . . . . 2n : les localisations de l'element de . +c . . . . reference . +c . . . . 3n : les fonctions de forme . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . nbnorf . e . 1 . nbre de noeuds de l'element de reference . +c . sdim . e . 1 . dimension de l'element de reference . +c . conorf . e . sdim* . coordonnees des noeuds de l'element de . +c . . . nbnorf . reference . +c . copgrf . e . sdim* . coordonnees des points de Gauss . +c . . . ngauss . de l'element de reference . +c . wipg . s . nbnorf*. fonctions de forme exprimees aux points de . +c . . . ngauss . Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTIMPG' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer choix + integer ngauss, nbnorf, sdim +c + double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss) + double precision wipg(nbnorf,ngauss) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c + if ( choix.gt.0 ) then +c +c==== +c 2. Ecriture des localisations +c==== +c + if ( mod(choix,2).eq.0 ) then +c +c 2.1. ==> dimension 1 +c + if ( sdim.eq.1 ) then +c 123456789012345 + write (ulsort,20001) 'noeuds ' + do 2011 , iaux = 1 , nbnorf + write (ulsort,20011) iaux, conorf(1,iaux) + 2011 continue + write (ulsort,20021) + write (ulsort,20001) 'points de Gauss' + do 2021 , iaux = 1 , ngauss + write (ulsort,20011) iaux, copgrf(1,iaux) + 2021 continue + write (ulsort,20021) +c +c 2.2. ==> dimension 2 +c + elseif ( sdim.eq.2 ) then +c + write (ulsort,20002) 'noeuds ' + do 2012 , iaux = 1 , nbnorf + write (ulsort,20012) iaux, conorf(1,iaux), conorf(2,iaux) + 2012 continue + write (ulsort,20022) + write (ulsort,20002) 'points de Gauss' + do 2022 , iaux = 1 , ngauss + write (ulsort,20012) iaux, copgrf(1,iaux), copgrf(2,iaux) + 2022 continue + write (ulsort,20022) +c +c 2.3. ==> dimension 3 +c + else +c + write (ulsort,20003) 'noeuds ' + do 2013 , iaux = 1 , nbnorf + write (ulsort,20013) iaux, conorf(1,iaux), conorf(2,iaux), + > conorf(3,iaux) + 2013 continue + write (ulsort,20023) + write (ulsort,20003) 'points de Gauss' + do 2023 , iaux = 1 , ngauss + write (ulsort,20013) iaux, copgrf(1,iaux), copgrf(2,iaux), + > copgrf(3,iaux) + 2023 continue + write (ulsort,20023) + endif +c +20001 format( + >/,28('*'), + >/,'* Coordonnees des *', + >/,'* ',a15 ,' *', + >/,28('*'), + >/,'* Numero * x *', + >/,28('*')) +20002 format( + >/,44('*'), + >/,'* Coordonnees des ',a15 ,' *', + >/,44('*'), + >/,'* Numero * x * y *', + >/,44('*')) +20003 format( + >/,60('*'), + >/,'* Coordonnees des ',a15 , + >' *', + >/,60('*'), + >/,'* Numero * x * y *', + >' z *', + >/,60('*')) +20011 format('* ',i5,' * ',g11.5,' *') +20012 format('* ',i5,2x,2(' * ',g11.5),' *') +20013 format('* ',i5,2x,3(' * ',g11.5),' *') +20021 format(28('*')) +20022 format(44('*')) +20023 format(60('*')) +c +c==== +c 3. Ecriture des fonctions de forme aux points de Gauss +c==== +c + elseif ( mod(choix,3).eq.0 ) then +c 123456789012345 + do 3011 , iaux = 1 , nbnorf + write (ulsort,30001) iaux + do 3021 , jaux = 1 , ngauss + write (ulsort,20011) jaux, wipg(iaux,jaux) + 3021 continue + write (ulsort,20021) + 3011 continue +c + endif +c +c 123456789012345678901234567890 +30001 format( + >/,28('*'), + >/,'* Fonction associee au *', + >/,'* noeud numero', i8,' *', + >/,28('*'), + >/,'* Point de * Valeur *', + >/,'* Gauss * *', + >/,28('*')) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utinca.F b/src/tool/Utilitaire/utinca.F new file mode 100644 index 00000000..8ca089dd --- /dev/null +++ b/src/tool/Utilitaire/utinca.F @@ -0,0 +1,155 @@ + subroutine utinca +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - INitialisation des Constantes de l'Adaptation +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "permut.h" +#include "cofhex.h" +#include "cofpen.h" +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c +c==== +c 1. permutations des codes des faces dans les tetraedres +c==== +c + perm1(1) = 4 + perm1(2) = 5 + perm1(3) = 6 + perm1(4) = 1 + perm1(5) = 2 + perm1(6) = 3 +c + perm2(1) = 5 + perm2(2) = 6 + perm2(3) = 4 + perm2(4) = 3 + perm2(5) = 1 + perm2(6) = 2 +c + perm3(1) = 6 + perm3(2) = 4 + perm3(3) = 5 + perm3(4) = 2 + perm3(5) = 3 + perm3(6) = 1 +c +c=== +c 2. codes des faces creees dans le raffinement standard d'un hexaedre +c suivant le code de la mere +c=== +c + cofh18(1)=1 + cofh18(2)=1 + cofh18(3)=1 + cofh18(4)=1 + cofh18(5)=8 + cofh18(6)=8 + cofh18(7)=8 + cofh18(8)=8 + + cofh25(1)=2 + cofh25(2)=2 + cofh25(3)=2 + cofh25(4)=2 + cofh25(5)=5 + cofh25(6)=5 + cofh25(7)=5 + cofh25(8)=5 + + cofh36(1)=3 + cofh36(2)=3 + cofh36(3)=3 + cofh36(4)=3 + cofh36(5)=6 + cofh36(6)=6 + cofh36(7)=6 + cofh36(8)=6 +c + cofh47(1)=4 + cofh47(2)=4 + cofh47(3)=4 + cofh47(4)=4 + cofh47(5)=7 + cofh47(6)=7 + cofh47(7)=7 + cofh47(8)=7 +c +c=== +c 3. codes des faces creees dans le raffinement standard d'un pentaedre +c suivant le code de la mere +c=== +c + cofp08(1,0) = 1 + cofp08(2,0) = 2 + cofp08(3,0) = 3 + cofp08(4,0) = 4 + cofp08(5,0) = 5 + cofp08(6,0) = 6 + cofp08(7,0) = 7 + cofp08(8,0) = 8 +c + cofp08(1,1) = 2 + cofp08(2,1) = 3 + cofp08(3,1) = 4 + cofp08(4,1) = 1 + cofp08(5,1) = 8 + cofp08(6,1) = 5 + cofp08(7,1) = 6 + cofp08(8,1) = 7 +c + cofp08(1,2) = 3 + cofp08(2,2) = 4 + cofp08(3,2) = 1 + cofp08(4,2) = 2 + cofp08(5,2) = 7 + cofp08(6,2) = 8 + cofp08(7,2) = 5 + cofp08(8,2) = 6 +c + cofp08(1,3) = 4 + cofp08(2,3) = 1 + cofp08(3,3) = 2 + cofp08(4,3) = 3 + cofp08(5,3) = 6 + cofp08(6,3) = 7 + cofp08(7,3) = 8 + cofp08(8,3) = 5 +c + end diff --git a/src/tool/Utilitaire/utincg.F b/src/tool/Utilitaire/utincg.F new file mode 100644 index 00000000..7087b001 --- /dev/null +++ b/src/tool/Utilitaire/utincg.F @@ -0,0 +1,1124 @@ + subroutine utincg +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - INitialisation des Constantes Generales +c -- -- - - +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "i1i2i3.h" +#include "j1234j.h" +#include "defiqu.h" +#include "demitr.h" +#include "comp07.h" +#include "op0012.h" +#include "op0123.h" +#include "op1234.h" +#include "oriett.h" +#include "orieqh.h" +#include "oriefp.h" +#include "oriefy.h" +#include "op1aa6.h" +#include "ope1a3.h" +#include "ope1a4.h" +#include "ope4a6.h" +#include "ope001.h" +#include "ope002.h" +#include "infini.h" +#include "impr02.h" +#include "enti01.h" +#include "indefi.h" +#include "indefr.h" +#include "indefs.h" +#include "precis.h" +#include "chisig.h" +#include "hexcf0.h" +#include "hexcf1.h" +#include "dicfen.h" +#include "nbfamm.h" +c +#include "fahmed.h" +c +c 0.3. ==> arguments +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer kaux1, kaux2, kaux3, kaux4 + integer tabaux(6) + integer typenh +c +#include "impr03.h" +c +c==== +c 1. les constantes +c==== +c +c 1.1. ==> les extremes +c + call dmzero ( vinfpo, zeroma ) +c + vinfne = - vinfpo +c +c 1.2. ==> precision machine et plus grand entier +c + call dmprma ( epsima, dmxent, nbchii ) +c +c 1.3. ==> les valeurs indefinies +c + call dmindf ( iindef, rindef, sindef ) +c +c==== +c 2. initialisation des fonctions en dur +c==== +c +c 2.1. ==> fonction de numerotation des demi-triangles fils +c remarque : la diagonale du tableau n'est pas utilisee +c on met une valeur indefinie pour planter au cas ou ! +c + nutrde(1,1) = iindef + nutrde(1,2) = 0 + nutrde(1,3) = 1 + nutrde(2,1) = 0 + nutrde(2,2) = iindef + nutrde(2,3) = 1 + nutrde(3,1) = 0 + nutrde(3,2) = 1 + nutrde(3,3) = iindef +c +c 2.2. ==> Codes permettant d'ordonner les fils d'un quadrangle +c quand il est face d'un hexaedre ou d'un pentaedre +c + defiq1(1) = 0 + defiq1(2) = 3 + defiq1(3) = 2 + defiq1(4) = 1 + defiq1(5) = 1 + defiq1(6) = 2 + defiq1(7) = 3 + defiq1(8) = 0 +c + defiq2(1) = 1 + defiq2(2) = 0 + defiq2(3) = 3 + defiq2(4) = 2 + defiq2(5) = 0 + defiq2(6) = 1 + defiq2(7) = 2 + defiq2(8) = 3 +c + defiq3(1) = 2 + defiq3(2) = 1 + defiq3(3) = 0 + defiq3(4) = 3 + defiq3(5) = 3 + defiq3(6) = 0 + defiq3(7) = 1 + defiq3(8) = 2 +c + defiq4(1) = 3 + defiq4(2) = 2 + defiq4(3) = 1 + defiq4(4) = 0 + defiq4(5) = 2 + defiq4(6) = 3 + defiq4(7) = 0 + defiq4(8) = 1 +c +c 2.3. ==> numero local de la face opposee pour un hexaedre respectant +c la convention d'un de : i + coen07(i) = 7 +c + coen07(1) = 6 + coen07(2) = 5 + coen07(3) = 4 + coen07(4) = 3 + coen07(5) = 2 + coen07(6) = 1 +c +c 2.4. ==> correspondance entre le code d'un triangle dans un +c tetraedre ou un pentaedre et les numeros locaux des aretes +c de cette face +c Pour une face de code c : +c i1(c) : numero local de l'arete I1 +c i2(c) : numero local de l'arete I2 +c i3(c) : numero local de l'arete I3 +c + i1(1) = 1 + i1(2) = 3 + i1(3) = 2 + i1(4) = 1 + i1(5) = 3 + i1(6) = 2 +c + i2(1) = 2 + i2(2) = 1 + i2(3) = 3 + i2(4) = 3 + i2(5) = 2 + i2(6) = 1 +c + i3(1) = 3 + i3(2) = 2 + i3(3) = 1 + i3(4) = 2 + i3(5) = 1 + i3(6) = 3 +c +c 2.5. ==> correspondance entre le code d'un quadrangle dans un +c un hexaedre ou un pentaedre et les numeros locaux des aretes +c de cette face +c Pour une face de code c : +c j1(c) : numero local de l'arete I1 +c j2(c) : numero local de l'arete I2 +c j3(c) : numero local de l'arete I3 +c j4(c) : numero local de l'arete I4 +c + j1(1) = 1 + j1(2) = 4 + j1(3) = 3 + j1(4) = 2 + j1(5) = 1 + j1(6) = 2 + j1(7) = 3 + j1(8) = 4 +c + j2(1) = 2 + j2(2) = 1 + j2(3) = 4 + j2(4) = 3 + j2(5) = 4 + j2(6) = 1 + j2(7) = 2 + j2(8) = 3 +c + j3(1) = 3 + j3(2) = 2 + j3(3) = 1 + j3(4) = 4 + j3(5) = 3 + j3(6) = 4 + j3(7) = 1 + j3(8) = 2 +c + j4(1) = 4 + j4(2) = 3 + j4(3) = 2 + j4(4) = 1 + j4(5) = 2 + j4(6) = 3 + j4(7) = 4 + j4(8) = 1 +c +c 2.6. ==> correspondance entre le code des faces dans un volume +c et l'orientation relative de cette face +c Pour la face i de code c : +c orcoxx(i,c) : 1, la face est sortante +c -1, la face est entrante +c 2.6.1. ==> tetraedre/triangle +c + orcott(1,1) = 1 + orcott(1,2) = 1 + orcott(1,3) = 1 + orcott(1,4) = -1 + orcott(1,5) = -1 + orcott(1,6) = -1 +c + orcott(2,1) = -1 + orcott(2,2) = -1 + orcott(2,3) = -1 + orcott(2,4) = 1 + orcott(2,5) = 1 + orcott(2,6) = 1 +c + orcott(3,1) = -1 + orcott(3,2) = -1 + orcott(3,3) = -1 + orcott(3,4) = 1 + orcott(3,5) = 1 + orcott(3,6) = 1 +c + orcott(4,1) = 1 + orcott(4,2) = 1 + orcott(4,3) = 1 + orcott(4,4) = -1 + orcott(4,5) = -1 + orcott(4,6) = -1 +c +c 2.6.3. ==> hexaedre/quadrangle +c + orcoqh(1,1) = -1 + orcoqh(1,2) = -1 + orcoqh(1,3) = -1 + orcoqh(1,4) = -1 + orcoqh(1,5) = 1 + orcoqh(1,6) = 1 + orcoqh(1,7) = 1 + orcoqh(1,8) = 1 +c + orcoqh(2,1) = -1 + orcoqh(2,2) = -1 + orcoqh(2,3) = -1 + orcoqh(2,4) = -1 + orcoqh(2,5) = 1 + orcoqh(2,6) = 1 + orcoqh(2,7) = 1 + orcoqh(2,8) = 1 +c + orcoqh(3,1) = -1 + orcoqh(3,2) = -1 + orcoqh(3,3) = -1 + orcoqh(3,4) = -1 + orcoqh(3,5) = 1 + orcoqh(3,6) = 1 + orcoqh(3,7) = 1 + orcoqh(3,8) = 1 +c + orcoqh(4,1) = -1 + orcoqh(4,2) = -1 + orcoqh(4,3) = -1 + orcoqh(4,4) = -1 + orcoqh(4,5) = 1 + orcoqh(4,6) = 1 + orcoqh(4,7) = 1 + orcoqh(4,8) = 1 +c + orcoqh(5,1) = -1 + orcoqh(5,2) = -1 + orcoqh(5,3) = -1 + orcoqh(5,4) = -1 + orcoqh(5,5) = 1 + orcoqh(5,6) = 1 + orcoqh(5,7) = 1 + orcoqh(5,8) = 1 +c + orcoqh(6,1) = -1 + orcoqh(6,2) = -1 + orcoqh(6,3) = -1 + orcoqh(6,4) = -1 + orcoqh(6,5) = 1 + orcoqh(6,6) = 1 + orcoqh(6,7) = 1 + orcoqh(6,8) = 1 +c +c 2.6.3. ==> pentaedre/triangle et pentaedre/quadrangle +c + orcofp(1,1) = -1 + orcofp(1,2) = -1 + orcofp(1,3) = -1 + orcofp(1,4) = 1 + orcofp(1,5) = 1 + orcofp(1,6) = 1 +c + orcofp(2,1) = -1 + orcofp(2,2) = -1 + orcofp(2,3) = -1 + orcofp(2,4) = 1 + orcofp(2,5) = 1 + orcofp(2,6) = 1 +c + orcofp(3,1) = -1 + orcofp(3,2) = -1 + orcofp(3,3) = -1 + orcofp(3,4) = -1 + orcofp(3,5) = 1 + orcofp(3,6) = 1 + orcofp(3,7) = 1 + orcofp(3,8) = 1 +c + orcofp(4,1) = -1 + orcofp(4,2) = -1 + orcofp(4,3) = -1 + orcofp(4,4) = -1 + orcofp(4,5) = 1 + orcofp(4,6) = 1 + orcofp(4,7) = 1 + orcofp(4,8) = 1 +c + orcofp(5,1) = -1 + orcofp(5,2) = -1 + orcofp(5,3) = -1 + orcofp(5,4) = -1 + orcofp(5,5) = 1 + orcofp(5,6) = 1 + orcofp(5,7) = 1 + orcofp(5,8) = 1 +c +c 2.6.4. ==> pyramide/triangle et pyramide/quadrangle +c + orcofy(1,1) = -1 + orcofy(1,2) = -1 + orcofy(1,3) = -1 + orcofy(1,4) = 1 + orcofy(1,5) = 1 + orcofy(1,6) = 1 +c + orcofy(2,1) = -1 + orcofy(2,2) = -1 + orcofy(2,3) = -1 + orcofy(2,4) = 1 + orcofy(2,5) = 1 + orcofy(2,6) = 1 +c + orcofy(3,1) = -1 + orcofy(3,2) = -1 + orcofy(3,3) = -1 + orcofy(3,4) = 1 + orcofy(3,5) = 1 + orcofy(3,6) = 1 +c + orcofy(4,1) = -1 + orcofy(4,2) = -1 + orcofy(4,3) = -1 + orcofy(4,4) = 1 + orcofy(4,5) = 1 + orcofy(4,6) = 1 +c + orcofy(5,1) = -1 + orcofy(5,2) = -1 + orcofy(5,3) = -1 + orcofy(5,4) = -1 + orcofy(5,5) = 1 + orcofy(5,6) = 1 + orcofy(5,7) = 1 + orcofy(5,8) = 1 +c +c==== +c 3. manipulations numeriques +c==== +c 3.1. ==> choix du 2nd chiffre entre 1 et 2 +c + fp0012(1) = 2 + fp0012(2) = 1 +c +c 3.2. ==> choix du 3eme chiffre entre 1, 2 et 3 +c + fp0123(1,1) = iindef + fp0123(1,2) = 3 + fp0123(1,3) = 2 + fp0123(2,1) = 3 + fp0123(2,2) = iindef + fp0123(2,3) = 1 + fp0123(3,1) = 2 + fp0123(3,2) = 1 + fp0123(3,3) = iindef +c +c 3.3. ==> choix du 4eme chiffre entre 1, 2, 3 et 4 +c + do 33 , iaux = 1 , 4 + do 331 , jaux = 1 , 4 + do 3311 , kaux1 = 1 , 4 + tabaux(kaux1) = 0 + 3311 continue + tabaux(iaux) = 1 + tabaux(jaux) = 1 + do 3312 , kaux1 = 1 , 4 + if ( iaux.eq.jaux .or. jaux.eq.kaux1 .or. + > kaux1.eq.iaux ) then + fp1234(iaux,jaux,kaux1) = iindef + else + do 3313 , kaux2 = 1 , 4 + if ( tabaux(kaux2).eq.0 .and. kaux2.ne.kaux1 ) then + fp1234(iaux,jaux,kaux1) = kaux2 + endif + 3313 continue + endif + 3312 continue + 331 continue + 33 continue +c +c 3.4. ==> choix du 6eme chiffre entre 1, 2, 3, 4, 5 et 6 +c + do 34 , iaux = 1 , 6 + do 341 , jaux = 1 , 6 + do 3411 , kaux1 = 1 , 6 + do 3412 , kaux2 = 1 , 6 + do 3413 , kaux3 = 1 , 6 + tabaux(kaux3) = 0 + 3413 continue + tabaux(iaux) = 1 + tabaux(jaux) = 1 + tabaux(kaux1) = 1 + tabaux(kaux2) = 1 + do 3414 , kaux3 = 1 , 6 + if ( iaux.eq.jaux .or. iaux.eq.kaux1 .or. + > iaux.eq.kaux2 .or. jaux.eq.kaux1 .or. + > jaux.eq.kaux2 .or. kaux1.eq.kaux2 ) then + fp1aa6(iaux,jaux,kaux1,kaux2,kaux3) = iindef + else + do 3415 , kaux4 = 1 , 6 + if ( tabaux(kaux4).eq.0 .and. kaux4.ne.kaux3 ) then + fp1aa6(iaux,jaux,kaux1,kaux2,kaux3) = kaux4 + endif + 3415 continue + endif + 3414 continue + 3412 continue + 3411 continue + 341 continue + 34 continue +c +c 3.5. ==> dans la permutation circulaire (1,2,3) : +c per1a3(-1,i) renvoie l'entier qui est avant i +c per1a3( 0,i) renvoie l'entier i +c per1a3( 1,i) renvoie l'entier qui est apres i +c per1a3( 2,i) renvoie l'entier qui est 2 places apres i +c + per1a3(-1,1) = 3 + per1a3(-1,2) = 1 + per1a3(-1,3) = 2 +c + per1a3( 0,1) = 1 + per1a3( 0,2) = 2 + per1a3( 0,3) = 3 +c + per1a3( 1,1) = 2 + per1a3( 1,2) = 3 + per1a3( 1,3) = 1 +c + per1a3( 2,1) = 3 + per1a3( 2,2) = 1 + per1a3( 2,3) = 2 +c +c 3.6. ==> dans la permutation circulaire (1,2,3,4) : +c . Pour i de 1 a 4 : +c per1a4(-5,i) = 1 devient 2, puis sens inverse +c per1a4(-4,i) = 1 devient 3, puis sens inverse +c per1a4(-3,i) = 1 devient 4, puis sens inverse +c per1a4(-2,i) = 1 idem, puis sens inverse +c per1a4(-1,i) renvoie l'entier qui est avant i +c per1a4( 0,i) renvoie l'entier i +c per1a4( 1,i) renvoie l'entier qui est apres i +c per1a4( 2,i) renvoie l'entier qui est 2 places apres i +c per1a4( 3,i) renvoie l'entier qui est 3 places apres i +c . Pour i =5 : +c per1a4(j,5) = le reciproque de per1a4(j,*) +c + per1a4(-5,1) = 2 + per1a4(-5,2) = 1 + per1a4(-5,3) = 4 + per1a4(-5,4) = 3 + per1a4(-5,5) = -5 +c + per1a4(-4,1) = 3 + per1a4(-4,2) = 2 + per1a4(-4,3) = 1 + per1a4(-4,4) = 4 + per1a4(-4,5) = -4 +c + per1a4(-3,1) = 4 + per1a4(-3,2) = 3 + per1a4(-3,3) = 2 + per1a4(-3,4) = 1 + per1a4(-3,5) = -3 +c + per1a4(-2,1) = 1 + per1a4(-2,2) = 4 + per1a4(-2,3) = 3 + per1a4(-2,4) = 2 + per1a4(-2,5) = -2 +c + per1a4(-1,1) = 4 + per1a4(-1,2) = 1 + per1a4(-1,3) = 2 + per1a4(-1,4) = 3 + per1a4(-1,5) = 3 +c + per1a4( 0,1) = 1 + per1a4( 0,2) = 2 + per1a4( 0,3) = 3 + per1a4( 0,4) = 4 + per1a4( 0,5) = 0 +c + per1a4( 1,1) = 2 + per1a4( 1,2) = 3 + per1a4( 1,3) = 4 + per1a4( 1,4) = 1 + per1a4( 1,5) = -1 +c + per1a4( 2,1) = 3 + per1a4( 2,2) = 4 + per1a4( 2,3) = 1 + per1a4( 2,4) = 2 + per1a4( 2,5) = 2 +c + per1a4( 3,1) = 4 + per1a4( 3,2) = 1 + per1a4( 3,3) = 2 + per1a4( 3,4) = 3 + per1a4( 3,5) = 1 +c +c 3.7. ==> dans la permutation circulaire (4,5,6) : +c per4a6(-1,i) = entier avant i +c per4a6( 0,i) = i +c per4a6( 1,i) = entier apres i +c per4a6( 2,i) = entier 2 places apres i = per4a6(-1,i) +c + per4a6(-1,4) = 6 + per4a6(-1,5) = 4 + per4a6(-1,6) = 5 +c + per4a6( 0,4) = 4 + per4a6( 0,5) = 5 + per4a6( 0,6) = 6 +c + per4a6( 1,4) = 5 + per4a6( 1,5) = 6 + per4a6( 1,6) = 4 +c + per4a6( 2,4) = 6 + per4a6( 2,5) = 4 + per4a6( 2,6) = 5 +c +c 3.8. ==> per001 : etablissement des codes pour les raffinements +c conformes des pentaedres +c remarque : per001(i,1) = i +c + per001(1,1) = 1 + per001(1,2) = 2 + per001(1,3) = 3 + per001(1,4) = 4 + per001(1,5) = 5 + per001(1,6) = 6 +c + per001(2,1) = 2 + per001(2,2) = 3 + per001(2,3) = 1 + per001(2,4) = 6 + per001(2,5) = 4 + per001(2,6) = 5 +c + per001(3,1) = 3 + per001(3,2) = 1 + per001(3,3) = 2 + per001(3,4) = 5 + per001(3,5) = 6 + per001(3,6) = 4 +c + per001(4,1) = 4 + per001(4,2) = 5 + per001(4,3) = 6 + per001(4,4) = 1 + per001(4,5) = 2 + per001(4,6) = 3 +c + per001(5,1) = 5 + per001(5,2) = 6 + per001(5,3) = 4 + per001(5,4) = 3 + per001(5,5) = 1 + per001(5,6) = 2 +c + per001(6,1) = 6 + per001(6,2) = 4 + per001(6,3) = 5 + per001(6,4) = 2 + per001(6,5) = 3 + per001(6,6) = 1 +c +c 3.9. ==> per002 : permutation circulaire des 8 permiers entiers, +c traites par paquet de 4 +c remarque : per002(i,1) = i +c + per002(1,1) = 1 + per002(1,2) = 2 + per002(1,3) = 3 + per002(1,4) = 4 + per002(1,5) = 5 + per002(1,6) = 6 + per002(1,7) = 7 + per002(1,8) = 8 +c + per002(2,1) = 2 + per002(2,2) = 3 + per002(2,3) = 4 + per002(2,4) = 1 + per002(2,5) = 6 + per002(2,6) = 7 + per002(2,7) = 8 + per002(2,8) = 5 +c + per002(3,1) = 3 + per002(3,2) = 4 + per002(3,3) = 1 + per002(3,4) = 2 + per002(3,5) = 7 + per002(3,6) = 8 + per002(3,7) = 5 + per002(3,8) = 6 +c + per002(4,1) = 4 + per002(4,2) = 1 + per002(4,3) = 2 + per002(4,4) = 3 + per002(4,5) = 8 + per002(4,6) = 5 + per002(4,7) = 6 + per002(4,8) = 7 +c +c==== +c 4. description pour une connectivite a la med +c==== +c +c 4.1. ==> prealable +c + do 41 , iaux = 0 , 7 + do 411 , jaux = 1 , 6 + nofmed(iaux,jaux,1) = iindef + nofmed(iaux,jaux,2) = iindef + nofmed(iaux,jaux,3) = iindef + 411 continue + 41 continue +c +c 4.2. ==> tetraedre +c + typenh = 3 + nofmed(typenh,1,1) = 1 + nofmed(typenh,2,1) = 2 + nofmed(typenh,3,1) = 3 + nofmed(typenh,4,1) = 4 +c + do 42 , jaux = 1 , 4 + iaux = nofmed(typenh,jaux,1) + nofmed(typenh,iaux,2) = jaux + 42 continue +cgn print *,(nofmed(typenh,jaux,2),jaux = 1 , 4) +c +c 4.3. ==> hexaedre +c + typenh = 6 + nofmed(typenh,1,1) = 1 + nofmed(typenh,2,1) = 6 + nofmed(typenh,3,1) = 2 + nofmed(typenh,4,1) = 4 + nofmed(typenh,5,1) = 5 + nofmed(typenh,6,1) = 3 +c + do 43 , jaux = 1 , 6 + iaux = nofmed(typenh,jaux,1) + nofmed(typenh,iaux,2) = jaux + 43 continue +cgn print *,(nofmed(typenh,jaux,2),jaux = 1 , 6) +c +c 4.4. ==> pentaedre +c + typenh = 7 + nofmed(typenh,1,1) = 1 + nofmed(typenh,2,1) = 2 + nofmed(typenh,3,1) = 3 + nofmed(typenh,4,1) = 4 + nofmed(typenh,5,1) = 5 +c + do 44 , jaux = 1 , 5 + iaux = nofmed(typenh,jaux,1) + nofmed(typenh,iaux,2) = jaux + 44 continue +cgn print *,(nofmed(typenh,jaux,2),jaux = 1 , 5) + +c 4.5. ==> pyramide +c + typenh = 5 + nofmed(typenh,1,1) = 5 + nofmed(typenh,2,1) = 1 + nofmed(typenh,3,1) = 2 + nofmed(typenh,4,1) = 3 + nofmed(typenh,5,1) = 4 +c + do 45 , jaux = 1 , 5 + iaux = nofmed(typenh,jaux,1) + nofmed(typenh,iaux,2) = jaux + 45 continue +cgn print *,(nofmed(typenh,jaux,2),jaux = 1 , 5) +c +c==== +c 5. messages +c remarque : le code doit etre le meme que pour suffix +c==== +c +c 12345678901234 + mess14(1,1,-1) = 'noeud ' + mess14(1,1,0) = 'maille-point ' + mess14(1,1,1) = 'segment ' + mess14(1,1,2) = 'triangle ' + mess14(1,1,3) = 'tetraedre ' + mess14(1,1,4) = 'quadrangle ' + mess14(1,1,5) = 'pyramide ' + mess14(1,1,6) = 'hexaedre ' + mess14(1,1,7) = 'pentaedre ' + mess14(1,1,8) = 'face ' + mess14(1,1,9) = 'volume ' + mess14(1,1,10) = ' entite ' + mess14(1,1,11) = 'provisoire ' + mess14(1,1,12) = 'sans objet ' + mess14(1,1,13) = 'maille ' +c + mess14(1,2,-1) = 'Noeud ' + mess14(1,2,0) = 'Maille-Point ' + mess14(1,2,1) = 'Segment ' + mess14(1,2,2) = 'Triangle ' + mess14(1,2,3) = 'Tetraedre ' + mess14(1,2,4) = 'Quadrangle ' + mess14(1,2,5) = 'Pyramide ' + mess14(1,2,6) = 'Hexaedre ' + mess14(1,2,7) = 'Pentaedre ' + mess14(1,2,8) = 'Face ' + mess14(1,2,9) = 'Volume ' + mess14(1,2,10) = ' Entite ' + mess14(1,2,11) = 'Provisoire ' + mess14(1,2,12) = 'Sans objet ' + mess14(1,2,13) = 'Maille ' +c + mess14(1,3,-1) = 'noeuds ' + mess14(1,3,0) = 'mailles-points' + mess14(1,3,1) = 'segments ' + mess14(1,3,2) = 'triangles ' + mess14(1,3,3) = 'tetraedres ' + mess14(1,3,4) = 'quadrangles ' + mess14(1,3,5) = 'pyramides ' + mess14(1,3,6) = 'hexaedres ' + mess14(1,3,7) = 'pentaedres ' + mess14(1,3,8) = 'faces ' + mess14(1,3,9) = 'volumes ' + mess14(1,3,10) = 'entites ' + mess14(1,3,11) = 'Provisoire ' + mess14(1,3,12) = 'Sans objet ' + mess14(1,3,13) = 'mailles ' +c + mess14(1,4,-1) = 'Noeuds ' + mess14(1,4,0) = 'Mailles-Points' + mess14(1,4,1) = 'Segments ' + mess14(1,4,2) = 'Triangles ' + mess14(1,4,3) = 'Tetraedres ' + mess14(1,4,4) = 'Quadrangles ' + mess14(1,4,5) = 'Pyramides ' + mess14(1,4,6) = 'Hexaedres ' + mess14(1,4,7) = 'Pentaedres ' + mess14(1,4,8) = 'Faces ' + mess14(1,4,9) = 'Volumes ' + mess14(1,4,10) = ' Entites ' + mess14(1,4,11) = 'Provisoires ' + mess14(1,4,12) = 'Sans objet ' + mess14(1,4,13) = 'Mailles ' +c + mess14(1,5,-1) = 'NOEUDS ' + mess14(1,5,0) = 'MAILLES-POINTS' + mess14(1,5,1) = 'SEGMENTS ' + mess14(1,5,2) = 'TRIANGLES ' + mess14(1,5,3) = 'TETRAEDRES ' + mess14(1,5,4) = 'QUADRANGLES ' + mess14(1,5,5) = 'PYRAMIDES ' + mess14(1,5,6) = 'HEXAEDRES ' + mess14(1,5,7) = 'PENTAEDRES ' + mess14(1,5,8) = 'FACES ' + mess14(1,5,9) = 'VOLUMES ' + mess14(1,5,10) = ' ENTITES ' + mess14(1,5,11) = 'PROVISOIRES ' + mess14(1,5,12) = 'SANS OBJET ' + mess14(1,5,13) = 'MAILLES ' +c + mess14(2,1,-1) = 'node ' + mess14(2,1,0) = 'point-mesh ' + mess14(2,1,1) = 'edge ' + mess14(2,1,2) = 'triangle ' + mess14(2,1,3) = 'tetrahedron ' + mess14(2,1,4) = 'quadrangle ' + mess14(2,1,5) = 'pyramid ' + mess14(2,1,6) = 'hexahedron ' + mess14(2,1,7) = 'prism ' + mess14(2,1,8) = 'face ' + mess14(2,1,9) = 'volume ' + mess14(2,1,10) = ' entity ' + mess14(2,1,11) = 'temporary ' + mess14(2,1,12) = 'useless ' + mess14(2,1,13) = 'mesh ' +c + mess14(2,2,-1) = 'Node ' + mess14(2,2,0) = 'Point-Mesh ' + mess14(2,2,1) = 'Edge ' + mess14(2,2,2) = 'Triangle ' + mess14(2,2,3) = 'Tetrahedron ' + mess14(2,2,4) = 'Quadrangle ' + mess14(2,2,5) = 'Pyramid ' + mess14(2,2,6) = 'Hexahedron ' + mess14(2,2,7) = 'Prism ' + mess14(2,2,8) = 'Face ' + mess14(2,2,9) = 'Volume ' + mess14(2,2,10) = ' Entity ' + mess14(2,2,11) = 'Temporary ' + mess14(2,2,12) = 'Useless ' + mess14(2,2,13) = 'Mesh ' +c + mess14(2,3,-1) = 'nodes ' + mess14(2,3,0) = 'point-meshes ' + mess14(2,3,1) = 'edges ' + mess14(2,3,2) = 'triangles ' + mess14(2,3,3) = 'tetraedra ' + mess14(2,3,4) = 'quadrangles ' + mess14(2,3,5) = 'pyramids ' + mess14(2,3,6) = 'hexahedrons ' + mess14(2,3,7) = 'prisms ' + mess14(2,3,8) = 'faces ' + mess14(2,3,9) = 'volumes ' + mess14(2,3,10) = 'entities ' + mess14(2,3,11) = 'Temporary ' + mess14(2,3,12) = 'Useless ' + mess14(2,3,13) = 'meshes ' +c + mess14(2,4,-1) = 'Nodes ' + mess14(2,4,0) = 'Point-Meshes ' + mess14(2,4,1) = 'Edges ' + mess14(2,4,2) = 'Triangles ' + mess14(2,4,3) = 'Tetraedra ' + mess14(2,4,4) = 'Quadrangles ' + mess14(2,4,5) = 'Pyramids ' + mess14(2,4,6) = 'Hexahedrons ' + mess14(2,4,7) = 'Prisms ' + mess14(2,4,8) = 'Faces ' + mess14(2,4,9) = 'Volumes ' + mess14(2,4,10) = ' Entities ' + mess14(2,4,11) = 'Temporary ' + mess14(2,4,12) = 'Useless ' + mess14(2,4,13) = 'Meshes ' +c + mess14(2,5,-1) = 'NODES ' + mess14(2,5,0) = 'POINT-MESHES ' + mess14(2,5,1) = 'EDGES ' + mess14(2,5,2) = 'TRIANGLES ' + mess14(2,5,3) = 'TETRAEDRA ' + mess14(2,5,4) = 'QUADRANGLES ' + mess14(2,5,5) = 'PYRAMIDS ' + mess14(2,5,6) = 'HEXAHEDRONS ' + mess14(2,5,7) = 'PRISMS ' + mess14(2,5,8) = 'FACES ' + mess14(2,5,9) = 'VOLUMES ' + mess14(2,5,10) = ' ENTITIES ' + mess14(2,5,11) = 'TEMPORARY ' + mess14(2,5,12) = 'USELESS ' + mess14(2,5,13) = 'MESHES ' +c 12345678901234 +c +c==== +c 6. type gm +c remarque : le code doit etre le meme que pour mess14 +c==== +c +c 12345678 + suffix(1,-1) = 'Noeud ' + suffix(1,0) = 'Point ' + suffix(1,1) = 'Arete ' + suffix(1,2) = 'Trian ' + suffix(1,3) = 'Tetra ' + suffix(1,4) = 'Quadr ' + suffix(1,5) = 'Pyram ' + suffix(1,6) = 'Hexae ' + suffix(1,7) = 'Penta ' + suffix(1,8) = ' ' + suffix(1,9) = ' ' + suffix(1,10) = ' ' +c + suffix(2,-1) = 'noeu ' + suffix(2,0) = 'poin ' + suffix(2,1) = 'aret ' + suffix(2,2) = 'tria ' + suffix(2,3) = 'tetr ' + suffix(2,4) = 'quad ' + suffix(2,5) = 'pyra ' + suffix(2,6) = 'hexa ' + suffix(2,7) = 'pent ' + suffix(2,8) = ' ' + suffix(2,9) = ' ' + suffix(2,10) = ' ' +c 12345678 + suffix(3,-1) = 'No ' + suffix(3,0) = 'MP ' + suffix(3,1) = 'Ar ' + suffix(3,2) = 'Tr ' + suffix(3,3) = 'Te ' + suffix(3,4) = 'Qu ' + suffix(3,5) = 'Py ' + suffix(3,6) = 'He ' + suffix(3,7) = 'Pe ' + suffix(3,8) = ' ' + suffix(3,9) = ' ' + suffix(3,10) = ' ' +c 12345678 + suffix(4,-1) = 'no ' + suffix(4,0) = 'mp ' + suffix(4,1) = 'ar ' + suffix(4,2) = 'tr ' + suffix(4,3) = 'te ' + suffix(4,4) = 'qu ' + suffix(4,5) = 'py ' + suffix(4,6) = 'he ' + suffix(4,7) = 'pe ' + suffix(4,8) = ' ' + suffix(4,9) = ' ' + suffix(4,10) = ' ' +c +c==== +c 7. fonctions pour la conformite des hexaedres +c==== +c +#include "hexcf2.h" +c +c==== +c 8. Caracteristiques des familles : +c==== +c 8.1. ==> initialisation des nombres maximaux de familles +c + nbfarm = 20000 + nbftrm = 20000 + nbfqum = 20000 +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'nbfarm', nbfarm + write (*,90002) 'nbftrm', nbftrm + write (*,90002) 'nbfqum', nbfqum +#endif +c +c 8.2. ==> Caracteristiques par type de mailless +c +c noeuds 1 : famille MED +c Si extrusion : +c 2 : famille du noeud translate dans l'extrusion +c 3 : famille de l'arete creee dans l'extrusion +c 4 : position du noeud +c Si equivalence : +c + l : appartenance a l'equivalence l +c +c mailles-points 1 : famille MED +c 2 : type de maille-point +c 3 : famille du sommet support +c + l : appartenance a l'equivalence l +c +c aretes 1 : famille MED +c 2 : type de segment +c 3 : orientation +c 4 : famille d'orientation inverse +c 5 : numero de ligne de frontiere +c > 0 si arete concernee par le suivi de frontiere +c <= 0 si non concernee +c 6 : famille de suivi de frontiere active/inactive +c 7 : numero de surface de frontiere +c Si extrusion : +c 8 : famille de l'arete translatee dans l'extrusion +c 9 : famille du quadrangle cree dans l'extrusion +c 10 : position de l'arete +c Si equivalence : +c + l : appartenance a l'equivalence l +c +c triangles 1 : famille MED +c 2 : type de triangle +c 3 : numero de surface de frontiere +c 4 : famille des aretes internes apres raf +c Si extrusion : +c 5 : famille du triangle translate dans l'extrusion +c 6 : famille du pentaedre cree dans l'extrusion +c 7 : orientation du triangle face du pentaedre +c 8 : position du triangle +c Si equivalence : +c + l : appartenance a l'equivalence l +c +c quadrangles 1 : famille MED +c 2 : type de quadrangle +c 3 : numero de surface de frontiere +c 4 : famille des aretes internes apres raf +c 5 : famille des triangles de conformite +c 6 : famille de suivi de frontiere active/inactive +c Si extrusion : +c 7 : famille du quadrangle translate dans l'extrusion +c 8 : famille de l'hexaedre cree dans l'extrusion +c 9 : orientation du quadrangle face de l'hexaedre +c 10 : position du quadrangle +c Si equivalence : +c + l : appartenance a l'equivalence l +c +c tetraedres 1 : famille MED +c 2 : type de tetraedres +c +c hexaedres 1 : famille MED +c 2 : type de hexaedres +c 3 : famille des tetraedres de conformite +c 4 : famille des pyramides de conformite +c +c pyramides 1 : famille MED +c 2 : type de pyramides +c +c pentaedres 1 : famille MED +c 2 : type de pentaedres +c 3 : famille des tetraedres de conformite +c 4 : famille des pyramides de conformite +c==== +c + ncffno = 1 + ncffmp = 3 + ncffar = 7 + ncfftr = 4 + ncffqu = 6 + ncffte = 2 + ncffhe = 4 + ncffpy = 2 + ncffpe = 4 +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'ncffno', ncffno + write (*,90002) 'ncffmp', ncffmp + write (*,90002) 'ncffar', ncffar + write (*,90002) 'ncfftr', ncfftr + write (*,90002) 'ncffqu', ncffqu + write (*,90002) 'ncffte', ncffte + write (*,90002) 'ncffhe', ncffhe + write (*,90002) 'ncffpy', ncffpy + write (*,90002) 'ncffpe', ncffpe +#endif +c + ncxfno = 3 + ncxfar = 3 + ncxftr = 4 + ncxfqu = 4 +c +#ifdef _DEBUG_HOMARD_ + write (*,90002) 'ncxfno', ncxfno + write (*,90002) 'ncxfar', ncxfar + write (*,90002) 'ncxftr', ncxftr + write (*,90002) 'ncxfqu', ncxfqu +#endif +c + nctfno = ncffno + nctfmp = ncffmp + nctfar = ncffar + nctftr = ncfftr + nctfqu = ncffqu + nctfte = ncffte + nctfhe = ncffhe + nctfpy = ncffpy + nctfpe = ncffpe +c + end diff --git a/src/tool/Utilitaire/utinci.F b/src/tool/Utilitaire/utinci.F new file mode 100644 index 00000000..9bc7f815 --- /dev/null +++ b/src/tool/Utilitaire/utinci.F @@ -0,0 +1,1538 @@ + subroutine utinci ( ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - INitialisation des Communs des Interfaces +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINCI' ) +c +#include "referx.h" +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "refere.h" +#include "refert.h" +c +#include "rfamed.h" +c +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux, jaux + character*6 saux06 +c + integer iindef + double precision rindef + character*8 sindef +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Le type maximum pour HOMARD vaut :'',i6)' + texte(1,5) = '(''mais la variable '',a6,'' vaut :'',i6)' +c + texte(2,4) = '(''Maximum type for HOMARD is :'',i6)' + texte(2,5) = '(''but variable '',a6,'' is :'',i6)' +c + codret = 0 +c +c==== +c 2. communs pour les interfaces +c==== +c +c 2.1. ==> prealable : les valeurs indefinies +c + call dmindf ( iindef, rindef, sindef ) +c +c==== +c 3. generalites sur les elements de reference +c==== +c +c 3.1. ==> type HOMARD des differents elements +c on a interet a les prendre continus de 0 a themax, pour +c minimiser l'occupation en memoire. +c mais pour deboguer, il est interessant de varier ces chiffres +c il faut alors verifier qu'on ne depasse pas le maximum +c qui est defini par un parameter. +c attention, il faut utiliser en debug toutes les bibliotheques +c ou apparait tehmax +c + tyhnoe = -1 + tyhmpo = 0 + tyhse1 = 1 + tyhse2 = 2 + tyhtr1 = 3 + tyhtr2 = 4 + tyhte1 = 5 + tyhte2 = 6 + tyhqu1 = 7 + tyhqu2 = 8 + tyhpy1 = 9 + tyhpy2 = 10 + tyhhe1 = 11 + tyhhe2 = 12 + tyhpe1 = 13 + tyhpe2 = 14 + tyhtr3 = 15 + tyhqu3 = 16 + tyhhe3 = 17 +c +#ifdef _DEBUG_HOMARD_ + tyhmpo = 7 + tyhse1 = 14 + tyhse2 = 17 + tyhtr1 = 28 + tyhtr2 = 21 + tyhte1 = 33 + tyhte2 = 30 +c + tyhmpo = 6 + tyhse1 = 1 + tyhse2 = 4 + tyhtr1 = 2 + tyhtr2 = 5 + tyhte1 = 3 + tyhte2 = 0 + tyhqu1 = 7 + tyhqu2 = 8 +c + tyhmpo = 0 + tyhse1 = 1 + tyhse2 = 2 + tyhtr1 = 3 + tyhtr2 = 4 + tyhte1 = 5 + tyhte2 = 6 + tyhqu1 = 7 + tyhqu2 = 8 +#endif +c + jaux = 0 + if ( tyhmpo.gt.tehmax ) then + jaux = 2 + iaux = tyhmpo + saux06 = 'tyhmpo' + endif + if ( tyhse1.gt.tehmax ) then + jaux = 2 + iaux = tyhse1 + saux06 = 'tyhse1' + endif + if ( tyhse2.gt.tehmax ) then + jaux = 2 + iaux = tyhse2 + saux06 = 'tyhse2' + endif + if ( tyhtr1.gt.tehmax ) then + jaux = 2 + iaux = tyhtr1 + saux06 = 'tyhtr1' + endif + if ( tyhtr2.gt.tehmax ) then + jaux = 2 + iaux = tyhtr2 + saux06 = 'tyhtr2' + endif + if ( tyhtr3.gt.tehmax ) then + jaux = 2 + iaux = tyhtr3 + saux06 = 'tyhtr3' + endif + if ( tyhte1.gt.tehmax ) then + jaux = 2 + iaux = tyhte1 + saux06 = 'tyhte1' + endif + if ( tyhte2.gt.tehmax ) then + jaux = 2 + iaux = tyhte2 + saux06 = 'tyhte2' + endif + if ( tyhqu1.gt.tehmax ) then + jaux = 2 + iaux = tyhqu1 + saux06 = 'tyhqu1' + endif + if ( tyhqu2.gt.tehmax ) then + jaux = 2 + iaux = tyhqu2 + saux06 = 'tyhqu2' + endif + if ( tyhqu3.gt.tehmax ) then + jaux = 2 + iaux = tyhqu3 + saux06 = 'tyhqu3' + endif + if ( tyhpy1.gt.tehmax ) then + jaux = 2 + iaux = tyhpy1 + saux06 = 'tyhpy1' + endif + if ( tyhpy2.gt.tehmax ) then + jaux = 2 + iaux = tyhpy2 + saux06 = 'tyhpy2' + endif + if ( tyhpe1.gt.tehmax ) then + jaux = 2 + iaux = tyhpe1 + saux06 = 'tyhpe1' + endif + if ( tyhpe2.gt.tehmax ) then + jaux = 2 + iaux = tyhpe2 + saux06 = 'tyhpe2' + endif + if ( tyhhe1.gt.tehmax ) then + jaux = 2 + iaux = tyhhe1 + saux06 = 'tyhhe1' + endif + if ( tyhhe2.gt.tehmax ) then + jaux = 2 + iaux = tyhhe2 + saux06 = 'tyhhe2' + endif + if ( tyhhe3.gt.tehmax ) then + jaux = 2 + iaux = tyhhe3 + saux06 = 'tyhhe3' + endif + if ( jaux.ne.0 ) then + write (ulsort,texte(langue,4)) tehmax + write (ulsort,texte(langue,5)) saux06, iaux + codret = 1 + endif +c +c 3.2. ==> prealable +c tyeref : precise le type d'element en fonction du type de reference +c 0 : standard HOMARD, +c 1 : possible en fonction du type de travail +c 2 : toujours interdit +c nbnref : donne le nombre de noeuds en fonction du type de reference ; +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : 1 : sommets +c 2 : sommets + milieux d'aretes +c 3 : total (sommets+milieux+internes) +c nbaref : donne le nombre d'aretes en fonction du type de reference +c nasref : donne le nombre d'aretes reliees a chaque sommet, sans +c se preoccuper d'orientation, en fonction du type +c nfaref : donne le nombre de faces qui s'appuient sur chaque arete +c sans se preoccuper d'orientation +c nafref : donne le nombre d'aretes de chaque face +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de la face envisagee +c defref : pour chaque arete de chaque face, donne le numero local +c de l'arete dans la description de l'element, sans se +c preoccuper d'orientation +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de la face envisagee +c 3eme champ : 1, 2, 3 et 4 pour chaque arete +c faaref : donne le numero local de la face s'appuyant sur une arete +c 1er champ : type HOMARD de l'element de reference +c 2eme champ : numero local de l'arete concernee +c 3eme champ : rang de la face envisagee +c + do 32 , iaux = 0 , tehmax + tyeref(iaux) = iindef + nbnref(iaux,1) = iindef + nbnref(iaux,2) = iindef + nbnref(iaux,3) = iindef + nbaref(iaux) = iindef + nasref(iaux) = iindef + nfaref(iaux) = iindef + do 321 , jaux = 1 , 6 + nafref(iaux,jaux) = iindef + defref(iaux,jaux,1) = iindef + defref(iaux,jaux,2) = iindef + defref(iaux,jaux,3) = iindef + defref(iaux,jaux,4) = iindef + 321 continue + do 322 , jaux = 1, 12 + faaref(iaux,jaux,1) = iindef + faaref(iaux,jaux,2) = iindef + 322 continue + 32 continue +c +c 3.3. ==> description d'une maille-point +c + tyeref(tyhmpo) = 0 + nbnref(tyhmpo,1) = 1 + nbnref(tyhmpo,2) = nbnref(tyhmpo,1) + nbnref(tyhmpo,3) = nbnref(tyhmpo,2) + nbaref(tyhmpo) = 0 + nasref(tyhmpo) = 0 + nfaref(tyhmpo) = 0 +c +c 3.4. ==> description d'un segment +c +c 3.4.1. ==> lineaire +c + tyeref(tyhse1) = 0 + nbnref(tyhse1,1) = 2 + nbnref(tyhse1,2) = nbnref(tyhse1,1) + nbnref(tyhse1,3) = nbnref(tyhse1,2) + nbaref(tyhse1) = 1 + nasref(tyhse1) = 1 + nfaref(tyhse1) = 0 +c +c 3.4.2. ==> quadratique +c + tyeref(tyhse2) = tyeref(tyhse1) + nbnref(tyhse2,1) = nbnref(tyhse1,1) + nbnref(tyhse2,2) = 3 + nbnref(tyhse2,3) = nbnref(tyhse2,2) + nbaref(tyhse2) = nbaref(tyhse1) + nasref(tyhse2) = nasref(tyhse1) + nfaref(tyhse2) = nfaref(tyhse1) +c +c 3.5. ==> description d'un triangle +c +c 3.5.1. ==> lineaire +c + tyeref(tyhtr1) = 0 + nbnref(tyhtr1,1) = 3 + nbnref(tyhtr1,2) = nbnref(tyhtr1,1) + nbnref(tyhtr1,3) = nbnref(tyhtr1,2) + nbaref(tyhtr1) = 3 + nasref(tyhtr1) = 2 + nfaref(tyhtr1) = 1 +c + nafref(tyhtr1,1) = 3 + defref(tyhtr1,1,1) = 1 + defref(tyhtr1,1,2) = 2 + defref(tyhtr1,1,3) = 3 +c + faaref(tyhtr1,1,1) = 1 + faaref(tyhtr1,2,1) = 1 + faaref(tyhtr1,3,1) = 1 +c +c 3.5.2. ==> complements pour le quadratique +c + tyeref(tyhtr2) = tyeref(tyhtr1) + nbnref(tyhtr2,1) = nbnref(tyhtr1,1) + nbnref(tyhtr2,2) = 6 + nbnref(tyhtr2,3) = nbnref(tyhtr2,2) + nbaref(tyhtr2) = nbaref(tyhtr1) + nasref(tyhtr2) = nasref(tyhtr1) + nfaref(tyhtr2) = nfaref(tyhtr1) +c +c 3.5.3. ==> complements pour le quadratique etendu +c + tyeref(tyhtr3) = tyeref(tyhtr1) + nbnref(tyhtr3,1) = nbnref(tyhtr2,1) + nbnref(tyhtr3,2) = nbnref(tyhtr2,2) + nbnref(tyhtr3,3) = 7 + nbaref(tyhtr3) = nbaref(tyhtr1) + nasref(tyhtr3) = nasref(tyhtr1) + nfaref(tyhtr3) = nfaref(tyhtr1) +c +c 3.6. ==> description d'un quadrangle +c +c 3.6.1. ==> lineaire +c + tyeref(tyhqu1) = 0 + nbnref(tyhqu1,1) = 4 + nbnref(tyhqu1,2) = nbnref(tyhqu1,1) + nbnref(tyhqu1,3) = nbnref(tyhqu1,2) + nbaref(tyhqu1) = 4 + nasref(tyhqu1) = 2 + nfaref(tyhqu1) = 1 +c + nafref(tyhqu1,1) = 4 + defref(tyhqu1,1,1) = 1 + defref(tyhqu1,1,2) = 2 + defref(tyhqu1,1,3) = 3 + defref(tyhqu1,1,4) = 4 +c + faaref(tyhqu1,1,1) = 1 + faaref(tyhqu1,2,1) = 1 + faaref(tyhqu1,3,1) = 1 + faaref(tyhqu1,4,1) = 1 +c +c 3.6.2. ==> complements pour le quadratique +c + tyeref(tyhqu2) = tyeref(tyhqu1) + nbnref(tyhqu2,1) = nbnref(tyhqu1,1) + nbnref(tyhqu2,2) = 8 + nbnref(tyhqu2,3) = nbnref(tyhqu2,2) + nbaref(tyhqu2) = nbaref(tyhqu1) + nasref(tyhqu2) = nasref(tyhqu1) + nfaref(tyhqu2) = nfaref(tyhqu1) +c +c 3.6.3. ==> complements pour le quadratique etendu +c + tyeref(tyhqu3) = tyeref(tyhqu1) + nbnref(tyhqu3,1) = nbnref(tyhqu2,1) + nbnref(tyhqu3,2) = nbnref(tyhqu2,2) + nbnref(tyhqu3,3) = 9 + nbaref(tyhqu3) = nbaref(tyhqu1) + nasref(tyhqu3) = nasref(tyhqu1) + nfaref(tyhqu3) = nfaref(tyhqu1) +c +c 3.7. ==> description d'un tetraedre +c +c 3.7.1. ==> lineaire +c + tyeref(tyhte1) = 0 + nbnref(tyhte1,1) = 4 + nbnref(tyhte1,2) = nbnref(tyhte1,1) + nbnref(tyhte1,2) = nbnref(tyhte1,1) + nbnref(tyhte1,3) = nbnref(tyhte1,2) + nbaref(tyhte1) = 6 + nasref(tyhte1) = 3 + nfaref(tyhte1) = 2 +c + nafref(tyhte1,1) = 3 + defref(tyhte1,1,1) = 4 + defref(tyhte1,1,2) = 5 + defref(tyhte1,1,3) = 6 + nafref(tyhte1,2) = 3 + defref(tyhte1,2,1) = 2 + defref(tyhte1,2,2) = 3 + defref(tyhte1,2,3) = 6 + nafref(tyhte1,3) = 3 + defref(tyhte1,3,1) = 1 + defref(tyhte1,3,2) = 3 + defref(tyhte1,3,3) = 5 + nafref(tyhte1,4) = 3 + defref(tyhte1,4,1) = 1 + defref(tyhte1,4,2) = 2 + defref(tyhte1,4,3) = 4 +c + faaref(tyhte1,1,1) = 3 + faaref(tyhte1,1,2) = 4 + faaref(tyhte1,2,1) = 2 + faaref(tyhte1,2,2) = 4 + faaref(tyhte1,3,1) = 2 + faaref(tyhte1,3,2) = 3 + faaref(tyhte1,4,1) = 1 + faaref(tyhte1,4,2) = 4 + faaref(tyhte1,5,1) = 1 + faaref(tyhte1,5,2) = 3 + faaref(tyhte1,6,1) = 1 + faaref(tyhte1,6,2) = 2 +c +c 3.7.2. ==> complements pour le quadratique +c + tyeref(tyhte2) = tyeref(tyhte1) + nbnref(tyhte2,1) = nbnref(tyhte1,1) + nbnref(tyhte2,2) = 10 + nbnref(tyhte2,3) = nbnref(tyhte2,2) + nbaref(tyhte2) = nbaref(tyhte1) + nasref(tyhte2) = nasref(tyhte1) + nfaref(tyhte2) = nfaref(tyhte1) +c +c 3.8. ==> description d'une pyramide +c +c 3.8.1. ==> lineaire +c + tyeref(tyhpy1) = 1 + nbnref(tyhpy1,1) = 5 + nbnref(tyhpy1,2) = nbnref(tyhpy1,1) + nbnref(tyhpy1,3) = nbnref(tyhpy1,2) + nbaref(tyhpy1) = 8 + nasref(tyhpy1) = 3 + nfaref(tyhpy1) = 2 +c + nafref(tyhpy1,1) = 3 + defref(tyhpy1,1,1) = 1 + defref(tyhpy1,1,2) = 2 + defref(tyhpy1,1,3) = 5 + nafref(tyhpy1,2) = 3 + defref(tyhpy1,2,1) = 2 + defref(tyhpy1,2,2) = 3 + defref(tyhpy1,2,3) = 6 + nafref(tyhpy1,3) = 3 + defref(tyhpy1,3,1) = 3 + defref(tyhpy1,3,2) = 4 + defref(tyhpy1,3,3) = 7 + nafref(tyhpy1,4) = 3 + defref(tyhpy1,4,1) = 1 + defref(tyhpy1,4,2) = 8 + defref(tyhpy1,4,3) = 4 + nafref(tyhpy1,5) = 4 + defref(tyhpy1,5,1) = 5 + defref(tyhpy1,5,2) = 6 + defref(tyhpy1,5,3) = 7 + defref(tyhpy1,5,4) = 8 +c + faaref(tyhpy1,1,1) = 4 + faaref(tyhpy1,1,2) = 1 + faaref(tyhpy1,2,1) = 1 + faaref(tyhpy1,2,2) = 2 + faaref(tyhpy1,3,1) = 2 + faaref(tyhpy1,3,2) = 3 + faaref(tyhpy1,4,1) = 3 + faaref(tyhpy1,4,2) = 4 + faaref(tyhpy1,5,1) = 1 + faaref(tyhpy1,5,2) = 5 + faaref(tyhpy1,6,1) = 2 + faaref(tyhpy1,6,2) = 5 + faaref(tyhpy1,7,1) = 3 + faaref(tyhpy1,7,2) = 5 + faaref(tyhpy1,8,1) = 4 + faaref(tyhpy1,8,2) = 5 +c +c 3.8.2. ==> complements pour le quadratique +c + tyeref(tyhpy2) = tyeref(tyhpy1) + nbnref(tyhpy2,1) = nbnref(tyhpy1,1) + nbnref(tyhpy2,2) = 13 + nbnref(tyhpy2,3) = nbnref(tyhpy2,2) + nbaref(tyhpy2) = nbaref(tyhpy1) + nasref(tyhpy2) = nasref(tyhpy1) + nfaref(tyhpy2) = nfaref(tyhpy1) +c +c 3.9. ==> description d'un hexaedre +c +c 3.9.1. ==> lineaire +c + tyeref(tyhhe1) = 0 + nbnref(tyhhe1,1) = 8 + nbnref(tyhhe1,2) = nbnref(tyhhe1,1) + nbnref(tyhhe1,3) = nbnref(tyhhe1,2) + nbaref(tyhhe1) = 12 + nasref(tyhhe1) = 3 + nfaref(tyhhe1) = 2 +c + nafref(tyhhe1,1) = 4 + defref(tyhhe1,1,1) = 1 + defref(tyhhe1,1,2) = 2 + defref(tyhhe1,1,3) = 4 + defref(tyhhe1,1,4) = 3 + nafref(tyhhe1,2) = 4 + defref(tyhhe1,2,1) = 1 + defref(tyhhe1,2,2) = 6 + defref(tyhhe1,2,3) = 9 + defref(tyhhe1,2,4) = 5 + nafref(tyhhe1,3) = 4 + defref(tyhhe1,3,1) = 2 + defref(tyhhe1,3,2) = 5 + defref(tyhhe1,3,3) = 10 + defref(tyhhe1,3,4) = 7 + nafref(tyhhe1,4) = 4 + defref(tyhhe1,4,1) = 3 + defref(tyhhe1,4,2) = 8 + defref(tyhhe1,4,3) = 11 + defref(tyhhe1,4,4) = 6 + nafref(tyhhe1,5) = 4 + defref(tyhhe1,5,1) = 4 + defref(tyhhe1,5,2) = 7 + defref(tyhhe1,5,3) = 12 + defref(tyhhe1,5,4) = 8 + nafref(tyhhe1,6) = 4 + defref(tyhhe1,6,1) = 9 + defref(tyhhe1,6,2) = 11 + defref(tyhhe1,6,3) = 12 + defref(tyhhe1,6,4) = 10 +c + faaref(tyhhe1,1,1) = 1 + faaref(tyhhe1,1,2) = 2 + faaref(tyhhe1,2,1) = 1 + faaref(tyhhe1,2,2) = 3 + faaref(tyhhe1,3,1) = 1 + faaref(tyhhe1,3,2) = 4 + faaref(tyhhe1,4,1) = 1 + faaref(tyhhe1,4,2) = 5 + faaref(tyhhe1,5,1) = 2 + faaref(tyhhe1,5,2) = 3 + faaref(tyhhe1,6,1) = 2 + faaref(tyhhe1,6,2) = 4 + faaref(tyhhe1,7,1) = 3 + faaref(tyhhe1,7,2) = 5 + faaref(tyhhe1,8,1) = 4 + faaref(tyhhe1,8,2) = 5 + faaref(tyhhe1,9,1) = 2 + faaref(tyhhe1,9,2) = 6 + faaref(tyhhe1,10,1) = 3 + faaref(tyhhe1,10,2) = 6 + faaref(tyhhe1,11,1) = 4 + faaref(tyhhe1,11,2) = 6 + faaref(tyhhe1,12,1) = 5 + faaref(tyhhe1,12,2) = 6 +c +c 3.9.2. ==> complements pour le quadratique +c + tyeref(tyhhe2) = tyeref(tyhhe1) + nbnref(tyhhe2,1) = nbnref(tyhhe1,1) + nbnref(tyhhe2,2) = 20 + nbnref(tyhhe2,3) = nbnref(tyhhe2,2) + nbaref(tyhhe2) = nbaref(tyhhe1) + nasref(tyhhe2) = nasref(tyhhe1) + nfaref(tyhhe2) = nfaref(tyhhe1) +c +c 3.9.3. ==> complements pour le quadratique etendu +c + tyeref(tyhhe3) = tyeref(tyhhe1) + nbnref(tyhhe3,1) = nbnref(tyhhe2,1) + nbnref(tyhhe3,2) = nbnref(tyhhe2,2) + nbnref(tyhhe3,3) = 27 + nbaref(tyhhe3) = nbaref(tyhhe1) + nasref(tyhhe3) = nasref(tyhhe1) + nfaref(tyhhe3) = nfaref(tyhhe1) +c +c 3.10. ==> description d'un pentaedre +c 3.10.1. ==> lineaire +c + tyeref(tyhpe1) = 0 + nbnref(tyhpe1,1) = 6 + nbnref(tyhpe1,2) = nbnref(tyhpe1,1) + nbnref(tyhpe1,3) = nbnref(tyhpe1,2) + nbaref(tyhpe1) = 9 + nasref(tyhpe1) = 3 + nfaref(tyhpe1) = 2 +c + nafref(tyhpe1,1) = 3 + defref(tyhpe1,1,1) = 1 + defref(tyhpe1,1,2) = 2 + defref(tyhpe1,1,3) = 3 + nafref(tyhpe1,2) = 3 + defref(tyhpe1,2,1) = 4 + defref(tyhpe1,2,2) = 6 + defref(tyhpe1,2,3) = 5 + nafref(tyhpe1,3) = 4 + defref(tyhpe1,3,1) = 1 + defref(tyhpe1,3,2) = 9 + defref(tyhpe1,3,3) = 4 + defref(tyhpe1,3,4) = 7 + nafref(tyhpe1,4) = 4 + defref(tyhpe1,4,1) = 2 + defref(tyhpe1,4,2) = 7 + defref(tyhpe1,4,3) = 5 + defref(tyhpe1,4,4) = 8 + nafref(tyhpe1,5) = 4 + defref(tyhpe1,5,1) = 3 + defref(tyhpe1,5,2) = 8 + defref(tyhpe1,5,3) = 6 + defref(tyhpe1,5,4) = 9 +c + faaref(tyhpe1,1,1) = 1 + faaref(tyhpe1,1,2) = 3 + faaref(tyhpe1,2,1) = 1 + faaref(tyhpe1,2,2) = 4 + faaref(tyhpe1,3,1) = 1 + faaref(tyhpe1,3,2) = 5 + faaref(tyhpe1,4,1) = 2 + faaref(tyhpe1,4,2) = 3 + faaref(tyhpe1,5,1) = 2 + faaref(tyhpe1,5,2) = 4 + faaref(tyhpe1,6,1) = 2 + faaref(tyhpe1,6,2) = 5 + faaref(tyhpe1,7,1) = 3 + faaref(tyhpe1,7,2) = 4 + faaref(tyhpe1,8,1) = 4 + faaref(tyhpe1,8,2) = 5 + faaref(tyhpe1,9,1) = 5 + faaref(tyhpe1,9,2) = 3 +c +c 3.10.2. ==> complements pour le quadratique +c + tyeref(tyhpe2) = tyeref(tyhpe1) + nbnref(tyhpe2,1) = nbnref(tyhpe1,1) + nbnref(tyhpe2,2) = 15 + nbnref(tyhpe2,3) = nbnref(tyhpe2,2) + nbaref(tyhpe2) = nbaref(tyhpe1) + nasref(tyhpe2) = nasref(tyhpe1) + nfaref(tyhpe2) = nfaref(tyhpe1) +c +c 3.11. ==> En quadratique +c On en fait trop mais cela simpilife l'ecriture +c + do 3111 , iaux = 1, 6 +c + nafref(tyhtr2,iaux) = nafref(tyhtr1,iaux) + defref(tyhtr2,iaux,1) = defref(tyhtr1,iaux,1) + defref(tyhtr2,iaux,2) = defref(tyhtr1,iaux,2) + defref(tyhtr2,iaux,3) = defref(tyhtr1,iaux,3) +c + nafref(tyhtr3,iaux) = nafref(tyhtr1,iaux) + defref(tyhtr3,iaux,1) = defref(tyhtr1,iaux,1) + defref(tyhtr3,iaux,2) = defref(tyhtr1,iaux,2) + defref(tyhtr3,iaux,3) = defref(tyhtr1,iaux,3) +c + nafref(tyhqu2,iaux) = nafref(tyhqu1,iaux) + defref(tyhqu2,iaux,1) = defref(tyhqu1,iaux,1) + defref(tyhqu2,iaux,2) = defref(tyhqu1,iaux,2) + defref(tyhqu2,iaux,3) = defref(tyhqu1,iaux,3) + defref(tyhqu2,iaux,4) = defref(tyhqu1,iaux,4) +c + nafref(tyhqu3,iaux) = nafref(tyhqu1,iaux) + defref(tyhqu3,iaux,1) = defref(tyhqu1,iaux,1) + defref(tyhqu3,iaux,2) = defref(tyhqu1,iaux,2) + defref(tyhqu3,iaux,3) = defref(tyhqu1,iaux,3) + defref(tyhqu3,iaux,4) = defref(tyhqu1,iaux,4) +c + nafref(tyhte2,iaux) = nafref(tyhte1,iaux) + defref(tyhte2,iaux,1) = defref(tyhte1,iaux,1) + defref(tyhte2,iaux,2) = defref(tyhte1,iaux,2) + defref(tyhte2,iaux,3) = defref(tyhte1,iaux,3) +c + nafref(tyhpy2,iaux) = nafref(tyhpy1,iaux) + defref(tyhpy2,iaux,1) = defref(tyhpy1,iaux,1) + defref(tyhpy2,iaux,2) = defref(tyhpy1,iaux,2) + defref(tyhpy2,iaux,3) = defref(tyhpy1,iaux,3) + defref(tyhpy2,iaux,4) = defref(tyhpy1,iaux,4) +c + nafref(tyhhe2,iaux) = nafref(tyhhe1,iaux) + defref(tyhhe2,iaux,1) = defref(tyhhe1,iaux,1) + defref(tyhhe2,iaux,2) = defref(tyhhe1,iaux,2) + defref(tyhhe2,iaux,3) = defref(tyhhe1,iaux,3) + defref(tyhhe2,iaux,4) = defref(tyhhe1,iaux,4) +c + nafref(tyhhe3,iaux) = nafref(tyhhe1,iaux) + defref(tyhhe3,iaux,1) = defref(tyhhe1,iaux,1) + defref(tyhhe3,iaux,2) = defref(tyhhe1,iaux,2) + defref(tyhhe3,iaux,3) = defref(tyhhe1,iaux,3) + defref(tyhhe3,iaux,4) = defref(tyhhe1,iaux,4) +c + nafref(tyhpe2,iaux) = nafref(tyhpe1,iaux) + defref(tyhpe2,iaux,1) = defref(tyhpe1,iaux,1) + defref(tyhpe2,iaux,2) = defref(tyhpe1,iaux,2) + defref(tyhpe2,iaux,3) = defref(tyhpe1,iaux,3) + defref(tyhpe2,iaux,4) = defref(tyhpe1,iaux,4) +c + 3111 continue +c + do 3112 , iaux = 1, 12 +c + faaref(tyhtr2,iaux,1) = faaref(tyhtr1,iaux,1) + faaref(tyhtr2,iaux,2) = faaref(tyhtr1,iaux,2) +c + faaref(tyhtr3,iaux,1) = faaref(tyhtr1,iaux,1) + faaref(tyhtr3,iaux,2) = faaref(tyhtr1,iaux,2) +c + faaref(tyhqu2,iaux,1) = faaref(tyhqu1,iaux,1) + faaref(tyhqu2,iaux,2) = faaref(tyhqu1,iaux,2) +c + faaref(tyhqu3,iaux,1) = faaref(tyhqu1,iaux,1) + faaref(tyhqu3,iaux,2) = faaref(tyhqu1,iaux,2) +c + faaref(tyhte2,iaux,1) = faaref(tyhte1,iaux,1) + faaref(tyhte2,iaux,2) = faaref(tyhte1,iaux,2) +c + faaref(tyhpy2,iaux,1) = faaref(tyhpy1,iaux,1) + faaref(tyhpy2,iaux,2) = faaref(tyhpy1,iaux,2) +c + faaref(tyhhe2,iaux,1) = faaref(tyhhe1,iaux,1) + faaref(tyhhe2,iaux,2) = faaref(tyhhe1,iaux,2) +c + faaref(tyhhe3,iaux,1) = faaref(tyhhe1,iaux,1) + faaref(tyhhe3,iaux,2) = faaref(tyhhe1,iaux,2) +c + faaref(tyhpe2,iaux,1) = faaref(tyhpe1,iaux,1) + faaref(tyhpe2,iaux,2) = faaref(tyhpe1,iaux,2) +c + 3112 continue +c +c==== +c 4. types HOMARD associe au format commun MED +c==== +c +c 4.0. ==> initialisation des types generaux +c + do 40 , iaux = 0 , nbtmed + mednnm(iaux) = iindef + medtrf(iaux) = iindef + medt12(iaux) = iindef + 40 continue +c +c 4.1. ==> description du sommet +c + medtrf(0) = tyhnoe + medt12(0) = 0 +c +c 4.2. ==> description de la maille-point +c + mednnm(edpoi1) = 1 + medtrf(edpoi1) = tyhmpo + medt12(edpoi1) = edpoi1 +c +c 4.3. ==> description du segment +c +c 4.3.1. ==> lineaire +c + mednnm(edseg2) = 2 + medtrf(edseg2) = tyhse1 + medt12(edseg2) = edseg3 +c +c 4.3.2. ==> quadratique +c + mednnm(edseg3) = 3 + medtrf(edseg3) = tyhse2 + medt12(edseg3) = edseg2 +c +c 4.4. ==> description du triangle +c +c 4.4.1. ==> lineaire +c + mednnm(edtri3) = 3 + medtrf(edtri3) = tyhtr1 + medt12(edtri3) = edtri6 +c +c 4.4.2. ==> quadratique +c + mednnm(edtri6) = 6 + medtrf(edtri6) = tyhtr2 + medt12(edtri6) = edtri3 +c +c 4.4.3. ==> quadratique etendu +c + mednnm(edtri7) = 7 + medtrf(edtri7) = tyhtr3 + medt12(edtri7) = edtri3 +c +c 4.5. ==> description du quadrangle +c +c 4.5.1. ==> lineaire +c + mednnm(edqua4) = 4 + medtrf(edqua4) = tyhqu1 + medt12(edqua4) = edqua8 +c +c 4.5.2. ==> quadratique +c + mednnm(edqua8) = 8 + medtrf(edqua8) = tyhqu2 + medt12(edqua8) = edqua4 +c +c 4.5.3. ==> quadratique etendu +c + mednnm(edqua9) = 9 + medtrf(edqua9) = tyhqu3 + medt12(edqua9) = edqua4 +c +c 4.6. ==> description du tetraedre +c +c 4.6.1. ==> lineaire +c + mednnm(edtet4) = 4 + medtrf(edtet4) = tyhte1 + medt12(edtet4) = edte10 +c +c 4.6.2. ==> quadratique +c + mednnm(edte10) = 10 + medtrf(edte10) = tyhte2 + medt12(edte10) = edtet4 +c +c 4.7. ==> description de la pyramide +c +c 4.7.1. ==> lineaire +c + mednnm(edpyr5) = 5 + medtrf(edpyr5) = tyhpy1 + medt12(edpyr5) = edpy13 +c +c 4.7.2. ==> quadratique +c + mednnm(edpy13) = 13 + medtrf(edpy13) = tyhpy2 + medt12(edpy13) = edpyr5 +c +c 4.8. ==> description de l'hexaedre +c +c 4.8.1. ==> lineaire +c + mednnm(edhex8) = 8 + medtrf(edhex8) = tyhhe1 + medt12(edhex8) = edhe20 +c +c 4.8.2. ==> quadratique +c + mednnm(edhe20) = 20 + medtrf(edhe20) = tyhhe2 + medt12(edhe20) = edhex8 +c +c 4.8.2. ==> quadratique etendu +c + mednnm(edhe27) = 27 + medtrf(edhe27) = tyhhe3 + medt12(edhe27) = edhex8 +c +c 4.9. ==> description du pentaedre +c +c 4.9.1. ==> lineaire +c + mednnm(edpen6) = 6 + medtrf(edpen6) = tyhpe1 + medt12(edpen6) = edpe15 +c +c 4.9.2. ==> quadratique +c + mednnm(edpe15) = 15 + medtrf(edpe15) = tyhpe2 + medt12(edpe15) = edpen6 +c +c==== +c 5. description pour une connectivite a la med +c==== +c +c 5.1. ==> prealable +c + do 51 , iaux = 0 , tehmax + do 511 , jaux = 1 , 10 + arsmed(iaux,jaux,1) = iindef + arsmed(iaux,jaux,2) = iindef + arsmed(iaux,jaux,3) = iindef + arsmed(iaux,jaux,4) = iindef + 511 continue + do 512 , jaux = 1 , 12 + deamed(iaux,jaux,1) = iindef + deamed(iaux,jaux,2) = iindef + deamed(iaux,jaux,3) = iindef + 512 continue + 51 continue +c +c 5.2. ==> description de la poutre +c +c 5.2.1. ==> lineaire +c a1 +c n1*-------------*n2 +c + arsmed(tyhse1,1,1) = 1 + arsmed(tyhse1,2,1) = 1 +c + deamed(tyhse1,1,1) = 1 + deamed(tyhse1,1,2) = 2 +c +c 5.2.2. ==> complements pour le quadratique +c a1 +c n1*------*------*n2 +c n3 + deamed(tyhse2,1,3) = 3 +c +c 5.3. ==> description du triangle +c +c 5.3.1. ==> lineaire +c a1 +c n1*---------------*n2 +c . . +c . . +c . . +c a2 . . a3 +c . . +c . . +c . . +c * +c n3 +c + arsmed(tyhtr1,1,1) = 1 + arsmed(tyhtr1,1,2) = 2 + arsmed(tyhtr1,2,1) = 1 + arsmed(tyhtr1,2,2) = 3 + arsmed(tyhtr1,3,1) = 2 + arsmed(tyhtr1,3,2) = 3 +c + deamed(tyhtr1,1,1) = 1 + deamed(tyhtr1,1,2) = 2 + deamed(tyhtr1,2,1) = 1 + deamed(tyhtr1,2,2) = 3 + deamed(tyhtr1,3,1) = 2 + deamed(tyhtr1,3,2) = 3 +c +c 5.3.2. ==> complements pour le quadratique +c a1 +c n1*-------*-------*n2 +c . n4 . +c . . +c . . +c a2 *n6 *n5 a3 +c . . +c . . +c . . +c * +c n3 +c + deamed(tyhtr2,1,3) = 4 + deamed(tyhtr2,2,3) = 6 + deamed(tyhtr2,3,3) = 5 +c + do 532 , iaux = 1, 3 + deamed(tyhtr3,iaux,3) = deamed(tyhtr2,iaux,3) + 532 continue +c +c 5.4. ==> description du quadrangle +c +c 5.4.1. ==> lineaire +c a1 +c n1*---------------*n2 +c . . +c . . +c . . +c a4 . . a2 +c . . +c . . +c . . +c n4*---------------*n3 +c a3 +c + arsmed(tyhqu1,1,1) = 1 + arsmed(tyhqu1,1,2) = 4 + arsmed(tyhqu1,2,1) = 2 + arsmed(tyhqu1,2,2) = 1 + arsmed(tyhqu1,3,1) = 3 + arsmed(tyhqu1,3,2) = 2 + arsmed(tyhqu1,4,1) = 4 + arsmed(tyhqu1,4,2) = 3 +c + deamed(tyhqu1,1,1) = 1 + deamed(tyhqu1,1,2) = 2 + deamed(tyhqu1,2,1) = 2 + deamed(tyhqu1,2,2) = 3 + deamed(tyhqu1,3,1) = 3 + deamed(tyhqu1,3,2) = 4 + deamed(tyhqu1,4,1) = 4 + deamed(tyhqu1,4,2) = 1 +c +c 5.4.2. ==> complements pour le quadratique +c a1/n5 +c n1*---------------*n2 +c . . +c . . +c . . +c a4/n8 . . a2/n6 +c . . +c . . +c . . +c n4*---------------*n3 +c a3/n7 +c + deamed(tyhqu2,1,3) = 5 + deamed(tyhqu2,2,3) = 6 + deamed(tyhqu2,3,3) = 7 + deamed(tyhqu2,4,3) = 8 +c + do 542 , iaux = 1, 4 + deamed(tyhqu3,iaux,3) = deamed(tyhqu2,iaux,3) + 542 continue +c +c 5.5. ==> description du tetraedre +c +c 5.5.1. ==> lineaire +c la face fi est opposee au sommet ni +c +c n1 +c * +c . .. +c . . . a2 +c . . . +c . . . +c a1 . a3 . . n3 +c . . * +c . . . . +c . a4 . . . a6 +c . . . . +c . . .. +c . . . +c *..................................* +c n2 a5 n4 +c + arsmed(tyhte1,1,1) = 1 + arsmed(tyhte1,1,2) = 2 + arsmed(tyhte1,1,3) = 3 + arsmed(tyhte1,2,1) = 1 + arsmed(tyhte1,2,2) = 4 + arsmed(tyhte1,2,3) = 5 + arsmed(tyhte1,3,1) = 2 + arsmed(tyhte1,3,2) = 4 + arsmed(tyhte1,3,3) = 6 + arsmed(tyhte1,4,1) = 3 + arsmed(tyhte1,4,2) = 5 + arsmed(tyhte1,4,3) = 6 +c + deamed(tyhte1,1,1) = 1 + deamed(tyhte1,1,2) = 2 + deamed(tyhte1,2,1) = 1 + deamed(tyhte1,2,2) = 3 + deamed(tyhte1,3,1) = 1 + deamed(tyhte1,3,2) = 4 + deamed(tyhte1,4,1) = 2 + deamed(tyhte1,4,2) = 3 + deamed(tyhte1,5,1) = 2 + deamed(tyhte1,5,2) = 4 + deamed(tyhte1,6,1) = 3 + deamed(tyhte1,6,2) = 4 +c +c 5.5.2. ==> complements pour le quadratique +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a2 +c . . *n7 +c . . . +c a1 . a3 * . n3 +c n5* n8. * +c . . . . +c . a4 . . . a6 +c . *n6 . *n10 +c . . .. +c . . . +c *................*.................* +c n2 a5 n9 n4 +c +c + deamed(tyhte2,1,3) = 5 + deamed(tyhte2,2,3) = 7 + deamed(tyhte2,3,3) = 8 + deamed(tyhte2,4,3) = 6 + deamed(tyhte2,5,3) = 9 + deamed(tyhte2,6,3) = 10 +c +c 5.6. ==> description de l'hexaedre +c +c 5.6.1. ==> lineaire +c +c 1 4 +c -------------------- +c / /. +c / / . +c / / . +c / / . +c 2 -------------------- 3 . +c . . . +c . . . +c . 5 . . 8 +c . . / +c . . / +c . . / +c . ./ +c -------------------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (1-->2,1-->5,1-->4) est direct +c + arsmed(tyhhe1,1,1) = 1 + arsmed(tyhhe1,1,2) = 2 + arsmed(tyhhe1,1,3) = 5 + arsmed(tyhhe1,2,1) = 1 + arsmed(tyhhe1,2,2) = 3 + arsmed(tyhhe1,2,3) = 6 + arsmed(tyhhe1,3,1) = 3 + arsmed(tyhhe1,3,2) = 4 + arsmed(tyhhe1,3,3) = 8 + arsmed(tyhhe1,4,1) = 2 + arsmed(tyhhe1,4,2) = 4 + arsmed(tyhhe1,4,3) = 7 + arsmed(tyhhe1,5,1) = 5 + arsmed(tyhhe1,5,2) = 9 + arsmed(tyhhe1,5,3) = 10 + arsmed(tyhhe1,6,1) = 6 + arsmed(tyhhe1,6,2) = 9 + arsmed(tyhhe1,6,3) = 11 + arsmed(tyhhe1,7,1) = 8 + arsmed(tyhhe1,7,2) = 11 + arsmed(tyhhe1,7,3) = 12 + arsmed(tyhhe1,8,1) = 7 + arsmed(tyhhe1,8,2) = 10 + arsmed(tyhhe1,8,3) = 12 +c + deamed(tyhhe1,1,1) = 1 + deamed(tyhhe1,1,2) = 2 + deamed(tyhhe1,2,1) = 1 + deamed(tyhhe1,2,2) = 4 + deamed(tyhhe1,3,1) = 2 + deamed(tyhhe1,3,2) = 3 + deamed(tyhhe1,4,1) = 3 + deamed(tyhhe1,4,2) = 4 + deamed(tyhhe1,5,1) = 1 + deamed(tyhhe1,5,2) = 5 + deamed(tyhhe1,6,1) = 2 + deamed(tyhhe1,6,2) = 6 + deamed(tyhhe1,7,1) = 4 + deamed(tyhhe1,7,2) = 8 + deamed(tyhhe1,8,1) = 3 + deamed(tyhhe1,8,2) = 7 + deamed(tyhhe1,9,1) = 5 + deamed(tyhhe1,9,2) = 6 + deamed(tyhhe1,10,1) = 5 + deamed(tyhhe1,10,2) = 8 + deamed(tyhhe1,11,1) = 6 + deamed(tyhhe1,11,2) = 7 + deamed(tyhhe1,12,1) = 7 + deamed(tyhhe1,12,2) = 8 +c +c 5.6.2. ==> complements pour le quadratique +c +c 1 4 +c ---------12--------- +c / /. +c 9/ 11. +c / / . +c / 17 / . +c 2 ---------10---------3 20 +c . . . +c . . . +c . 5 16 . . 8 +c 18. .19 / +c . 13 . /15 +c . . / +c . ./ +c ---------14--------- +c 6 7 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Les noeuds (5,6,7,8) sont translates de (1,2,3,4) +c . Le triedre (1-->2,1-->5,1-->4) est direct +c + deamed(tyhhe2,1,3) = 9 + deamed(tyhhe2,2,3) = 12 + deamed(tyhhe2,3,3) = 10 + deamed(tyhhe2,4,3) = 11 + deamed(tyhhe2,5,3) = 17 + deamed(tyhhe2,6,3) = 18 + deamed(tyhhe2,7,3) = 20 + deamed(tyhhe2,8,3) = 19 + deamed(tyhhe2,9,3) = 13 + deamed(tyhhe2,10,3) = 16 + deamed(tyhhe2,11,3) = 14 + deamed(tyhhe2,12,3) = 15 +c + do 562 , iaux = 1, 12 + deamed(tyhhe3,iaux,3) = deamed(tyhhe2,iaux,3) + 562 continue +c +c 5.7. ==> Les pentaedres +c +c . Les noeuds (1,2,3) definissent un triangle a orientation +c vers l'exterieur +c . Les noeuds (4,5,6,) sont translates de (1,2,3) +c +c 5.7.1. ==> Les lineaires +c la face (n1,n2,n3) tourne vers l'exterieur +c la face (n4,n5,n6) est translatee, donc tourne vers l'interieur +c n3 n6 +c x------------------------------------------x +c . . +c . . . . +c . . +c . . . . +c . . +c . . . . +c . . +c n2. . n5. . +c x------------------------------------------x +c . . . . +c . . +c . . . . +c x------------------------------------------x +c n1 n4 +c + arsmed(tyhpe1,1,1) = 1 + arsmed(tyhpe1,1,2) = 2 + arsmed(tyhpe1,1,3) = 7 + arsmed(tyhpe1,2,1) = 1 + arsmed(tyhpe1,2,2) = 3 + arsmed(tyhpe1,2,3) = 9 + arsmed(tyhpe1,3,1) = 2 + arsmed(tyhpe1,3,2) = 3 + arsmed(tyhpe1,3,3) = 8 + arsmed(tyhpe1,4,1) = 4 + arsmed(tyhpe1,4,2) = 5 + arsmed(tyhpe1,4,3) = 7 + arsmed(tyhpe1,5,1) = 4 + arsmed(tyhpe1,5,2) = 6 + arsmed(tyhpe1,5,3) = 9 + arsmed(tyhpe1,6,1) = 5 + arsmed(tyhpe1,6,2) = 6 + arsmed(tyhpe1,6,3) = 8 +c + deamed(tyhpe1,1,1) = 1 + deamed(tyhpe1,1,2) = 2 + deamed(tyhpe1,2,1) = 1 + deamed(tyhpe1,2,2) = 3 + deamed(tyhpe1,3,1) = 2 + deamed(tyhpe1,3,2) = 3 + deamed(tyhpe1,4,1) = 4 + deamed(tyhpe1,4,2) = 5 + deamed(tyhpe1,5,1) = 4 + deamed(tyhpe1,5,2) = 6 + deamed(tyhpe1,6,1) = 5 + deamed(tyhpe1,6,2) = 6 + deamed(tyhpe1,7,1) = 1 + deamed(tyhpe1,7,2) = 4 + deamed(tyhpe1,8,1) = 3 + deamed(tyhpe1,8,2) = 6 + deamed(tyhpe1,9,1) = 2 + deamed(tyhpe1,9,2) = 5 +c +c 5.7.2 Les quadratiques +c la face (n1,n2,n3) tourne vers l'exterieur +c la face (n4,n5,n6) est translatee, donc tourne vers l'interieur +c n3 n15 n6 +c x------------------------------------------x +c . . +c . . . . +c . . +c n8. . n11. . +c . . +c . . . . +c . n9 . n12 +c n2. . n14 n5. . +c x------------------------------------------x +c . . . . +c . n10 . +c . . . . +c n7 x------------------------------------------x +c n1 n13 n4 +c + deamed(tyhpe2,1,3) = 7 + deamed(tyhpe2,2,3) = 9 + deamed(tyhpe2,3,3) = 8 + deamed(tyhpe2,4,3) = 10 + deamed(tyhpe2,5,3) = 12 + deamed(tyhpe2,6,3) = 11 + deamed(tyhpe2,7,3) = 13 + deamed(tyhpe2,8,3) = 15 + deamed(tyhpe2,9,3) = 14 +c +c 5.8. ==> description de la pyramide +c +c 5.8.1. ==> lineaire +c +c 1 ----------------- 2 +c . . . . +c . . . . +c . . . . +c . . 5 . Ici le noeud 5 est au-dessus +c . . . . +c . . . . +c . . . . +c ----------------- +c 4 3 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Le triedre (1-->2,1-->4,1-->5) est direct +c + arsmed(tyhpy1,1,1) = 1 + arsmed(tyhpy1,1,2) = 5 + arsmed(tyhpy1,1,3) = 8 + arsmed(tyhpy1,2,1) = 4 + arsmed(tyhpy1,2,2) = 7 + arsmed(tyhpy1,2,3) = 8 + arsmed(tyhpy1,3,1) = 3 + arsmed(tyhpy1,3,2) = 6 + arsmed(tyhpy1,3,3) = 7 + arsmed(tyhpy1,4,1) = 2 + arsmed(tyhpy1,4,2) = 5 + arsmed(tyhpy1,4,3) = 6 + arsmed(tyhpy1,5,1) = 1 + arsmed(tyhpy1,5,2) = 2 + arsmed(tyhpy1,5,3) = 3 + arsmed(tyhpy1,5,4) = 4 +c + deamed(tyhpy1,1,1) = 1 + deamed(tyhpy1,1,2) = 5 + deamed(tyhpy1,2,1) = 4 + deamed(tyhpy1,2,2) = 5 + deamed(tyhpy1,3,1) = 3 + deamed(tyhpy1,3,2) = 5 + deamed(tyhpy1,4,1) = 2 + deamed(tyhpy1,4,2) = 5 + deamed(tyhpy1,5,1) = 1 + deamed(tyhpy1,5,2) = 4 + deamed(tyhpy1,6,1) = 3 + deamed(tyhpy1,6,2) = 4 + deamed(tyhpy1,7,1) = 2 + deamed(tyhpy1,7,2) = 3 + deamed(tyhpy1,8,1) = 1 + deamed(tyhpy1,8,2) = 2 +c +c 5.8.2. ==> complements pour le quadratique +c +c 1 ----------------- 2 +c . . . . +c . . . . +c . . . . +c . . 5 . Ici le noeud 5 est au-dessus +c . . . . +c . . . . +c . . . . +c ----------------- +c 4 3 +c +c . Les noeuds (1,2,3,4) definissent un quadrangle a orientation +c vers l'exterieur +c . Le triedre (1-->2,1-->4,1-->5) est direct +c + deamed(tyhpy2,1,3) = 10 + deamed(tyhpy2,2,3) = 13 + deamed(tyhpy2,3,3) = 12 + deamed(tyhpy2,4,3) = 11 + deamed(tyhpy2,5,3) = 9 + deamed(tyhpy2,6,3) = 8 + deamed(tyhpy2,7,3) = 7 + deamed(tyhpy2,8,3) = 6 +c +c 5.9 ==> En quadratique +c + do 591 , jaux = 1 , 10 +c + arsmed(tyhse2,jaux,1) = arsmed(tyhse1,jaux,1) + arsmed(tyhse2,jaux,2) = arsmed(tyhse1,jaux,2) + arsmed(tyhse2,jaux,3) = arsmed(tyhse1,jaux,3) +c + arsmed(tyhtr2,jaux,1) = arsmed(tyhtr1,jaux,1) + arsmed(tyhtr2,jaux,2) = arsmed(tyhtr1,jaux,2) + arsmed(tyhtr2,jaux,3) = arsmed(tyhtr1,jaux,3) +c + arsmed(tyhtr3,jaux,1) = arsmed(tyhtr1,jaux,1) + arsmed(tyhtr3,jaux,2) = arsmed(tyhtr1,jaux,2) + arsmed(tyhtr3,jaux,3) = arsmed(tyhtr1,jaux,3) +c + arsmed(tyhte2,jaux,1) = arsmed(tyhte1,jaux,1) + arsmed(tyhte2,jaux,2) = arsmed(tyhte1,jaux,2) + arsmed(tyhte2,jaux,3) = arsmed(tyhte1,jaux,3) +c + arsmed(tyhqu2,jaux,1) = arsmed(tyhqu1,jaux,1) + arsmed(tyhqu2,jaux,2) = arsmed(tyhqu1,jaux,2) + arsmed(tyhqu2,jaux,3) = arsmed(tyhqu1,jaux,3) +c + arsmed(tyhqu3,jaux,1) = arsmed(tyhqu1,jaux,1) + arsmed(tyhqu3,jaux,2) = arsmed(tyhqu1,jaux,2) + arsmed(tyhqu3,jaux,3) = arsmed(tyhqu1,jaux,3) +c + arsmed(tyhpy2,jaux,1) = arsmed(tyhpy1,jaux,1) + arsmed(tyhpy2,jaux,2) = arsmed(tyhpy1,jaux,2) + arsmed(tyhpy2,jaux,3) = arsmed(tyhpy1,jaux,3) + arsmed(tyhpy2,jaux,4) = arsmed(tyhpy1,jaux,4) +c + arsmed(tyhhe2,jaux,1) = arsmed(tyhhe1,jaux,1) + arsmed(tyhhe2,jaux,2) = arsmed(tyhhe1,jaux,2) + arsmed(tyhhe2,jaux,3) = arsmed(tyhhe1,jaux,3) +c + arsmed(tyhhe3,jaux,1) = arsmed(tyhhe1,jaux,1) + arsmed(tyhhe3,jaux,2) = arsmed(tyhhe1,jaux,2) + arsmed(tyhhe3,jaux,3) = arsmed(tyhhe1,jaux,3) +c + arsmed(tyhpe2,jaux,1) = arsmed(tyhpe1,jaux,1) + arsmed(tyhpe2,jaux,2) = arsmed(tyhpe1,jaux,2) + arsmed(tyhpe2,jaux,3) = arsmed(tyhpe1,jaux,3) +c + 591 continue +c + do 592 , jaux = 1 , 12 +c + deamed(tyhse2,jaux,1) = deamed(tyhse1,jaux,1) + deamed(tyhse2,jaux,2) = deamed(tyhse1,jaux,2) +c + deamed(tyhtr2,jaux,1) = deamed(tyhtr1,jaux,1) + deamed(tyhtr2,jaux,2) = deamed(tyhtr1,jaux,2) +c + deamed(tyhtr3,jaux,1) = deamed(tyhtr1,jaux,1) + deamed(tyhtr3,jaux,2) = deamed(tyhtr1,jaux,2) +c + deamed(tyhqu2,jaux,1) = deamed(tyhqu1,jaux,1) + deamed(tyhqu2,jaux,2) = deamed(tyhqu1,jaux,2) +c + deamed(tyhqu3,jaux,1) = deamed(tyhqu1,jaux,1) + deamed(tyhqu3,jaux,2) = deamed(tyhqu1,jaux,2) +c + deamed(tyhte2,jaux,1) = deamed(tyhte1,jaux,1) + deamed(tyhte2,jaux,2) = deamed(tyhte1,jaux,2) +c + deamed(tyhpy2,jaux,1) = deamed(tyhpy1,jaux,1) + deamed(tyhpy2,jaux,2) = deamed(tyhpy1,jaux,2) +c + deamed(tyhhe2,jaux,1) = deamed(tyhhe1,jaux,1) + deamed(tyhhe2,jaux,2) = deamed(tyhhe1,jaux,2) +c + deamed(tyhhe3,jaux,1) = deamed(tyhhe1,jaux,1) + deamed(tyhhe3,jaux,2) = deamed(tyhhe1,jaux,2) +c + deamed(tyhpe2,jaux,1) = deamed(tyhpe1,jaux,1) + deamed(tyhpe2,jaux,2) = deamed(tyhpe1,jaux,2) +c + 592 continue +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utindh.F b/src/tool/Utilitaire/utindh.F new file mode 100644 index 00000000..8bc1c20d --- /dev/null +++ b/src/tool/Utilitaire/utindh.F @@ -0,0 +1,251 @@ + subroutine utindh ( typpro, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : INitialisation des Donnees de HOMARD +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typpro . e . 1 . type de programme . +c . . . . 1 : homard complet . +c . . . . 2 : interface avant adaptation . +c . . . . 3 : adaptation . +c . . . . 4 : suivi de frontiere . +c . . . . 5 : interface apres adaptation . +c . . . . 6 : information . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : impossible d'allouer la tete . +c . . . . 4 : impossible d'allouer les objets simples. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINDH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "cndoad.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer typpro + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 + integer adress +c + character*200 nomobj +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages, +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + > '(''Impossible d''''allouer la tete de type DonnHOMA.'')' + texte(1,4) = '(''Impossible d''''allouer l''''objet :'')' +c + texte(2,10) = + > '(''Head object of type DonnHOMA cannot be allocated.'')' + texte(2,4) = '(''This object cannot be allocated :'')' +c +c==== +c 2. Les options +c==== +c +c 2.1. ==> allocation de l'objet de tete +c + call gmalot ( nndoad, 'DonnHOMA', 0, iaux, codre0 ) +c + if ( codre0.ne.0 ) then + codret = 2 + endif +c +c 2.2. ==> allocation des options entieres +c + if ( codret.eq.0 ) then +c + nomobj = nndoad//'.OptEnt' + iaux = 50 + call gmecat ( nndoad, 1, iaux, codre1 ) + call gmaloj ( nomobj, ' ', iaux, adress, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + codret = 4 + else + imem(adress) = langue + endif +c + endif +c +c 2.3. ==> allocation des options reelles +c + if ( codret.eq.0 ) then +c + nomobj = nndoad//'.OptRee' + iaux = 20 + call gmecat ( nndoad, 2, iaux, codre1 ) + call gmaloj ( nomobj, ' ', iaux, adress, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + codret = 4 + endif +c + endif +c +c 2.4. ==> allocation des options caracteres +c + if ( codret.eq.0 ) then +c + nomobj = nndoad//'.OptCar' + iaux = 40 + call gmecat ( nndoad, 3, iaux, codre1 ) + call gmaloj ( nomobj, ' ', iaux, adress, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + codret = 4 + endif +c + endif +c +c 2.5. ==> allocation de l'etat courant +c + if ( codret.eq.0 ) then +c + nomobj = nndoad//'.EtatCour' + iaux = 10 + call gmecat ( nndoad, 4, iaux, codre1 ) + call gmaloj ( nomobj, ' ', iaux, adress, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( codret.ne.0 ) then + codret = 4 + else + imem(adress) = 1 + imem(adress+1) = 1 + imem(adress+2) = 10 + imem(adress+3) = 10 + endif +c + endif +c +c 2.6. ==> le type de programme +c + if ( codret.eq.0 ) then +c + call gmecat ( nndoad, 5, typpro, codret ) +c + if ( codret.ne.0 ) then + codret = 4 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nndoad ) + call gmprsx (nompro, nndoad//'.OptEnt' ) + call gmprsx (nompro, nndoad//'.OptRee' ) + call gmprsx (nompro, nndoad//'.OptCar' ) + call gmprsx (nompro, nndoad//'.EtatCour' ) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.2 ) then + write (ulsort,texte(langue,10)) + else + write (ulsort,texte(langue,4)) + write (ulsort,*) nomobj + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utinei.F b/src/tool/Utilitaire/utinei.F new file mode 100644 index 00000000..5df5f0e2 --- /dev/null +++ b/src/tool/Utilitaire/utinei.F @@ -0,0 +1,132 @@ + subroutine utinei ( modhom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - INitialisation des Elements Ignores +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . -5 : executable du suivi de frontiere . +c . . . . -4 : exec. de l'interface apres adaptation . +c . . . . -3 : exec. de l'interface avant adaptation . +c . . . . -2 : executable de l'information . +c . . . . -1 : executable de l'adaptation . +c . . . . 0 : executable autre . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : presence de quadrangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINEI' ) +c +#include "nblang.h" +#include "consts.h" +c +#include "referx.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "refere.h" +#include "refert.h" +c +c 0.3. ==> arguments +c + integer modhom +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. a priori, tout va bien +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. Controle des compatibilites +c . pour l'adaptation, on accepte tout sauf les pyramides +c==== +c + if ( modhom.ne.1 .and. modhom.ne.-1 ) then +c + tyeref(tyhpy1) = 0 + tyeref(tyhpy2) = 0 +c + endif +c +c=== +c 3. bilan +c=== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utinfm.F b/src/tool/Utilitaire/utinfm.F new file mode 100644 index 00000000..26d55ba6 --- /dev/null +++ b/src/tool/Utilitaire/utinfm.F @@ -0,0 +1,173 @@ + subroutine utinfm ( numfam, nomfam, + > nbrgrf, nomgrf, + > nbnofa, nbmafa, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Entree-Sortie - UTilitaire - INformation sur les Familles MED +c - - - -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . numfam . e . 1 . numero de la famille a decrire . +c . nomfam . e .char*64 . nom de la famille a decrire . +c . nbnofa . e . 1 . nombre de noeuds dans cette famille . +c . nbmafa . e . 1 . nombre de mailles dans cette famille . +c . nbrgrf . e . 1 . nombre de groupes dans cette famille . +c . nomgrf . e .10*nbgrf. noms des groupes dans cette famille . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINFM' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer numfam + integer nbnofa, nbmafa, nbrgrf +c + integer ulsort, langue, codret +c + character*8 nomgrf(10*nbrgrf) + character*64 nomfam +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''* Famille : '',a64,5x,''*'')' + texte(1,5) = '(''* Numero : '',i8,61x,''*'')' + texte(1,9) = '(''* Nombre de groupes : '',i8,50x,''*'')' + texte(1,10) = + > '(''*'',10x,''Groupe(s) correspondant(s) :'',44x,''*'')' + texte(1,17) = '(''* Nombre de noeuds : '',i8,49x,''*'')' + texte(1,18) = '(''* Nombre de noeuds inconnus.'',53x,''*'')' + texte(1,19) = '(''* Nombre de mailles : '',i8,49x,''*'')' + texte(1,20) = '(''* Nombre de mailles inconnues.'',51x,''*'')' +c + texte(2,4) = '(''* Family : '',a64,5x,''*'')' + texte(2,5) = '(''* # : '',i8,61x,''*'')' + texte(2,9) = '(''* Number of groups : '',i8,54x,''*'')' + texte(2,10) = '(''*'',8x,''Associated group(s)'',55x,''*'')' + texte(2,17) = '(''* Number of nodes : '',i8,49x,''*'')' + texte(2,18) = '(''* Number of nodes is unknown.'',52x,''*'')' + texte(2,19) = '(''* Number of meshes : '',i8,47x,''*'')' + texte(2,20) = '(''* Number of meshes is unknown.'',47x,''*'')' +c +10001 format(/) +10002 format(84('*')) +10003 format('* ',a80,' *') +10004 format('* ',10a8,' *') +c +c==== +c 2. affichage +c==== +c + write (ulsort,10001) + write (ulsort,10002) + write (ulsort,texte(langue,4)) nomfam + write (ulsort,texte(langue,5)) numfam +c + write (ulsort,texte(langue,9)) nbrgrf + if ( nbrgrf.gt.0 ) then + write (ulsort,10002) + write (ulsort,texte(langue,10)) + do 22 , iaux = 1 , nbrgrf + write (ulsort,10004) (nomgrf(jaux),jaux=10*(iaux-1)+1,10*iaux) + 22 continue + write (ulsort,10002) + endif +c + if ( nbnofa.gt.0 ) then + write (ulsort,texte(langue,17)) nbnofa + elseif ( nbnofa.lt.0 ) then + write (ulsort,texte(langue,18)) + endif +c + if ( nbmafa.gt.0 ) then + write (ulsort,texte(langue,19)) nbmafa + elseif ( nbmafa.lt.0 ) then + write (ulsort,texte(langue,20)) + endif +c + write (ulsort,10002) + write (ulsort,10001) +c + codret = 0 +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utinit.F b/src/tool/Utilitaire/utinit.F new file mode 100644 index 00000000..260e7999 --- /dev/null +++ b/src/tool/Utilitaire/utinit.F @@ -0,0 +1,390 @@ + subroutine utinit ( nfconf, lfconf, messag, nbrmes, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : INITialisation +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . messag . e . char40 . message d'en tete des listes . +c . nbrmes . e . 1 . nombres de messages . +c . ulsort . s . 1 . numero d'unite logique de la liste standard. +c . langue . es . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2x : probleme dans les memoires . +c . . . . 3 : probleme dans le decodage du fichier . +c . . . . de configuration . +c . . . . 3x : probleme dans les fichiers . +c . . . . 5 : deuxieme appel au programme . +c . . . . 7 : impossible de decoder le $HOME . +c . . . . 11 : date d'autorisation depassee . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINIT' ) +c +#include "nblang.h" +c + integer nbcar + parameter ( nbcar = 6 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf +c + integer ulsort, langue, codret +c + integer nbrmes + character*40 messag(nblang,nbrmes) +c +c 0.4. ==> variables locales +c +#include "consts.h" +#include "motcle.h" +#include "nuvers.h" +#include "webweb.h" +c + integer lfsort + integer guimp, gmimp, raison + integer iaux, jaux, kaux + integer ulsost, ulmess + integer numann, datheu + integer lgcar(nbcar) +c + character*8 motcle + character*50 nomare, nomais, typmac, noarch, systre, systve + character*48 ladate + character*200 nfsort +c + character*40 blabla +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c + texte(1,4) = '(//,''1. INITIALISATIONS'')' + texte(1,5) = '(18(''=''),/)' + texte(1,7) = '(/,''Ce calcul date du '',a48)' + texte(1,8) = '(''Il a eu lieu sur '',a)' + texte(1,9) = '(''. type de machine : '',a )' + texte(1,10) = '(''. systeme d''''exploitation : '',a)' + texte(1,11) = '('' release : '',a )' + texte(1,12) = '('' version : '',a ,//)' +c + texte(2,4) = '(//,''1. INITIALISATIONS'')' + texte(2,5) = '(18(''=''),/)' + texte(2,7) = '(/,''This computation ran '',a48)' + texte(2,8) = '(''It was done on '',a)' + texte(2,9) = '(''. machine type : '',a)' + texte(2,10) = '(''. operating system : '',a)' + texte(2,11) = '('' release : '',a)' + texte(2,12) = '('' version : '',a,//)' +c +51001 format ( + > 15x,'..........................................') +51101 format ( + > 15x,':........................................:') +51002 format ( + > 15x,': :') +51003 format (15x,':',a40,':') +51004 format (//) +51011 format ( + > 'Copyright 1996 EDF', + > /,'Copyright 2015 EDF', + > /,'Copyright ',i4,' EDF', + > /,'------------------',/) +51012 format ( + > 15x,': H O M A R D ',a8 ,' :') +c + spropb = blan08(1:6) +c +c==== +c 2. premier appel de uginit pour initialisation du gestionnaire +c d'unites logiques +c remarque : au premier appel, ulsort n'a pas besoin d'etre +c initialise +c==== +c + codret = 0 +c + if ( langue.le.0 .or. langue.gt.nblang ) then + langue = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de UGINIT par ', nompro +#endif + call uginit ( ulsort, langue, nfconf, lfconf, codret ) +c + if ( codret.eq.0 ) then +c + call gusost ( ulsost ) +c + endif +c +c==== +c 3. le fichier associe a la sortie standard +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) '3. sortie standard ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 3.1. ==> le nom de ce fichier +c + motcle = mclist +#ifdef _DEBUG_HOMARD_ + write (*,*) 'Appel de UGFINO par ', nompro +#endif + call ugfino ( motcle, nfsort, lfsort, + > nfconf, lfconf, + > ulsost, langue, codret ) +c + if ( codret.ne.0 .and. codret.ne.1 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop (nompro, ulsost, guimp, gmimp, raison) + endif +c +c 3.2. ==> l'unite logique associee a cette liste +c on redirige sur la sortie standard si le fichier +c n'a pas ete mentionne dans la configuration, sinon +c on ouvre le fichier correspondant. +c + if ( codret.eq.1 .or. lfsort.le.0 ) then +c + ulsort = ulsost + codret = 0 +c + else +c + call guoufs ( nfsort, lfsort, ulsort, codret ) + if ( codret.ne.0 ) then + guimp = 1 + gmimp = 0 + raison = 1 + call ugstop (nompro, ulsost, guimp, gmimp, raison) + endif +c + call gurbbu ( ulsort, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + endif +#endif +c +c==== +c 4. l'environnement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. environnement ; codret = ', codret +#endif +c +c 4.1. ==> la langue +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (*,texte(1,3)) 'UTINLA', nompro +#endif + call utinla ( nfconf, lfconf, + > ulsort, langue, codret ) + endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (*,texte(1,3)) 'GULANM', nompro +#endif + call gulanm ( langue, codret ) + endif +c +c 4.2. ==> les dates et types de machines +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'UTDHCO', nompro +#endif + call utdhco ( numann, datheu ) +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'UTDHLG', nompro +#endif + call utdhlg ( ladate, langue ) +c +#ifdef _DEBUG_HOMARD_ + write (*,texte(langue,3)) 'DMMACH', nompro +#endif + call dmmach ( nomare, nomais, typmac, + > noarch, systre, systve, + > lgcar ) +c + endif +c +c==== +c 5. en-tete +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) '5. en-tete ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 5.1. ==> debut de l'en-tete +c + ulmess = ulsort +c + write (ulmess,51011) numann + write (ulmess,51001) + write (ulmess,51002) + write (ulmess,51012) nuvers + write (ulmess,51002) + write (ulmess,51101) + write (ulmess,51002) +c +c recopie prudente du message (40 caracteres utiles a priori) +c dans blabla : +c + do 511 , jaux = 1 , nbrmes + call dmcpch( messag(langue,jaux), 40, blabla, kaux ) + write (ulmess,51003) blabla + 511 continue +c + write (ulmess,51002) + write (ulmess,51101) + write (ulmess,51002) +c + call dmcpch( weba, 40, blabla, kaux ) + write (ulmess,51003) blabla + if ( langue.eq.2 ) then + call dmcpch( web2, 40, blabla, kaux ) + write (ulmess,51003) blabla + endif + write (ulmess,51002) + write (ulmess,51101) +c + write (ulsort,texte(langue,7)) ladate +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nomare(1:lgcar(1)) + write (ulsort,texte(langue,9)) typmac(1:lgcar(3)) + write (ulsort,texte(langue,10)) noarch(1:lgcar(4)) + write (ulsort,texte(langue,11)) systre(1:lgcar(5)) + write (ulsort,texte(langue,12)) systve(1:lgcar(6)) +#endif +c +c 5.2. ==> fin de l'en-tete +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) + endif +c + endif +c +c==== +c 6. second appel de uginit pour initialisation du gestionnaire +c de mesures de temps calcul et de memoire +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) '6. second appel de uginit ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UGINIT', nompro +#endif + call uginit ( ulsort, langue, nfconf, lfconf, codret ) +c + endif +c +c==== +c 7. acquisition des noms des fichiers utiles au calcul +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) '7. noms des fichiers ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIAC', nompro +#endif + call utfiac ( nfconf, lfconf, ulsort, langue, codret ) +c + endif +c +c==== +c 8. bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (*,*) '8. bilan ; codret = ', codret +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utinla.F b/src/tool/Utilitaire/utinla.F new file mode 100644 index 00000000..6a36f266 --- /dev/null +++ b/src/tool/Utilitaire/utinla.F @@ -0,0 +1,215 @@ + subroutine utinla ( nfconf, lfconf, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : INitialisation de la LAngue +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nfconf . e . ch<200 . nom du fichier de configuration . +c . lfconf . e . 1 . longueur du nom du fichier . +c . ulsort . s . 1 . numero d'unite logique de la liste standard. +c . langue . es . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINLA' ) +c +#include "motcle.h" +#include "nblang.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*(*) nfconf +c + integer lfconf +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif +c + integer loptio +c + character*8 motcle + character*200 noptio +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + if ( langue.le.0 .or. langue.gt.nblang ) then + langue = 1 + endif +c +c==== +c 1. les messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,20) = '(/,''Fichier de configuration :'')' + texte(1,4) = '(''Decodage du parametre : '',a8)' + texte(1,5) = '(''La langue par defaut est utilisee.'')' + texte(1,6) = '(''Erreur de decodage.'')' + texte(1,7) = '(''Aucune langue n''''est associe.'')' + texte(1,8) = '(''Plusieurs langues sont definies.'')' + texte(1,9) = '(''Il est absent du fichier.'')' + texte(1,10) = '(''Desole, cette langue est inconnue :'')' +c + texte(2,20) = '(/,''Configuration file :'')' + texte(2,4) = '(''Uncoding of parameter '',a8)' + texte(2,5) = '(''The default language is used.'')' + texte(2,6) = '(''Error during uncoding.'')' + texte(2,7) = '(''No language is connected to.'')' + texte(2,8) = '(''Several languages are defined.'')' + texte(2,9) = '(''It is missing.'')' + texte(2,10) = '(''Sorry, this language is unknown.'')' +c +c==== +c 2. decodage de la langue choisie +c==== +c +c 2.1. ==> recherche du mot-cle +c + motcle = mclang + call ugfino ( motcle, noptio, loptio, + > nfconf, lfconf, + > ulsort, langue, codret) +c +c 2.2. ==> recherche du type de langue +c + if ( codret.eq.0 ) then +c + if ( loptio.eq.6 ) then +c + if ( noptio(1:loptio).eq.'French' .or. + > noptio(1:loptio).eq.'french' .or. + > noptio(1:loptio).eq.'FRENCH' ) then +c + langue = 1 +c + else + codret = 10 +c + endif +c + elseif ( loptio.eq.8 ) then +c + if ( noptio(1:loptio).eq.'Francais' .or. + > noptio(1:loptio).eq.'francais' .or. + > noptio(1:loptio).eq.'FRANCAIS' ) then +c + langue = 1 +c + else + codret = 10 +c + endif +c + elseif ( loptio.eq.7 ) then +c + if ( noptio(1:loptio).eq.'Anglais' .or. + > noptio(1:loptio).eq.'anglais' .or. + > noptio(1:loptio).eq.'ANGLAIS' .or. + > noptio(1:loptio).eq.'English' .or. + > noptio(1:loptio).eq.'english' .or. + > noptio(1:loptio).eq.'ENGLISH' ) then +c + langue = 2 +c + else + codret = 10 +c + endif +c + endif +c + elseif ( codret.eq.1 ) then + codret = 9 +c + elseif ( codret.eq.2 ) then + codret = 8 +c + elseif ( codret.eq.3 ) then + codret = 7 +c + else + codret = 6 +c + endif +c +c 2.3. ==> messages d'erreur eventuels +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,2)) codret +#endif +c + if ( codret.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) + if ( lfconf.gt.0 .and. len(nfconf).gt.0 ) then + write (ulsort,*) nfconf(1:lfconf) + else + write (ulsort,*) + endif + write (ulsort,texte(langue,4)) motcle + write (ulsort,texte(langue,codret)) + if ( codret.eq.9 ) then + if ( loptio.gt.0 ) then + write (ulsort,*) noptio(1:loptio) + else + write (ulsort,*) + endif + endif + write (ulsort,texte(langue,5)) +#endif + codret = 0 +c + endif +c + end diff --git a/src/tool/Utilitaire/utinma.F b/src/tool/Utilitaire/utinma.F new file mode 100644 index 00000000..9e0c6449 --- /dev/null +++ b/src/tool/Utilitaire/utinma.F @@ -0,0 +1,377 @@ + subroutine utinma ( option, saux, + > sdim, mdim, degre, + > nbnoto, nbnop1, nbnop2, nbnoim, + > nbnois, nbnomp, + > nbnoei, nbmail, + > nbmapo, nbsegm, nbtria, nbquad, + > nbtetr, nbhexa, nbpyra, nbpent, + > nbelig, + > nbmane, nbmaae, nbmafe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c UTilitaire - INformation sur le MAillage +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option d'impressions . +c . . . . 0 : tout . +c . . . . 1 : le minimum . +c . saux . e . * . texte complementaire . +c . sdim . e . 1 . dimension de l'espace . +c . mdim . e . 1 . dimension du maillage . +c . degre . e . 1 . degre du maillage . +c . nbnoto . e . 1 . nombre total de noeuds du maillage . +c . nbnop1 . e . 1 . nombre de sommets du maillage (noeuds p1) . +c . nbnop2 . e . 1 . nombre de noeuds milieux d'aretes du . +c . . . . maillage (noeuds p2) . +c . nbnoim . e . 1 . nombre de noeuds internes aux mailles . +c . nbnois . e . 1 . nombre de noeuds isoles . +c . nbnomp . e . 1 . nombre de noeuds support de maille-point . +c . . . . uniquement . +c . nbnoei . e . 1 . nombre de noeuds d'elements ignores . +c . nbmail . e . 1 . nombre de mailles dans le maillage . +c . nbmapo . e . 1 . nombre de mailles-points dans le maillage . +c . nbsegm . e . 1 . nombre de segments dans le maillage . +c . nbtria . e . 1 . nombre de triangles dans le maillage . +c . nbtetr . e . 1 . nombre de tetraedres dans le maillage . +c . nbquad . e . 1 . nombre de quadrangles dans le maillage . +c . nbhexa . e . 1 . nombre d'hexaedres dans le maillage . +c . nbpent . e . 1 . nombre de pentaedres dans le maillage . +c . nbpyra . e . 1 . nombre de pyramides dans le maillage . +c . nbelig . e . 1 . nombre de mailles ignorees . +c . nbmane . e . 1 . nombre maximum de noeuds par element . +c . nbmaae . e . 1 . nombre maximum d'aretes par element . +c . nbmafe . e . 1 . nombre maximum de faces par element . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTINMA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer sdim, mdim, degre + integer nbnoto, nbnop1, nbnop2, nbnoim + integer nbnois, nbnomp + integer nbnoei + integer nbmail + integer nbmapo, nbsegm, nbtria, nbquad + integer nbtetr, nbhexa, nbpyra, nbpent + integer nbelig + integer nbmane, nbmaae, nbmafe +c + character*(*) saux +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 40 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Caracteristiques du maillage '',a,/)' + texte(1,5) = + > '(8x,''Degre :'',i11)' + texte(1,6) = + > '(8x,''Dimension de l''''espace :'',i11)' + texte(1,7) = + > '(8x,''Dimension du maillage :'',i11)' + texte(1,11) = + > '(8x,''Nombre de noeuds :'',i11)' + texte(1,12) = + > '(8x,''. dont noeuds isoles :'',i11)' + texte(1,13) = + > '(8x,''. dont noeuds maille-point uniquement :'',i11)' + texte(1,14) = + > '(8x,''. dont noeuds sommets :'',i11)' + texte(1,15) = + > '(8x,''. dont noeuds milieux :'',i11)' + texte(1,16) = + > '(8x,''. dont noeuds internes aux mailles :'',i11)' + texte(1,21) = + > '(8x,''Nombre de mailles :'',i11)' + texte(1,22) = + > '(8x,''. Mailles'',i2,''D'',34x,'':'',i11)' + texte(1,23) = + > '(8x,''. '',a14,30x,'':'',i11)' + texte(1,24) = + > '(10x,''. '',a14,28x,'':'',i11)' + texte(1,31) = + > '(8x,''Nombre maximum de faces par maille :'',i11)' + texte(1,32) = + > '(8x,''Nombre maximum d''''aretes par maille :'',i11)' + texte(1,33) = + > '(8x,''Nombre maximum de noeuds par maille :'',i11)' + texte(1,39) = + > '(8x,''. dont noeuds de mailles ignorees uniquement :'',i11)' + texte(1,40) = + > '(8x,''. Elimination de'',i11,1x,a14)' +c + texte(2,4) = + > '(5x,''Characteristics of the mesh '',a,/)' + texte(2,5) = + > '(8x,''Degree :'',i11)' + texte(2,6) = + > '(8x,''Dimension of the space :'',i11)' + texte(2,7) = + > '(8x,''Dimension of the mesh :'',i11)' + texte(2,11) = + > '(8x,''Number of nodes :'',i11)' + texte(2,12) = + > '(8x,''. included isolated nodes :'',i11)' + texte(2,13) = + > '(8x,''. included only mesh-point nodes :'',i11)' + texte(2,14) = + > '(8x,''. included nodes vertices :'',i11)' + texte(2,15) = + > '(8x,''. included nodes center of edges :'',i11)' + texte(2,16) = + > '(8x,''. included internal nodes :'',i11)' + texte(2,21) = + > '(8x,''Number of meshes :'',i11)' + texte(2,22) = + > '(8x,''.'',i2,''D meshes'',35x,'':'',i11)' + texte(2,23) = + > '(8x,''. '',a14,30x,'':'',i11)' + texte(2,24) = + > '(10x,''. '',a14,28x,'':'',i11)' + texte(2,31) = + > '(8x,''Maximum number of faces per mesh :'',i11)' + texte(2,32) = + > '(8x,''Maximum number of edges per mesh :'',i11)' + texte(2,33) = + > '(8x,''Maximum number of nodes per mesh :'',i11)' + texte(2,39) = + > '(8x,''. included only ignored meshes nodes :'',i11)' + texte(2,40) = + > '(8x,''. Elimination of'',i11,1x,a14)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. impression +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. impression ; codret', codret + call dmflsh(iaux) +#endif +c + if ( codret.eq.0 ) then +c + write(ulsort,texte(langue,4)) saux + write(ulsort,texte(langue,6)) sdim + write(ulsort,texte(langue,7)) mdim + write(ulsort,texte(langue,5)) degre +c +c 2.1. ==> Les noeuds +c + write(ulsort,texte(langue,11)) nbnoto +c + if ( option.eq.0 ) then +c + if ( nbnois.ne.0 ) then + write(ulsort,texte(langue,12)) nbnois + endif + if ( nbnomp.ne.0 ) then + write(ulsort,texte(langue,13)) nbnomp + endif + write(ulsort,texte(langue,14)) nbnop1 + if ( nbnop2.ne.0 ) then + write(ulsort,texte(langue,15)) nbnop2 + endif + if ( nbnoim.ne.0 ) then + write(ulsort,texte(langue,16)) nbnoim + endif + if ( nbnoei.ne.0 ) then + write(ulsort,texte(langue,39)) nbnoei + endif +c + endif +c +c 2.2. ==> Les mailles +c + write(ulsort,texte(langue,21)) nbmail +c +c 2.2.1. ==> 0D +c + if ( nbmapo.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,0), nbmapo + endif +c +c 2.2.2. ==> 1D +c + if ( nbsegm.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,1), nbsegm + endif +c +c 2.2.3. ==> 2D +c + iaux = nbtria + nbquad +c + if ( iaux.eq.nbtria .or. iaux.eq.nbquad ) then +c + if ( nbtria.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,2), nbtria + endif + if ( nbquad.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,4), nbquad + endif +c + else +c + write(ulsort,texte(langue,22)) 2, iaux + write(ulsort,texte(langue,24)) mess14(langue,3,2), nbtria + write(ulsort,texte(langue,24)) mess14(langue,3,4), nbquad +c + endif +c +c 2.2.4. ==> 3D +c + iaux = nbtetr + nbhexa + nbpyra + nbpent +c + if ( iaux.eq.nbtetr .or. iaux.eq.nbhexa .or. + > iaux.eq.nbpyra .or. iaux.eq.nbpent ) then +c + if ( nbtetr.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,3), nbtetr + endif + if ( nbhexa.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,6), nbhexa + endif + if ( nbpyra.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,5), nbpyra + endif + if ( nbpent.ne.0 ) then + write(ulsort,texte(langue,23)) mess14(langue,4,7), nbpent + endif +c + else +c + write(ulsort,texte(langue,22)) 3, iaux + if ( nbtetr.ne.0 ) then + write(ulsort,texte(langue,24)) mess14(langue,3,3), nbtetr + endif + if ( nbhexa.ne.0 ) then + write(ulsort,texte(langue,24)) mess14(langue,3,6), nbhexa + endif + if ( nbpyra.ne.0 ) then + write(ulsort,texte(langue,24)) mess14(langue,3,5), nbpyra + endif + if ( nbpent.ne.0 ) then + write(ulsort,texte(langue,24)) mess14(langue,3,7), nbpent + endif +c + endif +c +c 2.2.5. ==> Caracteristiques des mailles +c + if ( option.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( nbmafe.ge.0 ) then +#else + if ( nbmafe.gt.0 ) then +#endif + write(ulsort,texte(langue,31)) nbmafe + endif + write(ulsort,texte(langue,32)) nbmaae + write(ulsort,texte(langue,33)) nbmane +c + endif +c +c 2.2.6. ==> Mailles eliminees +c + if ( option.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( nbelig.ne.0 ) then + write(ulsort,texte(langue,40)) nbelig, mess14(langue,3,5) + endif +#endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utjomo.h b/src/tool/Utilitaire/utjomo.h new file mode 100644 index 00000000..9e1cf93b --- /dev/null +++ b/src/tool/Utilitaire/utjomo.h @@ -0,0 +1,87 @@ +c + character*9 nomjou(nblang,7) + character*9 nommoi(nblang,12) +c + integer lgnomj(nblang,7) + integer lgnomm(nblang,12) +c + nomjou(1,1) = 'lundi ' + lgnomj(1,1) = 5 + nomjou(1,2) = 'mardi ' + lgnomj(1,2) = 5 + nomjou(1,3) = 'mercredi ' + lgnomj(1,3) = 8 + nomjou(1,4) = 'jeudi ' + lgnomj(1,4) = 5 + nomjou(1,5) = 'vendredi ' + lgnomj(1,5) = 8 + nomjou(1,6) = 'samedi ' + lgnomj(1,6) = 6 + nomjou(1,7) = 'dimanche ' + lgnomj(1,7) = 8 +c + nomjou(2,1) = 'monday ' + lgnomj(2,1) = 6 + nomjou(2,2) = 'tuesday ' + lgnomj(2,2) = 7 + nomjou(2,3) = 'wednesday' + lgnomj(2,3) = 9 + nomjou(2,4) = 'thursday ' + lgnomj(2,4) = 8 + nomjou(2,5) = 'friday ' + lgnomj(2,5) = 6 + nomjou(2,6) = 'saturday ' + lgnomj(2,6) = 8 + nomjou(2,7) = 'sunday ' + lgnomj(2,7) = 6 +c + nommoi(1,1) = 'janvier ' + lgnomm(1,1) = 7 + nommoi(1,2) = 'fevrier ' + lgnomm(1,2) = 7 + nommoi(1,3) = 'mars ' + lgnomm(1,3) = 4 + nommoi(1,4) = 'avril ' + lgnomm(1,4) = 5 + nommoi(1,5) = 'mai ' + lgnomm(1,5) = 3 + nommoi(1,6) = 'juin ' + lgnomm(1,6) = 4 + nommoi(1,7) = 'juillet ' + lgnomm(1,7) = 7 + nommoi(1,8) = 'aout ' + lgnomm(1,8) = 4 + nommoi(1,9) = 'septembre' + lgnomm(1,9) = 9 + nommoi(1,10) = 'octobre ' + lgnomm(1,10) = 7 + nommoi(1,11) = 'novembre ' + lgnomm(1,11) = 8 + nommoi(1,12) = 'decembre ' + lgnomm(1,12) = 8 +c + nommoi(2,1) = 'january ' + lgnomm(2,1) = 7 + nommoi(2,2) = 'february ' + lgnomm(2,2) = 8 + nommoi(2,3) = 'march ' + lgnomm(2,3) = 5 + nommoi(2,4) = 'april ' + lgnomm(2,4) = 5 + nommoi(2,5) = 'may ' + lgnomm(2,5) = 3 + nommoi(2,6) = 'june ' + lgnomm(2,6) = 4 + nommoi(2,7) = 'july ' + lgnomm(2,7) = 4 + nommoi(2,8) = 'august ' + lgnomm(2,8) = 6 + nommoi(2,9) = 'september' + lgnomm(2,9) = 9 + nommoi(2,10) = 'october ' + lgnomm(2,10) = 7 + nommoi(2,11) = 'november ' + lgnomm(2,11) = 8 + nommoi(2,12) = 'december ' + lgnomm(2,12) = 8 +c diff --git a/src/tool/Utilitaire/utlgar.F b/src/tool/Utilitaire/utlgar.F new file mode 100644 index 00000000..5d96e76d --- /dev/null +++ b/src/tool/Utilitaire/utlgar.F @@ -0,0 +1,129 @@ + subroutine utlgar ( larete, coonoe, somare, + > dlong, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - LonGueur d'une ARete +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . larete . e . 1 . l'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . dlong . s . 1 . la longueur de l'arete . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLGAR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) +c + integer larete + integer somare(2,nbarto) +c + double precision dlong +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#ifdef _DEBUG_HOMARD_ + integer iaux +#endif + integer sa1a2, sa2a3 +c + double precision vn(3) +c + integer nbmess + parameter (nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. calcul de la longueur de l'arete +c==== +c + sa1a2 = somare(1,larete) + sa2a3 = somare(2,larete) +c + vn(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) +c + if ( sdim.eq.1 ) then +c + dlong = abs ( vn(1) ) +c + elseif ( sdim.eq.2 ) then +c + vn(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + dlong = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) ) +c + else +c + vn(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + vn(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) + dlong = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + endif +c + end diff --git a/src/tool/Utilitaire/utlgut.F b/src/tool/Utilitaire/utlgut.F new file mode 100644 index 00000000..7d672528 --- /dev/null +++ b/src/tool/Utilitaire/utlgut.F @@ -0,0 +1,151 @@ + subroutine utlgut ( lgchai, chaine, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - retourne la LonGueur UTile d'une chaine de caractere +c -- - - -- +c +c en gros, on elimine les blancs a droite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lgchai . s . 1 . longueur de la chaine obtenue . +c . chaine . e .char*(*). chaine de caractere a mesurer . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : impossible de trouver la longueur . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLGUT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgchai +c + character*(*) chaine +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Chaine a mesurer : '',a)' + texte(1,5) = '(''Longueur = '',i8)' + texte(1,6) = '(''La chaine est vide.'')' +c + texte(2,4) = '(''String : '',a)' + texte(2,5) = '(''Length = '',i8)' + texte(2,6) = '(''The string is empty.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) chaine +#endif +c +c==== +c 2. mesure +c==== +c + codret = 0 +c + jaux = len(chaine) + if ( jaux.eq.0 ) then + lgchai = -1 + codret = 1 + endif +c + if ( codret.eq.0 ) then +c + do 21 , iaux = jaux, 1, -1 + if ( chaine(iaux:iaux).ne.' ' ) then + lgchai = iaux + goto 22 + endif + 21 continue +c + lgchai = 0 +c + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) lgchai +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) chaine + write (ulsort,texte(langue,6)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utliob.h b/src/tool/Utilitaire/utliob.h new file mode 100644 index 00000000..5f6aad4d --- /dev/null +++ b/src/tool/Utilitaire/utliob.h @@ -0,0 +1,5 @@ +c +c osliob est le nom objet qui contient la liste de la configuration +c + character*8 osliob + parameter ( osliob = 'ListFich' ) diff --git a/src/tool/Utilitaire/utlo00.F b/src/tool/Utilitaire/utlo00.F new file mode 100644 index 00000000..6a940c78 --- /dev/null +++ b/src/tool/Utilitaire/utlo00.F @@ -0,0 +1,185 @@ + subroutine utlo00 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 00 +c -- - - -- +c ______________________________________________________________________ +c +c but : transformer les choix de type oui/non en entier 1/0 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : non, 1 : oui . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO00' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0 ) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.2 ) then +c + if ( noptio(1:loptio).eq.'NO' ) then + option = 0 +c + else + codre0 = 5 + endif +c + elseif ( loptio.eq.3 ) then +c + if ( noptio(1:loptio).eq.'NON' ) then + option = 0 +c + elseif ( noptio(1:loptio).eq.'OUI' .or. + > noptio(1:loptio).eq.'YES' ) then + option = 1 +c + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo00.h b/src/tool/Utilitaire/utlo00.h new file mode 100644 index 00000000..221a902f --- /dev/null +++ b/src/tool/Utilitaire/utlo00.h @@ -0,0 +1,22 @@ +c + texte(1,4) = '(1x,24(''=''),/)' + texte(1,5) = + > '(1x,''Option associee au mot-cle '',a8,'' illisible :'')' + texte(1,6) = '(1x,''On laisse l''''option par defaut :'',i4)' + texte(1,7) = '(1x,''On ne retrouve rien ?'')' + texte(1,8) = '(''Mot cle : '',a)' + texte(1,9) = '(''Option lue : '',a)' + texte(1,10) = '(''Option enregistree : '',i10)' + texte(1,11) = '(''Il est trop present dans la configuration.'')' + texte(1,12) = '(''On voudrait entre'',i5,'' et'',i5)' +c + texte(2,4) = '(1x,24(''=''),/)' + texte(2,5) = + > '(1x,''Option related to keyword '',a8,'' unreadable.'')' + texte(2,6) = '(1x,''Default option, '',i4,'', is kept.'')' + texte(2,7) = '(1x,''Nothing can be found ?'')' + texte(2,8) = '(''Keyword : '',a)' + texte(2,9) = '(''Read option : '',a)' + texte(2,10) = '(''Final option : '',i10)' + texte(2,11) = '(''Too many times in the configuration.'')' + texte(2,12) = '(''Asked: between'',i5,'' and'',i5)' diff --git a/src/tool/Utilitaire/utlo01.F b/src/tool/Utilitaire/utlo01.F new file mode 100644 index 00000000..5244c5c3 --- /dev/null +++ b/src/tool/Utilitaire/utlo01.F @@ -0,0 +1,236 @@ + subroutine utlo01 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 01 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au code de calcul associe +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . reperage du code de calcul retenu . +c . . . . 1 : HOMARD . +c . . . . 6 : MED (defaut) . +c . . . . 16 : ATHENA (format MED) . +c . . . . 26 : SATURNE_2D (format MED) . +c . . . . 36 : SATURNE (format MED) . +c . . . . 46 : NEPTUNE_2D (format MED) . +c . . . . 56 : NEPTUNE (format MED) . +c . . . . 66 : CARMEL_2D (format MED) . +c . . . . 76 : CARMEL (format MED) . +c . . . . 106 : NON-CONFORME (format MED) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, MED +c + option = 6 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.3 ) then +c + if ( noptio(1:loptio).eq.'MED' ) then + option = 6 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.6 ) then +c + if ( noptio(1:loptio).eq.'HOMARD' ) then + option = 1 + elseif ( noptio(1:loptio).eq.'ATHENA' ) then + option = 16 + elseif ( noptio(1:loptio).eq.'CARMEL' ) then + option = 76 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.7 ) then +c + if ( noptio(1:loptio).eq.'SATURNE' ) then + option = 36 + elseif ( noptio(1:loptio).eq.'NEPTUNE' ) then + option = 56 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.9 ) then +c + if ( noptio(1:loptio).eq.'CARMEL_2D' ) then + option = 66 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.10 ) then +c + if ( noptio(1:loptio).eq.'SATURNE_2D' .or. + > noptio(1:loptio).eq.'SATURNE-2D' ) then + option = 26 + elseif ( noptio(1:loptio).eq.'NEPTUNE_2D' .or. + > noptio(1:loptio).eq.'NEPTUNE-2D' ) then + option = 46 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.12 ) then +c + if ( noptio(1:loptio).eq.'NON_CONFORME' .or. + > noptio(1:loptio).eq.'NON-CONFORME' ) then + option = 106 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo01.h b/src/tool/Utilitaire/utlo01.h new file mode 100644 index 00000000..5f4c594e --- /dev/null +++ b/src/tool/Utilitaire/utlo01.h @@ -0,0 +1,27 @@ +c +c 2.3. ==> messages d'erreur eventuels +c + if ( codre0.eq.3 ) then + write (ulsort,texte(langue,5)) motcle + write (ulsort,texte(langue,11)) + write (ulsort,texte(langue,12)) nbrmin, nbrmax + write (ulsort,texte(langue,1)) 'Sortie', nompro + codret = 6 +c + elseif ( codre0.eq.6 ) then + write (ulsort,texte(langue,5)) motcle + write (ulsort,texte(langue,7)) + write (ulsort,texte(langue,1)) 'Sortie', nompro + codret = 6 +c + elseif ( codre0.eq.5 ) then + write (ulsort,texte(langue,1)) 'Entree', nompro + write (ulsort,texte(langue,5)) motcle + write (ulsort,*) noptio(1:loptio) + write (ulsort,texte(langue,6)) option +#ifdef _DEBUG_HOMARD_ + elseif ( codre0.eq.0 ) then + write (ulsort,texte(langue,10)) option +#endif +c + endif diff --git a/src/tool/Utilitaire/utlo02.F b/src/tool/Utilitaire/utlo02.F new file mode 100644 index 00000000..89cdb086 --- /dev/null +++ b/src/tool/Utilitaire/utlo02.F @@ -0,0 +1,291 @@ + subroutine utlo02 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 02 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au type de conformite +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut : conforme +c + option = 0 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.8 ) then +c + if ( noptio(1:loptio).eq.'CONFORME' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.9 ) then +c + if ( noptio(1:loptio).eq.'CONFORMAL' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.12 ) then +c +c 123456789012 + if ( noptio(1:loptio).eq.'NON_CONFORME' .or. + > noptio(1:loptio).eq.'NON-CONFORME' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.13 ) then +c +c 1234567890123 + if ( noptio(1:loptio).eq.'HANGING_NODES' .or. + > noptio(1:loptio).eq.'HANGING-NODES' ) then + option = 1 +c + else + codre0 = 5 + endif +c + elseif ( loptio.eq.15 ) then +c + if ( noptio(1:loptio).eq.'CONFORME_BOITES' .or. + > noptio(1:loptio).eq.'CONFORME-BOITES' ) then + option = -1 + elseif ( noptio(1:loptio).eq.'CONFORMAL_BOXES' .or. + > noptio(1:loptio).eq.'CONFORMAL-BOXES' ) then + option = -1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.20 ) then +c +c 12345678901234567890 + if ( noptio(1:loptio).eq.'NON_CONFORME_1_ARETE' .or. + > noptio(1:loptio).eq.'NON-CONFORME_1_ARETE' .or. + > noptio(1:loptio).eq.'NON_CONFORME-1_ARETE' .or. + > noptio(1:loptio).eq.'NON-CONFORME-1_ARETE' .or. + > noptio(1:loptio).eq.'NON_CONFORME_1-ARETE' .or. + > noptio(1:loptio).eq.'NON-CONFORME_1-ARETE' .or. + > noptio(1:loptio).eq.'NON_CONFORME-1-ARETE' .or. + > noptio(1:loptio).eq.'NON-CONFORME-1-ARETE' ) then + option = -2 +c + elseif ( noptio(1:loptio).eq.'HANGING_NODES_1_EDGE' .or. + > noptio(1:loptio).eq.'HANGING-NODES_1_EDGE' .or. + > noptio(1:loptio).eq.'HANGING_NODES-1_EDGE' .or. + > noptio(1:loptio).eq.'HANGING-NODES-1_EDGE' .or. + > noptio(1:loptio).eq.'HANGING_NODES_1-EDGE' .or. + > noptio(1:loptio).eq.'HANGING-NODES_1-EDGE' .or. + > noptio(1:loptio).eq.'HANGING_NODES-1-EDGE' .or. + > noptio(1:loptio).eq.'HANGING-NODES-1-EDGE' ) then + option = -2 +c + elseif ( noptio(1:loptio).eq.'NON_CONFORME_1_NOEUD' .or. + > noptio(1:loptio).eq.'NON-CONFORME_1_NOEUD' .or. + > noptio(1:loptio).eq.'NON_CONFORME-1_NOEUD' .or. + > noptio(1:loptio).eq.'NON-CONFORME-1_NOEUD' .or. + > noptio(1:loptio).eq.'NON_CONFORME_1-NOEUD' .or. + > noptio(1:loptio).eq.'NON-CONFORME_1-NOEUD' .or. + > noptio(1:loptio).eq.'NON_CONFORME-1-NOEUD' .or. + > noptio(1:loptio).eq.'NON-CONFORME-1-NOEUD' ) then + option = 2 +c + elseif ( noptio(1:loptio).eq.'HANGING_NODES_1_NODE' .or. + > noptio(1:loptio).eq.'HANGING-NODES_1_NODE' .or. + > noptio(1:loptio).eq.'HANGING_NODES-1_NODE' .or. + > noptio(1:loptio).eq.'HANGING-NODES-1_NODE' .or. + > noptio(1:loptio).eq.'HANGING_NODES_1-NODE' .or. + > noptio(1:loptio).eq.'HANGING-NODES_1-NODE' .or. + > noptio(1:loptio).eq.'HANGING_NODES-1-NODE' .or. + > noptio(1:loptio).eq.'HANGING-NODES-1-NODE' ) then + option = 2 +c + else + codre0 = 5 + endif +c + elseif ( loptio.eq.23 ) then +c + if ( noptio(1:loptio).eq.'NON_CONFORME_INDICATEUR' .or. + > noptio(1:loptio).eq.'NON-CONFORME_INDICATEUR' .or. + > noptio(1:loptio).eq.'NON_CONFORME-INDICATEUR' .or. + > noptio(1:loptio).eq.'NON-CONFORME-INDICATEUR' ) then + option = 3 +c + elseif ( noptio(1:loptio).eq.'HANGING_NODES_INDICATOR' .or. + > noptio(1:loptio).eq.'HANGING-NODES_INDICATOR' .or. + > noptio(1:loptio).eq.'HANGING_NODES-INDICATOR' .or. + > noptio(1:loptio).eq.'HANGING-NODES-INDICATOR' ) then + option = 3 +c + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo02.h b/src/tool/Utilitaire/utlo02.h new file mode 100644 index 00000000..ab91d527 --- /dev/null +++ b/src/tool/Utilitaire/utlo02.h @@ -0,0 +1,3 @@ +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) motcle +#endif diff --git a/src/tool/Utilitaire/utlo03.F b/src/tool/Utilitaire/utlo03.F new file mode 100644 index 00000000..e50a5e5d --- /dev/null +++ b/src/tool/Utilitaire/utlo03.F @@ -0,0 +1,237 @@ + subroutine utlo03 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 03 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au type de raffinement ou deraffinement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . A. raffinement : . +c . . . . -1 : uniforme . +c . . . . 0 : pas de raffinement . +c . . . . 1 : libre (defaut) . +c . . . . 2 : libre homogene en type d'element . +c . . . . B. deraffinement : . +c . . . . -1 : uniforme . +c . . . . 0 : pas de deraffinement . +c . . . . 1 : libre (defaut) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.2 ) then +c + if ( noptio(1:loptio).eq.'NO' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.3 ) then +c + if ( noptio(1:loptio).eq.'NON' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.4 ) then +c + if ( noptio(1:loptio).eq.'FREE' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.5 ) then +c + if ( noptio(1:loptio).eq.'LIBRE' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.7 ) then +c + if ( noptio(1:loptio).eq.'UNIFORM' ) then + option = -1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.8 ) then +c + if ( noptio(1:loptio).eq.'UNIFORME' ) then + option = -1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.14 ) then +c + if ( noptio(1:loptio).eq.'LIBRE_HOMOGENE' .or. + > noptio(1:loptio).eq.'LIBRE-HOMOGENE' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.16 ) then +c + if ( noptio(1:loptio).eq.'FREE_HOMOGENEOUS' .or. + > noptio(1:loptio).eq.'FREE-HOMOGENEOUS' ) then + option = 2 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + elseif ( codre0.ne.3 ) then + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo03.h b/src/tool/Utilitaire/utlo03.h new file mode 100644 index 00000000..26f4d14e --- /dev/null +++ b/src/tool/Utilitaire/utlo03.h @@ -0,0 +1,3 @@ +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) noptio(1:loptio) +#endif diff --git a/src/tool/Utilitaire/utlo04.F b/src/tool/Utilitaire/utlo04.F new file mode 100644 index 00000000..1201476e --- /dev/null +++ b/src/tool/Utilitaire/utlo04.F @@ -0,0 +1,254 @@ + subroutine utlo04 ( motcle, option, tyconf, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 04 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif aux contraintes sur le raffinement +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . c'est le produit de : . +c . . . . 1 : aucune (defaut) . +c . . . . 2 : decalage de deux elements avant . +c . . . . un changement de niveau (2D) . +c . . . . 3 : bande de raffinement interdite (3D) . +c . . . . 5 : pas de mailles decoupees sans leurs . +c . . . voisines de dimension superieure . +c . . . . 7 : pas de bord decoupe seul . +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option + integer tyconf +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, aucune contrainte +c + option = 1 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.3 ) then +c + if ( noptio(1:loptio).eq.'NON' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.6 ) then +c + if ( noptio(1:loptio).eq.'AUCUNE' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.9 ) then +c +c 123456789012345678901234 + if ( noptio(1:loptio).eq. + > 'VOISINAGE' ) then + option = 5 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.12 ) then +c + if ( noptio(1:loptio).eq.'PAS_DE_BANDE' ) then + option = 3 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.19 ) then +c +c 1234567890123456789 + if ( noptio(1:loptio).eq.'DECALAGE_2_ELEMENTS' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.24 ) then +c +c 123456789012345678901234 + if ( noptio(1:loptio).eq. + > 'PAS_DE_BORD_DECOUPE_SEUL' ) then + option = 7 + option = 5 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.32 ) then +c +c 12345678901234567890123456789012 + if ( noptio(1:loptio).eq. + > 'PAS_DE_BANDE&DECALAGE_2_ELEMENTS' ) then + option = 6 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo05.F b/src/tool/Utilitaire/utlo05.F new file mode 100644 index 00000000..c78e538c --- /dev/null +++ b/src/tool/Utilitaire/utlo05.F @@ -0,0 +1,240 @@ + subroutine utlo05 ( motcle, option, modhom, maextr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 05 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif aux coordonnees pour les maillages +c extrudes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : valeur imposee . +c . . . . 1 : coordonnees initiales (defaut) . +c . . . . 2 : moyenne arithmetique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 3 : moyenne geometrique des mini/maxi en . +c . . . . (x,y) des mailles . +c . . . . 4 : ecart initial, divise par 2**nivsup . +c . modhom . e . 1 . mode de fonctionnement de homard . +c . . . . 1 : homard pur . +c . . . . 2 : information . +c . . . . 3 : modification de maillage sans adaptati. +c . . . . 4 : interpolation de la solution . +c . maextr . e . 1 . maillage extrude . +c . . . . 0 : non (defaut) . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option + integer modhom, maextr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, rien si le maillage n'est pas extrude +c coordonnees initiales sinon +c + if ( maextr.eq.0 .or. modhom.ne.1 ) then + option = 0 + else + option = 1 + endif +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.6 ) then +c + if ( noptio(1:loptio).eq.'IMPOSE' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.7 ) then +c + if ( noptio(1:loptio).eq.'INITIAL' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.14 ) then +c +c 12345678901234 + if ( noptio(1:loptio).eq.'INITIAL_NIVSUP' ) then + option = 5 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.19 ) then +c +c 1234567890123456789 + if ( noptio(1:loptio).eq.'MOYENNE_GEOMETRIQUE' ) then + option = 4 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.20 ) then +c +c 12345678901234567890 + if ( noptio(1:loptio).eq.'MOYENNE_ARITHMETIQUE' ) then + option = 3 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c + if ( maextr.eq.0 .and. modhom.eq.1 ) then + if ( option.ne.0 ) then + codret = 1 + endif + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo06.F b/src/tool/Utilitaire/utlo06.F new file mode 100644 index 00000000..09dc314f --- /dev/null +++ b/src/tool/Utilitaire/utlo06.F @@ -0,0 +1,223 @@ + subroutine utlo06 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 06 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif a l'usage des composantes de +c l'indicateur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : valeur relative . +c . . . . 1 : valeur absolue (defaut) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, valeur absolue +c + option = 0 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.2 ) then +c + if ( noptio(1:loptio).eq.'L2' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.6 ) then +c +c 123456 + if ( noptio(1:loptio).eq.'ABSOLU' ) then + option = 0 + elseif ( noptio(1:loptio).eq.'INFINI' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.7 ) then +c +c 1234567 + if ( noptio(1:loptio).eq.'L2_NORM' ) then + option = 0 + elseif ( noptio(1:loptio).eq.'RELATIF' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.8 ) then +c +c 12345678 + if ( noptio(1:loptio).eq.'ABSOLUTE' ) then + option = 0 + elseif ( noptio(1:loptio).eq.'NORME_L2' ) then + option = 0 + elseif ( noptio(1:loptio).eq.'INFINITE' ) then + option = 1 + elseif ( noptio(1:loptio).eq.'RELATIVE' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.13 ) then +c +c 1234567890123 + if ( noptio(1:loptio).eq.'NORME_INFINIE' ) then + option = 1 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo07.F b/src/tool/Utilitaire/utlo07.F new file mode 100644 index 00000000..fbdf340d --- /dev/null +++ b/src/tool/Utilitaire/utlo07.F @@ -0,0 +1,185 @@ + subroutine utlo07 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 07 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au mode de fonctionnement de +c l'indicateur d'erreur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : par maille (defaut) . +c . . . . 1 : par saut entre mailles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO07' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, indicateur pris par maille +c + option = 0 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.4 ) then +c 1234 + if ( noptio(1:loptio).eq.'SAUT' ) then + option = 1 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.6 ) then +c 123456 + if ( noptio(1:loptio).eq.'MAILLE' ) then + option = 0 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo08.F b/src/tool/Utilitaire/utlo08.F new file mode 100644 index 00000000..e7cd477d --- /dev/null +++ b/src/tool/Utilitaire/utlo08.F @@ -0,0 +1,254 @@ + subroutine utlo08 ( motcle, typemc, ival, dval, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 08 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder les informations temporelles pour l'indicateur d'erreur +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . typemc . e . 1 . 1 CCNumPTI : entier . +c . . . . 2 CCNumOrI : entier . +c . . . . 3 CCInstaI : reel . +c . ival . s . 1 . valeur entiere decodee . +c . dval . s . 1 . valeur reelle decodee . +c . option . s . 1 . type d'option sur le temps : . +c . . . . 0, si aucune valeur n'a ete fournie . +c . . . . 1, si une valeur est fournie . +c . . . . 2, si on prend le dernier instant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO08' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "indefi.h" +#include "indefr.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer typemc, ival, option + double precision dval +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> defaut +c + option = -1 + ival = iindef + dval = rindef +c +c==== +c 2. option +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c 2.2.1. ==> un texte eventuel, sauf pour le numero d'ordre +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + option = 1 +c + if ( loptio.eq.4 ) then +c 1234 + if ( noptio(1:loptio).eq.'LAST' ) then + if ( typemc.ne.2 ) then + option = 2 + endif + endif +c + elseif ( loptio.eq.7 ) then +c 1234567 + if ( noptio(1:loptio).eq.'DERNIER' ) then + if ( typemc.ne.2 ) then + option = 2 + endif + endif + endif +c + elseif ( codre0.eq.2 ) then +c + option = 0 + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +c 2.2.2. ==> des valeurs +c + if ( codre0.eq.0 ) then +c + if ( option.eq.1 ) then +c +c 2.3.2.1 ==> des valeurs entieres +c + if ( typemc.le.2 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCEN', nompro +#endif + call utmcen ( motcle, ival, 1, + > ulsort, langue, codre0 ) +c +c +c 2.3.2.2 ==> des valeurs reelles +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCRE', nompro +#endif + call utmcre ( motcle, dval, + > ulsort, langue, codre0 ) +c + endif +c + endif +c + endif +c +#include "utlo01.h" +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +c + write (ulsort,*) 'motcle =', motcle + write (ulsort,*) 'option =', option + if ( typemc.le.2 ) then + if ( option.eq.1 ) then + texte(1,10) = '(''==> valeurs i ='',i12)' + texte(2,10) = '(''==> values i ='',i12)' + write (ulsort,texte(langue,10)) ival + endif + else + if ( option.eq.1 ) then + texte(1,10) = '(''==> valeurs d ='',g18.5)' + texte(2,10) = '(''==> values d ='',g18.5)' + write (ulsort,texte(langue,10)) dval + endif + endif +c + endif +#endif +c +c==== +c 3. la fin +c==== +c +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo09.F b/src/tool/Utilitaire/utlo09.F new file mode 100644 index 00000000..516cc7c5 --- /dev/null +++ b/src/tool/Utilitaire/utlo09.F @@ -0,0 +1,227 @@ + subroutine utlo09 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 09 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au mode de fonctionnement de +c l'ecriture des fichiers au format HOMARD +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . produit de : . +c . . . . 2 : maillage n . +c . . . . 3 : maillage n+1 . +c . . . . >0 : on ecrit les frontieres . +c . . . . <0 : on n'ecrit pas les frontieres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO09' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, ecriture apres adaptation, sans les frontieres +c + option = -3 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.1 ) then +c 1 + if ( noptio(1:loptio).eq.'N' ) then + option = 2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.3 ) then +c 123 + if ( noptio(1:loptio).eq.'NP1' ) then + option = 3 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.4 ) then +c 1234 + if ( noptio(1:loptio).eq.'TOUT' ) then + option = 6 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.16 ) then +c 1234567890123456 + if ( noptio(1:loptio).eq.'N_SANS_FRONTIERE' ) then + option = -2 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.18 ) then +c 123456789012345678 + if ( noptio(1:loptio).eq.'NP1_SANS_FRONTIERE' ) then + option = -3 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.19 ) then +c 1234567890123456789 + if ( noptio(1:loptio).eq.'TOUT_SANS_FRONTIERE' ) then + option = -6 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then +c + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo10.F b/src/tool/Utilitaire/utlo10.F new file mode 100644 index 00000000..55c1c3a3 --- /dev/null +++ b/src/tool/Utilitaire/utlo10.F @@ -0,0 +1,156 @@ + subroutine utlo10 ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 10 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif aux informations complementaires +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . option du mot-cle . +c . . . . 1 :oui, 2 : non . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO10' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> bilan +c + if ( codre0.eq.0 ) then + option = 1 +c + elseif ( codre0.eq.2 ) then + codre0 = 0 + option = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utlo11.F b/src/tool/Utilitaire/utlo11.F new file mode 100644 index 00000000..e722eab3 --- /dev/null +++ b/src/tool/Utilitaire/utlo11.F @@ -0,0 +1,189 @@ + subroutine utlo11 ( motcle, option, typcca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - 11 +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif pour les maillages extrudes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : le maillage n'est pas extrude (defaut) . +c . . . . 1 : extrusion en X . +c . . . . 2 : extrusion en Y . +c . . . . 3 : extrusion en Z . +c . typcca . e . 1 . type du code de calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLO11' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option + integer typcca +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c 1.3. ==> par defaut, le maillage est extrude en Z si c'est du SATURNE +c ou du NEPTUNE 2D +c + if ( typcca.eq.26 .or. typcca.eq.46 ) then + option = 3 + else + option = 0 + endif +c +c==== +c 2. options textuelles +c==== +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.1 ) then +c + if ( noptio(1:loptio).eq.'X' ) then + option = 1 + elseif ( noptio(1:loptio).eq.'Y' ) then + option = 2 + elseif ( noptio(1:loptio).eq.'Z' ) then + option = 3 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utloea.F b/src/tool/Utilitaire/utloea.F new file mode 100644 index 00000000..234b2a1e --- /dev/null +++ b/src/tool/Utilitaire/utloea.F @@ -0,0 +1,184 @@ + subroutine utloea ( motcle, option, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Lectures des Options - ea +c -- - - -- +c ______________________________________________________________________ +c +c but : decoder le texte relatif au type d'elements autorises +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . option . s . 1 . 0 : s'il existe des elements incompatibles . +c . . . . avec le type d'usage de HOMARD, on . +c . . . . bloque (defaut) . +c . . . . 1 : s'il existe des elements incompatibles . +c . . . . avec le type d'usage de HOMARD, on . +c . . . . les ignore . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : impossible de decoder les options . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTLOEA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nbrmin, nbrmax +c + character*200 noptio +c + integer nbmess + parameter ( nbmess = 15 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "utlo00.h" +#include "utlo02.h" +c + nbrmin = 0 + nbrmax = 1 +c +c==== +c 2. options textuelles +c==== +c +c 2.1. ==> recherche du texte associe au mot-cle +c code de retour de utfino : +c 0 : pas de probleme +c 1 : la configuration est perdue +c 2 : pas de nom dans la base +c remarque : on recupere le texte en majuscule +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN2', nompro +#endif + call utfin2 ( motcle, iaux, noptio, loptio, + > nbrmin, nbrmax, + > ulsort, langue, codre0) +c +c 2.2. ==> decodage de l'option +c + if ( codre0.eq.0 ) then +c +#include "utlo03.h" +c + if ( loptio.eq.6 ) then +c + if ( noptio(1:loptio).eq.'HOMARD' ) then + option = 0 + else + codre0 = 5 + endif +c + elseif ( loptio.eq.11 ) then +c + if ( noptio(1:loptio).eq.'IGNORE_PYRA' ) then + option = 1 + else + codre0 = 5 + endif +c + else + codre0 = 5 + endif +c + elseif ( codre0.eq.2 ) then + codre0 = 0 +c + else + codre0 = 6 +c + endif +c +#include "utlo01.h" +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcc0.F b/src/tool/Utilitaire/utmcc0.F new file mode 100644 index 00000000..08240340 --- /dev/null +++ b/src/tool/Utilitaire/utmcc0.F @@ -0,0 +1,620 @@ + subroutine utmcc0 ( nbcham, + > caetal, cactal, cartal, + > nbfich, + > nomref, lgnofi, poinno, + > nomufi, nomstr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - liste des Champs a mettre a jour - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcham . e . 1 . nombre de champs a mettre a jour . +c . cactal . s .8*nbseal. caracteristiques caracteres de chaque . +c . . . . tableau a lire . +c . . . . 1,2,3,4. nom du champ associe . +c . caetal . s . 12 * . caracteristiques entieres de chaque . +c . . . nbseal . tableau a lire . +c . . . . 1. type de support au sens MED . +c . . . . -1, si on prend tous les supports . +c . . . . 2. 1, si numero du pas de temps, 0 sinon . +c . . . . 3. numero du pas de temps . +c . . . . 4. 1, si numero d'ordre, 0 sinon . +c . . . . 5. numero d'ordre . +c . . . . 6. 1, si instant, 0 sinon . +c . . . . 7. 1, si aux noeuds par elements, 0 sinon, . +c . . . . -1, si non precise . +c . . . . 8. numero du champ noeuds/element associe . +c . . . . 9. numero du champ associe dans HOMARD . +c . . . . 10. type d'interpolation . +c . . . . 0, si automatique . +c . . . . 1 si degre 1, 2 si degre 2, 3 si iso-P2 . +c . . . . 11. sans objet a ce stade du traitement . +c . . . . 12. type de champ edfl64/edin64 . +c . cartal . s . nbseal . caracteristiques reelles de chaque . +c . . . . tableau a lire . +c . . . . 1. instant . +c . nomref . e . nbfich . nom de reference des fichiers . +c . lgnofi . e . nbfich . longueurs des noms des fichiers . +c . poinno . e .0:nbfich. pointeur dans le tableau des noms . +c . nomufi . e . lgtanf . noms des fichiers . +c . nomstr . e . nbfich . nom des structures . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCC0' ) +c +#include "nblang.h" +#include "motcle.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbcham + integer caetal(12,nbcham) + integer nbfich + integer lgnofi(nbfich), poinno(0:nbfich) +c + double precision cartal(*) +c + character*8 cactal(*) + character*8 nomref(nbfich), nomufi(*), nomstr(nbfich) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nrcham, nrfich + integer numero +c + double precision daux +c + character*8 motcle + character*200 sau200 +c + logical chnom, chnum, chpdt, chins, chcas, chncn +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de champs a mettre a jour :'',i8)' + texte(1,5) = '(/,''Numero du champ en cours de recherche :'',i8)' + texte(1,6) = '('' .. ==> Nom du champ : '',a)' + texte(1,7) = '(''Le nom est introuvable.'')' + texte(1,8) = '('' .. ==> Numero d''''ordre :'',i8)' + texte(1,9) = '(''Le numero d''''ordre est introuvable.'')' + texte(1,10) = '('' .. ==> Numero du pas de temps :'',i8)' + texte(1,11) = '(''Le numero de pas de temps est introuvable.'')' + texte(1,12) = '('' .. ==> Instant :'',g12.5)' + texte(1,13) = '(''L''''instant est introuvable.'')' + texte(1,14) = '('' .. ==> Caracteristique du support : '',a)' + texte(1,15) = + > '(''La caracteristique du support est inconnue : '',a)' + texte(1,16) = '('' .. ==> Numero du champ associe :'',i8)' +c + texte(2,4) = '(''Number of files to update :'',i8)' + texte(2,5) = '(/,''Search for field #'',i8)' + texte(2,6) = '('' .. ==> Name of the field : '',a)' + texte(2,7) = '(''Name of the field cannot be found.'')' + texte(2,8) = '('' .. ==> Rank number :'',i8)' + texte(2,9) = '(''Rank number cannot be found.'')' + texte(2,10) = '('' .. ==> Time step # :'',i8)' + texte(2,11) = '(''Time step # cannot be found.'')' + texte(2,12) = '('' .. ==> Instant :'',g12.5)' + texte(2,13) = '(''Instant cannot be found.'')' + texte(2,14) = '('' .. ==> Characteristic of support : '',a)' + texte(2,15) = + > '(''The characteristic of support is unknown : '',a)' + texte(2,16) = '(''. Number for the associated field :'',i8)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbcham +#endif +c + codret = 0 +c +c==== +c 2. on parcourt toutes les posssibilites de champs +c==== +c + do 20 , nrcham = 1 , nbcham +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nrcham +#endif + chnom = .false. + chnum = .false. + chpdt = .false. + chins = .false. + chcas = .false. + chncn = .false. +c + caetal(2,nrcham) = 0 + caetal(4,nrcham) = 0 + caetal(6,nrcham) = 0 + caetal(9,nrcham) = 0 + caetal(10,nrcham) = 0 +c + do 200 , nrfich = 1 , nbfich +c +c 2.1. ==> si c'est un des mots-cles possibles, on verifie que c'est +c pour le bon champ +c + if ( codret.eq.0 ) then +c + motcle = nomref(nrfich) +cgn write (ulsort,*) '.. motcle = ',motcle +c + if ( motcle.eq.mcchno .or. + > motcle.eq.mcchcs .or. + > motcle.eq.mcchpt .or. + > motcle.eq.mcchnu .or. + > motcle.eq.mcchin .or. + > motcle.eq.mcchti .or. + > motcle.eq.mcchnc ) then +c +cgn write (ulsort,*) '.. nomstr(nrfich) = ',nomstr(nrfich) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro +#endif + call utchen ( nomstr(nrfich), numero, + > ulsort, langue, codret ) +c +cgn write (ulsort,*) '.. motcle = ',motcle,' ',nrcham,' ',numero + if ( nrcham.eq.numero ) then +c + if ( motcle.eq.mcchno ) then + goto 22 + elseif ( motcle.eq.mcchcs ) then + goto 23 + elseif ( motcle.eq.mcchpt .or. motcle.eq.mcchnu ) then + goto 24 + elseif ( motcle.eq.mcchin ) then + goto 25 + elseif ( motcle.eq.mcchti ) then + goto 26 + else + goto 27 + endif + else + goto 200 + endif +c + else +c + goto 200 +c + endif +c +c + endif +c +c 2.2. ==> recherche du nom du champ +c + 22 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 22 continue ; nrcham', nrcham +c + jaux = 8*(nrcham-1) + do 221 , iaux = jaux+1 , jaux+8 + cactal(iaux) = blan08 + 221 continue + kaux = poinno(nrfich-1) + 1 + do 222 , iaux = kaux, poinno(nrfich) + jaux = jaux + 1 + cactal(jaux) = nomufi(iaux) + 222 continue + chnom = .true. +#ifdef _DEBUG_HOMARD_ + jaux = poinno(nrfich-1) + 1 + kaux = lgnofi(nrfich) + call uts8ch ( nomufi(jaux), kaux, sau200, + > ulsort, langue, codret ) + write (ulsort,texte(langue,6)) sau200(1:kaux) +#endif +c + goto 28 +c + endif +c +c 2.3. ==> recherche de la caracteristique du support du champ +c par defaut, il est standard +c + 23 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 23 continue ; nrcham', nrcham +c + caetal(7,nrcham) = 0 +c + jaux = 1 + kaux = poinno(nrfich-1) + 1 + do 231 , iaux = kaux, poinno(nrfich) + sau200(jaux:jaux+7) = nomufi(iaux) + jaux = jaux + 8 + 231 continue +c + do 232 , iaux = jaux , 200 + sau200(iaux:iaux) = ' ' + 232 continue +c + call utlgut ( iaux, sau200, + > ulsort, langue, codret ) +c + jaux = 1 +c + if ( iaux.eq.8 ) then +c 12345678 + if ( sau200(1:iaux).eq.'standard' ) then + caetal(7,nrcham) = 1 + jaux = 0 + endif +c + elseif ( iaux.eq.22 ) then +c 1234567890123456789012 + if ( sau200(1:iaux).eq.'aux_noeuds_par_element' ) then + caetal(7,nrcham) = 1 + jaux = 0 + endif +c + endif + if ( jaux.ne.0 ) then + write (ulsort,texte(langue,15)) sau200(1:iaux) + codret = 1 +#ifdef _DEBUG_HOMARD_ + else + write (ulsort,texte(langue,14)) sau200(1:iaux) +#endif + endif +c + chcas = .true. +c + goto 28 +c + endif +c +c 2.4. ==> recherche de numero d'ordre du champ +c + 24 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 24 continue ; nrcham', nrcham +c + jaux = poinno(nrfich-1) + 1 + kaux = lgnofi(nrfich) + call uts8ch ( nomufi(jaux), kaux, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro +#endif + call utchen ( sau200, iaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( motcle.eq.mcchpt ) then + caetal(2,nrcham) = 1 + caetal(3,nrcham) = iaux + chpdt = .true. +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) iaux +#endif + else + caetal(4,nrcham) = 1 + caetal(5,nrcham) = iaux + chnum = .true. +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) iaux +#endif + endif +c + goto 28 +c + endif +c +c 2.5. ==> recherche de l'instant du champ +c + 25 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 25 continue ; nrcham', nrcham +c + jaux = poinno(nrfich-1) + 1 + kaux = lgnofi(nrfich) + call uts8ch ( nomufi(jaux), kaux, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHRE', nompro +#endif + call utchre ( sau200, daux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + caetal(6,nrcham) = 1 + cartal(nrcham) = daux + chins = .true. +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) daux +#endif +c + goto 28 +c + endif +c +c 2.6. ==> recherche du type d'interpolation +c + 26 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 26 continue ; nrcham', nrcham +c + jaux = poinno(nrfich-1) + 1 + kaux = lgnofi(nrfich) + call uts8ch ( nomufi(jaux), kaux, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro +#endif + call utchen ( sau200, iaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + caetal(10,nrcham) = iaux +c + goto 28 +c + endif +c +c 2.7. ==> recherche du numero du champ aux noeuds par elements associe +c au champ courant. +c remarque : on ne peut pas controler ici que c'est un vrai +c champ aux points de Gauss +c + 27 continue +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,90002) 'debut de 27 continue ; nrcham', nrcham +c + jaux = poinno(nrfich-1) + 1 + kaux = lgnofi(nrfich) + call uts8ch ( nomufi(jaux), kaux, sau200, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHEN', nompro +#endif + call utchen ( sau200, iaux, + > ulsort, langue, codret ) +c + caetal(8,nrcham) = iaux + chncn = .true. +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,16)) iaux +#endif +c + goto 28 +c + endif +c +c 2.8. ==> si on a tout trouve, on passe au champ suivant +c + 28 continue +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... arrivee dans 28 continue' + write (ulsort,90003) 'chnom', chnom + write (ulsort,90003) 'chnum', chnum + write (ulsort,90003) 'chpdt', chpdt + write (ulsort,90003) 'chins', chins + write (ulsort,90003) 'chcas', chcas + write (ulsort,90003) 'chncn', chncn +#endif +c + if ( chnom .and. + > ( ( chnum .and. chpdt ) .or. chins ) .and. + > chcas .and. chncn ) then + caetal(1,nrcham) = -1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... ==> OK 28 ; passage au champ suivant' +#endif + goto 20 + endif +c + endif +c + 200 continue +c +c 2.9. ==> si on arrive ici, il faut verifier qu'il ne manque rien +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'debut de 29 continue' + write (ulsort,90003) 'chnom', chnom + write (ulsort,90003) 'chnum', chnum + write (ulsort,90003) 'chpdt', chpdt + write (ulsort,90003) 'chins', chins + write (ulsort,90003) 'chcas', chcas + write (ulsort,90003) 'chncn', chncn +#endif +c +c 2.9.1. ==> s'il ne manque que la caracteristique du support ou les +c indications temporelles, on suppose que ce champ est +c standard +c + if ( chnom ) then +c + caetal(1,nrcham) = -1 + if ( .not.chcas ) then + caetal(7,nrcham) = 0 + endif + if ( .not.chncn ) then + caetal(8,nrcham) = 0 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '... ==> OK 29 ; passage au champ suivant' +#endif +c +c 2.9.2. ==> s'il manque le nom, probleme ... +c + else +c + write (ulsort,texte(langue,5)) nrcham + write (ulsort,texte(langue,7)) +#ifdef _DEBUG_HOMARD_ + if ( .not.chnum ) then + write (ulsort,texte(langue,9)) + endif + if ( .not.chpdt ) then + write (ulsort,texte(langue,11)) + endif + if ( .not.chins ) then + write (ulsort,texte(langue,13)) + endif +#endif + codret = 1 +c + endif +c + endif +c +cgn print texte(langue,6), sau200(1:kaux) +cgn print *, '... support MED caetal(1,',nrcham,') = ', +cgn > caetal(1,nrcham) +cgn print *, '... pas de temps ? caetal(2,',nrcham,') = ', +cgn > caetal(2,nrcham) +cgn print *, '... pas de temps = caetal(3,',nrcham,') = ', +cgn > caetal(3,nrcham) +cgn print *, '... nro ordre ? caetal(4,',nrcham,') = ', +cgn > caetal(4,nrcham) +cgn print *, '... nro ordre = caetal(5,',nrcham,') = ', +cgn > caetal(5,nrcham) +cgn print *, '... instant ? caetal(6,',nrcham,') = ', +cgn > caetal(6,nrcham) +cgn print *, '... no/el ? caetal(7,',nrcham,') = ', +cgn > caetal(7,nrcham) +cgn print *, '... nr chp no/el caetal(8,',nrcham,') = ', +cgn > caetal(8,nrcham) +cgn print *, '... typint caetal(10,',nrcham,') = ', +cgn > caetal(10,nrcham) +cgn print *, '... instant = cartal(',nrcham,') = ', +cgn > cartal(nrcham) + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcch.F b/src/tool/Utilitaire/utmcch.F new file mode 100644 index 00000000..b3c3fadc --- /dev/null +++ b/src/tool/Utilitaire/utmcch.F @@ -0,0 +1,165 @@ + subroutine utmcch ( motcle, lgvale, valeur, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - CHaracter qui lui est associe +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a rechercher . +c . lgvale . s . 1 . longueur de la chaine . +c . valeur . s .char*(*). valeur caractere associee au mot-cle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme au decodage du mot-cle . +c . . . . 4 : le mot-cle n'a pas ete defini . +c . . . . 5 : le mot-cle est defini plusieurs fois . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCCH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgvale +c + character*8 motcle + character*(*) valeur +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer nombre, numero +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Option liee au mot-cle '',a8,'' :'')' + texte(1,12) = '(''Elle est illisible.'')' + texte(1,14) = '(''Elle n''''est pas definie.'')' + texte(1,15) = '(''Elle est definie plusieurs fois.'')' +c + texte(2,10) = '(''Option for keyword '',a8,'' :'')' + texte(2,12) = '(''It cannot be read.'')' + texte(2,14) = '(''It does not exist.'')' + texte(2,15) = '(''It exists more than once.'')' +c +c==== +c 2. caractere associe +c==== +c +c 2.1. ==> recherche du pseudo-fichier associe au mot-cle +c + numero = 1 +c + call utfin1 ( motcle, numero, + > nombre, valeur, lgvale, + > ulsort, langue, codre0 ) +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + codret = 4 +c +c 2.3. ==> definition multiple +c + elseif ( codre0.eq.0 .and. nombre.gt.1 ) then +c + codret = 5 +c +c 2.4. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 2 +c +c 2.5. ==> tout va bien +c + else +c + codret = 0 +c + endif +c +c==== +c 3. Messages +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +#else + if ( codret.eq.2 ) then +#endif +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,10+codret)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcen.F b/src/tool/Utilitaire/utmcen.F new file mode 100644 index 00000000..99c00b8a --- /dev/null +++ b/src/tool/Utilitaire/utmcen.F @@ -0,0 +1,185 @@ + subroutine utmcen ( motcle, valeur, imopti, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - ENtier qui lui est associe +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a rechercher . +c . valeur . s . 1 . valeur entiere associee au mot-cle . +c . imopti . e . 1 . choix d'impression en mode optimise . +c . . . . 0 : jamais . +c . . . . 1 : si codret = 2 . +c . . . . 2 : si codret = 2, 4 . +c . . . . 3 : si codret = 2 ou 5 . +c . . . . 4 : si codret = 2, 4 ou 5 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme au decodage du mot-cle . +c . . . . 4 : le mot-cle n'a pas ete defini . +c . . . . 5 : le mot-cle est defini plusieurs fois . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + integer imopti + integer valeur + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 + integer loptio + integer nombre, numero +c + character*200 option +c + character*5 fmtent +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Option liee au mot-cle '',a8,'' :'')' + texte(1,12) = '(''Elle est illisible.'')' + texte(1,14) = '(''Elle n''''est pas definie.'')' + texte(1,15) = '(''Elle est definie plusieurs fois.'')' +c + texte(2,10) = '(''Option for keyword '',a8,'' :'')' + texte(2,12) = '(''It cannot be read.'')' + texte(2,14) = '(''It does not exist.'')' + texte(2,15) = '(''It exists more than once.'')' +c +cgn write (ulsort,texte(langue,10)) motcle +c +c==== +c 2. entier associe +c==== +c +c 2.1. ==> recherche du pseudo-fichier associe au mot-cle +c + numero = 1 +c + call utfin1 ( motcle, numero, + > nombre, option, loptio, + > ulsort, langue, codre0 ) +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + codret = 4 +c +c 2.3. ==> definition multiple +c + elseif ( codre0.eq.0 .and. nombre.gt.1 ) then +c + codret = 5 +c +c 2.4. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 2 +c +c 2.5. ==> decodage +c + else +c + fmtent = '(I )' + if ( loptio.lt.10 ) then + write(fmtent(3:3),'(i1)') loptio + else + write(fmtent(3:4),'(i2)') loptio + endif + read ( option(1:loptio),fmtent) valeur +c + codret = 0 +c + endif +c +c==== +c 3. Messages +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 .and. imopti.ge.0 ) then +#else + if ( ( imopti.eq.1 .and. codret.eq.2 ) .or. + > ( imopti.eq.2 .and. + > ( codret.eq.2 .or. codret.eq.4 ) ) .or. + > ( imopti.eq.3 .and. + > ( codret.eq.2 .or. codret.eq.5 ) ) .or. + > ( imopti.eq.4 .and. + > ( codret.eq.2 .or. codret.eq.4 .or. codret.eq.5 ) ) ) then +#endif +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,10+codret)) +c + endif +c + end diff --git a/src/tool/Utilitaire/utmcf0.F b/src/tool/Utilitaire/utmcf0.F new file mode 100644 index 00000000..1923ba78 --- /dev/null +++ b/src/tool/Utilitaire/utmcf0.F @@ -0,0 +1,181 @@ + subroutine utmcf0 ( nombre, nomobj, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Frontieres - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nombre . e . 1 . nombre d'entrees ; le tableau Pointeur est . +c . . . . dimensionne a (0:nombre) . +c . nomobj . es . char8 . nom de l'objet PtTabC08 . +c . ncafar . es . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . valeurs reelles . +c . adpoin . s . 1 . adresse de Pointeur . +c . adtail . s . 1 . adresse de Taille . +c . adtabl . s . 1 . adresse de Table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCF0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nombre + integer adcpoi, adctai, adctab +c + character*8 nomobj +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''Impossible d''''allouer la structure memorisant les choix.'')' +c + texte(2,4) = '(''Structure of choices cannot be allocated.'')' +c +c==== +c 2. on alloue le receptacle des caracteristiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocation ; codret = ', codret +#endif +c +c 2.1. ==> Allocation de la tete et/ou des branches +c + if ( codret.eq.0 ) then +c + iaux = 0 + kaux = 10*nombre + if ( nombre.eq.0 ) then + jaux = 1 + else + jaux = 0 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAPTC - tete', nompro +#endif + call utaptc ( nomobj, iaux, jaux, + > nombre, kaux, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + codret = 1 + endif +c + endif +c +c 2.2. ==> Enregistrement des attributs +c + if ( codret.eq.0 ) then +c + if ( nombre.eq.0 ) then +c + jaux = 4 + kaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAPTC - attributs', nompro +#endif + call utaptc ( nomobj, iaux, jaux, + > nombre, kaux, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +c + endif +c + if ( codret.ne.0 ) then + codret = 1 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,nomobj) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcf1.F b/src/tool/Utilitaire/utmcf1.F new file mode 100644 index 00000000..bab0da93 --- /dev/null +++ b/src/tool/Utilitaire/utmcf1.F @@ -0,0 +1,541 @@ + subroutine utmcf1 ( nbfran, casfre, + > cacfpo, cacfta, casfnf, + > nbfich, + > nomref, lgnofi, poinno, + > nomufi, nomstr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Frontieres - 1 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfran . e . 1 . nombre de frontieres analytiques . +c . casfre . s .13nbfran. caracteristiques des frontieres analytiques. +c . . . . 1 : 1., si cylindre . +c . . . . 2., si sphere . +c . . . . 3., si cone par origine, axe et angle . +c . . . . 4., si cone par 2 centres et 2 rayons . +c . . . . 5., si tore . +c . . . . de 2 a 13 : . +c . . . . . cylindre : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon . +c . . . . . sphere : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . . cone : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 13 : angle en degre . +c . . . . . cone 2 : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 8 : rayon . +c . . . . 9,10,11:xcent2, ycent2, zcent2. +c . . . . 12 : rayon2 . +c . . . . . tore : 2,3,4 : xcentr, ycentr, zcentr. +c . . . . 5,6,7 : xaxe, yaxe, zaxe . +c . . . . 8 : rayon de revolution . +c . . . . 12 : rayon primaire . +c . cacfpo . s .0:nbfran. pointeurs sur le tableau du nom frontieres . +c . cacfta . s .10nbfran. taille du nom des frontieres . +c . casfnf . s .10nbfran. nom des frontieres . +c . nbfich . e . 1 . nombre de fichiers . +c . nomref . e . nbfich . nom de reference des fichiers . +c . lgnofi . e . nbfich . longueurs des noms des fichiers . +c . poinno . e .0:nbfich. pointeur dans le tableau des noms . +c . nomufi . e . lgtanf . noms des fichiers . +c . nomstr . e . nbfich . nom des structures . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme de lecture . +c . . . . 3 : type inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCF1' ) +c +#include "nblang.h" +#include "motcle.h" +c + integer nbmcle + parameter ( nbmcle = 13 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfran + integer nbfich + integer lgnofi(nbfich), poinno(0:nbfich) + integer cacfpo(0:nbfran), cacfta(10*nbfran) +c + character*8 nomref(nbfich), nomufi(*), nomstr(nbfich) + character*8 casfnf(10*nbfran) +c + double precision casfre(nbmcle,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nrfich + integer nrfran, tyfran + integer numero, nrmcle +c + character*8 mclref(0:nbmcle) + character*200 sau200 +c + logical mccode(0:nbmcle) + logical mccod2(0:nbmcle) +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*24 messag(nblang,5) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de frontiere(s) analytique(s) :'',i8)' + texte(1,5) = + > '(/,''Numero de la frontiere en cours de recherche :'',i8)' + texte(1,6) = '(''Type de la frontiere : '',a)' + texte(1,7) = '(''Le type '',i8,'' est inconnu.'')' + texte(1,8) = '(''La valeur de '',a,'' est indecodable.'')' +c + texte(2,4) = '(''Number of analytical boundarie(s):'',i8)' + texte(2,5) = '(/,''Search for boundary #'',i8)' + texte(2,6) = '(''Type of boundary: '',a)' + texte(2,7) = '(''The type #'',i8,'' is unknown.'')' + texte(2,8) = '(''The value for '',a,'' cannot be uncoded.'')' +c +#include "impr03.h" +c +c 123456789012345678901234 + messag(1,1) = 'Cylindre ' + messag(1,2) = 'Sphere ' + messag(1,3) = 'Cone ' + messag(1,4) = 'Cone ' + messag(1,5) = 'Tore ' +c + messag(2,1) = 'Cylindre ' + messag(2,2) = 'Sphere ' + messag(2,3) = 'Cone ' + messag(2,4) = 'Cone ' + messag(2,5) = 'Torus ' +c +c 1.3. ==> preliminaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbfran +#endif + mclref( 0) = mcfanm + mclref( 1) = mcfaty + mclref( 2) = mcfaxc + mclref( 3) = mcfayc + mclref( 4) = mcfazc + mclref( 5) = mcfaxa + mclref( 6) = mcfaya + mclref( 7) = mcfaza + mclref( 8) = mcfara + mclref( 9) = mcfax2 + mclref(10) = mcfay2 + mclref(11) = mcfaz2 + mclref(12) = mcfar2 + mclref(13) = mcfaan +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,93020) 'Mots-cles', mclref +#endif +c + cacfpo(0) = 0 +c +c==== +c 2. on parcourt toutes les posssibilites de frontieres +c==== +c + do 20 , nrfran = 1 , nbfran +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nrfran +#endif +c +c 2.0. ==> On n'a rien au debut +c + do 201 , iaux = 0 , nbmcle + mccode(iaux) = .false. + mccod2(iaux) = .false. + 201 continue +c + do 200 , nrfich = 1 , nbfich +c +c 2.1. ==> si c'est un des mots-cles possibles, on verifie si c'est +c pour la bonne frontiere +c + if ( codret.eq.0 ) then +c + nrmcle = -1 + do 21 , iaux = 0 , nbmcle + if ( nomref(nrfich).eq.mclref(iaux) ) then + nrmcle = iaux + goto 211 + endif + 21 continue +c + 211 continue +c + if ( nrmcle.ge.0 ) then +c + call utchen ( nomstr(nrfich), numero, + > ulsort, langue, codret ) +c + if ( nrfran.ne.numero ) then + goto 200 + endif +c + else +c + goto 200 +c + endif +c +c + endif +c +c 2.2. ==> recherche de la valeur +c 2.2.1. ==> Mise sous forme de chaine de la 3eme donnee sur la ligne +c + if ( codret.eq.0 ) then +c + iaux = poinno(nrfich-1) + 1 + jaux = lgnofi(nrfich) + call uts8ch ( nomufi(iaux), jaux, sau200, + > ulsort, langue, codret ) +c + endif +c +c 2.2.2. ==> Conversions +c + if ( codret.eq.0 ) then +c +c 2.2.2.1. ==> Stockage du nom de la frontiere +c + if ( nrmcle.eq.0 ) then +c + iaux = mod(lgnofi(nrfich),8) + kaux = (lgnofi(nrfich) - iaux)/8 + if ( iaux.ne.0 ) then + kaux = kaux + 1 + endif + cacfpo(nrfran) = cacfpo(nrfran-1) + kaux + jaux = 1 + do 2221 , iaux = 1 , kaux + cacfta(cacfpo(nrfran-1)+iaux) = 8 + casfnf(cacfpo(nrfran-1)+iaux) = sau200(jaux:jaux+7) + jaux = jaux + 8 + 2221 continue + iaux = mod(lgnofi(nrfich),8) + if ( iaux.ne.0 ) then + cacfta(cacfpo(nrfran)) = iaux + endif +c +c 2.2.2.2. ==> Conversion du type : entier a decoder, puis reel +c + elseif ( nrmcle.eq.1 ) then +c + call utchen ( sau200, tyfran, + > ulsort, langue, codret ) +c + casfre(nrmcle,nrfran) = dble(tyfran) +c +c 2.2.2.3. ==> Conversion des coordonnees : reel +c + elseif ( nrmcle.ge.2 ) then +c + call utchre ( sau200, daux, + > ulsort, langue, codret ) + casfre(nrmcle,nrfran) = daux +cgn write (ulsort,90004) '---'//mclref(nrmcle), daux +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) nrfran + write (ulsort,texte(langue,8)) mclref(nrmcle) + endif +c + endif +c + endif +c +c 2.2.3. ==> Archivage +c + if ( codret.eq.0 ) then +c + mccode(nrmcle) = .true. +c + endif +c +c 2.3. ==> si on a tout trouve, on passe a la frontiere suivante, +c apres controle +c + if ( codret.eq.0 ) then +c + if ( mccode(1) ) then +c + tyfran = nint(casfre(1,nrfran)) +c +c 2.3.1. ==> Cas du cylindre +c + if ( tyfran.eq.1 ) then +c + if ( mccode(0) .and. + > mccode(2) .and. mccode(3) .and. + > mccode(4) .and. mccode(5) .and. + > mccode(6) .and. mccode(7) .and. + > mccode(8) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) messag(langue,tyfran) + write (ulsort,90004) 'X centre', casfre(2,nrfran) + write (ulsort,90004) 'Y centre', casfre(3,nrfran) + write (ulsort,90004) 'Z centre', casfre(4,nrfran) + write (ulsort,90004) 'X axe ', casfre(5,nrfran) + write (ulsort,90004) 'Y axe ', casfre(6,nrfran) + write (ulsort,90004) 'Z axe ', casfre(7,nrfran) + write (ulsort,90004) 'Rayon ', casfre(8,nrfran) +#endif +c + goto 20 +c + endif +c +c 2.3.2. ==> Cas de la sphere +c + elseif ( tyfran.eq.2 ) then +c + if ( mccode(0) .and. + > mccode(2) .and. mccode(3) .and. + > mccode(4) .and. mccode(8) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) messag(langue,tyfran) + write (ulsort,90004) 'X centre', casfre(2,nrfran) + write (ulsort,90004) 'Y centre', casfre(3,nrfran) + write (ulsort,90004) 'Z centre', casfre(4,nrfran) + write (ulsort,90004) 'Rayon ', casfre(8,nrfran) +#endif +c + goto 20 +c + endif +c +c 2.3.3. ==> Cas du cone defini par centre, axe et angle +c + elseif ( tyfran.eq.3 ) then +c + if ( mccode(0) .and. + > mccode( 2) .and. mccode( 3) .and. + > mccode( 4) .and. + > mccode( 5) .and. mccode( 6) .and. + > mccode( 7) .and. mccode(13) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) messag(langue,tyfran) + write (ulsort,90004) 'X centre', casfre( 2,nrfran) + write (ulsort,90004) 'Y centre', casfre( 3,nrfran) + write (ulsort,90004) 'Z centre', casfre( 4,nrfran) + write (ulsort,90004) 'X axe ', casfre(5,nrfran) + write (ulsort,90004) 'Y axe ', casfre(6,nrfran) + write (ulsort,90004) 'Z axe ', casfre(7,nrfran) + write (ulsort,90004) 'Angle ', casfre(13,nrfran) +#endif +c + goto 20 +c + endif +c +c 2.3.4. ==> Cas du cone defini par 2 centres et 2 rayons +c + elseif ( tyfran.eq.4 ) then +c + if ( mccode(0) .and. + > mccode( 2) .and. mccode( 3) .and. + > mccode( 4) .and. mccode( 8) .and. + > mccode( 9) .and. mccode(10) .and. + > mccode(11) .and. mccode(12) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) messag(langue,tyfran) + write (ulsort,90004) 'X centre ', casfre( 2,nrfran) + write (ulsort,90004) 'Y centre ', casfre( 3,nrfran) + write (ulsort,90004) 'Z centre ', casfre( 4,nrfran) + write (ulsort,90004) 'Rayon ', casfre( 8,nrfran) + write (ulsort,90004) 'X centre 2', casfre( 9,nrfran) + write (ulsort,90004) 'Y centre 2', casfre(10,nrfran) + write (ulsort,90004) 'Z centre 2', casfre(11,nrfran) + write (ulsort,90004) 'Rayon 2', casfre(12,nrfran) +#endif +c + goto 20 +c + endif +c +c 2.3.5. ==> Cas du tore +c + elseif ( tyfran.eq.5 ) then +c + if ( mccode(0) .and. + > mccode( 2) .and. mccode( 3) .and. + > mccode( 4) .and. + > mccode( 5) .and. mccode( 6) .and. + > mccode( 7) .and. + > mccode( 8) .and. mccode(12) ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) messag(langue,tyfran) + write (ulsort,90004) 'X centre', casfre( 2,nrfran) + write (ulsort,90004) 'Y centre', casfre( 3,nrfran) + write (ulsort,90004) 'Z centre', casfre( 4,nrfran) + write (ulsort,90004) 'X axe ', casfre( 5,nrfran) + write (ulsort,90004) 'Y axe ', casfre( 6,nrfran) + write (ulsort,90004) 'Z axe ', casfre( 7,nrfran) + write (ulsort,90004) 'R revolu', casfre( 8,nrfran) + write (ulsort,90004) 'R primai', casfre(12,nrfran) +#endif +c + goto 20 +c + endif +c +c 2.3.n. ==> Type inconnu +c + else + write (ulsort,texte(langue,7)) tyfran + codret = 3 + endif +c + endif +c + endif +c + 200 continue +c +c 2.4. ==> si on arrive ici, c'est qu'il en manque pour la +c frontiere courante +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,5)) nrfran + write (ulsort,texte(langue,6)) messag(langue,tyfran) + mccod2(1) = .true. + if ( tyfran.eq.1 ) then + do 241 , iaux = 2 , 8 + mccod2(iaux) = .true. + 241 continue + elseif ( tyfran.eq.2 ) then + do 242 , iaux = 2 , 4 + mccod2(iaux) = .true. + 242 continue + mccod2(8) = .true. + elseif ( tyfran.eq.3 ) then + do 243 , iaux = 2 , 7 + mccod2(iaux) = .true. + 243 continue + mccod2(13) = .true. + elseif ( tyfran.eq.4 ) then + do 2441 , iaux = 2 , 4 + mccod2(iaux) = .true. + 2441 continue + do 2442 , iaux = 8 , 12 + mccod2(iaux) = .true. + 2442 continue + elseif ( tyfran.eq.5 ) then + do 2451 , iaux = 2 , 8 + mccod2(iaux) = .true. + 2451 continue + mccod2(12) = .true. + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,99002) 'mccod2', mccod2 + write(ulsort,99002) 'mccode', mccode +#endif + do 24 , iaux = 0 , nbmcle + if ( .not.mccode(iaux) .and. mccod2(iaux) ) then + write (ulsort,texte(langue,8)) mclref(iaux) + endif + 24 continue +c + codret = 2 +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + call dmflsh(iaux) +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcf2.F b/src/tool/Utilitaire/utmcf2.F new file mode 100644 index 00000000..094ac6c5 --- /dev/null +++ b/src/tool/Utilitaire/utmcf2.F @@ -0,0 +1,339 @@ + subroutine utmcf2 ( nbfrgr, + > calfpo, calfta, calfnm, + > calgpo, calgta, calgnm, + > nbfich, + > nomref, lgnofi, poinno, + > nomufi, nomstr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Frontieres - 2 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfrgr . e . 1 . nombre de liens frontieres/groupes . +c . calfpo . s .0:nbfrgr. pointeurs sur le tableau du nom frontieres . +c . calfta . s .10nbfrgr. taille du nom des frontieres . +c . calfnm . s .10nbfrgr. nom des frontieres . +c . calgpo . s .0:nbfrgr. pointeurs sur le tableau du nom groupes . +c . calgta . s .10nbfrgr. taille du nom des groupes . +c . calgnm . s .10nbfrgr. nom des groupes . +c . nbfich . e . 1 . nombre de fichiers . +c . nomref . e . nbfich . nom de reference des fichiers . +c . lgnofi . e . nbfich . longueurs des noms des fichiers . +c . poinno . e .0:nbfich. pointeur dans le tableau des noms . +c . nomufi . e . lgtanf . noms des fichiers . +c . nomstr . e . nbfich . nom des structures . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme de lecture . +c . . . . 3 : type inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCF2' ) +c +#include "nblang.h" +#include "motcle.h" +c + integer nbmcle + parameter ( nbmcle = 1 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbfrgr + integer nbfich + integer lgnofi(nbfich), poinno(0:nbfich) + integer calfpo(0:nbfrgr), calfta(10*nbfrgr) + integer calgpo(0:nbfrgr), calgta(10*nbfrgr) +c + character*8 calfnm(10*nbfrgr) + character*8 calgnm(10*nbfrgr) + character*8 nomref(nbfich), nomufi(*), nomstr(nbfich) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nrfich + integer nrfrgr + integer numero, nrmcle +c + character*8 mclref(0:nbmcle) + character*200 sau200 +c + logical mccode(0:nbmcle) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de lien(s) frontiere/groupe :'',i8)' + texte(1,5) = + > '(''Numero du lien en cours de recherche :'',i8)' + texte(1,8) = '(''La valeur de '',a,'' est indecodable.'')' +c + texte(2,4) = '(''Number of link(s) boundary/group:'',i8)' + texte(2,5) = '(''Search for link #'',i8)' + texte(2,8) = '(''The value for '',a,'' cannot be uncoded.'')' +c +c 1.3. ==> preliminaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbfrgr +#endif + mclref( 0) = mcfgfr + mclref( 1) = mcfggr +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) mclref +#endif +c + calfpo(0) = 0 + calgpo(0) = 0 +c +c==== +c 2. on parcourt toutes les posssibilites de liens +c==== +c + do 20 , nrfrgr = 1 , nbfrgr +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nrfrgr +#endif +c +c 2.0. ==> On n'a rien au debut +c + do 201 , iaux = 0 , nbmcle + mccode(iaux) = .false. + 201 continue +c + do 200 , nrfich = 1 , nbfich +c +c 2.1. ==> si c'est un des mots-cles possibles, on verifie si c'est +c pour le bon lien +c + if ( codret.eq.0 ) then +c + nrmcle = -1 + do 21 , iaux = 0 , nbmcle + if ( nomref(nrfich).eq.mclref(iaux) ) then + nrmcle = iaux + goto 211 + endif + 21 continue +c + 211 continue +c + if ( nrmcle.ge.0 ) then +c + call utchen ( nomstr(nrfich), numero, + > ulsort, langue, codret ) +c + if ( nrfrgr.ne.numero ) then + goto 200 + endif +c + else +c + goto 200 +c + endif +c +c + endif +c +c 2.2. ==> recherche de la valeur +c 2.2.1. ==> Mise sous forme de chaine de la 3eme donnee sur la ligne +c + if ( codret.eq.0 ) then +c + iaux = poinno(nrfich-1) + 1 + jaux = lgnofi(nrfich) + call uts8ch ( nomufi(iaux), jaux, sau200, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) sau200 +#endif + endif +c +c 2.2.2. ==> Conversions +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'nrmcle =', nrmcle +#endif +c +c 2.2.2.1. ==> Stockage du nom de la frontiere +c + if ( nrmcle.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Stockage du nom de la frontiere' +#endif +c + iaux = mod(lgnofi(nrfich),8) + kaux = (lgnofi(nrfich) - iaux)/8 + if ( iaux.ne.0 ) then + kaux = kaux + 1 + endif + calfpo(nrfrgr) = calfpo(nrfrgr-1) + kaux + jaux = 1 + do 2221 , iaux = 1 , kaux + calfta(calfpo(nrfrgr-1)+iaux) = 8 + calfnm(calfpo(nrfrgr-1)+iaux) = sau200(jaux:jaux+7) + jaux = jaux + 8 + 2221 continue + iaux = mod(lgnofi(nrfich),8) + if ( iaux.ne.0 ) then + calfta(calfpo(nrfrgr)) = iaux + endif +c +c 2.2.2.2. ==> Stockage du nom du groupe +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Stockage du nom du groupe' +#endif +c + iaux = mod(lgnofi(nrfich),8) + kaux = (lgnofi(nrfich) - iaux)/8 + if ( iaux.ne.0 ) then + kaux = kaux + 1 + endif + calgpo(nrfrgr) = calgpo(nrfrgr-1) + kaux + jaux = 1 + do 2222 , iaux = 1 , kaux + calgta(calgpo(nrfrgr-1)+iaux) = 8 + calgnm(calgpo(nrfrgr-1)+iaux) = sau200(jaux:jaux+7) + jaux = jaux + 8 + 2222 continue + iaux = mod(lgnofi(nrfich),8) + if ( iaux.ne.0 ) then + calgta(calgpo(nrfrgr)) = iaux + endif +c + endif +c + endif +c +c 2.2.3. ==> Archivage +c + if ( codret.eq.0 ) then +c + mccode(nrmcle) = .true. +c + endif +c +c 2.3. ==> si on a tout trouve, on passe a la frontiere suivante, +c apres controle +c + if ( codret.eq.0 ) then +c + if ( mccode(0) .and. mccode(1) ) then +c + goto 20 +c + endif +c + endif +c +c + 200 continue +c +c 2.4. ==> si on arrive ici, c'est qu'il en manque pour la +c frontiere courante +c + if ( codret.eq.0 ) then +c + write (ulsort,texte(langue,5)) nrfrgr + do 24 , iaux = 0 , nbmcle + if ( .not.mccode(iaux) ) then + write (ulsort,texte(langue,8)) mclref(iaux) + endif + 24 continue +c + codret = 2 +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + call dmflsh(iaux) +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcfa.F b/src/tool/Utilitaire/utmcfa.F new file mode 100644 index 00000000..681c367a --- /dev/null +++ b/src/tool/Utilitaire/utmcfa.F @@ -0,0 +1,403 @@ + subroutine utmcfa ( ncafan, ncafar, ncfgnf, ncfgng, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Frontieres Analytiques +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncafan . es . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . nom des frontieres . +c . ncafar . es . char*8 . nom de l'objet des frontieres analytiques :. +c . . . . valeurs reelles . +c . ncfgnf . es . char*8 . lien frontiere/groupe : nom des frontieres . +c . ncfgng . es . char*8 . lien frontiere/groupe : nom des groupes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCFA' ) +c +#include "nblang.h" +#include "motcle.h" +c + integer nbmcle + parameter ( nbmcle = 13 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 ncafan, ncafar, ncfgnf, ncfgng +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer codre0 + integer iaux, jaux + integer loptio + integer numero + integer nbfich +c + integer nbfran + integer adnore, adlono, adpono, adnofi, adnoos + integer adcafr + integer nbfrgr + integer adcpoi, adctai, adctab + integer adfpoi, adftai, adftab + integer adgpoi, adgtai, adgtab +c + character*8 motcle + character*200 option +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de frontieres analytiques :'',i8)' + texte(1,5) = '(''Nombre de liens frontiere/groupe :'',i8)' + texte(1,9) = '(''Le mot-cle '',a,'' apparait :'',i8,'' fois.'')' + texte(1,11) = '(''La configuration est perdue ?'')' + texte(1,12) = '(''Probleme de lecture.'')' + texte(1,13) = '(''Donnees incoherentes.'')' + texte(1,18) = + >'(''Impossible d''''allouer la structure memorisant les choix.'')' +c + texte(2,4) = '(''Number of analytical boundaries :'',i8)' + texte(2,5) = '(''Number of links boundary/group :'',i8)' + texte(2,9) = '(''Keyword '',a,'' appears :'',i8,'' times.'')' + texte(2,11) = '(''Configuration is lost ?'')' + texte(2,12) = '(''Problem while reading.'')' + texte(2,13) = '(''Data without coherence.'')' + texte(2,18) = '(''Structure of choices cannot be allocated.'')' +c +c==== +c 2. recherche du nombre d'occurences du mot-cle : +c A. Le nom d'une frontiere analytique dans sa description +c B. Le nom d'une frontiere analytique dans son lien avec un groupe +c==== +c + do 20 , iaux = 1 , 2 +c +c 2.1. ==> presence du mot-cle ? +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + motcle = mcfanm + else + motcle = mcfgfr + endif + numero = 1 +c + call utfin1 ( motcle, numero, + > jaux, option, loptio, + > ulsort, langue, codre0 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) motcle, jaux +#endif +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + jaux = 0 + codret = 0 +c +c 2.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 1 +c +c 2.4. ==> on peut y aller +c + else +c + codret = 0 +c + endif +c +c 2.5. ==> bilan +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + nbfran = jaux + else + nbfrgr = jaux + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3+iaux)) jaux +#endif +c + else + codret = 2 + endif +c + endif +c + 20 continue +c +c 2.6. ==> Si aucun lien frontiere/groupe n'est present, on annule +c toute description eventuelle de frontiere pour ne pas +c surcharger les donnees +c + if ( codret.eq.0 ) then +c + if ( nbfrgr.eq.0 ) then +c + nbfran = 0 +c + endif +c + endif +c +c==== +c 3. on alloue le receptacle des caracteristiques des frontieres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocation ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCF0 - frontiere', nompro +#endif + call utmcf0 ( nbfran, ncafan, + > adcpoi, adctai, adctab, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx(nompro,ncafan) +#endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( nbfran.ne.0 ) then +c + iaux = nbfran*nbmcle + call gmalot ( ncafar, 'reel ', iaux, adcafr, codret ) +c + endif +c + endif +c +c==== +c 4. recherche des adresses des objets GM lies aux noms des fichiers +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Recherche ; codret = ', codret +#endif +c + if ( nbfran.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD80', nompro +#endif + call utad80 ( nbfich, + > adnore, adlono, adpono, adnofi, adnoos, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. remplissage des tableaux caracterisant les frontieres +c==== +c + if ( nbfran.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCF1', nompro +#endif + call utmcf1 ( nbfran, rmem(adcafr), + > imem(adcpoi), imem(adctai), smem(adctab), + > nbfich, + > smem(adnore), imem(adlono), imem(adpono), + > smem(adnofi), smem(adnoos), + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + codret = 3 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, ncafar ) + call gmprsx (nompro, ncafan ) + call gmprsx (nompro, ncafan//'.Pointeur' ) + call gmprsx (nompro, ncafan//'.Taille' ) + call gmprsx (nompro, ncafan//'.Table' ) + endif +#endif +c + endif +c +c==== +c 6. Les tableaux des liens frontieres/groupes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '6. liens frontieres/groupes ; codret = ', codret +#endif +c + if ( nbfrgr.ne.0 ) then +c +c 6.1. ==> Nom des frontieres +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCF0 - lien - frontiere', nompro +#endif + call utmcf0 ( nbfrgr, ncfgnf, + > adfpoi, adftai, adftab, + > ulsort, langue, codret ) +c + endif +c +c 6.2. ==> Nom des groupes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCF0 - lien - groupe', nompro +#endif + call utmcf0 ( nbfrgr, ncfgng, + > adgpoi, adgtai, adgtab, + > ulsort, langue, codret ) +c + endif +c +c 6.3. remplissage des tableaux des liens frontieres/groupes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCF2', nompro +#endif + call utmcf2 ( nbfrgr, + > imem(adfpoi), imem(adftai), smem(adftab), + > imem(adgpoi), imem(adgtai), smem(adgtab), + > nbfich, + > smem(adnore), imem(adlono), imem(adpono), + > smem(adnofi), smem(adnoos), + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + codret = 3 + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, ncfgnf ) + call gmprsx (nompro, ncfgnf//'.Pointeur' ) + call gmprsx (nompro, ncfgnf//'.Taille' ) + call gmprsx (nompro, ncfgnf//'.Table' ) + call gmprsx (nompro, ncfgng ) + call gmprsx (nompro, ncfgng//'.Pointeur' ) + call gmprsx (nompro, ncfgng//'.Taille' ) + call gmprsx (nompro, ncfgng//'.Table' ) + endif +#endif +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10+codret)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmclc.F b/src/tool/Utilitaire/utmclc.F new file mode 100644 index 00000000..8c0d46a4 --- /dev/null +++ b/src/tool/Utilitaire/utmclc.F @@ -0,0 +1,316 @@ + subroutine utmclc ( nbseal, majsol, nochso, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - Liste des Champs a mettre a jour +c -- - - - - +c ______________________________________________________________________ +c +c but : creer une structure de type ChampMAJ qui memorise les +c caracteristiques des champs a mettre a jour +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbseal . es . 1 . En entree : . +c . . . . 0 : aucune demande particuliere . +c . . . . 1 : on a demande la mise a jour de tous . +c . . . . les champs . +c . . . . En sortie : . +c . . . . -1 : tous les champs sont a lire . +c . . . . 0 : aucun champ n'est a lire . +c . . . . >0 : nombre de champs a mettre a jour . +c . majsol . s . 1 . conversion de la solution 0 : non, 1 : oui . +c . nochso . es . char*8 . nom de l'objet qui memorise les champs . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c . . . . 9 : incoherence de donnees . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCLC' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbseal, majsol +c + character*8 nochso +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer codre1, codre2, codre3, codre4 + integer codre0 + integer iaux + integer loptio + integer numero + integer nbfich + integer adcaet, adcact, adcart + integer adnore, adlono, adpono, adnofi, adnoos +c + character*8 motcle + character*200 option +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Nombre de champs a mettre a jour :'',i8)' + texte(1,11) = '(''La configuration est perdue ?'')' + texte(1,12) = '(''Probleme de lecture.'')' + texte(1,18) = + >'(''Impossible d''''allouer la structure memorisant les choix.'')' + texte(1,19) = + > '(''Mise a jour de tous les champs ou de certains ?'')' +c + texte(2,10) = '(''Number of fields to update :'',i8)' + texte(2,11) = '(''Configuration is lost ?'')' + texte(2,12) = '(''Problem while reading.'')' + texte(2,18) = '(''Structure of choices cannot be allocated.'')' + texte(2,19) = '(''Updating of all fields or someone ?'')' +c +c==== +c 2. recherche du nombre d'occurences du mot-cle +c==== +c + if ( codret.eq.0 ) then +c +c 2.1. ==> on recherche la premiere occurence associe au mot-cle +c + numero = 1 +c + motcle = mcchno + call utfin1 ( motcle, numero, + > iaux, option, loptio, + > ulsort, langue, codre0 ) +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + codret = 0 +c +c 2.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 1 +c +c 2.4. ==> on peut y aller +c + else +c + codret = 0 +c + endif +c + if ( codret.ne.0 ) then + codret = 2 + endif +c + endif +c +c 2.5. ==> coherence avec la demande globale de mise a jour des champs +c + if ( codret.eq.0 ) then +c + if ( nbseal.eq.0 ) then + nbseal = iaux + else + if ( iaux.eq.0 ) then + nbseal = -1 + else + codret = 9 + endif + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) nbseal +#endif +c +c==== +c 3. Les caracteristiques des champs quand on en lit quelques uns +c==== +c + if ( nbseal.gt.0 ) then +c +c 3.1. ==> on alloue le receptacle des caracteristiques des champs +c + if ( codret.eq.0 ) then + call gmalot ( nochso, 'ChampMAJ', 0, iaux, codret ) + endif +c + if ( codret.eq.0 ) then +c + iaux = 8*nbseal + call gmecat ( nochso, 1, nbseal, codre1 ) + call gmaloj ( nochso//'.CarCaChp', ' ', iaux, adcact, codre2 ) + iaux = 12*nbseal + call gmaloj ( nochso//'.CarEnChp', ' ', iaux, adcaet, codre3 ) + iaux = 1*nbseal + call gmaloj ( nochso//'.CarReChp', ' ', iaux, adcart, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + if ( codret.ne.0 ) then + codret = 8 + endif +c + endif +c +c 3.2. ==> adresses des objets GM lies aux noms des fichiers +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD80', nompro +#endif + call utad80 ( nbfich, + > adnore, adlono, adpono, adnofi, adnoos, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> remplissage des tableaux +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCC0', nompro +#endif + call utmcc0 ( nbseal, + > imem(adcaet), smem(adcact), rmem(adcart), + > nbfich, + > smem(adnore), imem(adlono), imem(adpono), + > smem(adnofi), smem(adnoos), + > ulsort, langue, codret ) +c + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( nbseal.gt.0 ) then +cgn call gmprsx (nompro, nochso ) + call gmprsx (nompro, nochso//'.CarCaChp' ) + call gmprsx (nompro, nochso//'.CarEnChp' ) + call gmprsx (nompro, nochso//'.CarReChp' ) + endif +#endif +c +c==== +c 4. consequence sur la conversion de solution +c==== +c + if ( codret.eq.0 ) then +c +c 4.1. ==> pointeur sur la conversion de solution +c + if ( nbseal.eq.0 ) then + majsol = 0 + else + majsol = 1 + endif +c +c 4.2. ==> si tous les champs sont concernes, on met un nom blanc pour +c la structure de stockage car c'est ainsi que l'on se repere +c ensuite +c + if ( nbseal.eq.-1 ) then +c 12345678 + nochso = ' ' + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10+codret)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcls.F b/src/tool/Utilitaire/utmcls.F new file mode 100644 index 00000000..edfc33b7 --- /dev/null +++ b/src/tool/Utilitaire/utmcls.F @@ -0,0 +1,308 @@ + subroutine utmcls ( motcle, choix, oblist, nombre, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - Liste des Strings associee +c -- - - - - +c ______________________________________________________________________ +c +c but : creer une structure de type PtTabC08 qui contient une liste +c d'options reperees par le meme mot-cle +c a priori, on suppose que les options sont de taille maximale 200 +c on complete par des blancs au-dela des caracteres utiles +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a decoder . +c . choix . e . 1 . option de la recherche : . +c . . . . 0 : si le mot-cle est indefini, erreur . +c . . . . 1 : si le mot-cle est indefini, on alloue . +c . . . . une structure vide . +c . oblist . es . char*8 . nom de l'objet de type PtTabC08 qui . +c . . . . definit la liste . +c . nombre . s . 1 . nombre d'options enregistrees . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : le mot-cle n'a pas ete defini . +c . . . . 3 : Le numero voulu est impossible . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCLS' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + character*8 oblist + integer choix + integer nombre +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer iaux, jaux, kaux, laux + integer loptio + integer numero + integer adpoin, adtail, adtabl +c + character*200 option +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Mot-cle symbolique : '',a8)' + texte(1,5) = '(''La configuration est perdue ?'')' + texte(1,6) = + > '(''Ce mot-cle est inconnu dans la configuration.'')' + texte(1,7) = '(''Le numero voulu est impossible.'')' + texte(1,8) = + >'(''Impossible d''''allouer la structure memorisant les choix.'')' +c + texte(2,4) = '(''Symbolic keyword : '',a8)' + texte(2,5) = '(''Configuration is lost ?'')' + texte(2,6) = '(''This keyword is unknown in configuration.'')' + texte(2,7) = '(''The wanted rank is impossible.'')' + texte(2,8) = '(''Structure of choices cannot be allocated.'')' +c +#include "impr03.h" +c +c==== +c 2. recherche du nombre d'occurence du mot-cle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) motcle +#endif +c + if ( codret.eq.0 ) then +c +c 2.1. ==> on recherche la premiere occurence associe au mot-cle +c + numero = 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN1_0', nompro +#endif + call utfin1 ( motcle, numero, + > nombre, option, loptio, + > ulsort, langue, codre0 ) +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + if ( choix.eq.0 ) then + codret = 2 + else + nombre = 0 + codret = 0 + endif +c +c 2.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 1 +c +c 2.4. ==> on peut y aller +c + else +c + codret = 0 +c + endif +c + endif +c +c==== +c 3. on alloue le receptacle des options +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocation ; codret =', codret +#endif +c + if ( codret.eq.0 ) then +c +c nom automatique + iaux = 0 +c on alloue tete et branches + jaux = 0 +c longueur de la table + kaux = 25*nombre +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAPTC', nompro + write (ulsort,90002) 'nombre', nombre + write (ulsort,90002) 'iaux', iaux + write (ulsort,90002) 'jaux', jaux + write (ulsort,90002) 'kaux', kaux +#endif + call utaptc ( oblist, iaux, jaux, + > nombre, kaux, + > adpoin, adtail, adtabl, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then + codret = 3 + endif +c + endif +c +c==== +c 4. on parcourt toutes les occurences du mot-cle +c==== +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nombre +c + if ( codret.eq.0 ) then +c +c 4.1. ==> on recherche l'occurence iaux associe au mot-cle +c + numero = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFIN1', nompro +#endif + call utfin1 ( motcle, numero, + > nombre, option, loptio, + > ulsort, langue, codre0 ) +c +c 4.2. ==> probleme de lecture +c + if ( codre0.ne.0 ) then +c + codret = 1 +c +c 4.3. ==> on stocke +c + else +c + jaux = imem(adpoin+iaux-1) +c + call utchs8 ( option, loptio, smem(adtabl+jaux), + > ulsort, langue, codret ) +c + laux = (loptio-mod(loptio,8)) / 8 + do 431 , kaux = 1 , laux + imem(adtail+jaux+kaux-1) = 8 + 431 continue +c + if ( mod(loptio,8).ne.0 ) then + imem(adtail+jaux+laux) = mod(loptio,8) + laux = laux + 1 + endif +c + laux = laux + 1 + do 432 , kaux = laux , 25 + imem(adtail+jaux+kaux-1) = 0 + smem(adtabl+jaux+kaux-1) = ' ' +c 12345678 + 432 continue +c + imem(adpoin+iaux) = 25*iaux +c + endif +c + endif +c + 41 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, oblist ) + call gmprsx (nompro, oblist//'.Pointeur' ) + call gmprsx (nompro, oblist//'.Taille' ) + call gmprsx (nompro, oblist//'.Table' ) +#endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +#else + if ( codret.eq.2 ) then +#endif +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) motcle + write (ulsort,texte(langue,5+codret)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmcre.F b/src/tool/Utilitaire/utmcre.F new file mode 100644 index 00000000..d755e1d9 --- /dev/null +++ b/src/tool/Utilitaire/utmcre.F @@ -0,0 +1,171 @@ + subroutine utmcre ( motcle, valeur, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - REel qui lui est associe +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . motcle . e . char*8 . mot-cle a rechercher . +c . valeur . s . 1 . valeur entiere associee au mot-cle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme au decodage du mot-cle . +c . . . . 4 : le mot-cle n'a pas ete defini . +c . . . . 5 : le mot-cle est defini plusieurs fois . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCRE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 motcle +c + double precision valeur + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer loptio + integer nombre, numero +c + integer iaux +c + character*200 option +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Option liee au mot-cle '',a8,'' :'')' + texte(1,12) = '(''Elle est illisible.'')' + texte(1,14) = '(''Elle n''''est pas definie.'')' + texte(1,15) = '(''Elle est definie plusieurs fois.'')' +c + texte(2,10) = '(''Option for keyword '',a8,'' :'')' + texte(2,12) = '(''It cannot be read.'')' + texte(2,14) = '(''It does not exist.'')' + texte(2,15) = '(''It exists more than once.'')' +c +c==== +c 2. reel associe +c==== +c +c 2.1. ==> recherche du pseudo-fichier associe au mot-cle +c + numero = 1 +c + call utfin1 ( motcle, numero, + > nombre, option, loptio, + > ulsort, langue, codre0 ) +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + codret = 4 +c +c 2.3. ==> definition multiple +c + elseif ( codre0.eq.0 .and. nombre.gt.1 ) then +c + codret = 5 +c +c 2.4. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 2 +c +c 2.5. ==> decodage +c + else +c + call utchre ( option, valeur, + > ulsort, langue, codret ) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c +c==== +c 3. Messages +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.ne.0 ) then +#else + if ( codret.eq.2 ) then +#endif +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) motcle + write (ulsort,texte(langue,10+codret)) +c + endif +c + end diff --git a/src/tool/Utilitaire/utmcz0.F b/src/tool/Utilitaire/utmcz0.F new file mode 100644 index 00000000..e00da6bc --- /dev/null +++ b/src/tool/Utilitaire/utmcz0.F @@ -0,0 +1,499 @@ + subroutine utmcz0 ( nbzord, cazord, + > nbfich, + > nomref, lgnofi, poinno, + > nomufi, nomstr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Zones a Raffiner - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbzord . es . 1 . nombre de zones a raffiner/deraffiner . +c . . . . si negatif, les zones sont 2D (en x et y) . +c . cazord . s . 20 * . caracteristiques zone a raffiner/deraffiner. +c . . . nbzord . 1 : >0 si a raffiner, <0 si a deraffiner . +c . . . . . si rectangle : . +c . . . . 1 : +-1 . +c . . . . de 2 a 5 : xmin, xmax, ymin, ymax . +c . . . . . si parallelepipede : . +c . . . . 1 : +-2 . +c . . . . de 2 a 7 : xmin, xmax, ymin, ymax . +c . . . . zmin, zmax . +c . . . . . si disque : . +c . . . . 1 : +-3 . +c . . . . de 8 a 10 : rayon, xcentr, ycentr . +c . . . . . si sphere : . +c . . . . 1 : +-4 . +c . . . . de 8 a 11 : rayon, xcentr, ycentr, zcentr . +c . . . . . si cylindre : . +c . . . . 1 : +-5 . +c . . . . 8 : rayon . +c . . . . de 12 a 14 : xaxe, yaxe, zaxe . +c . . . . de 15 a 17 : xbase, ybase, zbase . +c . . . . 18 : hauteur . +c . . . . . si disque perce : . +c . . . . 1 : +-6 . +c . . . . de 9 a 10 : xcentr, ycentr . +c . . . . 19 : rayon interieur . +c . . . . 20 : rayon exterieur . +c . . . . . si tuyau : . +c . . . . 1 : +-7 . +c . . . . de 12 a 14 : xaxe, yaxe, zaxe . +c . . . . de 15 a 17 : xbase, ybase, zbase . +c . . . . 18 : hauteur . +c . . . . 19 : rayon interieur . +c . . . . 20 : rayon exterieur . +c . nomref . e . nbfich . nom de reference des fichiers . +c . lgnofi . e . nbfich . longueurs des noms des fichiers . +c . poinno . e .0:nbfich. pointeur dans le tableau des noms . +c . nomufi . e . lgtanf . noms des fichiers . +c . nomstr . e . nbfich . nom des structures . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme de lecture . +c . . . . 3 : type inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCZ0' ) +c +#include "nblang.h" +#include "motcle.h" +c + integer nbmcle + parameter ( nbmcle = 20 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbzord + integer nbfich + integer lgnofi(nbfich), poinno(0:nbfich) +c + character*8 nomref(nbfich), nomufi(*), nomstr(nbfich) +c + double precision cazord(nbmcle,nbzord) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer nrfich + integer nrzord, tyzord, tyzosi + integer numero, nrmcle +c + character*8 mclref(nbmcle) + character*200 sau200 +c + logical mccode(nbmcle) + logical mccod2(nbmcle) +c + double precision daux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c + character*13 messag(nblang,7) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de zones a raffiner :'',i8)' + texte(1,5) = '(''Numero de la zone en cours de recherche :'',i8)' + texte(1,6) = '(''Type de la zone : '',a)' + texte(1,7) = '(''Le type '',i8,'' est inconnu.'')' + texte(1,8) = '(''La valeur de '',a,'' est indecodable.'')' +c + texte(2,4) = '(''Number of zones to refine :'',i8)' + texte(2,5) = '(''Search for zone #'',i8)' + texte(2,6) = '(''Type of zone : '',a)' + texte(2,7) = '(''The type #'',i8,'' is unknown.'')' + texte(2,8) = '(''The value for '',a,'' cannot be uncoded.'')' +c +c 1234567890123 + messag(1,1) = 'Rectangle ' + messag(1,2) = 'Parallepipede' + messag(1,3) = 'Disque ' + messag(1,4) = 'Sphere ' + messag(1,5) = 'Cylindre ' + messag(1,6) = 'Disque perce ' + messag(1,7) = 'Tuyau ' +c + messag(2,1) = 'Rectangle ' + messag(2,2) = 'Parallepiped ' + messag(2,3) = 'Disk ' + messag(2,4) = 'Sphere ' + messag(2,5) = 'Cylindre ' + messag(2,6) = 'Disk ' + messag(2,7) = 'Pipe ' +c +c 1.3. ==> preliminaires +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbzord +#endif + mclref( 1) = mczrty + mclref( 2) = mcrxmi + mclref( 3) = mcrxma + mclref( 4) = mcrymi + mclref( 5) = mcryma + mclref( 6) = mcrzmi + mclref( 7) = mcrzma + mclref( 8) = mcrray + mclref( 9) = mcrxce + mclref(10) = mcryce + mclref(11) = mcrzce + mclref(12) = mcrxax + mclref(13) = mcryax + mclref(14) = mcrzax + mclref(15) = mcrxba + mclref(16) = mcryba + mclref(17) = mcrzba + mclref(18) = mcrhau + mclref(19) = mcrrai + mclref(20) = mcrrae +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) mclref +#endif +c +c==== +c 2. on parcourt toutes les posssibilites de zones de raffinement +c==== +c + do 20 , nrzord = 1 , nbzord +c +c 2.0. ==> On n'a rien au debut +c + do 201 , iaux = 1 , nbmcle + mccode(iaux) = .false. + 201 continue +c + do 200 , nrfich = 1 , nbfich +c +c 2.1. ==> si c'est un des mots-cles possibles, on verifie si c'est +c pour la bonne zone +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,*) nomref(nrfich) + nrmcle = -1 + do 21 , iaux = 1 , nbmcle +cgn write(ulsort,*) 'mclref(',iaux,') =', mclref(iaux) + if ( nomref(nrfich).eq.mclref(iaux) ) then + nrmcle = iaux +cgn write(ulsort,*) '==> nrmcle =',iaux + goto 211 + endif + 21 continue +c + 211 continue +c + if ( nrmcle.ge.1 ) then +c + call utchen ( nomstr(nrfich), numero, + > ulsort, langue, codret ) +c + if ( nrzord.ne.numero ) then + goto 200 + endif +c + else +c + goto 200 +c + endif +c + endif +c +c 2.2. ==> Recherche de la valeur +c 2.2.1. ==> Mise sous forme de chaine de la 3eme donnee sur la ligne +c + if ( codret.eq.0 ) then +c + iaux = poinno(nrfich-1) + 1 + jaux = lgnofi(nrfich) + call uts8ch ( nomufi(iaux), jaux, sau200, + > ulsort, langue, codret ) +c + endif +cgn write(ulsort,*) 'nrmcle =',nrmcle,nomufi(iaux), +cgn >'sau200 = ',sau200 +c +c 2.2.2. ==> Conversions +c + if ( codret.eq.0 ) then +c +c 2.2.2.1. ==> Conversion du type : entier a decoder, puis reel +c + if ( nrmcle.eq.1 ) then +c + call utchen ( sau200, tyzord, + > ulsort, langue, codret ) +c + cazord(nrmcle,nrzord) = dble(tyzord) + if ( tyzord.gt.0 ) then + tyzosi = 1 + else + tyzosi = -1 + endif + tyzord = abs(tyzord) +c +c 2.2.2.2. ==> Conversion des coordonnees : reel +c + elseif ( nrmcle.ge.2 ) then +c + call utchre ( sau200, daux, + > ulsort, langue, codret ) + cazord(nrmcle,nrzord) = daux +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,5)) nrzord + write (ulsort,texte(langue,8)) mclref(nrmcle) + endif +c + endif +c + endif +c +c 2.2.3. ==> Memorisation du passage par le mot-cle +c + if ( codret.eq.0 ) then +c + mccode(nrmcle) = .true. +c + endif +c +c 2.3. ==> Controle ; si on a tout trouve, on passe a la zone suivante +c + if ( codret.eq.0 ) then +c + if ( mccode(1) ) then +c +c 2.3.1. ==> Cas du rectangle +c + if ( tyzord.eq.1 ) then +c + if ( mccode(2) .and. mccode(3) .and. + > mccode(4) .and. mccode(5) ) then +c + goto 20 +c + endif +c +c 2.3.2. ==> Cas du parallelepipede +c + elseif ( tyzord.eq.2 ) then +c + if ( mccode(2) .and. mccode(3) .and. + > mccode(4) .and. mccode(5) .and. + > mccode(6) .and. mccode(7) ) then +c + goto 20 +c + endif +c +c 2.3.3. ==> Cas du disque +c + elseif ( tyzord.eq.3 ) then +c + if ( mccode( 8) .and. mccode( 9) .and. + > mccode(10) ) then +c + goto 20 +c + endif +c +c 2.3.4. ==> Cas de la sphere +c + elseif ( tyzord.eq.4 ) then +c + if ( mccode( 8) .and. mccode( 9) .and. + > mccode(10) .and. mccode(11) ) then +c + goto 20 +c + endif +c +c 2.3.5. ==> Cas du cylindre +c + elseif ( tyzord.eq.5 ) then +c + if ( mccode( 8) .and. + > mccode(12) .and. mccode(13) .and. + > mccode(14) .and. mccode(15) .and. + > mccode(16) .and. mccode(17) .and. + > mccode(18) ) then +c + goto 20 +c + endif +c +c 2.3.6. ==> Cas du disque perce +c + elseif ( tyzord.eq.6 ) then +c + if ( mccode( 9) .and. mccode(10) .and. + > mccode(19) .and. mccode(20) ) then +c + goto 20 +c + endif +c +c 2.3.7. ==> Cas du tuyau +c + elseif ( tyzord.eq.7 ) then +c + if ( mccode(12) .and. mccode(13) .and. + > mccode(14) .and. mccode(15) .and. + > mccode(16) .and. mccode(17) .and. + > mccode(18) .and. mccode(19) .and. + > mccode(20) ) then +c + goto 20 +c + endif +c +c 2.3.n. ==> Type inconnu +c + else + write (ulsort,texte(langue,7)) tyzord*tyzosi + codret = 3 + endif +c + endif +c + endif +c + 200 continue +c +c 2.4. ==> si on arrive ici, c'est qu'il en manque pour la zone courante +c + if ( codret.eq.0 ) then +c + do 240 , iaux = 1 , nbmcle + mccod2(iaux) = .false. + 240 continue +c + write (ulsort,texte(langue,5)) nrzord + write (ulsort,texte(langue,6)) messag(langue,tyzord) + if ( tyzord.eq.1 ) then + do 241 , iaux = 2 , 5 + mccod2(iaux) = .true. + 241 continue + elseif ( tyzord.eq.2 ) then + do 242 , iaux = 2 , 7 + mccod2(iaux) = .true. + 242 continue + elseif ( tyzord.eq.3 ) then + do 243 , iaux = 8 , 10 + mccod2(iaux) = .true. + 243 continue + elseif ( tyzord.eq.4 ) then + do 244 , iaux = 8 , 11 + mccod2(iaux) = .true. + 244 continue + elseif ( tyzord.ge.5 ) then + mccod2(8) = .true. + do 245 , iaux = 12 , 18 + mccod2(iaux) = .true. + 245 continue + elseif ( tyzord.eq.6 ) then + do 246 , iaux = 8 , 10 + mccod2(iaux) = .true. + 246 continue + mccod2(19) = .true. + elseif ( tyzord.eq.7 ) then + mccod2(8) = .true. + do 248 , iaux = 12 , 19 + mccod2(iaux) = .true. + 248 continue + endif + do 24 , iaux = 2 , nbmcle + if ( .not.mccode(iaux) .and. mccod2(iaux) ) then + write (ulsort,texte(langue,8)) mclref(iaux) + endif + 24 continue +c + codret = 2 +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c + call dmflsh(iaux) +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmczr.F b/src/tool/Utilitaire/utmczr.F new file mode 100644 index 00000000..20efc0a8 --- /dev/null +++ b/src/tool/Utilitaire/utmczr.F @@ -0,0 +1,272 @@ + subroutine utmczr ( ncazor, nbzord, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Mot-Cle - caracterisation des Zones a Raffiner +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ncazor . es . char*8 . nom de l'objet des zones a raffiner . +c . nbzord . s . 1 . nombre de zones a raffiner/deraffiner . +c . . . . si negatif, les zones sont 2D (en x et y) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : la configuration est perdue . +c . . . . 2 : probleme de lecture . +c . . . . 8 : Allocation impossible . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMCZR' ) +c +#include "nblang.h" +#include "motcle.h" +c + integer nbmcle + parameter ( nbmcle = 20 ) +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbzord +c + character*8 ncazor +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer codre0 + integer iaux, jaux + integer loptio + integer numero + integer nbfich +c + integer adnore, adlono, adpono, adnofi, adnoos + integer adzord +c + character*8 motcle + character*200 option +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> tout va bien +c + codret = 0 +c +c 1.2. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de zones a raffiner :'',i8)' + texte(1,9) = '(''Le mot-cle '',a,'' apparait :'',i8,'' fois.'')' + texte(1,11) = '(''La configuration est perdue ?'')' + texte(1,12) = '(''Probleme de lecture.'')' + texte(1,13) = '(''Donnees incoherentes.'')' + texte(1,18) = + >'(''Impossible d''''allouer la structure memorisant les choix.'')' +c + texte(2,4) = '(''Number of zones to refine :'',i8)' + texte(2,9) = '(''Keyword '',a,'' appears :'',i8,'' times.'')' + texte(2,11) = '(''Configuration is lost ?'')' + texte(2,12) = '(''Problem while reading.'')' + texte(2,13) = '(''Data without coherence.'')' + texte(2,18) = '(''Structure of choices cannot be allocated.'')' +c +c==== +c 2. recherche du nombre d'occurences du mot-cle de type +c Le nombre de zones de raffinement est egal au nombre de +c fois ou un type a ete declare +c==== +c + if ( codret.eq.0 ) then +c + motcle = mczrty + numero = 1 +c + call utfin1 ( motcle, numero, + > jaux, option, loptio, + > ulsort, langue, codre0 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) motcle, jaux +#endif +c +c 2.2. ==> aucune option n'a ete precisee +c + if ( codre0.eq.2 ) then +c + jaux = 0 + codret = 0 +c +c 2.3. ==> probleme de lecture +c + elseif ( codre0.ne.0 ) then +c + codret = 1 +c +c 2.4. ==> on peut y aller +c + else +c + codret = 0 +c + endif +c +c 2.5. ==> bilan +c + if ( codret.eq.0 ) then +c + nbzord = jaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbzord +#endif + else + codret = 2 + endif +c + endif +c +c==== +c 3. on alloue le receptacle des caracteristiques des zones +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocation ; codret = ', codret +#endif +c + if ( nbzord.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = nbzord*nbmcle + call gmalot ( ncazor, 'reel ', iaux, adzord, codret ) +c + endif +c + endif +c +c==== +c 4. recherche des adresses des objets GM lies aux noms des fichiers +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Recherche ; codret = ', codret +#endif +c + if ( nbzord.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD80', nompro +#endif + call utad80 ( nbfich, + > adnore, adlono, adpono, adnofi, adnoos, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. remplissage des tableaux +c==== +c + if ( nbzord.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMCZ0', nompro +#endif + call utmcz0 ( nbzord, rmem(adzord), + > nbfich, + > smem(adnore), imem(adlono), imem(adpono), + > smem(adnofi), smem(adnoos), + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, ncazor ) + endif +#endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10+codret)) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmemh.F b/src/tool/Utilitaire/utmemh.F new file mode 100644 index 00000000..6155a9fd --- /dev/null +++ b/src/tool/Utilitaire/utmemh.F @@ -0,0 +1,206 @@ + subroutine utmemh ( nomail, choix, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - MEnage du Maillage HOMARD +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . choix . e . 1 . choix du menage a faire . +c . . . . -1 : tous les menages . +c . . . . 0 : sauf les noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMEMH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer choix +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre0 +c + character*8 nhenti + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Maillage a nettoyer : '')' + texte(1,5) = '(''... Memorisations du deraffinement anterieur'')' + texte(1,6) = '(''..... Influence sur les '',a)' +c + texte(2,4) = '(''Mesh to be cleaned : '')' + texte(2,5) = '(''... Cleaning of previous unrefinement'')' + texte(2,6) = '(''.... Influence over '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + call gmprsx (nompro, nomail ) +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 3. les menages +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) +#endif +c + do 31 , iaux = choix , 7 +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.-1 ) then + nhenti = nhnoeu + elseif ( iaux.eq.0 ) then + nhenti = nhmapo + elseif ( iaux.eq.1 ) then + nhenti = nharet + elseif ( iaux.eq.2 ) then + nhenti = nhtria + elseif ( iaux.eq.3 ) then + nhenti = nhtetr + elseif ( iaux.eq.4 ) then + nhenti = nhquad + elseif ( iaux.eq.5 ) then + nhenti = nhpyra + elseif ( iaux.eq.6 ) then + nhenti = nhhexa + elseif ( iaux.eq.7 ) then + nhenti = nhpent + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,3,iaux) +#endif +c + call gmobal ( nhenti//'.Deraffin', codre0 ) + if ( codre0.eq.2 ) then + call gmlboj ( nhenti//'.Deraffin', codret ) + elseif ( codre0.ne.0 ) then + codret = 1 + endif +c + endif +c + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmess.F b/src/tool/Utilitaire/utmess.F new file mode 100644 index 00000000..7786a91d --- /dev/null +++ b/src/tool/Utilitaire/utmess.F @@ -0,0 +1,170 @@ + subroutine utmess ( messag, nblxms, nblims, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c UTilitaire - MESSages +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . messag . s . ch<200 . nom du fichier de configuration . +c . nblxms . e . 1 . nombre de lignes maximum du message . +c . nblims . s . 1 . nombre de lignes du message . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMESS' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nblxms, nblims +c + character*40 messag(nblang,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations des messages +c==== +c + codret = 0 +c +#include "impr01.h" +c +#ifdef NEPTUNE + messag(1,1) = 'Cette version est destinee exclusivement' + messag(1,2) = ' au couplage avec Code_Neptune. ' + messag(2,1) = ' Use with Code_Neptune only ' + messag(2,2) = ' ' + iaux = 2 +#else +#ifdef SATURNE + messag(1,1) = 'Cette version est destinee exclusivement' + messag(1,2) = ' au couplage avec Code_Saturne. ' + messag(2,1) = ' Use with Code_Saturne only ' + messag(2,2) = ' ' + iaux = 2 +#else +#ifdef ESTEL +c 1234567890123456789012345678901234567890 + messag(1,1) = 'Cette version est destinee exclusivement' + messag(1,2) = ' au couplage avec ESTEL_3D. ' + messag(1,3) = ' Simulation dans le systeme Telemac ' + messag(2,1) = ' Use with ESTEL_3D only ' + messag(2,2) = ' Simulation in Telemac system ' + messag(2,3) = ' ' + iaux = 3 +#else +#ifdef ASTER + messag(1,1) = 'Cette version est destinee exclusivement' + messag(1,2) = ' au couplage avec Code_Aster. ' + messag(2,1) = ' Use with Code_Aster only ' + messag(2,2) = ' ' + iaux = 2 +#else +#ifdef CEA + messag(1,1) = ' Cette version est destinee au CEA ' + messag(1,2) = ' exclusivement pour des travaux de R&D ' + messag(1,3) = ' Aucune commercialisation des resultats ' + messag(1,4) = ' n''est possible sans autorisation EDF. ' + messag(2,1) = ' This release is given to CEA ' + messag(2,2) = ' for R&D studies only. ' + messag(2,3) = ' No trade is allowed ' + messag(2,4) = ' without EDF authorization ' + iaux = 4 +#else +#ifdef SALOME + messag(1,1) = ' Usage exclusivement avec SALOME ' + messag(2,1) = ' Use with SALOME only ' + iaux = 1 +#else + messag(1,1) = ' Usage exclusivement avec SALOME ' + messag(2,1) = ' Use with SALOME only ' + iaux = 1 +c 1234567890123456789012345678901234567890 +#endif +#endif +#endif +#endif +#endif +#endif +c +c==== +c 2. controle +c==== +c + if ( iaux.le.nblxms ) then + nblims = iaux + else + codret = 1 + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmfar.F b/src/tool/Utilitaire/utmfar.F new file mode 100644 index 00000000..95b2d1ac --- /dev/null +++ b/src/tool/Utilitaire/utmfar.F @@ -0,0 +1,154 @@ + subroutine utmfar ( nomail, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - passage de Mere a Fille pour les ARetes +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMFAR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer degre + integer codre1, codre2 + integer codre0 +c + character*8 nhenti(2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(5x,''Reperage des filles a partir des meres pour les aretes'')' +c + texte(2,4) = '(5x,''Son arrays from father arrays for edges'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomail//'.Arete') +#endif +c + call gmliat ( nomail, 3, degre, codre1 ) + if ( degre.eq.1 ) then + call gmnomc ( nomail//'.Arete.HOM_Se02' , nhenti(1), codre2 ) + else + call gmnomc ( nomail//'.Arete.HOM_Se03' , nhenti(1), codre2 ) + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c==== +c 3. Appel du programme generique +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Programme generique ; codret', codret +#endif + if ( codret.eq.0 ) then +c + iaux = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFEN', nompro +#endif + call utmfen ( nhenti(1), nhenti(2), iaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmfen.F b/src/tool/Utilitaire/utmfen.F new file mode 100644 index 00000000..53e6025b --- /dev/null +++ b/src/tool/Utilitaire/utmfen.F @@ -0,0 +1,356 @@ + subroutine utmfen ( nhenti, nhent2, nbent2, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - passage de Mere a Fille pour les ENtites +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhenti . e . char8 . nom de l'objet decrivant l'entite . +c . nhent2 . e . char8 . nom de l'objet decrivant l'entite frere . +c . nbent2 . e . 1 . nombre d'entite frere . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMFEN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*8 nhenti, nhent2 +c + integer nbent2 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbenti, pfille, pmere, lamere + integer numead + integer pfill2 + integer iaux, jaux + integer ideb, ifin, ideb2 + integer codre1, codre2 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''... Reperage des filles a partir des meres'')' + texte(1,5) = '(''. Nombre d''''entites :'',i10)' + texte(1,6) = '(''. Nombre d''''entites soeurs :'',i10)' + texte(1,7) = '(''. Numero de la mere adoptive :'',i10))' +c + texte(2,4) = '(''... Son arrays from father arrays'')' + texte(2,5) = '(''. Number of entities :'',i10)' + texte(2,6) = '(''. Number of brother entities:'',i10)' + texte(2,7) = '(''. Number for adoptive mother:'',i10))' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhenti ) +#endif +c +c 2.1. ==> Parente +c + call gmliat ( nhenti, 1, nbenti, codre1 ) + call gmadoj ( nhenti//'.Mere', pmere, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbenti + write (ulsort,texte(langue,6)) nbent2 +#endif +c +c 2.2. ==> Eventuelle parente adoptive +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03', nompro +#endif + iaux = 5 + call utad03 ( iaux, nhenti, + > jaux, jaux, numead, + > jaux, jaux, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) numead +#endif +c + endif +c +c==== +c 3. Creation du tableau des filles +c Attention, la convention homard veut que le tableau soit cree, +c meme s'il est vide +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Creation tableau ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( nbenti.le.50 ) then + call gmprsx (nompro, nhenti//'.Mere' ) + else + call gmprot (nompro, nhenti//'.Mere', 1, 50) + call gmprot (nompro, nhenti//'.Mere', max(51,nbenti-50),nbenti ) + endif +#endif +c + call gmobal ( nhenti//'.Fille', codre1 ) +c + if ( codre1.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Allocation avec nbenti', nbenti +#endif + call gmaloj ( nhenti//'.Fille', ' ', nbenti, pfille, codre2 ) +c + if ( codre2.eq.0 ) then +c + ideb = pfille + ifin = pfille + nbenti - 1 + do 31 , iaux = ideb , ifin + imem(iaux) = 0 + 31 continue +c + endif +c + elseif ( codre1.eq.2 ) then +c + call gmadoj ( nhenti//'.Fille', pfille, iaux, codre2 ) + codre1 = 0 +c + else + codre2 = 2 +c + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c==== +c 4. Entite frere eventuelle +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Entite frere eventuelle ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbent2.ne.0 ) then +c + call gmobal ( nhent2//'.Fille', codre1 ) +c + if ( codre1.eq.0 ) then +c + call gmaloj ( nhent2//'.Fille', ' ', nbent2, pfill2, codre2 ) +c + if ( codre2.eq.0 ) then +c + ideb = pfill2 + ifin = pfill2 + nbent2 - 1 + do 41 , iaux = ideb , ifin + imem(iaux) = 0 + 41 continue +c + endif +c + elseif ( codre1.eq.2 ) then +c + call gmadoj ( nhent2//'.Fille', pfill2, iaux, codre2 ) + codre1 = 0 +c + else + codre2 = 2 +c + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 5. traitement +c pour chaque entite qui est fille, on marque la mere +c attention : la convention homard veut que seule la fille +c ainee soit marquee +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. traitement ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + ideb = pfille - 1 + ifin = nbenti - 1 +c +c 5.1. ==> sans entite frere +c + if ( nbent2.eq.0 ) then +c + do 51 , iaux = 0 , ifin +c + lamere = imem(pmere+iaux) +c +c lamere > 0 : il existe une mere +c + if ( lamere.gt.0 ) then + if ( imem(ideb+lamere).eq.0 ) then + imem(ideb+lamere) = iaux + 1 + endif + endif +c + 51 continue +c +c 5.2. ==> avec une entite frere +c + else +c + ideb2 = pfill2 - 1 +c + do 52 , iaux = 0 , ifin +c + lamere = imem(pmere+iaux) +c +c lamere > 0 : il existe une mere et elle est de meme type +c que la fille +c +cgn print *,'Face =', iaux+1,' ==> lamere =', lamere + if ( lamere.gt.0 ) then + if ( imem(ideb+lamere).eq.0 ) then + imem(ideb+lamere) = iaux + 1 + endif +c +c lamere < 0 : il existe une mere et elle est du type frere de +c celui de la fille +c attention : il ne faut rien faire quand ce numero vaut +c le numero de mere adoptive. Cela signifie que c'est +c une mere adoptive pour traiter les non conformites +c initiales. S'il n'y en a pas, numead vaut 0 +c + elseif ( lamere.lt.0 .and. lamere.ne.numead ) then + if ( imem(ideb2-lamere).eq.0 ) then + imem(ideb2-lamere) = -( iaux + 1 ) + endif + endif +c + 52 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( nbenti.le.50 ) then + call gmprsx (nompro, nhenti//'.Mere' ) + else + call gmprot (nompro, nhenti//'.Mere', 1, 50) + call gmprot (nompro, nhenti//'.Mere', max(51,nbenti-50), nbenti) + endif + if ( nbenti.le.50 ) then + call gmprsx (nompro, nhenti//'.Fille' ) + else + call gmprot (nompro, nhenti//'.Fille', 1, 50) + call gmprot (nompro, nhenti//'.Fille', max(51,nbenti-50),nbenti) + endif +#endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmffa.F b/src/tool/Utilitaire/utmffa.F new file mode 100644 index 00000000..c5c00511 --- /dev/null +++ b/src/tool/Utilitaire/utmffa.F @@ -0,0 +1,243 @@ + subroutine utmffa ( nomail, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - passage de Mere a Fille pour les FAces +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMFFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nbenti(2) + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + character*4 saux04(2) + character*8 nhenti(2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Reperage des fils a partir des peres pour les faces'')' + texte(1,5) = '(''. Type d''''entites : '',a)' + texte(1,6) = '(''. Nombre d''''entites :'',i10)' +c + texte(2,4) = '(''Son arrays from father arrays for faces'')' + texte(2,5) = '(''. Type of entities : '',a)' + texte(2,6) = '(''. Number of entities:'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +c + call gmliat ( nomail, 3, degre, codre0 ) + codret = max ( abs(codre0), codret ) +c +c==== +c 3. les triangles puis les quadrangles +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + call gmprsx (nompro, nomail//'.Face' ) + endif +#endif +c + do 30 , iaux = 1 , 2 +c +c 3.1. ==> nom de la branche +c + if ( codret.eq.0 ) then +c + jaux = mod(iaux,2) + 1 + if ( degre.eq.1 ) then + saux04(iaux) = 'Tr03' + saux04(jaux) = 'Qu04' + else + if ( mod(mailet,2).eq.0 .or. mod(mailet,3).eq.0 ) then + saux04(iaux) = 'Tr07' + saux04(jaux) = 'Qu09' + else + saux04(iaux) = 'Tr06' + saux04(jaux) = 'Qu08' + endif + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) saux04(1) +cgn call gmprsx (nompro, nomail//'.Face.HOM_'//saux04(1) ) + endif +#endif +c + call gmobal ( nomail//'.Face.HOM_'//saux04(1) , codre0 ) + if ( codre0.eq.0 ) then + goto 30 + elseif ( codre0.ne.1 ) then + codret = 1 + endif +c + endif +c +c 3.2. ==> combien d'entites de ce type ? +c + if ( codret.eq.0 ) then +c + call gmliat ( nomail//'.Face.HOM_'//saux04(1), + > 1, nbenti(1), codre0 ) + codret = max ( abs(codre0), codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,6)) nbenti(1) + endif +#endif +c + endif +c +c 3.3. ==> s'il y en a, on recupere la structure qui les decrit +c sinon, on passe a la suite +c + if ( codret.eq.0 ) then +c + if ( nbenti(1).eq.0 ) then +c + goto 30 +c + else +c + call gmnomc ( nomail//'.Face.HOM_'//saux04(1), + > nhenti(1), codre1 ) + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 3.4. ==> A-t-on le type frere ? +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.Face.HOM_'//saux04(2) , codre0 ) + if ( codre0.eq.1 ) then + call gmliat ( nomail//'.Face.HOM_'//saux04(2), + > 1, nbenti(2), codre1 ) + call gmnomc ( nomail//'.Face.HOM_'//saux04(2), + > nhenti(2), codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + else + nbenti(2) = 0 + endif +c + endif +c +c 3.5. ==> Appel du programme generique +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFEN', nompro +#endif + call utmfen ( nhenti(1), nhenti(2), nbenti(2), + > ulsort, langue, codret ) +c + endif +c + 30 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmfv1.F b/src/tool/Utilitaire/utmfv1.F new file mode 100644 index 00000000..36a40d76 --- /dev/null +++ b/src/tool/Utilitaire/utmfv1.F @@ -0,0 +1,231 @@ + subroutine utmfv1 ( typenh, nbvoto, nbvoco, + > filvol, fvpyte, + > pertet, perpyr, + > pthepe, pphepe, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - passage de Mere a Fille pour les Volumes - 1 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . nbvoto . e . 1 . nombre total de volumes concernes . +c . nbvoco . e . 1 . nombre de volumes decoupes en conformite . +c . filvol . es . nbvoto . fils des volumes . +c . fvpyte . e .2*nbvoco. fvpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du volume k tel que filvol(k) =-j . +c . . . . fvpyte(2,j) = numero du 1er tetraedre . +c . . . . fils du volume k tel que filvol(k) = -j . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . perpyr . e . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . pthepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . pphepe . es . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMFV1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombte.h" +#include "nombpy.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, nbvoto, nbvoco + integer filvol(nbvoto) + integer fvpyte(2,nbvoco) + integer pertet(nbteto) + integer perpyr(nbpyto) + integer pthepe(*) + integer pphepe(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer indic1, indic2 + integer lapyra, letetr +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''. Reperage des filles des '',a)' + texte(1,5) = + >'(''.. Nombre de '',a,'' decoupes en conformite :'',i10)' + texte(1,6) = '(''Probleme de parentes pour les '',a)' + texte(1,7) = '(''Indice du pere de '',a,i10,'' :'',i10))' + texte(1,8) = '(''Incoherence.''))' + texte(1,9) = '(''. Reperage des filles du'',i6,''-ieme '',a)' +c + texte(2,4) = '(''. Son arrays from father arrays for '',a)' + texte(2,5) = + >'(''.. Number of '',a,'' cut for conformal reasons :'',i10)' + texte(2,6) = '(''Problems with the parents of the '',a)' + texte(2,7) = + > '(''Index for the father of '',a,'',i10,'' is '',i10))' + texte(2,8) = '(''Incoherence.''))' + texte(2,9) = '(''. Search for the sons of'',i6,''-th '',a)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) mess14(langue,3,typenh), nbvoco +#endif +c +c==== +c 2. parcours des volumes concernes +c==== +c + do 21 , iaux = 1 , nbvoco +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) iaux, mess14(langue,1,typenh) +#endif +c +c 2.1. ==> Examen par les pyramides +c + lapyra = fvpyte(1,iaux) + if ( lapyra.gt.0 ) then + indic1 = -perpyr(lapyra) + if ( indic1.eq.0 ) then + codret = 1 + endif + else + indic1 = 0 + endif +c +c 2.2. ==> Examen par les tetraedres +c + letetr = fvpyte(2,iaux) + if ( letetr.gt.0 ) then + indic2 = -pertet(letetr) + if ( indic2.eq.0 ) then + codret = 2 + endif + else + indic2 = 0 + endif +c +c 2.3. ==> Controle et affectation +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,1,5),lapyra, indic1 + write (ulsort,texte(langue,7)) mess14(langue,1,3),letetr, indic2 +#endif + if ( indic1.ne.0 .and. indic2.ne.0 ) then + if ( indic1.ne.indic2 ) then + codret = 3 + endif + endif +c + if ( codret.eq.0 ) then + if ( indic1.ne.0 ) then + filvol(pphepe(indic1)) = -iaux + else + filvol(pthepe(indic2)) = -iaux + endif + endif +c + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.eq.1 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,5) + elseif ( codret.eq.2 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,3) + elseif ( codret.eq.3 ) then + write (ulsort,texte(langue,7)) mess14(langue,1,5),lapyra, indic1 + write (ulsort,texte(langue,7)) mess14(langue,1,3),letetr, indic2 + write (ulsort,texte(langue,8)) + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmfvo.F b/src/tool/Utilitaire/utmfvo.F new file mode 100644 index 00000000..0fa5d816 --- /dev/null +++ b/src/tool/Utilitaire/utmfvo.F @@ -0,0 +1,425 @@ + subroutine utmfvo ( nomail, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - passage de Mere a Fille pour les VOlumes +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMFVO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer degre, nbenti(4), nbent0 + integer codre1, codre2 + integer codre0 + integer pperte + integer pfilhp, adhps2 + integer adtes2, adpys2 + integer pperpy + integer nbhpco +c + character*4 saux04(4) + character*8 nhenti(2) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + >'(''== Reperage des filles a partir des meres pour les volumes'')' + texte(1,5) = '(/,''. Type d''''entites : '',a)' + texte(1,6) = '(''. Nombre de '',a,'' :'',i8)' + texte(1,7) = '(''.. Pas de filiation ..'')' + texte(1,8) = '(''.. Aucun traitement a faire ..'')' +c + texte(2,4) = '(''== Son arrays from father arrays for volumes'')' + texte(2,5) = '(/,''. Type of entities: '',a)' + texte(2,6) = '(''. Number of '',a,'':'',i8)' + texte(2,7) = '(''.. No sons ..'')' + texte(2,8) = '(''.. Nothing to do ..'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +c + call gmliat ( nomail, 3, degre, codre0 ) + codret = max ( abs(codre0), codret ) +c + if ( codret.eq.0 ) then +c + if ( degre.eq.1 ) then + saux04(1) = 'Te04' + saux04(2) = 'He08' + saux04(3) = 'Py05' + saux04(4) = 'Pe06' + else + saux04(1) = 'Te10' + saux04(2) = 'He20' + saux04(3) = 'Py13' + saux04(4) = 'Pe15' + endif +c + endif +c +c==== +c 3. Traitement des filiations de types identiques +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Traitement ; codret = ', codret +#endif +c + do 30 , iaux = 1 , 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Traitement ',iaux,' ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) saux04(iaux) +ccc call gmprsx (nompro, nomail//'.Volume.HOM_'//saux04(iaux) ) + endif +#endif +c + call gmobal ( nomail//'.Volume.HOM_'//saux04(iaux) , codre0 ) + if ( codre0.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) +#endif + nbenti(iaux) = 0 + goto 30 + elseif ( codre0.ne.1 ) then + codret = 1 + endif +c + endif + +c 3.2. ==> combien d'entites de ce type ? +c + if ( codret.eq.0 ) then +c + call gmliat ( nomail//'.Volume.HOM_'//saux04(iaux), + > 1, nbenti(iaux), codre0 ) + codret = max ( abs(codre0), codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( iaux.eq.1 ) then + jaux = 3 + elseif ( iaux.eq.2 ) then + jaux = 6 + elseif ( iaux.eq.3 ) then + jaux = 5 + else + jaux = 7 + endif + write (ulsort,texte(langue,6)) + > mess14(langue,3,jaux), nbenti(iaux) + endif +#endif +c + endif +c +c 3.3. ==> s'il y en a, on recupere la structure qui les decrit +c sinon, on passe a la suite +c + if ( codret.eq.0 ) then +c + if ( nbenti(iaux).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) +#endif + goto 30 +c + else +c + call gmnomc ( nomail//'.Volume.HOM_'//saux04(iaux), + > nhenti(1), codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c 3.5. ==> Appel du programme generique +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro, +cgn > nomail//'.Volume.HOM_'//saux04(iaux)//'.Mere' ) +c + nbent0 = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFEN', nompro +#endif + call utmfen ( nhenti(1), nhenti(2), nbent0, + > ulsort, langue, codret ) +c + endif +cgn call gmprsx (nompro, +cgn > nomail//'.Volume.HOM_'//saux04(iaux)//'.Fille' ) +c + 30 continue +c +c==== +c 4. Prise en compte des filiations de type differents : +c hexaedre --> tetraedre/pyramide +c pentaedre --> tetraedre/pyramide +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. Filiations hexa/tet-pyr; codret = ', codret + write (ulsort,90002) 'nbenti', nbenti +#endif +c + if ( nbenti(1).gt.0 .or. nbenti(3).gt.0 ) then +c + do 40 , iaux = 2 , 4, 2 +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) '4. Traitement numero',iaux + write (ulsort,90003) 'Entite mere', saux04(iaux) + endif +#endif +c +cgn call gmprsx (nompro,nomail//'.Volume' ) +cgn call gmprsx (nompro,nomail//'.Volume.HOM_'//saux04(iaux) ) +cgn call gmprsx +cgn > (nompro,nomail//'.Volume.HOM_'//saux04(iaux)//'.Fille') +cgn call gmprsx +cgn > (nompro,nomail//'.Volume.HOM_'//saux04(iaux)//'.InfoSup2' ) +c +c 4.1. ==> A-t-on une telle filiation ? +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.Volume.HOM_'//saux04(iaux)//'.InfoSup2', + > codre0 ) +c + if ( codre0.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) +#endif + goto 40 + elseif ( codre0.ne.2 ) then + codret = 1 + endif +c + endif +c +c 4.2. ==> Les adresses +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.2. Adresses ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c +c 4.2.1.==> Pour les tetraedres +c + if ( nbenti(1).gt.0 ) then +c + call gmadoj ( nomail//'.Volume.HOM_'//saux04(1)//'.Mere', + > pperte, jaux, codre1 ) + call gmobal ( nomail//'.Volume.HOM_'//saux04(1)//'.InfoSup2', + > codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( + > nomail//'.Volume.HOM_'//saux04(1)//'.InfoSup2', + > adtes2, jaux, codre2 ) + else + codre2 = codre0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'tetraedres - codre1/2', codre1, codre2 +#endif +c + endif +c +c 4.2.2.==> Pour les pyramides +c + if ( nbenti(3).gt.0 ) then +c + call gmadoj ( nomail//'.Volume.HOM_'//saux04(3)//'.Mere', + > pperpy, jaux, codre1 ) + call gmobal ( nomail//'.Volume.HOM_'//saux04(3)//'.InfoSup2', + > codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( + > nomail//'.Volume.HOM_'//saux04(3)//'.InfoSup2', + > adpys2, jaux, codre2 ) + else + codre2 = codre0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'pyramides - codre1/2', codre1, codre2 +#endif +c + endif +c +c 4.2.3.==> Pour les volumes +c + call gmadoj ( + > nomail//'.Volume.HOM_'//saux04(iaux)//'.Fille', + > pfilhp, jaux, codre1 ) + call gmobal ( + > nomail//'.Volume.HOM_'//saux04(iaux)//'.InfoSup2', + > codre0 ) + if ( codre0.eq.2 ) then + call gmadoj ( + > nomail//'.Volume.HOM_'//saux04(iaux)//'.InfoSup2', + > adhps2, nbhpco, codre2 ) + else + codre2 = codre0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'volumes - codre1/2', codre1, codre2 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbhpco', nbhpco +#endif +c + endif +c +c 4.3. ==> Traitement +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4.3. Traitement ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbhpco.ne.0 ) then +c + nbhpco = nbhpco/2 +c + if ( iaux.eq.2 ) then + jaux = 6 + else + jaux = 7 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMFV1_'//saux04(iaux), nompro +#endif + call utmfv1 ( jaux, nbenti(iaux), nbhpco, + > imem(pfilhp), imem(adhps2), + > imem(pperte), imem(pperpy), + > imem(adtes2), imem(adpys2), + > ulsort, langue, codret) +c + endif +c + endif +c + 40 continue +cgn call gmprsx (nompro, nomail//'.Volume.HOM_'//saux04(2)//'.Fille' ) +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmmc1.F b/src/tool/Utilitaire/utmmc1.F new file mode 100644 index 00000000..5701dae0 --- /dev/null +++ b/src/tool/Utilitaire/utmmc1.F @@ -0,0 +1,183 @@ + subroutine utmmc1 ( sdim, nbnoto, + > coonca, coocst, sdimre, ncnoeu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Minimum/Maximum des Coordonnees - phase 1 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sdim . e . 1 . dimension . +c . nbnoto . e . 1 . nombre total de noeuds . +c . coonca . e . nbnoto . coordonnees des noeuds . +c . coocst . s . 11 . 1 : coordonnee constante eventuelle . +c . . . . 2, 3, 4 : xmin, ymin, zmin . +c . . . . 5, 6, 7 : xmax, ymax, zmax . +c . . . . 8, 9, 10 : -1 si constant, max-min sinon . +c . . . . 11 : max des (max-min) . +c . sdimre . s . 1 . dimension reelle . +c . ncnoeu . es . 1 . structure des noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMMC1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "indefr.h" +c +c 0.3. ==> arguments +c + integer sdim, nbnoto, dimcst + integer sdimre +c + double precision coonca(nbnoto,sdim), coocst(11) +c + character*8 ncnoeu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Direction '',a1,'' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(1,5) = '(/,8x,''La coordonnee'',i2,'' est constante.'')' + texte(1,6) = '(8x,''Elle vaut : '',g12.4)' + texte(1,7) = + > '(50(''*''),/,''Taille maximale :'',g12.5,/,50(''*''))' +c + texte(2,4) = + > '(a1,''direction '','' : mini = '',g12.5,'' maxi = '',g12.5)' + texte(2,5) = '(/,8x,''The coordinate #'',i2,'' is constant.'')' + texte(2,6) = '(8x,''Its value is : '',g12.4)' + texte(2,7) = + > '(50(''*''),/,''Maximum size :'',g12.5,/,50(''*''))' +c +c 1.2. ==> constantes +c + codret = 0 +c +c==== +c 2. coordonnees extremes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTMMCO', nompro +#endif + call utmmco ( coocst(2), coocst(5), coocst(8), + > nbnoto, sdim, coonca, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,4)) 'x', coocst(2), coocst(5) + write (ulsort,texte(langue,4)) 'y', coocst(3), coocst(6) + if ( sdim.eq.3 ) then + write (ulsort,texte(langue,4)) 'z', coocst(4), coocst(7) + endif + endif +#endif +c +c==== +c 3. tests et memorisation +c==== +c + if ( codret.eq.0 ) then +c + dimcst = 0 + coocst(1) = rindef + sdimre = 0 +c + do 30 , iaux = 1 , sdim +c + if ( coocst(iaux+7).lt.0.d0 ) then + dimcst = iaux + call gmecat ( ncnoeu, 3, dimcst, codret ) + coocst(1) = coocst(iaux+1) + write (ulsort,texte(langue,5)) dimcst + write (ulsort,texte(langue,6)) coocst(1) + else + sdimre = sdimre + 1 + endif +c + 30 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmmco.F b/src/tool/Utilitaire/utmmco.F new file mode 100644 index 00000000..ec702a13 --- /dev/null +++ b/src/tool/Utilitaire/utmmco.F @@ -0,0 +1,189 @@ + subroutine utmmco ( xyzmin, xyzmax, xyzeps, + > nbnoto, sdim, coonoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Minimum/Maximum des COordonnees +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . xyzmin . s . 3 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) minimales du domaine total . +c . xyzmax . s . 3 . abscisse (i=1), ordonnee (i=2) et . +c . . . . cote (i=3) maximales du domaine total . +c . xyzeps . s . 4 . -1 si min = max dans la direction, . +c . . . . ecart sinon, puis ecart maximal . +c . nbnoto . e . 1 . nombre total de noeuds . +c . sdim . e . 1 . dimension . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMMCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbnoto, sdim +c + double precision coonoe (nbnoto,sdim) + double precision xyzmin(3), xyzmax(3), xyzeps(4) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de noeuds : '',i10)' + texte(1,5) = '(''Dimension : '',i8)' + texte(1,6) = + > '(''direction * minimum * maximum * ecart'',/,50(''*''))' + texte(1,7) = + > '(50(''*''),/,''Taille maximale :'',g12.5,/,50(''*''))' +c + texte(2,4) = '(''Number of nodes : '',i10)' + texte(2,5) = '(''Dimension : '',i8)' + texte(2,6) = + > '(''direction * minimum * maximum * shift'',/,50(''*''))' + texte(2,7) = + > '(50(''*''),/,''Maximum size :'',g12.5,/,50(''*''))' +c + 1000 format(5x,a1,4x,3('*',g12.5)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbnoto + write (ulsort,texte(langue,5)) sdim +#endif +c + codret = 0 +c +c==== +c 2. min/max des coordonnees et tolerance +c==== +c 2.1. ==> Mise a zero de la 3eme dimension eventuellement absente +c + do 21 , iaux = sdim+1 , 3 + xyzmin(iaux) = 0.d0 + xyzmax(iaux) = 0.d0 + 21 continue +c +c 2.2. ==> Recherche des extremes +c + xyzeps(4) = 0.d0 + do 22 , iaux = 1 , sdim +c + xyzmin(iaux) = coonoe(1,iaux) + xyzmax(iaux) = coonoe(1,iaux) + do 220 , jaux = 2 , nbnoto + xyzmin(iaux) = min ( xyzmin(iaux), coonoe(jaux,iaux) ) + xyzmax(iaux) = max ( xyzmax(iaux), coonoe(jaux,iaux) ) + 220 continue + xyzeps(iaux) = xyzmax(iaux) - xyzmin(iaux) + xyzeps(4) = max ( xyzeps(4), xyzeps(iaux) ) +c + 22 continue +c +c 2.3. ==> Notation des coordonnees constantes +c Si pour une coordonnee, l'ecart entre le min et le max +c est 1 million de fois plus petit que le max des ecarts, +c c'est que le probleme est vraisemblablement plan dans cette +c direction. On memorise cela en mettant une tolerance negative. +c Sinon, on memorise l'ecart min/max. +c Ces valeurs sont totalement pifometriques. +c + do 23 , iaux = 1 , 3 + if ( xyzeps(iaux)/xyzeps(4).lt.1.d-6 ) then + xyzeps(iaux) = -1.d0 + endif + 23 continue +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,texte(langue,6)) + write (ulsort,1000) 'x', xyzmin(1), xyzmax(1), xyzeps(1) + write (ulsort,1000) 'y', xyzmin(2), xyzmax(2), xyzeps(2) + if ( sdim.eq.3 ) then + write (ulsort,1000) 'z', xyzmin(3), xyzmax(3), xyzeps(3) + endif + write (ulsort,texte(langue,7)) xyzeps(4) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmnmj.F b/src/tool/Utilitaire/utmnmj.F new file mode 100644 index 00000000..39d22e84 --- /dev/null +++ b/src/tool/Utilitaire/utmnmj.F @@ -0,0 +1,302 @@ + subroutine utmnmj ( option, chaine, lgchai, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - convertit MiNuscule/MaJuscule +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de la conversion . +c . . . . 1 : de minuscule a majuscule . +c . . . . 2 : de majuscule a minuscule . +c . . . . si negatif, on interdit tout caractere . +c . . . . non alphabetique . +c . chaine . es .char*(*). chaine de caractere a convertir . +c . lgchai . s . 1 . longueur de la chaine traitee . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvaise option . +c . . . . 2 : il existe un caractere non alphabetique. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMNMJ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option, lgchai +c + character*(*) chaine +c + integer ulsort, langue, codret +c + character*01 saux01 +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Chaine a convertir : '',a)' + texte(1,5) = '(''Chaine convertie : '',a)' + texte(1,6) = '(''Longueur = '',i8)' + texte(1,7) = '(''Option : '',i8)' + texte(1,8) = '(''Cette option est inconnue.'')' +c + texte(2,4) = '(''String before conversion : '',a)' + texte(2,5) = '(''String after conversion : '',a)' + texte(2,6) = '(''Length = '',i8)' + texte(2,7) = '(''Option : '',i8)' + texte(2,8) = '(''This option is unknown.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) chaine +#endif +c +c==== +c 2. Longueur de la chaine +c==== +c + call utlgut ( lgchai, chaine, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) lgchai +#endif +c +c==== +c 3. Modification +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> De minuscule a majuscule +c + if ( abs(option).eq.1 ) then +c + do 31 , iaux = 1 , lgchai +c + saux01 = chaine(iaux:iaux) +c + if ( saux01.eq.'a' ) then + saux01 = 'A' + elseif ( saux01.eq.'b' ) then + saux01 = 'B' + elseif ( saux01.eq.'c' ) then + saux01 = 'C' + elseif ( saux01.eq.'d' ) then + saux01 = 'D' + elseif ( saux01.eq.'e' ) then + saux01 = 'E' + elseif ( saux01.eq.'f' ) then + saux01 = 'F' + elseif ( saux01.eq.'g' ) then + saux01 = 'G' + elseif ( saux01.eq.'h' ) then + saux01 = 'H' + elseif ( saux01.eq.'i' ) then + saux01 = 'I' + elseif ( saux01.eq.'j' ) then + saux01 = 'J' + elseif ( saux01.eq.'k' ) then + saux01 = 'K' + elseif ( saux01.eq.'l' ) then + saux01 = 'L' + elseif ( saux01.eq.'m' ) then + saux01 = 'M' + elseif ( saux01.eq.'n' ) then + saux01 = 'N' + elseif ( saux01.eq.'o' ) then + saux01 = 'O' + elseif ( saux01.eq.'p' ) then + saux01 = 'P' + elseif ( saux01.eq.'q' ) then + saux01 = 'Q' + elseif ( saux01.eq.'r' ) then + saux01 = 'R' + elseif ( saux01.eq.'s' ) then + saux01 = 'S' + elseif ( saux01.eq.'t' ) then + saux01 = 'T' + elseif ( saux01.eq.'u' ) then + saux01 = 'U' + elseif ( saux01.eq.'v' ) then + saux01 = 'V' + elseif ( saux01.eq.'w' ) then + saux01 = 'W' + elseif ( saux01.eq.'x' ) then + saux01 = 'X' + elseif ( saux01.eq.'y' ) then + saux01 = 'Y' + elseif ( saux01.eq.'z' ) then + saux01 = 'Z' + else + if ( option.lt.0 ) then + codret = 2 + endif + endif +c + chaine(iaux:iaux) = saux01 +c + 31 continue +c +c 3.2. ==> De majuscule a minuscule +c + elseif ( abs(option).eq.2 ) then +c + do 32 , iaux = 1 , lgchai +c + saux01 = chaine(iaux:iaux) +c + if ( saux01.eq.'A' ) then + saux01 = 'a' + elseif ( saux01.eq.'B' ) then + saux01 = 'b' + elseif ( saux01.eq.'C' ) then + saux01 = 'c' + elseif ( saux01.eq.'D' ) then + saux01 = 'd' + elseif ( saux01.eq.'E' ) then + saux01 = 'e' + elseif ( saux01.eq.'F' ) then + saux01 = 'f' + elseif ( saux01.eq.'G' ) then + saux01 = 'g' + elseif ( saux01.eq.'H' ) then + saux01 = 'h' + elseif ( saux01.eq.'I' ) then + saux01 = 'i' + elseif ( saux01.eq.'J' ) then + saux01 = 'j' + elseif ( saux01.eq.'K' ) then + saux01 = 'k' + elseif ( saux01.eq.'L' ) then + saux01 = 'l' + elseif ( saux01.eq.'M' ) then + saux01 = 'm' + elseif ( saux01.eq.'N' ) then + saux01 = 'n' + elseif ( saux01.eq.'O' ) then + saux01 = 'o' + elseif ( saux01.eq.'P' ) then + saux01 = 'p' + elseif ( saux01.eq.'Q' ) then + saux01 = 'q' + elseif ( saux01.eq.'R' ) then + saux01 = 'r' + elseif ( saux01.eq.'S' ) then + saux01 = 's' + elseif ( saux01.eq.'T' ) then + saux01 = 't' + elseif ( saux01.eq.'U' ) then + saux01 = 'u' + elseif ( saux01.eq.'V' ) then + saux01 = 'v' + elseif ( saux01.eq.'W' ) then + saux01 = 'w' + elseif ( saux01.eq.'X' ) then + saux01 = 'x' + elseif ( saux01.eq.'Y' ) then + saux01 = 'y' + elseif ( saux01.eq.'Z' ) then + saux01 = 'z' + else + if ( option.lt.0 ) then + codret = 2 + endif + endif +c + chaine(iaux:iaux) = saux01 +c + 32 continue +c +c 3.3. ==> Mauvaise option +c + else +c + write (ulsort,texte(langue,7)) option + write (ulsort,texte(langue,8)) + codret = 1 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) chaine +#endif + endif +c +c==== +c 4. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) chaine +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmoch.F b/src/tool/Utilitaire/utmoch.F new file mode 100644 index 00000000..c25685ee --- /dev/null +++ b/src/tool/Utilitaire/utmoch.F @@ -0,0 +1,370 @@ + subroutine utmoch ( nocham, option, + > nomobj, npfonc, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - MOdification d'un CHamp +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocham . e . char8 . nom de l'objet champ . +c . option . e . 1 . option de la modification : . +c . . . . 1 : ajout de la fonction nomobj . +c . nomobj . e . char8 . nom de la fonction a ajouter . +c . npfonc . e . char8 . nom de la fonction associee . +c . nbcomp . s . 1 . nombre de composantes . +c . nbtvch . s . 1 . nombre de tableaux du champ . +c . typcha . s . 1 . edin64/edfl64 selon entier/reel . +c . adnocp . s . 1 . adresse des noms des champ et composantes . +c . adcaen . s . 1 . adresse des caracteristiques entieres . +c . adcare . s . 1 . adresse des caracteristiques reelles . +c . adcaca . s . 1 . adresse des caracteristiques caracteres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMOCH' ) +c +#include "nblang.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +#include "gmenti.h" +#include "gmreel.h" +c +c 0.3. ==> arguments +c + integer option + integer nbcomp, nbtvch, typcha + integer adnocp, adcaen, adcare, adcaca +c + character*8 nocham, nomobj, npfonc +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + integer nbtach + integer typgeo, ngauss, nbenmx, nbvapr, nbtyas + integer carsup, nbtafo, typint + integer advale, advalr, adobch, adprpg, adtyas +c + character*64 nomcha +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Champ avant modification :'')' + texte(1,5) = '(''Champ apres modification :'')' + texte(1,6) = + > '(''Nombre initial de tableaux du champ :'',i5)' + texte(1,7) = + > '(''Nombre de tableaux de la fonction a ajouter :'',i5)' + texte(1,8) = + > '(''Nombre final de tableaux du champ :'',i5)' +c + texte(2,4) = '(''Field before modification :'')' + texte(2,5) = '(''Field after modification :'')' + texte(2,6) = + > '(''Initial number of arrays in the field :'',i5)' + texte(2,7) = + > '(''Number of arrays in the function to be added :'',i5)' + texte(2,8) = + > '(''Final number of arrays in the field :'',i5)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Nom_Comp' ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) +cgn call gmprsx (nompro, nocham//'.Cham_Ree' ) +cgn call gmprsx (nompro, nocham//'.Cham_Car' ) +#endif +c +c==== +c 2. caracteristiques de l'objet contenant le champ +c==== +c +c 2.1. ==> nombre de tableaux de valeurs pour ce champ +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCACH', nompro +#endif + call utcach ( nocham, + > nomcha, + > nbcomp, nbtvch, typcha, + > adnocp, adcaen, adcare, adcaca, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbtvch +#endif +c +c 2.2. ==> nombre de tableaux de valeurs pour ce champ et cette fonction +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,*) 'au depart' + nbtach = 0 +c + do 21 , iaux = 1 , nbtvch +c + jaux = adcaca + nbincc*(iaux-1) +c + if ( smem(jaux).eq.npfonc ) then +c + nbtach = nbtach + 1 +c + endif +cgn call gmprot (nompro, nocham//'.Cham_Ent', +cgn > nbinec*(iaux-1)+1, nbinec*iaux ) +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbtach +#endif + endif +c +c==== +c 3. ajout d'une fonction +c==== +c + if ( option.eq.1 ) then +c +c 3.1. ==> caracteristiques de la fonction +c + if ( codret.eq.0 ) then +c +cgn call gmprsx (nompro, nomobj ) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAFO', nompro +#endif + call utcafo ( nomobj, + > typcha, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> allongement de la structure pour accueillir les nbtafo +c tableaux de la fonction +c + if ( codret.eq.0 ) then +c + call gmecat ( nocham, 2, nbtvch+nbtach, codre1 ) + iaux = nbinec*(nbtvch+nbtach) + call gmmod ( nocham//'.Cham_Ent', + > adcaen, nbinec*nbtvch, iaux, 1, 1, codre2 ) + iaux = nbtvch+nbtach + call gmmod ( nocham//'.Cham_Ree', + > adcare, nbtvch, iaux, 1, 1, codre3 ) + iaux = nbincc*(nbtvch+nbtach) + call gmmod ( nocham//'.Cham_Car', + > adcaca, nbincc*nbtvch, iaux, 1, 1, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +cgn write(ulsort,*) 'apres 32' +cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec ) +cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec ) +cgn call gmprsx (nompro, nocham//'.Cham_Ent' ) +cgn call gmprsx (nompro, nocham//'.Cham_Car' ) +c +c 3.3. ==> transfert des caracteristiques de la fonction +c Rappel : +c 1. type de support au sens MED +c 2. numero du pas de temps +c 3. numero d'ordre +c 4. nombre de points de Gauss +c 5. nombre d'entites support +c 6. nombre de valeurs du profil eventuel +c 7. supports associes +c 8. noeuds par elements/points de Gauss/autre +c 9. numero du 1er tableau dans la fonction +c 10. -1 ou champ elga/champ elno +c 11. type interpolation +c 21-nbinec. type des supports associes +c + if ( codret.eq.0 ) then +c + do 33 , iaux = 1 , nbtach +c + jaux = adcaen + nbinec*(nbtvch+iaux-1) + imem(jaux) = typgeo + imem(jaux+3) = ngauss + imem(jaux+4) = nbenmx + imem(jaux+5) = nbvapr + imem(jaux+6) = nbtyas + imem(jaux+7) = carsup + if ( carsup.ne.2 ) then + imem(jaux+9) = 0 + endif + imem(jaux+10) = typint + if ( nbtyas.gt.0 ) then + do 331 , kaux = 1 , nbtyas + imem(jaux+19+kaux) = imem(adtyas+kaux-1) + 331 continue + endif +c + jaux = adcaca + nbincc*(nbtvch+iaux-1) + smem(jaux ) = nomobj + smem(jaux+1) = smem(adprpg) + smem(jaux+2) = smem(adprpg+1) +c + 33 continue +c + endif +cgn write(ulsort,*) 'apres 33' +cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec ) +cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec ) +cgn call gmprsx (nompro, nocham//'.Cham_Ent' ) +cgn call gmprsx (nompro, nocham//'.Cham_Car' ) +c +c 3.4. ==> transfert des caracteristiques temporelles du champ +c on doit recopier celles de la fonction associee +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,*) 'apres 34' + kaux = 0 +c + do 34 , iaux = 1 , nbtvch +c + jaux = adcaca + nbincc*(iaux-1) +c + if ( smem(jaux).eq.npfonc ) then +c +c 2. numero du pas de temps + imem(adcaen+nbinec*(nbtvch+kaux)+1) = + > imem(adcaen+nbinec*(iaux-1)+1) +c 3. numero d'ordre + imem(adcaen+nbinec*(nbtvch+kaux)+2) = + > imem(adcaen+nbinec*(iaux-1)+2) +c 9. numero du 1er tableau dans la fonction + imem(adcaen+nbinec*(nbtvch+kaux)+8) = + > imem(adcaen+nbinec*(iaux-1)+8) +c + rmem(adcare+(nbtvch+kaux)) = rmem(adcare+iaux-1) +c + kaux = kaux + 1 +cgn call gmprot (nompro, nocham//'.Cham_Ent', +cgn > nbinec*(nbtvch+kaux-1)+1, nbinec*(nbtvch+kaux) ) +c + endif +c + 34 continue +c + endif +cgn call gmprot (nompro, nocham//'.Cham_Ent', 1, nbinec ) +cgn call gmprot (nompro, nocham//'.Cham_Ent', nbinec+1, 2*nbinec ) +cgn call gmprsx (nompro, nocham//'.Cham_Ent' ) +cgn call gmprsx (nompro, nocham//'.Cham_Car' ) +c +c 3.5. ==> cumul du nombre total de tableaux pour le champ +c + nbtvch = nbtvch + kaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbtvch +#endif +c + endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Nom_Comp' ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Ree' ) + call gmprsx (nompro, nocham//'.Cham_Car' ) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmopf.F b/src/tool/Utilitaire/utmopf.F new file mode 100644 index 00000000..c9ec97d3 --- /dev/null +++ b/src/tool/Utilitaire/utmopf.F @@ -0,0 +1,446 @@ + subroutine utmopf ( obpafo, option, + > nbraux, tbsaux, tbiaux, + > nomobj, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - MOdification d'un Paquet de Fonctions +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obpafo . e . char8 . nom de l'objet du paquet de fonctions . +c . option . e . 1 . option de la modification : . +c . . . . 1 : ajout de la fonction nomobj . +c . . . . 2 : modification de typgpf . +c . . . . 3 : modification de ngauss . +c . . . . 4 : ajout du paquet associe eventuel . +c . . . . 5 : remplissage des types associes . +c . . . . 6 : degre du support geometrique . +c . nbraux . e . 1 . si option = 4 : nombre de paquets . +c . . . . si option = 5 : nombre de types . +c . tbsaux . e . nbraux . si option = 4 : liste des paquets . +c . tbiaux . e . nbraux . si option = 5 : liste des types geo. . +c . nomobj . e . char8 . si option = 1 :nom de la fonction a ajouter. +c . . . . si option = 4 :nom du paquet a l'etape n . +c . nbfopa . s . 1 . nombre de fonctions dans le paquet . +c . typgpf . s . 1 . si >0 : type geometrique s'il est unique . +c . . . . si <0 : nombre de type geometriques associe. +c . ngauss . s . 1 . nombre de points de gauss . +c . carsup . s . 1 . caracteristiques du support . +c . . . . 1, si aux noeuds par elements . +c . . . . 2, si aux points de Gauss, associe avec . +c . . . . n champ aux noeuds par elements . +c . . . . 3 si aux points de Gauss autonome . +c . . . . 0, sinon . +c . typint . s . 1 . type d'interpolation . +c . . . . 0, si automatique . +c . . . . elements : 0 si intensif, sans orientation. +c . . . . 1 si extensif, sans orientation. +c . . . . 2 si intensif, avec orientation. +c . . . . 3 si extensif, avec orientation. +c . . . . noeuds : 1 si degre 1 . +c . . . . 2 si degre 2 . +c . . . . 3 si iso-P2 . +c . adobfo . s . 1 . adresse des noms des objets 'Fonction' et . +c . . . . de l'eventuel paquet associe . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMOPF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +#include "rftmed.h" +c +c 0.3. ==> arguments +c + integer option + integer nbraux + integer nbfopa, typgpf, ngauss, carsup, typint + integer adobfo + integer tbiaux(nbraux) +c + character*8 obpafo, nomobj + character*8 tbsaux(nbraux) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2 + integer codre0 + integer iaux, jaux, kaux, laux, maux, naux + integer adobfa, adtyge, adtyga +c + character*8 nomoba, saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Paquet de fonctions avant modification :'')' + texte(1,5) = '(''Paquet de fonctions apres modification :'')' + texte(1,6) = '(''Option'',i8,'' impossible.'')' + texte(1,7) = '(''Impossible de trouver le paquet.'')' +c + texte(2,4) = '(''Pack of functions before modification :'')' + texte(2,5) = '(''Pack of functions after modification :'')' + texte(2,6) = '(''Option'',i8,'' impossible.'')' + texte(2,7) = '(''Pack cannot be found.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +10000 format(50('=')) + write (ulsort,10000) + write (ulsort,texte(langue,4)) + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) + call gmprsx (nompro, obpafo//'.TypeSuAs' ) +#endif +c +c==== +c 2. ajout d'une fonction +c==== +c + if ( option.eq.1 ) then +c +c 2.1. ==> caracteristiques initiales +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +cgn print *,'nbfopa = ', nbfopa +cgn print *,'typgpf = ', typgpf +cgn print *,'ngauss = ', ngauss +cgn print *,'carsup = ', carsup +cgn print *,'typint = ', typint +c +c 2.2. ==> allongement de la structure +c + if ( codret.eq.0 ) then +c + call gmecat ( obpafo, 1, nbfopa+1, codre1 ) + call gmmod ( obpafo//'.Fonction', + > adobfo, nbfopa+1, nbfopa+2, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3. ==> transfert des caracteristiques de la fonction +c 2.3.1. ==> placement a la fin du nom de l'eventuel paquet associe +c + if ( codret.eq.0 ) then +c + smem(adobfo+nbfopa+1) = smem(adobfo+nbfopa) +c + endif +c +c 2.3.2. ==> ajout de la nouvelle fonction +c + if ( codret.eq.0 ) then +c + smem(adobfo+nbfopa) = nomobj + nbfopa = nbfopa + 1 +c + endif +c +c==== +c 3. modification des attributs typgpf ou ngauss +c==== +c + elseif ( option.ge.2 .and. option.le.3 ) then +c +c 3.1. ==> ecriture de l'attribut +c + if ( codret.eq.0 ) then +c + if ( option.eq.2 ) then + iaux = typgpf + else + iaux = ngauss + endif + call gmecat ( obpafo, option, iaux, codret ) +c + endif +c +c 3.2. ==> caracteristiques finales +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. ajout du paquet associe pour un champ aux points de Gauss +c==== +c + elseif ( option.eq.4 ) then +c +c 4.1. ==> nomobj est le paquet correspondant a obpafo, mais a l'etape n +c on cherche son associe a l'etape n, nomoba +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nomobj) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( nomobj, + > jaux, kaux, laux, maux, naux, + > adobfa, adtyga, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nomoba = smem(adobfa+jaux) +cgn print *,'===> nomoba = ',nomoba +c + endif +c +c 4.2. ==> on cherche le correspondant de nomoba a l'etape p +c + if ( codret.eq.0 ) then +c + do 42 , iaux = 1 , nbraux + if ( tbsaux(iaux).eq.nomoba ) then + saux08 = tbsaux(iaux+nbraux) + goto 420 + endif + 42 continue + codret = 5 + write (ulsort,texte(langue,7)) +c + 420 continue +c + endif +c +c 4.3. ==> stockage correspondant de nomoba a l'etape p +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adobfo+nbfopa) = saux08 +c + endif +c +c==== +c 5. ajout des types geometriques +c si la branche existe, on commence par la detruire +c==== +c + elseif ( option.eq.5 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( typgpf.lt.0 ) then +c + call gmlboj ( obpafo//'.TypeSuAs', codret ) +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + call gmaloj ( obpafo//'.TypeSuAs', ' ', nbraux, adtyge, codre1 ) + iaux = -nbraux + call gmecat ( obpafo, 2, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + do 51 , iaux = 1 , nbraux + imem(adtyge+iaux-1) = tbiaux(iaux) + 51 continue +c + endif +c +c==== +c 6. degre du type geometrique +c==== +c + elseif ( option.eq.6 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, typgpf, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c +c Le type geometrique +c + if ( codret.eq.0 ) then +c +cgn write (ulsort,*) nompro, ' typgpf old', typgpf + typgpf = medt12(typgpf) +cgn write (ulsort,*) nompro, ' typgpf new', typgpf + call gmecat ( obpafo, 2, typgpf, codret ) +c + endif +c +c Le nombre de noeuds par mailles +c + if ( codret.eq.0 ) then +c + if ( carsup.eq.1 ) then +c +cgn write (ulsort,*) nompro, ' ngauss old', ngauss + ngauss = mednnm(typgpf) +cgn write (ulsort,*) nompro, ' ngauss new', ngauss + call gmecat ( obpafo, 3, ngauss, codret ) +c + endif +c + endif +c +c==== +c 7. erreur dans l'option +c==== +c + else +c + write (ulsort,texte(langue,6)) option + codret = 1 +c + endif +c +c==== +c 8. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) + call gmprsx (nompro, obpafo//'.TypeSuAs' ) +cgn write (ulsort,10000) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utmoso.F b/src/tool/Utilitaire/utmoso.F new file mode 100644 index 00000000..c6ab0dbd --- /dev/null +++ b/src/tool/Utilitaire/utmoso.F @@ -0,0 +1,231 @@ + subroutine utmoso ( nocsol, option, + > nomobj, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - MOdifie une SOlution +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . e . char8 . nom de l'objet solution . +c . option . e . 1 . option de la modification : . +c . . . . 1 : ajout de la fonction nomobj . +c . . . . 2 : ajout du profil nomobj . +c . nomobj . e . char8 . nom de la fonction a ajouter . +c . nbcham . s . 1 . nombre de champs associes . +c . nbpafo . s . 1 . nombre de paquets de fonctions . +c . nbprof . s . 1 . nombre de profils associes . +c . nblopg . s . 1 . nombre de localisations de points de Gauss . +c . adinch . s . 1 . adresse de l'information sur les champs . +c . adinpf . s . 1 . adresse de l'inf. sur paquets de fonctions . +c . adinpr . s . 1 . adresse de l'information sur les profils . +c . adinlg . s . 1 . adresse de l'information sur les . +c . . . . localisations de points de Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTMOSO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer option + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg +c + character*8 nocsol, nomobj +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Solution avant modification :'')' + texte(1,4) = '(''Solution apres modification :'')' +c + texte(2,10) = '(''Solution before modification :'')' + texte(2,4) = '(''Solution after modification :'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) + call gmprsx (nompro, nocsol//'.InfoLoPG' ) +#endif +c +c==== +c 2. caracteristiques de depart +c==== +c + if ( codret.eq.0 ) then +c + call utcaso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. ajout d'un paquet de fonction +c==== +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then + codret = 123 +c +cgn iaux = nbpafo + 1 +cgn call gmmod ( nocsol//'.InfoPaFo', +cgn > adinpf, nbpafo, iaux, 1, 1, codre1 ) +cgn call gmecat ( nocsol, 2, iaux, codre2 ) +cgnc +cgn codre0 = min ( codre1, codre2 ) +cgn codret = max ( abs(codre0), codret, +cgn > codre1, codre2 ) +cgnc +cgn smem(adinpf+nbpafo) = nomobj +cgn nbpafo = nbpafo + 1 +c + endif +c + endif +c +c==== +c 4. ajout d'un profil +c==== +c + if ( option.eq.2 ) then +c +c 4.1. ==> tableau recueillant les noms des profils +c +c 4.1.1. ==> il n'y en avait pas : on en cree +c + if ( codret.eq.0 ) then +c + if ( nbprof.eq.0 ) then +c + iaux = 1 + call gmaloj ( nocsol//'.InfoProf', ' ', iaux, adinpr, codret ) +c +c 4.1.2. ==> il y en avait deja : on allonge d'une case +c + else +c + iaux = nbprof + 1 + call gmmod ( nocsol//'.InfoProf', + > adinpr, nbprof, iaux, 1, 1, codret ) +c + endif +c + endif +c +c 4.2. ==> enregistrement +c + if ( codret.eq.0 ) then +c + iaux = nbprof + 1 + call gmecat ( nocsol, 3, iaux, codret ) +c + smem(adinpr+nbprof) = nomobj + nbprof = nbprof + 1 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) + call gmprsx (nompro, nocsol//'.InfoLoPG' ) +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnbmc.F b/src/tool/Utilitaire/utnbmc.F new file mode 100644 index 00000000..9445bde7 --- /dev/null +++ b/src/tool/Utilitaire/utnbmc.F @@ -0,0 +1,176 @@ + subroutine utnbmc ( nombre, + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - NomBres pour le Maillage de Calcul +c -- -- - - - +c ______________________________________________________________________ +c +c C'est le contenu du common nbutil +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nombre . e . 36 . le tableau des nombres . +c . nbmaae . s . 1 . nombre maximum d'aretes par element . +c . nbmafe . s . 1 . nombre maximum de faces par element . +c . nbmnei . s . 1 . nombre max. de noeuds des elements ignores . +c . numano . s . 1 . numero maximum de noeud dans le maillage . +c . numael . s . 1 . numero maximum d'element dans le maillage . +c . nbma2d . s . 1 . nombre total de mailles 2D . +c . nbma3d . s . 1 . nombre total de mailles 3D . +c . nbmapo . s . 1 . nombre de mailles-points dans le maillage . +c . nbsegm . s . 1 . nombre de segments dans le maillage . +c . nbtria . s . 1 . nombre de triangles dans le maillage . +c . nbtetr . s . 1 . nombre de tetraedres dans le maillage . +c . nbquad . s . 1 . nombre de quadrangles dans le maillage . +c . nbhexa . s . 1 . nombre d'hexaedres dans le maillage . +c . nbpent . s . 1 . nombre de pentaedres dans le maillage . +c . nbpyra . s . 1 . nombre de pyramides dans le maillage . +c . nbfmed . s . 1 . nombre total de familles MED . +c . nbfmen . s . 1 . nombre de familles MED pour les noeuds . +c . ngrouc . s . 1 . nombre de groupes cumules dans les familles. +c . nbequi . s . 1 . nombre total d'equivalences . +c . nbeqno . s . 1 . nombre total de paires equiv. de noeuds . +c . nbeqmp . s . 1 . nombre total de paires equiv. de m-points. +c . nbeqar . s . 1 . nombre total de paires equiv. d'aretes . +c . nbeqtr . s . 1 . nombre total de paires equiv. de triangles . +c . nbeqqu . s . 1 . nombre total de paires equiv. de quad. . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNBMC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nombre(*) +c + integer nbmaae, nbmafe, nbmnei + integer numano, numael + integer nbma2d, nbma3d + integer nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra + integer nbfmed, nbfmen, ngrouc + integer nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. valeurs +c==== +c + nbmaae = nombre( 1) + nbmafe = nombre( 2) + nbmnei = nombre( 3) + numano = nombre( 4) + numael = nombre( 5) + nbma2d = nombre( 6) + nbma3d = nombre( 7) + nbmapo = nombre(12) + nbsegm = nombre(13) + nbtria = nombre(14) + nbtetr = nombre(15) + nbquad = nombre(17) + nbhexa = nombre(18) + nbpent = nombre(19) + nbpyra = nombre(20) + nbfmed = nombre(22) + nbfmen = nombre(23) + ngrouc = nombre(24) + nbequi = nombre(31) + nbeqno = nombre(32) + nbeqmp = nombre(33) + nbeqar = nombre(34) + nbeqtr = nombre(35) + nbeqqu = nombre(36) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnbmh.F b/src/tool/Utilitaire/utnbmh.F new file mode 100644 index 00000000..9339f248 --- /dev/null +++ b/src/tool/Utilitaire/utnbmh.F @@ -0,0 +1,175 @@ + subroutine utnbmh ( nombre, + > nbnois, nbnoei, nbnomp, + > nbnop1, nbnop2, nbnoim, + > nbeutc, nbevca, nbevto, + > nbelem, nbmaae, nbmafe, nbmane, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > numano, numael, + > nvoare, nvosom, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - NomBres pour le Maillage HOMARD +c -- -- - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nombre . e . 25 . le tableau des nombres . +c . nbnois . s . 1 . nombre de noeuds isoles . +c . nbnomp . s . 1 . nombre de noeuds support de mailles-points . +c . nbnop1 . s . 1 . nombre de noeuds p1 . +c . nbnop2 . s . 1 . nombre de noeuds p2 . +c . nbnoim . s . 1 . nombre de noeuds internes aux mailles . +c . nbeutc . s . 1 . nombre d'elements utiles au calcul . +c . nbevca . s . 1 . nombre d'elements de volumes dans le calcul. +c . nbevto . s . 1 . nombre d'elements de volumes total . +c . nbelem . s . 1 . nombre d'elements dans le calcul . +c . nbmaae . s . 1 . nombre maximum d'aretes par element . +c . nbmafe . s . 1 . nombre maximum de faces par element . +c . nbmane . s . 1 . nombre maximum de noeuds par element . +c . nbmapo . s . 1 . nombre de mailles-points dans le maillage . +c . nbsegm . s . 1 . nombre de segments dans le maillage . +c . nbtria . s . 1 . nombre de triangles dans le maillage . +c . nbtetr . s . 1 . nombre de tetraedres dans le maillage . +c . nbquad . s . 1 . nombre de quadrangles dans le maillage . +c . nbhexa . s . 1 . nombre d'hexaedres dans le maillage . +c . nbpent . s . 1 . nombre de pentaedres dans le maillage . +c . nbpyra . s . 1 . nombre de pyramides dans le maillage . +c . numano . s . 1 . numero maximum de noeud dans le maillage . +c . numael . s . 1 . numero maximum d'element dans le maillage . +c . nvoare . s . 1 . nombre de voisins par arete . +c . nvosom . s . 1 . nombre de voisins par sommet . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNBMH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nombre(*) +c + integer nbnois, nbnoei, nbnomp + integer nbnop1, nbnop2, nbnoim + integer nbeutc, nbevca, nbevto + integer nbelem, nbmaae, nbmafe, nbmane + integer nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra + integer numano, numael + integer nvoare, nvosom +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +c==== +c 2. valeurs +c==== +c + nbnois = nombre( 1) + nbnoei = nombre( 2) + nbnomp = nombre( 3) + nbnop1 = nombre( 4) + nbnop2 = nombre( 5) + nbnoim = nombre( 6) + nbeutc = nombre( 7) + nbevca = nombre( 8) + nbevto = nombre( 9) + nbelem = nombre(10) + nbmaae = nombre(11) + nbmafe = nombre(12) + nbmane = nombre(13) + nbmapo = nombre(14) + nbsegm = nombre(15) + nbtetr = nombre(16) + nbtria = nombre(17) + nbquad = nombre(18) + numael = nombre(19) + numano = nombre(20) + nvoare = nombre(21) + nvosom = nombre(22) + nbhexa = nombre(23) + nbpyra = nombre(24) + nbpent = nombre(25) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc01.F b/src/tool/Utilitaire/utnc01.F new file mode 100644 index 00000000..8407ba4a --- /dev/null +++ b/src/tool/Utilitaire/utnc01.F @@ -0,0 +1,589 @@ + subroutine utnc01 ( nbanci, nbgemx, + > coonoe, + > somare, merare, + > aretri, + > povoso, voisom, + > ngenar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 01 +c -- - - -- +c Reperage des non conformites : on repere les aretes par des +c filiations "adoptives" en notant negativement les numeros d'arete +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . s . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . nbgemx . s . 1 . nombre maximal de generations sous une . +c . . . . arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . merare . es . nbarto . mere des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . povoso . e .0:nbnoto. pointeur des voisins par sommet . +c . voisom . e . nvosom . elements 1d, 2d ou 3d voisins par sommet . +c . ngenar . s . nbarto . nombre de generations au-dessus des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "envca1.h" +#include "precis.h" +#include "ope1a3.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbanci, nbgemx + integer somare(2,nbarto), merare(nbarto) + integer aretri(nbtrto,3) + integer povoso(0:nbnoto), voisom(*) + integer ngenar(nbarto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer poind2, poinf2, point2 + integer poind3, poinf3, point3 + integer aret1, aretmi, aretmo, aretma + integer sonnnn, sopppp, soqqqq + integer somdep, somarr + integer somde3, somar3 + integer larete(3), lenoeu(3,3) +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + double precision daux(3), vect(3,3) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' + texte(1,5) = + > '(''Nombre maximal de generations de '',a,'' :'',i10))' + texte(1,6) = '(/,''Examen du '',a,i10)' + texte(1,7) = '(a,1x,a,i10,'', de'',i10,'' a'',i10)' + texte(1,8) = '(a,3('' '',a,'' :'',i10))' + texte(1,10) = + > '(''Nombre de '',a,'' de generation'',i10,'' :'',i10)' +c + texte(2,4) = + > '(''Number of non-conformal situations for '',a,'':'',i10))' + texte(2,5) = + > '(''Maximal number of generations for '',a,'':'',i10))' + texte(2,6) = '(/,''Examination of '',a,'' #'',i10)' + texte(2,7) = '(a,1x,a,'' #'',i10,'', from'',i10,'' to'',i10)' + texte(2,8) = '(a,3('' '',a,'' :'',i10))' + texte(2,10) = + > '(''Number of '',a,'' from generation #'',i10,'' :'',i10)' +c + codret = 0 + nbanci = 0 +c +c==== +c 2. On cherche tous les triplets d'aretes (aret1,larete(2),larete(3)) +c qui sont concourrantes. +c Si elles definissent un triangle, on ne fait rien. +c Sinon, on repere laquelle chapeaute les 2 autres : ce sera la +c non conformite. +c==== +c +c 2.1. ==> initialisations +c + do 21 , aret1 = 1 , nbarto + merare(aret1) = 0 + ngenar(aret1) = 0 + 21 continue +c +c 2.2. ==> traitement +c + do 2 , aret1 = 1 , nbarto +c + if ( codret.eq.0 ) then +c + sonnnn = somare(1,aret1) + sopppp = somare(2,aret1) +#ifdef _DEBUG_HOMARD_ + if ( aret1.eq.10)then + glop = 1 + else + glop = 0 + endif + if ( glop.gt.0)then + write (ulsort,texte(langue,6)) mess14(langue,1,1), aret1 + write (ulsort,texte(langue,8)) ' ', 'de', sonnnn, 'a', sopppp +cgn write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci + endif +#endif +c +c 2.2.1. ==> pour chacune des autres aretes contenant 'sonnnn' +c + poind2 = povoso(sonnnn-1) + 1 + poinf2 = povoso(sonnnn) + do 22 , point2 = poind2, poinf2 +c + if ( aret1.ne.voisom(point2) ) then +c + larete(2) = voisom(point2) +c +c les deux sommets de cette arete : P et Q +c + somdep = somare(1,larete(2)) + somarr = somare(2,larete(2)) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,texte(langue,7)) '...', mess14(langue,1,1), + > larete(2), somdep, somarr + endif +#endif +c +c celui des sommets qui n'est pas sommet de 'aret1' +c + if ( somdep.eq.sonnnn ) then + soqqqq = somarr + else + soqqqq = somdep + endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,texte(langue,8)) ' ', 'N', sonnnn, 'P', sopppp, + > 'Q', soqqqq + endif +#endif +c +c existe-t-il une arete joignant P et Q ? +c + poind3 = povoso(sopppp-1) + 1 + poinf3 = povoso(sopppp) + do 221 , point3 = poind3, poinf3 +c + larete(3) = voisom(point3) +c +c les deux sommets de cette arete +c + somde3 = somare(1,larete(3)) + somar3 = somare(2,larete(3)) +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,texte(langue,7)) '.....', mess14(langue,1,1), + > larete(3), somde3, somar3 + endif +#endif +c + if ( somde3.eq.soqqqq .or. somar3.eq.soqqqq ) then +c + if ( ngenar(aret1).eq.0 .and. + > ngenar(larete(2)).eq.0 .and. + > ngenar(larete(3)).eq.0 ) then +c + larete(1) = aret1 +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,texte(langue,7)) '====>', mess14(langue,1,1), + > larete(3), somde3, somar3 + write (ulsort,texte(langue,8)) ' ', 'A1', larete(1), + > 'A2', larete(2), 'A3', larete(3) + endif +#endif +c +c existe-t-il un triangle defini par ces 3 aretes ? +c + if ( nbtrto.ne.0 ) then +c +cgn print *,'A1', larete(1),' A2', larete(2), ' A3', larete(3) + aretmi = min(larete(1), larete(2), larete(3)) + aretma = max(larete(1), larete(2), larete(3)) + if ( larete(1).ne.aretmi .and. + > larete(1).ne.aretma ) then + aretmo = larete(1) + elseif ( larete(2).ne.aretmi .and. + > larete(2).ne.aretma ) then + aretmo = larete(2) + else + aretmo = larete(3) + endif +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,*)'aretmi/mo/ma',aretmi, aretmo, aretma + endif +#endif + do 2211 , iaux = 1, nbtrto +cgn print *,aretri(iaux,1),aretri(iaux,2),aretri(iaux,3) + if ( min(aretri(iaux,1), + > aretri(iaux,2), + > aretri(iaux,3)).eq.aretmi ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.gt.0)then + write (ulsort,*)'triangle ',iaux,' :', + > aretri(iaux,1),aretri(iaux,2),aretri(iaux,3) + endif +#endif + if ( max(aretri(iaux,1), + > aretri(iaux,2), + > aretri(iaux,3)).eq.aretma ) then + if ( aretri(iaux,1).eq.aretmo .or. + > aretri(iaux,2).eq.aretmo .or. + > aretri(iaux,3).eq.aretmo ) then +cgn print *,'c''est un vrai triangle' + goto 22 + endif + endif + endif + 2211 continue +c + endif +c +c recherche des dependances de ces 3 aretes +c on cherche quel est l'alignement des noeuds +c +c l'arete 1 va de N a P +c l'arete 2 est entre N et Q +c l'arete 3 est entre Q et P +c l'arete i va de lenoeu(1,i) a lenoeu(2,i) +c + lenoeu(1,1) = sonnnn + lenoeu(2,1) = sopppp + lenoeu(3,1) = soqqqq +c + lenoeu(1,2) = min(sonnnn,soqqqq) + lenoeu(2,2) = max(sonnnn,soqqqq) + lenoeu(3,2) = sopppp +c + lenoeu(1,3) = min(sopppp,soqqqq) + lenoeu(2,3) = max(sopppp,soqqqq) + lenoeu(3,3) = sonnnn +c + do 2212 , iaux = 1, 3 +cgn print *,larete(iaux),lenoeu(1,iaux),lenoeu(2,iaux),lenoeu(3,iaux) + do 2213 , jaux = 1, sdim + vect(iaux,jaux) = coonoe(lenoeu(2,iaux),jaux) + > - coonoe(lenoeu(1,iaux),jaux) + 2213 continue +cgn print *,vect(iaux,1),vect(iaux,2),vect(iaux,3) + 2212 continue +c +c on verifie que les 3 points sont alignes : +c +c A--------C---------------------B +c attention : contrairement a ce que nous pensions au depart, +c on peut tres bien avoir des situations avec 3 aretes +c concourrantes sans qu'elles ne forment un triangle +c au sens de face HOMARD. +c Exemple : +c +c A +c . . . +c . . . +c . . . +c . . . +c . .R. . +c . . . . +c . . . . +c . . . . +c B...................C +c +c Si des tetraedres sont batis sur les faces ACR, CRB et +c BRA, le triangle ABC n'existe pas +c + if ( sdim.eq.2 ) then +c + daux(1) = + > ( vect(1,1) * vect(2,2) ) - ( vect(1,2) * vect(2,1) ) +cgn print *,daux(1) + if ( daux(1).gt.epsima ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'bizarrerie : daux(1) =',daux(1) + write(ulsort,*) 'arete 1 =',sonnnn,' => ', sopppp + write(ulsort,*) 'arete 2 =',sopppp,' => ', soqqqq + write(ulsort,*) 'arete 3 =',soqqqq,' => ', sonnnn +#endif + goto 22 + endif +c + else +c + daux(1) = + > ( vect(1,2) * vect(2,3) ) - ( vect(1,3) * vect(2,2) ) + daux(2) = + > ( vect(1,3) * vect(2,1) ) - ( vect(1,1) * vect(2,3) ) + daux(3) = + > ( vect(1,1) * vect(2,2) ) - ( vect(1,2) * vect(2,1) ) +c + daux(1) = abs(daux(1)) + abs(daux(2)) + abs(daux(3)) +cgn print *,daux(1) + if ( daux(1).gt.epsima ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'bizarrerie : daux(1) =',daux(1) + write(ulsort,6661) aret1,lenoeu(1,1), lenoeu(2,1) + write(ulsort,6661) larete(2),lenoeu(1,2), lenoeu(2,2) + write(ulsort,6661) larete(3),lenoeu(1,3), lenoeu(2,3) + write(ulsort,6662) sonnnn, + >coonoe(sonnnn,1),coonoe(sonnnn,2),coonoe(sonnnn,3) + write(ulsort,6662) sopppp, + >coonoe(sopppp,1),coonoe(sopppp,2),coonoe(sopppp,3) + write(ulsort,6662) soqqqq, + >coonoe(soqqqq,1),coonoe(soqqqq,2),coonoe(soqqqq,3) + write(ulsort,6663) sonnnn,soqqqq, + >coonoe(soqqqq,1)-coonoe(sonnnn,1), + >coonoe(soqqqq,2)-coonoe(sonnnn,2), + >coonoe(soqqqq,3)-coonoe(sonnnn,3) + write(ulsort,6663) sopppp,soqqqq, + >coonoe(soqqqq,1)-coonoe(sopppp,1), + >coonoe(soqqqq,2)-coonoe(sopppp,2), + >coonoe(soqqqq,3)-coonoe(sopppp,3) + write(ulsort,6664) + >(coonoe(soqqqq,1)-coonoe(sopppp,1))/ + >(coonoe(soqqqq,1)-coonoe(sonnnn,1)), + >(coonoe(soqqqq,2)-coonoe(sopppp,2))/ + >(coonoe(soqqqq,2)-coonoe(sonnnn,2)), + >(coonoe(soqqqq,3)-coonoe(sopppp,3))/ + >(coonoe(soqqqq,3)-coonoe(sonnnn,3)) + 6661 format('arete',i10,' de',i10,' a',i10) + 6662 format('noeud',i10,' :',3(g15.8,1x)) + 6663 format('de',i10,' a',i10,' :',3(g15.8,1x)) + 6664 format('rapport :',3(g15.8,1x)) +#endif + goto 22 + endif +c + endif +c +c Calcul du produit scalaire entre le 3�me noeud et les 2 extremites +c de chaque arete iaux : +c arete iaux +c A--------C---------------------B +c +c CA*CB = CA * CB * cos(CA,CB) = - CA * CB < 0 +c AB*AC = AB * AC * cos(AB,AC) = + AB * AC > 0 +c BC*BA = BC * BA * cos(BC,BA) = + BC * BA > 0 +c + do 2214 , iaux = 1, 3 +c + daux(iaux) = 0.d0 + do 2215 , jaux = 1, sdim + daux(iaux) = daux(iaux) + + > ( coonoe(lenoeu(1,iaux),jaux) - coonoe(lenoeu(3,iaux),jaux) ) * + > ( coonoe(lenoeu(2,iaux),jaux) - coonoe(lenoeu(3,iaux),jaux) ) + 2215 continue +cgn print *,'daux(',iaux,') =',daux(iaux) +c +c On repere celui qui est negatif (il y en a forcement un !) +c On connait alors l'arete qui recouvre les deux autres : c'est iaux +c Les deux autres sont obtenues par pemutation circulaire de iaux +c On declare que : +c - les deux "petites" aretes ont la grande comme mere adoptive +c cela servira dans la suite de la conversion +c - la "grande" arete a une fille ; il suffit de mettre un numero +c positif strictement car c'est utilise uniquement ici pour ne +c pas faire plusieurs fois la meme chose (cf test au debut de +c la boucle 221). On choisit de mettre 1. +c + if ( daux(iaux).lt.epsima ) then + jaux = per1a3(-1,iaux) + kaux = per1a3( 1,iaux) +cgn if ( aret1.eq.15931)then +cgn print *,larete(iaux),larete(jaux),larete(kaux) +cgn write (ulsort,texte(langue,6)) mess14(langue,1,1), 16334 +cgn write (ulsort,texte(langue,8)) ' ', 'de', somare(1,16334), +cgn > 'a', somare(2,16334) +cgn endif + merare(larete(jaux)) = -larete(iaux) + merare(larete(kaux)) = -larete(iaux) + ngenar(larete(iaux)) = 1 +cgn ngenar(larete(iaux)) = +cgn > - max(larete(jaux),larete(kaux)) + nbanci = nbanci + 1 + goto 22 + endif +c + 2214 continue +c +c probleme si on arrive ici ... +c + codret = codret + 1 +c + endif +c + endif +c + 221 continue +c + endif +c + 22 continue +c + endif +#ifdef _DEBUG_HOMARD_ +cgn if ( aret1.eq.15931)then + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci +cgn endif +#endif +c + 2 continue +c +c==== +c 3. Determination du nombre de generations au-dessus de chaque arete +c +c x---------------------------0---------------------------x +c x-------------1-------------x-------------1-------------x +c x------2------x------2------x------2------x------2------x +c x---3--x---3--x +c +c On part d'une arete quelconque. On compte le nombre d'aretes +c au-dessus d'elle dans l'ascendance. +c==== +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbarto +c + jaux = iaux + kaux = 0 + 310 continue +cgn write (ulsort,texte(langue,6)) mess14(langue,1,1), jaux + if ( merare(jaux).ne.0 ) then + jaux = -merare(jaux) + kaux = kaux + 1 + goto 310 + endif +c + ngenar(iaux) = kaux +c + 31 continue +c + nbgemx = ngenar(1) + do 32 , iaux = 2 , nbarto + nbgemx = max(nbgemx,ngenar(iaux)) + 32 continue +c + endif +c +cgn write (ulsort,*)'ngenar : ',ngenar +cgn write (ulsort,*)'merare : ',merare +cgn print *,'ngenar(190) : ',ngenar(190) +cgn print *,'merare(190) : ',merare(190) +c +#ifdef _DEBUG_HOMARD_ +c +c 3.3. ==> impression du nombre d'aretes par generation +c + kaux = 0 +c + 330 continue +c + if ( codret.eq.0 ) then +c + jaux = 0 + do 33 , iaux = 1 , nbarto +c + if ( ngenar(iaux).eq.kaux ) then + jaux = jaux + 1 + endif +c + 33 continue +c + if ( jaux.ne.0 ) then + write (ulsort,texte(langue,10)) mess14(langue,3,1), + > kaux, jaux + kaux = kaux + 1 + goto 330 + endif +c + endif +#endif +c +c==== +c 4. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci + write (ulsort,texte(langue,5)) mess14(langue,3,1), nbgemx +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc02.F b/src/tool/Utilitaire/utnc02.F new file mode 100644 index 00000000..15e89838 --- /dev/null +++ b/src/tool/Utilitaire/utnc02.F @@ -0,0 +1,179 @@ + subroutine utnc02 ( nbanci, + > arreca, arrecb, + > merare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 02 +c -- - - -- +c A partir de la filiation "adoptive" entre aretes, on memorise les +c correspondances dans 2 listes paralleles. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . arreca . s .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . s .2*nbanci. liste des aretes recouvertes par une autre . +c . merare . e . nbarto . mere des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbanci + integer arreca(2*nbanci), arrecb(2*nbanci) + integer merare(nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen du '',a,i10)' + texte(1,5) = '(''.. couvert par le '',a,i10)' + texte(1,6) = '(''Recollement des '',a)' + texte(1,7) = '(''Nombre trouve :'',i10)' + texte(1,8) = '(''Nombre attendu :'',i10)' +c + texte(2,4) = '(''Examination of '',a,'' #'',i10)' + texte(2,5) = '(''.. covered by '',a,'' #'',i10)' + texte(2,6) = '(''Glue for '',a)' + texte(2,7) = '(''Found number :'',i10)' + texte(2,8) = '(''Exepcted number :'',i10)' +c + codret = 0 +c +c==== +c 2. On regarde toutes les aretes qui sont recouvertes par une autre +c C'est repere par le fait qu'elles ont une mere negative (cf utnc01) +c==== +c + if ( codret.eq.0 ) then +c + jaux = 0 +c + do 21 , iaux = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,1), iaux +#endif +c + if ( merare(iaux).lt.0 ) then +c + jaux = jaux + 1 + arreca(jaux) = -merare(iaux) + arrecb(jaux) = iaux +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,1), -merare(iaux) +#endif +c + endif +c + 21 continue +c + endif +c +c==== +c 3. controle +c==== +c + if ( codret.eq.0 ) then +c + if ( jaux.ne.2*nbanci ) then +c + write (ulsort,texte(langue,6)) mess14(langue,3,1) + write (ulsort,texte(langue,7)) jaux + write (ulsort,texte(langue,8)) 2*nbanci + codret = 1 +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc03.F b/src/tool/Utilitaire/utnc03.F new file mode 100644 index 00000000..01bdeb29 --- /dev/null +++ b/src/tool/Utilitaire/utnc03.F @@ -0,0 +1,448 @@ + subroutine utnc03 ( option, nbanci, numfin, + > arreca, arrecb, + > somare, filare, merare, + > ngenar, nouare, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 03 +c -- - - -- +c On change les numeros des aretes concernees par les non-conformites +c On les regroupe par generations, en commencant par celle sans mere +c puis celle avec mere, puis celle avec une mere et une grand-mere, +c et ainsi de suite. +c On regroupe ensuite les fratries. +c Enfin, on etablit la bonne convention de numerotation des aretes +c dans une fratrie +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de l'operation de renumerotation . +c . . . . 0 : dans chaque fratrie, on classe les . +c . . . . aretes . +c . . . . -n : decalage des aretes ayant une . +c . . . . ascendance de n generations . +c . . . . n : on regroupe par fratries les aretes . +c . . . . ayant une ascendance de n generations. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . numfin . es . 1 . numero d'ordre maximal pour le classement . +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . e .2*nbanci. liste des aretes recouvertes par une autre . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . filare . e . nbarto . premiere fille des aretes . +c . merare . e . nbarto . mere des aretes . +c . ngenar . e . nbarto . nombre de generations au-dessus des aretes . +c . nouare . s .0:nbarto. nouveau numero des aretes . +c . tabaux . a .3*nbanci. tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise option . +c . . . . >0 : erreur dans le traitement de l'option . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer option + integer nbanci + integer numfin + integer arreca(2*nbanci), arrecb(2*nbanci) + integer somare(2,nbarto) + integer filare(nbarto), merare(nbarto) + integer ngenar(nbarto), nouare(0:nbarto) + integer tabaux(3,nbanci) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer numgen, ifin + integer laret1, laret2, laretg +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de non-conformites :'',i10))' + texte(1,5) = '(''Traitement numero'',i3))' + texte(1,6) = + > '(''Mise en coherence des '',a,''dans les fratries de '',a)' + texte(1,7) = '(''Decalage des '',a,'' de generation'',i3)' + texte(1,8) = '(''Regroupement des '',a,'' de generation'',i3)' + texte(1,9) = '(''Classement avant'',i10)' + texte(1,10) = '(i10,1x,a,''dans la generation'',i10)' + texte(1,11) = '(''Nouveau numero du '',a,i10,'' : '',i10)' + texte(1,12) = '(''Il devrait etre '',a,i10)' + texte(1,18) = '(''Generation du '',a,i10,'' :'',i4)' + texte(1,19) = '(''Examen du '',a,i10)' + texte(1,20) = '(''.. couvert par le '',a,i10)' +c + texte(2,4) = '(''Number of non-conformal situations :'',i10))' + texte(2,5) = '(''Treatment #'',i3)' + texte(2,6) = + > '(''Coherence of '',a,''in brotherhood of '',a)' + texte(2,7) = '(''Renumbering of '',a,'' in generation'',i3)' + texte(2,8) = '(''Gathering of '',a,'' in generation'',i3)' + texte(2,9) = '(''Sort before'',i10)' + texte(2,10) = '(i10,1x,a,''in generation'',i10)' + texte(2,11) = '(''New # for '',a,i10,'' : '',i10)' + texte(2,12) = '(''It should be '',a,i10)' + texte(2,18) = '(''Generation of '',a,i10,'' :'',i4)' + texte(2,19) = '(''Examination of '',a,'' #'',i10)' + texte(2,20) = '(''.. covered by '',a,'' #'',i10)' +c +c 1.2. ==> initialisation +c + codret = 0 +c + if ( option.lt.0 ) then + numgen = -option + elseif ( option.gt.0 ) then + numgen = option + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbanci +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) option + if ( option.eq.0 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,-1), + > mess14(langue,3,1) + else + if ( option.lt.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,1), numgen + write (ulsort,texte(langue,9)) numfin + else + write (ulsort,texte(langue,8)) mess14(langue,3,1), numgen + endif + endif +#endif +c +c 1.3. ==> Aucune renumerotation au depart +c + do 12 , iaux = 0 , nbarto + nouare(iaux) = iaux + 12 continue +c +c==== +c 2. option < 0 : on rassemble les aretes de meme generation +c on les deplace vers la fin, en prenant soin de ne pas ecraser +c les generations plus jeunes (d'ou le demarrage a ifin) +c==== +c + if ( option.lt.0 ) then +c + ifin = numfin +c + do 21 , iaux = 1 , nbarto +c + if ( codret.eq.0 ) then +c + if ( ngenar(iaux).eq.numgen .and. iaux.le.ifin ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,19)) mess14(langue,1,1), iaux +#endif + do 211 , jaux = ifin, 1, -1 + if ( jaux.eq.iaux ) then + goto 212 + elseif ( ngenar(jaux).lt.numgen ) then + nouare(jaux) = iaux + nouare(iaux) = jaux + ifin = jaux - 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,19)) mess14(langue,1,1),iaux + write (ulsort,*) iaux,' devient', jaux +#endif + goto 212 + endif + 211 continue +c + codret = option +c + 212 continue +c + ifin = jaux - 1 + goto 21 +c + endif +c + endif +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) numfin-ifin, + > mess14(langue,3,1), numgen +#endif +c + numfin = ifin +c +c==== +c 3. option > 0 : au sein d'une generation, les aretes sont regroupees +c par fratries +c==== +c + elseif ( option.gt.0 ) then +c +c 3.1. ==> Regroupement des triplets de filles adoptives et de mere +c 3.1.1. ==> Aucun regroupement au depart +c + do 31 , iaux = 1 , nbanci +c + tabaux(1,iaux) = 0 + tabaux(2,iaux) = 0 + tabaux(3,iaux) = 0 +c + 31 continue +c +c 3.2. ==> On regroupe les triplets de filles adoptives et de mere +c pour la generation de fille numgen +c + if ( codret.eq.0 ) then +c + kaux = 0 + ifin = 2*nbanci + do 32 , iaux = 1 , ifin +c + if ( codret.eq.0 ) then +c + laret1 = arrecb(iaux) +c + if ( ngenar(laret1).eq.numgen ) then +c + laretg = arreca(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,19)) mess14(langue,1,1), laret1 + write (ulsort,texte(langue,20)) mess14(langue,1,1), laretg +#endif +c +c on cherche si on a deja place l'arete jumelle de laret1 +c . si oui, on place l'arete courante en position 2 +c . si non, on place l'arete courante en position 1 et on +c enregistre la mere adoptive +c + do 321 , jaux = 1, kaux +c + if ( tabaux(3,jaux).eq.laretg ) then + if ( ngenar(tabaux(1,jaux)).ne.numgen ) then + write (ulsort,texte(langue,18)) mess14(langue,1,1), + > laret1, numgen + write (ulsort,texte(langue,18)) mess14(langue,1,1), + > tabaux(1,jaux), ngenar(tabaux(1,jaux)) + write (ulsort,texte(langue,20)) mess14(langue,1,1), laretg + codret = option + endif + tabaux(2,jaux) = laret1 + goto 32 + endif +c + 321 continue +c + kaux = kaux + 1 + tabaux(1,kaux) = laret1 + tabaux(3,kaux) = laretg +c + endif +c + endif +c + 32 continue +c + endif +c +cgn if ( codret.eq.0 ) then +cgn call utvars ( 1, 2, kaux, tabaux, +cgn > somare, +cgn > ulsort, langue, codret ) +cgn write (ulsort,*) 'dans ',nompro,' ',1, 2,codret +cgn endif +c +cgn if ( codret.eq.0 ) then +cgn call utvars ( 2, 3, kaux, tabaux, +cgn > somare, +cgn > ulsort, langue, codret ) +cgn write (ulsort,*) 'dans ',nompro,' ',2,3,codret +cgn endif +cc +cgn if ( codret.eq.0 ) then +cgn call utvars ( 3, 1, kaux, tabaux, +cgn > somare, +cgn > ulsort, langue, codret ) +cgn write (ulsort,*) 'dans ',nompro,' ',3,1,codret +cgn endif + +c 3.3. ==> Les places 1 et 2 de tabaux contiennent les 2 numeros actuels +c de 2 aretes soeurs, dans la generation numgen. Il y a kaux +c couples de ce genre. +c Ces aretes ont leurs numeros inferieurs a numfin. +c On va les placer 2 par 2 a partir de numfin, en descendant. +c + if ( codret.eq.0 ) then +c + ifin = numfin +c + do 33 , iaux = 1 , kaux +c + if ( codret.eq.0 ) then +c + laret1 = tabaux(1,iaux) + laret2 = tabaux(2,iaux) +c +#ifdef _DEBUG_HOMARD_ +cgn if (laret1.eq.15935)then + write (ulsort,texte(langue,19)) mess14(langue,1,1), laret1 + write (ulsort,texte(langue,19)) mess14(langue,1,1), laret2 + write (ulsort,texte(langue,20)) mess14(langue,1,1), tabaux(3,iaux) +cgn endif +#endif +c + nouare(laret1) = ifin + nouare(laret2) = ifin - 1 +c + ifin = ifin - 2 +c + endif +c + 33 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) numfin-ifin, + > mess14(langue,3,1), numgen +#endif +c + numfin = ifin +cgn write (ulsort,9999) (iaux, nouare(iaux),iaux=1,nbarto) +cgn 9999 format('nouare(',i10,') = ',i10) +c + endif +c +c==== +c 5. option numero 0 : dans une fratrie, les soeurs sont rangees selon +c les numeros des sommets de l'arete mere (cf. cmrda1) +c==== +c + elseif ( option.eq.0 ) then +c + do 50 , iaux = 1 , nbarto +c +cgn write (ulsort,*) 'arete ',iaux,' de fille ',filare(iaux) + if ( filare(iaux).gt.0 ) then +c + laret1 = filare(iaux) + laret2 = filare(iaux) + 1 +cgn write (ulsort,*) '.. ',laret1, ' de ', somare(1,laret1), +cgn >' a ',somare(2,laret1),' de mere ',merare(laret1) +cgn write (ulsort,*) '.. ',laret2, ' de ', somare(1,laret2), +cgn >' a ',somare(2,laret2),' de mere ',merare(laret2) +c + if ( merare(laret2).eq.iaux ) then +c + if ( somare(1,laret1).gt.somare(1,laret2) ) then +cgn write (ulsort,*) 'echange des aretes ',laret1, ' et ', laret2 + nouare(laret1) = laret2 + nouare(laret2) = laret1 + endif +c + endif +c + endif +c + 50 continue +c +c +c==== +c 6. option autre : impossible +c==== +c + else +c + codret = -1 +c + endif +c +c==== +c 7. la fin +c==== +c +cgn write (ulsort,*) 'nouare :' +cgn write (ulsort,5555) (nouare(iaux),iaux=1,nbarto) +cgn 5555 format(10i8) +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc04.F b/src/tool/Utilitaire/utnc04.F new file mode 100644 index 00000000..a20c4f10 --- /dev/null +++ b/src/tool/Utilitaire/utnc04.F @@ -0,0 +1,427 @@ + subroutine utnc04 ( nbanci, arreca, arrecb, + > nouare, tabaux, + > arenoe, + > somare, hetare, np2are, + > merare, filare, insoar, + > coexar, narsho, narsca, + > ngenar, + > aretri, arequa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 04 +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . arreca . es .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . es .2*nbanci. liste des aretes recouvertes par une autre . +c . nouare . e . nbarto . nouveau numero des aretes . +c . tabaux . a . * . tableau auxiliaire . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . hetare . es . nbarto . historique de l'etat des aretes . +c . np2are . es . nbarto . noeud milieux des aretes . +c . merare . es . nbarto . mere des aretes . +c . filare . es . nbarto . premiere fille des aretes . +c . insoar . es . nbarto . information sur les sommets des aretes . +c . coexar . es . nbarto*. codes de conditions aux limites portants . +c . . . nctfar . sur les aretes . +c . narsho . es . rsarac . numero des aretes dans HOMARD . +c . narsca . es . rsarto . numero des aretes du calcul . +c . ngenar . es . nbarto . nombre de generations au-dessus des aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "envca1.h" +#include "dicfen.h" +#include "nbutil.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer nbanci + integer arreca(2*nbanci), arrecb(2*nbanci) + integer nouare(0:nbarto) + integer tabaux(*) + integer arenoe(nbnoto) + integer somare(2,nbarto), hetare(nbarto), np2are(nbarto) + integer filare(nbarto), merare(nbarto), insoar(nbarto) + integer coexar(nbarto,nctfar) + integer narsho(rsarac), narsca(rsarto) + integer ngenar(nbarto) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ifin +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + +#endif +c + codret = 0 +c +c==== +c 2. A-t-on vraiment besoin ? +c==== +c + afaire = .false. + do 21 , iaux = 1 , nbarto +c + if ( nouare(iaux).ne.iaux ) then +cgn print *,iaux, nouare(iaux) + afaire = .true. + goto 29 + endif +c + 21 continue +c + 29 continue +cgn print *, 'afaire = ',afaire +c + if ( afaire ) then +c +c==== +c 3. Prise en compte du changement de numerotation des aretes +c dans les tableaux de reperage des non conformites +c==== +c + ifin = 2*nbanci + do 31 , iaux = 1 , ifin +cgn if ( iaux.eq.10 .or. iaux.eq.15 ) then +cgn write (ulsort,*) 'arreca(',iaux,') = ',arreca(iaux) +cgn write (ulsort,*) 'arrecb(',iaux,') = ',arrecb(iaux) +cgn write (ulsort,*)'nouare(',arreca(iaux),') = ',nouare(arreca(iaux)) +cgn write (ulsort,*)'nouare(',arrecb(iaux),') = ',nouare(arrecb(iaux)) +cgn endif +c + arreca(iaux) = nouare(arreca(iaux)) + arrecb(iaux) = nouare(arrecb(iaux)) +c + 31 continue +c +c==== +c 4. Renumerotation des aretes liees aux noeuds +c==== +c + do 41 , iaux = 1 , nbnoto +c + arenoe(iaux) = nouare(arenoe(iaux)) +c + 41 continue +c +c==== +c 5. Renumerotation des caracteristiques liees aux aretes +c==== +c 5.1. ==> Sommets +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - somare', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, nbarto, somare, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 5.2. ==> Historiques de l'etat +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - hetare', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, nbarto, hetare, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> Eventuel noeud milieu +c + if ( degre.eq.2 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - np2are', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, nbarto, np2are, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.4. ==> Eventuelle information sur les sommets +c + if ( nbelig.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - insoar', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, nbarto, insoar, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.5. ==> Code externe sur les conditions aux limites +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - coexar', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > nbarto, nctfar, coexar, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 5.6. ==> Filiation +c + if ( codret.eq.0 ) then +c + do 561 , iaux = 1 , nbarto + filare(iaux) = 0 + merare(iaux) = 0 + 561 continue +c + kaux = 2*nbanci + do 562 , iaux = 1 , kaux + jaux = arreca(iaux) + if ( filare(jaux).eq.0 ) then + filare(jaux) = arrecb(iaux) + hetare(jaux) = 2 + else + filare(jaux) = min(arrecb(iaux),filare(jaux)) + endif + merare(arrecb(iaux)) = jaux + 562 continue +c + endif +cgn do jaux=1,nbarto +cgn print *,filare(jaux),merare(jaux) +cgn enddo +c +c 5.7. ==> Eventuelle renumerotation avec le code de calcul +c + if ( rsarac.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - narsho', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, rsarac, narsho, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( rsarto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - narsca', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, rsarto, narsca, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 5.8. ==> Nombre de generations de l'ascendance +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - ngenar', nompro +#endif + call utchnu ( iaux, nbarto, nouare, + > jaux, nbarto, ngenar, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 6. Renumerotation des aretes definissant les triangles +c==== +c + if ( nbtrto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - aretri', nompro +#endif + iaux = 2 + jaux = 3 + call utchnu ( iaux, nbarto, nouare, + > nbtrto, jaux, aretri, + > tabaux, + > ulsort, langue, codret ) +c + endif +cgn do jaux=1,nbtrto +cgn print *,(aretri(jaux,iaux),iaux=1,3) +cgn enddo +c + endif +c +c==== +c 7. Renumerotation des aretes definissant les quadrangles +c==== +c + if ( nbquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - arequa', nompro +#endif + iaux = 2 + jaux = 4 + call utchnu ( iaux, nbarto, nouare, + > nbquto, jaux, arequa, + > tabaux, + > ulsort, langue, codret ) +c + endif +cgn do jaux=1,nbquto +cgn print *,(arequa(jaux,iaux),iaux=1,4) +cgn enddo +c + endif +c + endif +c +c==== +c 8. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc05.F b/src/tool/Utilitaire/utnc05.F new file mode 100644 index 00000000..be7384a5 --- /dev/null +++ b/src/tool/Utilitaire/utnc05.F @@ -0,0 +1,361 @@ + subroutine utnc05 ( option, nbanci, numfin, + > arreca, arrecb, + > somare, + > ngenar, ngenno, nounoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 05 +c -- - - -- +c On change les numeros des noeuds concernees par les non-conformites +c Le noeud correspondant au noeud commun a 2 aretes recouvertes +c doit etre superieur a leurs 2 autres extremites. On le met donc +c a la fin. +c Attention a bien prendre en compte les noeuds isoles : il y en a +c toujours un avec du saturne ou de neptune pseudo-2D (cf vcms21) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de l'operation de renumerotation . +c . . . . -1 : creation des generations de noeuds . +c . . . . 2 : on met aux (2*nbanci+nbnois) premieres . +c . . . . places les sommets simples des aretes . +c . . . . recouvrantes . +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . numfin . es . 1 . numero d'ordre maximal pour le classement . +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . e .2*nbanci. liste des aretes recouvertes par une autre . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . ngenar . e . nbarto . nombre de generations au-dessus des aretes . +c . ngenno . s . nbnoto . nombre de generations au-dessus des noeuds . +c . nounoe . s . nbnoto . nouveau numero des noeuds . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer option + integer nbanci, numfin + integer arreca(2*nbanci), arrecb(2*nbanci) + integer somare(2,nbarto) + integer ngenar(nbarto), ngenno(nbnoto), nounoe(0:nbnoto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numgen, ifin + integer laret1, laretg + integer lesomm +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''Traitement numero'',i3))' + texte(1,6) = '(''Elaboration des generations de '',a)' + texte(1,7) = '(''Decalage des '',a,'' de generation'',i3)' + texte(1,9) = '(''Classement avant'',i10)' + texte(1,10) = '(''.. couvert par le '',a,i10)' + texte(1,11) = '('' du '',a,i10,'' au '',a,i10)' + texte(1,12) = + >'(''Impossible de trouver un sommet commun a ces : '',a)' + texte(1,13) = '(''Incoherence de generation'',)' + texte(1,14) = '(''. Generation du '',a,i10,'' :'',i10)' + texte(1,15) = '(''Examen du '',a,i10)' + texte(1,20) = '(i10,1x,a,''dans la generation'',i10)' +c + texte(2,5) = '(''Treatment #'',i3)' + texte(2,6) = '(''Creation of generations of '',a)' + texte(2,7) = '(''Renumbering of '',a,'' in generation'',i3)' + texte(2,9) = '(''Sort before'',i10)' + texte(2,10) = '(''.. covered by '',a,i10)' + texte(2,11) = '('' from '',a,i10,'' to '',a,i10)' + texte(2,12) = + >'(''A common node cannot be found for these '',a)' + texte(2,13) = '(''Generations are not coherent.'')' + texte(2,14) = '(''. Generation of '',a,i10,'' :'',i10)' + texte(2,15) = '(''Examination of '',a,i10)' + texte(2,20) = '(i10,1x,a,'' in generation'',i10)' +c +c 1.2. ==> initialisation +c + codret = 0 +c + if ( option.gt.0 ) then + numgen = option + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) option + if ( option.eq.-1 ) then + write (ulsort,texte(langue,6)) mess14(langue,3,-1) + elseif ( option.gt.0 ) then + write (ulsort,texte(langue,7)) mess14(langue,3,-1), numgen + write (ulsort,texte(langue,9)) numfin + endif +#endif +c +c 1.2. ==> Aucune renumerotation au depart +c + do 12 , iaux = 0 , nbnoto + nounoe(iaux) = iaux + 12 continue +c +c==== +c 2. option numero -1 : elaboration des generations des noeuds +c==== +c + if ( option.eq.-1 ) then +c + do 21 , iaux = 1 , nbnoto +c + ngenno(iaux) = 0 +c + 21 continue +c + ifin = 2*nbanci + do 22 , iaux = 1 , ifin +c + if ( codret.eq.0 ) then +c + laret1 = arrecb(iaux) + laretg = arreca(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,15)) mess14(langue,1,1), laret1 + write (ulsort,texte(langue,11)) + > mess14(langue,1,-1), somare(1,laret1), + > mess14(langue,1,-1), somare(2,laret1) + write (ulsort,texte(langue,10)) mess14(langue,1,1), laretg + write (ulsort,texte(langue,11)) + > mess14(langue,1,-1), somare(1,laretg), + > mess14(langue,1,-1), somare(2,laretg) +#endif +c + if ( somare(1,laret1).eq.somare(1,laretg) ) then + lesomm = somare(2,laret1) +c + elseif ( somare(1,laret1).eq.somare(2,laretg) ) then + lesomm = somare(2,laret1) +c + elseif ( somare(2,laret1).eq.somare(1,laretg) ) then + lesomm = somare(1,laret1) +c + elseif ( somare(2,laret1).eq.somare(2,laretg) ) then + lesomm = somare(1,laret1) +c + else +c + write (ulsort,texte(langue,12)) mess14(langue,3,1) + write (ulsort,texte(langue,15)) mess14(langue,1,1), laret1 + write (ulsort,texte(langue,11)) + > mess14(langue,1,-1), somare(1,laret1), + > mess14(langue,1,-1), somare(2,laret1) + write (ulsort,texte(langue,10)) mess14(langue,1,1), laretg + write (ulsort,texte(langue,11)) + > mess14(langue,1,-1), somare(1,laretg), + > mess14(langue,1,-1), somare(2,laretg) + codret = 1 +c + endif +c + endif +c + if ( codret.eq.0 ) then +c + if ( ngenno(lesomm).eq.0 ) then +c + ngenno(lesomm) = ngenar(laret1) +c + elseif ( ngenno(lesomm).ne.ngenar(laret1) ) then +c + write (ulsort,texte(langue,13)) + write (ulsort,texte(langue,14)) mess14(langue,1,1), + > laret1, ngenar(laret1) + write (ulsort,texte(langue,14)) mess14(langue,1,-1), + > lesomm, ngenno(lesomm) + codret = 2 +c + endif +c + endif +c + 22 continue +c +#ifdef _DEBUG_HOMARD_ +c +c 2.3. ==> impression du nombre de noeuds par generation +c + numgen = 0 +c + 230 continue +c + if ( codret.eq.0 ) then +c + ifin = 0 + do 23 , iaux = 1 , nbnoto +c + if ( ngenno(iaux).eq.numgen ) then + ifin = ifin + 1 + endif +c + 23 continue +c + if ( ifin.ne.0 ) then + write (ulsort,texte(langue,20)) ifin, + > mess14(langue,3,-1), numgen + numgen = numgen + 1 + goto 230 + endif +c + endif +#endif +c +c +c==== +c 3. option > 0 : on rassemble les noeuds de meme generation +c on les deplace vers la fin, en prenant soin de ne pas ecraser +c les generations plus jeunes (d'ou le demarrage a ifin) +c==== +c + elseif ( option.gt.0 ) then +c + ifin = numfin +c + do 31 , iaux = 1 , nbnoto +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,15)) mess14(langue,1,-1), iaux +#endif +cgn write (ulsort,*) 'ngenno=',ngenno(iaux),'ifin = ',ifin + if ( ngenno(iaux).eq.numgen .and. iaux.le.ifin ) then +c + do 311 , jaux = ifin, 1, -1 + if ( jaux.eq.iaux ) then + goto 312 + elseif ( ngenno(jaux).lt.numgen ) then + nounoe(jaux) = iaux + nounoe(iaux) = jaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,15)) mess14(langue,1,-1),iaux + write (ulsort,*) iaux,' devient', jaux +#endif + goto 312 + endif + 311 continue +c + codret = option +c + 312 continue +c + ifin = jaux - 1 + goto 31 +c + endif +c + endif +c + 31 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,20)) numfin-ifin, + > mess14(langue,3,-1), numgen +#endif +c + numfin = ifin +c +c==== +c 4. option autre : impossible +c==== +c + elseif ( option.eq.3 ) then +c + codret = -1 +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc06.F b/src/tool/Utilitaire/utnc06.F new file mode 100644 index 00000000..773f2bb1 --- /dev/null +++ b/src/tool/Utilitaire/utnc06.F @@ -0,0 +1,370 @@ + subroutine utnc06 ( option, + > nounoe, tabaux, tbdaux, + > coonoe, hetnoe, arenoe, + > coexno, nnosho, nnosca, + > ngenno, + > noempo, + > somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 06 +c -- - - -- +c Prise en compte des renumerotations des noeuds +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 0 : on renumerote tout . +c . . . . 1 : on ne renumerote pas ngenno . +c . nounoe . e . nbarto . nouveau numero des noeuds . +c . tabaux . a . * . tableau auxiliaire entier . +c . tbdaux . a . * . tableau auxiliaire reel . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . hetnoe . es . nbnoto . historique de l'etat des noeuds . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . coexno . es . nbnoto*. codes de conditions aux limites portants . +c . . . nctfno . sur les noeuds . +c . nnosho . es . rsnoac . numero des noeuds dans HOMARD . +c . nnosca . es . rsnoto . numero des noeuds dans le calcul . +c . ngenno . es . nbnoto . nombre de generations au-dessus des noeuds . +c . noempo . es . nbmpto . numeros des noeuds associes aux mailles . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "impr02.h" +#include "envex1.h" +c +#include "nombno.h" +#include "nombmp.h" +#include "nombar.h" +#include "envca1.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer option + integer nounoe(0:nbnoto) + integer tabaux(*) + integer hetnoe(nbnoto), arenoe(nbnoto) + integer ngenno(nbnoto) + integer noempo(nbmpto) + integer somare(2,nbarto) + integer coexno(nbnoto,nctfno) + integer nnosho(rsnoac), nnosca(rsnoto) +c + double precision tbdaux(nbnoto,sdim) + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + logical afaire +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Renumerotation complete des tableaux lies aux '',a)' + texte(1,5) = + > '(''Renumerotation des tableaux lies aux '',a,''sauf ngenno'')' + texte(1,6) = '(''Examen du '',a,i10)' +c + texte(2,4) = '(''Total renumbering of arrays connected to '',a)' + texte(2,5) = + > '(''Renumbering of arrays connected to '',a,''except ngenno'')' + texte(2,6) = '(''Examination of '',a,i10)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + if ( option.eq.0 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,-1) + else + write (ulsort,texte(langue,5)) mess14(langue,3,-1) + endif +#endif +c +c==== +c 2. A-t-on vraiment besoin ? +c==== +c + afaire = .false. + do 21 , iaux = 1 , nbnoto +c + if ( nounoe(iaux).ne.iaux ) then +cgn print *,iaux, nounoe(iaux) + afaire = .true. + goto 29 + endif +c + 21 continue +c + 29 continue +cgn print *, 'afaire = ',afaire +c + if ( afaire ) then +c +c==== +c 3. Renumerotation des caracteristiques liees aux noeuds +c==== +c 3.1. ==> Coordonnees +c + if ( codret.eq.0 ) then +c + do 311 , iaux = 1 , nbnoto + do 3111 , jaux = 1 , sdim + tbdaux(iaux,jaux) = coonoe(iaux,jaux) + 3111 continue + 311 continue +c + do 312 , iaux = 1 , nbnoto +c +cgn write (ulsort,*) iaux,' ==> ',nounoe(iaux) + if ( nounoe(iaux).ne.iaux ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,-1), iaux +#endif + do 3121 , jaux = 1 , sdim + coonoe(nounoe(iaux),jaux) = tbdaux(iaux,jaux) + 3121 continue + endif +c + 312 continue +c + endif +c +c 3.2. ==> Historiques de l'etat +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - hetnoe', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > jaux, nbnoto, hetnoe, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Code externe sur les conditions aux limites +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - coexno', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > nbnoto, nctfno, coexno, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> Arete sur le noeud +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - arenoe', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > jaux, nbnoto, arenoe, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.5. ==> Renumerotation avec le code de calcul +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - nnosho', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > jaux, rsnoac, nnosho, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - nnosca', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > jaux, rsnoto, nnosca, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.6. ==> Nombre de generations de l'ascendance +c + if ( codret.eq.0 ) then +c + if ( option.ne.1 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - ngenno', nompro +#endif + call utchnu ( iaux, nbnoto, nounoe, + > jaux, nbnoto, ngenno, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Renumerotation des sommets definissant les aretes +c Il faut corriger eventuellement l'orientation des aretes +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - somare', nompro +#endif + iaux = 2 + jaux = 2 + call utchnu ( iaux, nbnoto, nounoe, + > jaux, nbarto, somare, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nbarto + if ( somare(1,iaux).gt.somare(2,iaux) ) then + jaux = somare(1,iaux) + somare(1,iaux) = somare(2,iaux) + somare(2,iaux) = jaux + endif + 41 continue +c + endif +c +c==== +c 5. Eventuellement, renumerotation des sommets definissant +c les mailles-points +c==== +c + if ( nbmpto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - noempo', nompro +#endif + iaux = 2 + jaux = 1 + call utchnu ( iaux, nbnoto, nounoe, + > jaux, nbmpto, noempo, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc07.F b/src/tool/Utilitaire/utnc07.F new file mode 100644 index 00000000..5c3d48a9 --- /dev/null +++ b/src/tool/Utilitaire/utnc07.F @@ -0,0 +1,188 @@ + subroutine utnc07 ( nbanci, + > noerec, arreca, arrecb, + > somare, arenoe, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 07 +c -- - - -- +c A partir des correspondances entre aretes, on memorise le sommet +c commun aux deux filles. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . noerec . s . nbanci . liste initiale des noeuds de recollement . +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . arrecb . e .2*nbanci. liste des aretes recouvertes par une autre . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arenoe . es . nbnoto . 0 pour un sommet, le numero de l'arete pour. +c . . . . un noeud milieu . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC07' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer nbanci + integer noerec(nbanci) + integer arreca(2*nbanci), arrecb(2*nbanci) + integer arenoe(nbnoto) + integer somare(2,nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer ifin, jfin + integer laret1, laretg + integer lesomm +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de l''''arete'',i10)' + texte(1,5) = '(''.. couverte par l''''arete'',i10)' + texte(1,6) = '(''Sommet commun aux aretes'')' + texte(1,7) = '(''Nombre de noeuds trouves :'',i10)' + texte(1,8) = '(''Nombre de noeuds attendus :'',i10)' +c + texte(2,4) = '(''Examination of edge #'',i10)' + texte(2,5) = '(''.. covered by edge #'',i10)' + texte(2,6) = '(''Glue for edges'')' + texte(2,7) = '(''Number of found edges :'',i10)' + texte(2,8) = '(''Number of expected edges :'',i10)' +c + codret = 0 +c +c==== +c 2. On regarde toutes les non conformites +c==== +c + jfin = 0 + ifin = 2*nbanci + do 21 , iaux = 1 , ifin +c + if ( codret.eq.0 ) then +c + laret1 = arrecb(iaux) + laretg = arreca(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) laret1 + write (ulsort,texte(langue,5)) laretg +#endif +c + lesomm = somare(2,laret1) +c + do 211 , jaux = 1 , jfin +c + if ( noerec(jaux).eq.lesomm ) then + goto 21 + endif +c + 211 continue +c + jfin = jfin + 1 + noerec(jfin) = lesomm + arenoe(lesomm) = laretg +c + endif +c + 21 continue +c +c==== +c 3. controle +c==== +c + if ( jfin.gt.nbanci ) then +c + write (ulsort,texte(langue,6)) + write (ulsort,texte(langue,7)) jfin + write (ulsort,texte(langue,8)) nbanci + codret = 1 +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc08.F b/src/tool/Utilitaire/utnc08.F new file mode 100644 index 00000000..d12c8dda --- /dev/null +++ b/src/tool/Utilitaire/utnc08.F @@ -0,0 +1,309 @@ + subroutine utnc08 ( nharet, nhtria, nhquad, nhvois, + > numead, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 08 +c -- - - -- +c On repere chaque face du macro maillage qui est bordee par une +c arete de non conformite initiale. On declare que cette face a une +c mere, dont le numero est un numero fictif, ne correspondant a +c aucune face possible. +c Ce programme est la surcouche de utnc09 qui fait le travail +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhvois . e . char8 . nom de la branche Voisins . +c . numead . s . 1 . numero de la mere adoptive . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC08' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + character*8 nharet, nhtria, nhquad + character*8 nhvois + integer numead +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre0 + integer pposif, pfacar + integer ppertr + integer pperqu + integer nbanci + integer adarrb + integer numea0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Parentes adoptive pour les faces'')' + texte(1,5) = '(''Nombre de non-conformites :'',i10))' + texte(1,6) = '(''Ancien numero de la mere adoptive :'',i10))' + texte(1,7) = '(''. Nouveau numero de la mere adoptive :'',i10))' +c + texte(2,4) = '(''Adoptive fatherhood for faces'')' + texte(2,5) = '(''Number of non-conformal situations :'',i10))' + texte(2,6) = '(''Old number for adoptive mother :'',i10))' + texte(2,7) = '(''. New number for adoptive mother :'',i10))' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) +#endif +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> Combien de non-conformites initiales ? +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03', nompro +#endif + iaux = 22 + call utad03 ( iaux, nharet, + > nbanci, jaux, jaux, + > jaux, adarrb, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbanci +#endif +c +c 2.2. ==> Adresses des peres +c + if ( nbanci.gt.0 ) then +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02', nompro +#endif + iaux = 5 + call utad02 ( iaux, nhtria, + > jaux, jaux, jaux, ppertr, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03', nompro +#endif + iaux = 5 + call utad03 ( iaux, nhtria, + > jaux, jaux, numea0, + > jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbquto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02', nompro +#endif + iaux = 5 + call utad02 ( iaux, nhquad, + > jaux, jaux, jaux, pperqu, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD03', nompro +#endif + iaux = 5 + call utad03 ( iaux, nhquad, + > jaux, jaux, numea0, + > jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c 2.3. ==> Voisinages des aretes +c + if ( nbanci.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD04', nompro +#endif + iaux = 3 + call utad04 ( iaux, nhvois, + > jaux, jaux, pposif, pfacar, + > jaux, jaux, + > jaux, jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. Traitement des non conformites +c==== +c + if ( nbanci.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) numea0 +#endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNC09', nompro +#endif +c + call utnc09 ( nbanci, imem(adarrb), numea0, + > imem(ppertr), imem(pperqu), numead, + > imem(pposif), imem(pfacar), + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) numead +#endif +c + if ( nbtrto.gt.0 ) then +c + call gmecat ( nhtria//'.Recollem', 3, numead, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c + if ( nbquto.gt.0 ) then +c + call gmecat ( nhquad//'.Recollem', 3, numead, codre0 ) + codret = max ( abs(codre0), codret ) +c + endif +c +cgn call gmprsx (nompro,nhtria//'.Recollem') +cgn call gmprsx (nompro,nhquad//'.Recollem') +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc09.F b/src/tool/Utilitaire/utnc09.F new file mode 100644 index 00000000..cc96dcb6 --- /dev/null +++ b/src/tool/Utilitaire/utnc09.F @@ -0,0 +1,200 @@ + subroutine utnc09 ( nbanci, arrecb, numea0, + > pertri, perqua, numead, + > posifa, facare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 09 +c -- - - -- +c On repere chaque face du macro maillage qui est bordee par une +c arete de non conformite initiale. On declare que cette face a une +c mere, dont le numero est un numero fictif, ne correspondant a +c aucune face possible. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . arrecb . e .2*nbanci. liste des aretes recouvertes par une autre . +c . numea0 . e . 1 . ancien numero de la mere adoptive ou 0 . +c . pertri . es . nbtrto . pere des triangles . +c . perqua . es . nbquto . pere des quadrangles . +c . numead . s . 1 . numero de la mere adoptive . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC09' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbanci, arrecb(2*nbanci) + integer numea0 + integer pertri(nbtrto), perqua(nbquto) + integer numead + integer posifa(0:nbarto), facare(nbfaar) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer ipos + integer ideb, ifin + integer larete +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de non-conformites :'',i10))' + texte(1,5) = '(''Numero de la mere adoptive :'',i10))' + texte(1,6) = '(''Examen de l''''arete'',i10)' + texte(1,7) = '(''..'',i2,''eme face :'',i10)' + texte(1,8) = '(''Ancien numero de la mere adoptive :'',i10))' +c + texte(2,4) = '(''Number of non-conformal situations :'',i10))' + texte(2,5) = '(''Number for adoptive mother :'',i10))' + texte(2,6) = '(''Examination of edge #'',i10)' + texte(2,7) = '(''..'',i2,''th face :'',i10)' + texte(2,8) = '(''Old number for adoptive mother :'',i10))' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbanci + if ( numea0.ne.0 ) then + write (ulsort,texte(langue,8)) numea0 + endif +#endif +c +c==== +c 2. On regarde toutes les aretes qui sont recouvertes par une autre. +c On trie les faces qui sont bordees par une de ces aretes. +c Chacune de ces faces qui sont du macro-maillage se voit +c attribuer une mere fictive, -nbfato-1, sauf si elle a deja une +c mere. Cela arrive dans le cas de face des recollement en 3D. +c==== +cgn print *,'perqua : ',perqua +cgn print *,'arrecb : ',arrecb +c + numead = -(nbtrto+nbquto+1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) numead +#endif +c + jaux = 2*nbanci + do 21 , iaux = 1 , jaux +c + larete = arrecb(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) larete +#endif + ideb = posifa(larete-1)+1 + ifin = posifa(larete) + do 211 , ipos = ideb, ifin +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) ipos-ideb+1, facare(ipos) +#endif + if ( facare(ipos).gt.0 ) then + if ( facare(ipos).le.nbtrma ) then + if ( pertri(facare(ipos)).eq.0 .or. + > pertri(facare(ipos)).eq.numea0 ) then + pertri(facare(ipos)) = numead + endif + endif + else + if ( -facare(ipos).le.nbquma ) then + if ( perqua(-facare(ipos)).eq.0 .or. + > perqua(-facare(ipos)).eq.numea0 ) then + perqua(-facare(ipos)) = numead + endif + endif + endif + 211 continue +c + 21 continue +cgn print *,'pertri : ',pertri +cgn print *,'perqua : ',perqua +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc11.F b/src/tool/Utilitaire/utnc11.F new file mode 100644 index 00000000..0b7016cf --- /dev/null +++ b/src/tool/Utilitaire/utnc11.F @@ -0,0 +1,238 @@ + subroutine utnc11 ( nbanci, arreca, + > aretri, filtri, + > arequa, filqua, + > filare, posifa, facare, + > nbnoct, nbnocq, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 11 +c -- - - -- +c On repere chaque face du macro maillage qui est bordee par une +c arete recouvrante pour la non conformite initiale. +c . Pour un triangle, on compte ceux dont les 3 aretes +c sont recouvrantes. +c . Pour un quadrangle on compte ceux dont les 4 aretes +c sont recouvrantes. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbanci . e . 1 . nombre d'aretes de non conformite initiale . +c . . . . egal au nombre d'aretes recouvrant 2 autres. +c . arreca . e .2*nbanci. liste des aretes recouvrant une autre . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . filare . e . nbarto . premiere fille des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . nbnoct . s . 1 . nombre de tria avec 3 aretes recouvrantes . +c . nbnocq . s . 1 . nombre de quad avec 4 aretes recouvrantes . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC11' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbanci, arreca(2*nbanci) + integer aretri(nbtrto,3) + integer filtri(nbtrto) + integer arequa(nbquto,4) + integer filqua(nbquto) + integer filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) + integer nbnoct, nbnocq +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ipos + integer ideb, ifin + integer larete, letria, lequad + integer compte +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paires de '',a,'' non-conformes :'',i10))' + texte(1,5) = '(a,'' Examen du '',a,'' numero'',i10)' + texte(1,6) = '(''...'',i2,''eme face voisine'')' + texte(1,7) = '(''... Nombre de '',a,'' recouvrants :'',i10))' + texte(1,8) = + > '(''Nombre de '',a,'' a aretes recouvrantes :'',i10))' +c + texte(2,4) = + > '(''Number of pairs of non-conformal '',a,'' :'',i10))' + texte(2,5) = '(a,'' Examination of '',a,'' #'',i10)' + texte(2,6) = '(''...'',i2,''th face'')' + texte(2,7) = '(''Number of covering '',a,'' :'',i10))' + texte(2,8) = + > '(''Number of '',a,'' with covering edges :'',i10))' +c + codret = 0 +c + nbnoct = 0 + nbnocq = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci +#endif +c +c==== +c 2. On regarde toutes les aretes qui en recouvrent une autre. +c==== +cgn print *,'filqua : ',filqua +c + jaux = 2*nbanci + do 21 , iaux = 1 , jaux +c + larete = arreca(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) '.', mess14(langue,1,1), larete +#endif +c +c 2.1. ==> On regarde toutes les faces qui s'appuie sur cette arete +c + ideb = posifa(larete-1)+1 + ifin = posifa(larete) +c + do 211 , ipos = ideb, ifin +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) ipos-ideb+1 +#endif +c +c 2.1.1. ==> un triangle : on arrete pour le moment +c + if ( facare(ipos).gt.0 ) then + letria = facare(ipos) +cgn#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) '...', mess14(langue,1,2), letria +cgn#endif + codret = 666 +c +c 2.1.2. ==> Un quadrangle : on compte le nombre d'aretes recouvrantes +c qui le definissent +c Attention a ne pas examiner plusieurs fois de suite +c le meme quadrangle ... +c + else + lequad = -facare(ipos) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) '...', mess14(langue,1,4), lequad +#endif + if ( filqua(lequad).eq.0 ) then +c + compte = 0 + do 2121 , kaux = 1 , 4 + if ( filare(arequa(lequad,kaux)).ne.0 ) then + compte = compte + 1 + endif + 2121 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,1), compte +#endif +c + if ( compte.eq.4 ) then + filqua(lequad) = -4 + nbnocq = nbnocq + 1 + endif +c + endif +c + endif +c + 211 continue +c + 21 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), nbnoct + write (ulsort,texte(langue,8)) mess14(langue,3,4), nbnocq +#endif +cgn print *,'filqua : ',filqua +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc12.F b/src/tool/Utilitaire/utnc12.F new file mode 100644 index 00000000..581f098f --- /dev/null +++ b/src/tool/Utilitaire/utnc12.F @@ -0,0 +1,301 @@ + subroutine utnc12 ( hettri, aretri, filtri, pertri, + > hetqua, arequa, filqua, perqua, + > filare, posifa, facare, + > nbnocq, qureca, qurecb, conocq, + > nbnoct, trreca, trrecb, conoct, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 12 +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . pertri . e . nbtrto . pere des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . filare . e . nbarto . premiere fille des aretes . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . facare . e . nbfaar . liste des faces contenant une arete . +c . nbnocq . e . 1 . nombre de non conformites de quadrangles . +c . qureca . s .4*nbnocq. liste des quad. recouvrant un autre . +c . qurecb . s .4*nbnocq. liste des quad. recouverts par un autre . +c . nbnoct . e . 1 . nombre de non conformites de quadrangles . +c . trreca . s .4*nbnoct. liste des triangles recouvrant un autre . +c . trrecb . s .4*nbnoct. liste des triangles recouverts par un autre. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC12' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +#include "impr02.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbnocq, qureca(4*nbnocq), qurecb(4*nbnocq), conocq + integer nbnoct, trreca(4*nbnoct), trrecb(4*nbnoct), conoct + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto), pertri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer filare(nbarto) + integer posifa(0:nbarto), facare(nbfaar) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ipos + integer ideb, ifin + integer lequad + integer conosv + integer lareta, laretb + integer fillea, filleb, lequfi +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de '',a,'' a aretes recouvrantes :'',i10))' + texte(1,6) = '(a,'' Examen du '',a,'' numero'',i10)' + texte(1,7) = '(''Recollement des '',a)' + texte(1,8) = '(''Nombre trouve :'',i10)' + texte(1,9) = '(''Nombre attendu :'',i10)' +c + texte(2,4) = + > '(''Number of '',a,'' with covering edges :'',i10))' + texte(2,6) = '(a,'' Examination of '',a,'' #'',i10)' + texte(2,7) = '(''Glue for '',a)' + texte(2,8) = '(''Found number :'',i10)' + texte(2,9) = '(''Expected number :'',i10)' +c + codret = 0 +c + conoct = 0 + conocq = 0 +c +c==== +c 2. Les triangles +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbnoct + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbnocq +#endif +c + if ( nbnoct.gt.0 ) then + codret = 12000 + endif +cgn print *,'pertri : ',pertri +cgn print *,'filtri : ',filtri +c +c==== +c 3. Les quadrangles +c On va reperer tous ceux concernes : c'est possible car on leur a +c attribue un fils negatif a l'etape precedente. +c==== +c + if ( nbnocq.gt.0 ) then +c + do 31 , lequad = 1 , nbquto +c +#ifdef _DEBUG_HOMARD_ + if ( filqua(lequad).ne.0 ) then + write (ulsort,texte(langue,6)) '...', mess14(langue,1,4), lequad + endif +#endif +c +c 3.1. ==> Le quadrangle a 4 aretes non conformes +c On cherche les numeros des 4 quadrangles qui se trouvent +c 'dessous'. On passe par les aretes qui sont les filles de +c ces aretes a lui. Les quadrangles fils sont ceux qui +c partagent deux aretes filles consecutives. +c Remarque : il faut placer les quadrangles fils dans l'ordre +c de la convention de decoupage (cf. cmrdqu). Le premier est +c celui qui s'appuie sur les aretes 4 et 1. Le 2eme s'appuie +c sur les aretes 1 et 2, le 3eme sur les aretes2 et 3, le 4eme +c sur les aretes 3 et 4. On va les ranger dans l'ordre dans +c les listes de recollement. +c +c remarque : le dernier quadrangle est celui qui correspond +c au fils aine +c remarque : per1a4(-1,i) renvoie l'entier qui est avant i +c + if ( filqua(lequad).eq.-4 ) then +c + conosv = conocq +c + do 311 , iaux = 4, 1, -1 +c + lareta = arequa(lequad,iaux) + laretb = arequa(lequad,per1a4(-1,iaux)) +cgn write (ulsort,*) lareta, laretb +c + do 312 , jaux = 0 , 1 + fillea = filare(lareta) + jaux + ideb = posifa(fillea-1)+1 + ifin = posifa(fillea) +cgn write (ulsort,*) '.', ideb, ifin + do 313 , kaux = 0 , 1 + filleb = filare(laretb) + kaux +cgn write (ulsort,*) '...', fillea, filleb + do 314 , ipos = ideb, ifin + if ( facare(ipos).lt.0 ) then + lequfi = -facare(ipos) +cgn write (ulsort,*) '.....', lequfi + if ( arequa(lequfi,1).eq.filleb .or. + > arequa(lequfi,2).eq.filleb .or. + > arequa(lequfi,3).eq.filleb .or. + > arequa(lequfi,4).eq.filleb ) then + conocq = conocq + 1 + qureca(conocq) = lequad + qurecb(conocq) = lequfi + perqua(lequfi) = lequad + goto 311 + endif + endif + 314 continue + 313 continue + 312 continue +c +cccc codret = codret + 1 +c + 311 continue +c + if ( conocq.eq.conosv ) then + filqua(lequad) = 0 + elseif ( conocq.eq.(conosv+4) ) then + filqua(lequad) = lequfi + hetqua(lequad) = 4 + else + write(ulsort,*) 'lequad = ',lequad + write(ulsort,*) 'conocq = ',conocq + write(ulsort,*) 'conosv = ',conosv + codret = 31 + endif +c +c 3.2. ==> Le quadrangle a 2 aretes non conformes +c + elseif ( filqua(lequad).eq.-1 .or. filqua(lequad).eq.-2 ) then +c + codret = 3232 +c + endif +c + 31 continue +cgn print *,'filqua : ',filqua +cgn print *,'perqua : ',perqua +c + endif +c +c==== +c 4. controle +c==== +c + if ( conoct.gt.4*nbnoct ) then +c + write (ulsort,texte(langue,7)) mess14(langue,3,2) + write (ulsort,texte(langue,8)) conoct + write (ulsort,texte(langue,9)) 4*nbnoct + codret = 1 +c + endif +c + if ( conocq.gt.4*nbnocq ) then +c + write (ulsort,texte(langue,7)) mess14(langue,3,4) + write (ulsort,texte(langue,8)) conocq + write (ulsort,texte(langue,9)) 4*nbnocq + codret = 1 +c + endif +c + conoct = conoct / 4 + conocq = conocq / 4 +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc13.F b/src/tool/Utilitaire/utnc13.F new file mode 100644 index 00000000..da5308a0 --- /dev/null +++ b/src/tool/Utilitaire/utnc13.F @@ -0,0 +1,527 @@ + subroutine utnc13 ( option, + > nbnoct, trreca, trrecb, + > nbnocq, qureca, qurecb, + > arequa, filqua, perqua, + > filare, + > nouqua, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 13 +c -- - - -- +c On change les numeros des faces concernees par les non-conformites +c . les faces recouvrantes sont mises au debut. +c . les faces recouvertes sont mises a la fin, en les regroupant +c par fratries +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de l'operation de renumerotation . +c . . . . 1 : on enleve des nbnocq premieres places . +c . . . . les faces recouvertes . +c . . . . 2 : on met aux nbnocq premieres places les . +c . . . . faces recouvrantes . +c . . . . 3 : on regroupe par fratries les faces . +c . . . . recouvertes . +c . nbnoct . e . 1 . nombre de non conformites de quadrangles . +c . trreca . s .4*nbnoct. liste des triangles recouvrant un autre . +c . trrecb . s .4*nbnoct. liste des triangles recouverts par un autre. +c . nbnocq . e . 1 . nombre de non conformites de quadrangles . +c . qureca . e .4*nbnocq. liste des quad. recouvrant un autre . +c . qurecb . e .4*nbnocq. liste des quad. recouverts par un autre . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . perqua . e . nbquto . pere des quadrangles . +c . filare . e . nbarto . premiere fille des aretes . +c . nouqua . s . nbquto . nouveau numero des quadrangles . +c . tabaux . a .5*nbnocq. tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC13' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +#include "impr02.h" +#include "nombar.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer option + integer nbnoct, trreca(4*nbnoct), trrecb(4*nbnoct) + integer nbnocq, qureca(4*nbnocq), qurecb(4*nbnocq) + integer arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer filare(nbarto) + integer nouqua(0:nbquto) + integer tabaux(5,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux, maux + integer ifin + integer jauxm1 + integer lequa1, lequag, lequad + integer lefils(4), quangl(4) + integer arei, areim1 + integer f1ai, f2ai, f1aim1, f2aim1 + integer aretf(4) + integer debut + integer lgtab +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Nombre de paquets de 4 '',a,'' non-conformes :'',i10))' + texte(1,5) = '(''Decalage des quadrangles recouverts'')' + texte(1,6) = '(''Renumerotation des quadrangles recouvrants'')' + texte(1,7) = '(''Regroupement des quadrangles recouverts'')' + texte(1,8) = '(''Examen du '',a,'' numero'',i10)' + texte(1,9) = '(''.. couvert par le '',a,'' numero'',i10)' + texte(1,10) = '(''.. couvrant les '',a,'' numero'',4i10)' + texte(1,11) = '(''dont les '',a,'' sont :'',4i10)' +c + texte(2,4) = + > '(''Number of packs of 4 non-conformal '',a,'' :'',i10))' + texte(2,5) = '(''Shift of covered edges'')' + texte(2,6) = '(''Renumbering of covering edges'')' + texte(2,7) = '(''Gathering of covered edges'')' + texte(2,8) = '(''Examination of '',a,'' #'',i10)' + texte(2,9) = '(''.. covered by '',a,'' #'',i10)' + texte(2,10) = '(''.. covering '',a,'' #'',4i10)' + texte(2,11) = '(''with '',a,'' # :'',4i10)' +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,2), nbnoct + write (ulsort,texte(langue,4)) mess14(langue,3,4), nbnocq + write (ulsort,texte(langue,4+option)) +#endif +c +c 1.2. ==> Aucune renumerotation au depart +c + do 12 , iaux = 0 , nbquto + nouqua(iaux) = iaux + 12 continue +c +c==== +c 2. option numero 1 : plus aucune face recouverte ne doit se trouver +c parmi les nbnocq premieres +c On examine chacune des faces recouvertes. Si son numero +c est inferieur a nbnocq, on la permute avec une face de numero +c superieur a nbnocq et qui n'est pas une recouverte +c==== +c + if ( option.eq.1 ) then +c + if ( codret.eq.0 ) then +c + debut = nbnocq + 1 + ifin = 4*nbnocq + do 21 , iaux = 1 , ifin +c + if ( codret.eq.0 ) then +c + lequad = qurecb(iaux) +c + if ( lequad.le.nbnocq ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad +#endif + do 211 , jaux = debut, nbquto + if ( perqua(jaux).eq.0 ) then + kaux = jaux + goto 212 + endif + 211 continue +c + codret = option +c + 212 continue +c + nouqua(kaux) = lequad + nouqua(lequad) = kaux + debut = kaux + 1 +cgn write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad +cgn write (ulsort,*) lequad,' devient', kaux +c + endif +c + endif +c + 21 continue +c + endif +c +c==== +c 3. option numero 2 : les faces recouvrantes sont mises aux nbnocq +c premieres places +c On examine chacune des faces recouvrantes dans la liste qureca. Si +c son numero est superieur a nbnocq, on la permute avec une face +c de numero inferieur a nbnocq et qui n'est pas une recouvrante. Il +c faut noter que chaque face apparait plusieurs fois. Il ne faut la +c permuter que la 1ere fois : cela se repere avec son nouveau numero +c==== +c + elseif ( option.eq.2 ) then +c + if ( codret.eq.0 ) then +c + debut = 1 + ifin = 4*nbnocq + do 31 , iaux = 1 , ifin +c + if ( codret.eq.0 ) then +c + lequad = qureca(iaux) +c + if ( lequad.gt.nbnocq .and. nouqua(lequad).eq.lequad ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad +#endif + do 311 , jaux = debut, nbnocq + if ( filqua(jaux).eq.0 ) then + kaux = jaux + goto 312 + endif + 311 continue +c + codret = option +c + 312 continue +c + nouqua(kaux) = lequad + nouqua(lequad) = kaux + debut = kaux + 1 +cgn write (ulsort,*) lequad,' devient', kaux +c + endif +c + endif +c + 31 continue +c + endif +c +c==== +c 4. option numero 3 : les faces recouvertes sont regroupees par +c fratries +c==== +c + elseif ( option.eq.3 ) then +c +c 4.1. ==> Regroupement des fils adoptifs et de leur pere +c 4.1.1. ==> Aucun regroupement au depart +c + do 41 , iaux = 1 , nbnocq +c + tabaux(1,iaux) = 0 + tabaux(2,iaux) = 0 + tabaux(3,iaux) = 0 + tabaux(4,iaux) = 0 + tabaux(5,iaux) = 0 +c + 41 continue +c +c 4.1.2. ==> On regroupe les fils adoptifs et leur pere +c + lgtab = 0 + ifin = 4*nbnocq + do 42 , iaux = 1 , ifin +c + lequa1 = qurecb(iaux) + lequag = qureca(iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lequa1 + write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag +#endif +c +c on cherche si on a deja place le quadrangle jumeau de lequa1 +c . si oui, on place le quadrangle courant en position 3, 4 ou 5 +c . si non, on place le quadrangle pere en position 1 et le fils +c en position 2 +c + do 422 , jaux = 1, lgtab +c + if ( tabaux(1,jaux).eq.lequag ) then + if ( tabaux(3,jaux).eq.0 ) then + tabaux(3,jaux) = lequa1 + elseif ( tabaux(4,jaux).eq.0 ) then + tabaux(4,jaux) = lequa1 + else + tabaux(5,jaux) = lequa1 + endif + goto 42 + endif +c + 422 continue +c + lgtab = lgtab + 1 + tabaux(1,lgtab) = lequag + tabaux(2,lgtab) = lequa1 +c + 42 continue +cgn print *,'lgtab = ', lgtab +c +c 4.3. ==> Les quadrangles recouverts : on les place par 2 ou 4 +c On cherche en partant de la fin de la numerotation 2 ou 4 places +c contigues qui ne soient pas deja des quadrangles recouverts. +c Remarque : ce ne peut pas etre des recouvrants car on les +c a mis au debut au cours du passage option=1 +c + debut = nbnocq + 1 + do 43 , iaux = 1 , lgtab +c + if ( codret.eq.0 ) then +c + lequag = tabaux(1,iaux) + lefils(1) = tabaux(2,iaux) + lefils(2) = tabaux(3,iaux) + lefils(3) = tabaux(4,iaux) + lefils(4) = tabaux(5,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4) + write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag +#endif +c +c Pour 2 fils, on ne fait rien car pas prevu aujourd'hui + if ( lefils(3).eq.0 ) then +c + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3) + write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4) + write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag + codret = -1 +c + else +c + do 432 , jaux = debut, nbquto + if ( perqua(jaux ).eq.0 .and. perqua(jaux+1).eq.0 .and. + > perqua(jaux+2).eq.0 .and. perqua(jaux+3).eq.0 ) then + kaux = jaux + goto 433 + endif + 432 continue + codret = option +c + endif +c + 433 continue +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'kaux = ', kaux +#endif +c +c 4.4. ==> Dans le cas de 4 fils, on doit reperer dans quel angle du +c pere se situe chacun d'eux pour respecter la convention +c de cmrdqu +c + if ( codret.eq.0 ) then +c + do 44 , jaux = 1 , 4 +c + if ( codret.eq.0 ) then +c +c 4.4.1. ==> Les 2 aretes j et j-1 du pere ainsi que leurs filles +c + arei = arequa(lequag,jaux) + f1ai = filare(arei) + f2ai = f1ai + 1 +c + jauxm1 = per1a4(-1,jaux) + areim1 = arequa(lequag,jauxm1) + f1aim1 = filare(areim1) + f2aim1 = f1aim1 + 1 +c +c 4.4.2. ==> Lequel des 4 quadrangles fils est dans cet angle ? +c + do 442 , laux = 1 , 4 +c +c 4.4.2.1. ==> Les aretes du laux-eme fils +c + do 4421 , maux = 1 , 4 + aretf(maux) = arequa(lefils(laux),maux) + 4421 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) + > mess14(langue,1,4)//'fils', lefils(laux) + write (ulsort,texte(langue,11)) mess14(langue,3,1), + > aretf +#endif +c +c 4.4.2.2. ==> Quelle arete du laux-eme fils est fille de l'arete i ? +c Si on n'en a pas trouve, on passe au fils suivant +c + do 4422 , maux = 1 , 4 +c + if ( aretf(maux).eq.f1ai .or. + > aretf(maux).eq.f2ai ) then + goto 44221 + endif +c + 4422 continue +c + goto 442 +c +44221 continue +c +c 4.4.2.3. ==> Quelle arete du fils est fille de l'arete i-1 ? +c Si on n'en a pas trouve, on passe au fils suivant +c + do 4423 , maux = 1 , 4 +c + if ( aretf(maux).eq.f1aim1 .or. + > aretf(maux).eq.f2aim1 ) then + goto 44231 + endif +c + 4423 continue +c + goto 442 +c +44231 continue +c +c 4.4.2.4. ==> Si on arrive ici, c'est que le laux-eme fils est +c dans l'angle jaux +c On passe a l'angle suivant. +c + quangl(jaux) = lefils(laux) + goto 44 +c + 442 continue +c +c 4.4.3. ==> Si on arrive ici, c'est qu'aucun fils n'est +c dans l'angle jaux +c + codret = 443 +c + endif +c + 44 continue +cgn write (ulsort,*) 'quangle : ',quangl +c + endif +c +c 4.5. ==> On renumerote en placant dans les angles corrects +c + if ( codret.eq.0 ) then +c + do 45 , jaux = 1 , 4 +c +cgn if ( kaux.eq.1501)then +cgn write(ulsort,*) 'kaux=1501 ',quangl(jaux) +cgn elseif ( quangl(jaux).eq.1501)then +cgn write(ulsort,*) 'quangl(jaux)=1501 ',kaux +cgn endif + nouqua(kaux) = quangl(jaux) + nouqua(quangl(jaux)) = kaux +c + kaux = kaux + 1 +c + 45 continue +c + debut = kaux +c + endif +c + endif +c + 43 continue +c +c==== +c 5. option autre : impossible +c==== +c + else +c + codret = -1 +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc14.F b/src/tool/Utilitaire/utnc14.F new file mode 100644 index 00000000..a1d1d408 --- /dev/null +++ b/src/tool/Utilitaire/utnc14.F @@ -0,0 +1,290 @@ + subroutine utnc14 ( nbnocq, qureca, qurecb, + > nouqua, tabaux, + > arequa, hetqua, + > filqua, perqua, + > coexqu, nqusho, nqusca, + > quahex, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 14 +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnocq . e . 1 . nombre de non conformites de quadrangles . +c . qureca . e .4*nbnocq. liste des quad. recouvrant un autre . +c . qurecb . e .4*nbnocq. liste des quad. recouverts par un autre . +c . nouqua . e . nbquto . nouveau numero des quadrangles . +c . tabaux . a . * . tableau auxiliaire . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . hetqua . es . nbquto . historique de l'etat des quadrangles . +c . filqua . es . nbquto . premier fils des quadrangles . +c . perqua . es . nbquto . pere des quadrangles . +c . coexqu . es . nbquto*. codes de conditions aux limites portants . +c . . . nctfqu . sur les quadrangles . +c . nqusho . es . rsquac . numero des quadrangles dans HOMARD . +c . nqusca . es . rsquto . numero des quadrangles du calcul . +c . quahex . es .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC14' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombqu.h" +#include "nombhe.h" +#include "dicfen.h" +#include "nombsr.h" +c +c 0.3. ==> arguments +c + integer nbnocq + integer qureca(4*nbnocq), qurecb(4*nbnocq) + integer nouqua(0:nbquto) + integer tabaux(*) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto), perqua(nbquto) + integer coexqu(nbquto,nctfqu) + integer nqusho(rsquac), nqusca(rsquto) + integer quahex(nbhecf,6) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ifin +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) + +#endif +c + codret = 0 +c +c==== +c 2. Prise en compte du changement de numerotation des aretes +c dans les tableaux de reperage des non conformites +c==== +c + ifin = 4*nbnocq + do 21 , iaux = 1 , ifin +c + qureca(iaux) = nouqua(qureca(iaux)) + qurecb(iaux) = nouqua(qurecb(iaux)) +c + 21 continue +c +c==== +c 3. Renumerotation des caracteristiques liees aux quadrangles +c==== +c 3.1. ==> Aretes +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - arequa', nompro +#endif + call utchnu ( iaux, nbquto, nouqua, + > nbquto, jaux, arequa, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.2. ==> Historiques de l'etat +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - hetqua', nompro +#endif + call utchnu ( iaux, nbquto, nouqua, + > jaux, nbquto, hetqua, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> Code externe sur les conditions aux limites +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - coexqu', nompro +#endif + call utchnu ( iaux, nbquto, nouqua, + > nbquto, nctfqu, coexqu, + > tabaux, + > ulsort, langue, codret ) +c + endif +c +c 3.4. ==> Filiation +c + if ( codret.eq.0 ) then +c + do 341 , iaux = 1 , nbquto + filqua(iaux) = 0 + perqua(iaux) = 0 + 341 continue +c + kaux = 4*nbnocq + do 342 , iaux = 1 , kaux + jaux = qureca(iaux) + if ( filqua(jaux).eq.0 ) then + filqua(jaux) = qurecb(iaux) + hetqua(jaux) = 4 + else + filqua(jaux) = min(qurecb(iaux),filqua(jaux)) + endif + perqua(qurecb(iaux)) = jaux + 342 continue +c + endif +cgn do jaux=1,nbquto +cgn print *,filqua(jaux),perqua(jaux) +cgn enddo +c +c 3.7. ==> Eventuelle renumerotation avec le code de calcul +c + if ( rsquac.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - nqusho', nompro +#endif + call utchnu ( iaux, nbquto, nouqua, + > jaux, rsquac, nqusho, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( rsquto.gt.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 + jaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - nqusca', nompro +#endif + call utchnu ( iaux, nbquto, nouqua, + > jaux, rsquto, nqusca, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 4. Renumerotation des quadrangles definissant les hexaedres +c==== +c + if ( nbheto.gt.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCHNU - quahex', nompro +#endif +cgn iaux=437 +cgn write(ulsort,1000) iaux, (quahex(iaux,jaux),jaux=1,6) +cgn 1000 format(i10,' :',6i10) + iaux = 2 + jaux = 6 + call utchnu ( iaux, nbquto, nouqua, + > nbheto, jaux, quahex, + > tabaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc15.F b/src/tool/Utilitaire/utnc15.F new file mode 100644 index 00000000..f55267c5 --- /dev/null +++ b/src/tool/Utilitaire/utnc15.F @@ -0,0 +1,419 @@ + subroutine utnc15 ( nbnocq, qureca, qurecb, + > somare, arequa, + > nounoe, tabaux, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 15 +c -- - - -- +c On cherche le numero du noeud central des faces recouvrantes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnocq . e . 1 . nombre de non conformites de quadrangles . +c . qureca . e .4*nbnocq. liste des quad. recouvrant un autre . +c . qurecb . e .4*nbnocq. liste des quad. recouverts par un autre . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . nounoe . s . nbnoto . nouveau numero des noeuds . +c . tabaux . a .5*nbnocq. tableau auxiliaire . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC15' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer nbnocq + integer qureca(4*nbnocq), qurecb(4*nbnocq) + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer nounoe(0:nbnoto) + integer tabaux(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer ifin + integer numqua, lequad(4), lepere + integer arequ1(4), arequ2(4), arequ3(4) + integer arco12, arco23, noecom, nbnoce + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen du '',a,'' numero'',i10)' + texte(1,5) = '(''.. couvert par le '',a,'' numero'',i10)' + texte(1,6) = '(''.. couvrant le '',a,'' numero'',4i10)' + texte(1,7) = '(''dont les '',a,'' sont :'',4i10)' + texte(1,8) = '(''Aucun '',a,'' en commun.'')' + texte(1,9) = '(''Ce noeud n''''appartient pas au '',a)' + texte(1,10) = '(a,'' commun :'',i10)' +c + texte(2,4) = '(''Examination of '',a,'' #'',i10)' + texte(2,5) = '(''.. covered by '',a,'' #'',i10)' + texte(2,6) = '(''.. covering '',a,'' #'',4i10)' + texte(2,7) = '(''with '',a,'' # :'',4i10)' + texte(2,8) = '(''No common '',a,''.'')' + texte(2,9) = '(''That node does not belong to '',a)' + texte(2,10) = '(''Common '',a,'' :'',i10)' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. On explore les paquets de 4 quadrangles recouverts +c==== +c + nbnoce = 0 + numqua = 1 + lequad(numqua) = qurecb(1) + lepere = qureca(1) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lepere + write (ulsort,texte(langue,6)) mess14(langue,1,4), qurecb(1) +#endif +c + ifin = 4*nbnocq + do 21 , iaux = 2 , ifin +c +c 2.1. ==> On cherche jusqu'a avoir trouve 4 quadrangles consecutifs +c recouverts par le meme autre +c + if ( codret.eq.0 ) then +c + if ( qureca(iaux).eq.lepere ) then + numqua = numqua + 1 + lequad(numqua) = qurecb(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,4), qurecb(iaux) +#endif + else + numqua = 1 + lequad(numqua) = qurecb(iaux) + lepere = qureca(iaux) +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lepere + write (ulsort,texte(langue,6)) mess14(langue,1,4), qurecb(iaux) +#endif + endif +c + endif +c +c 2.2. ==> On cherche le noeud commun aux 4 quadrangles +c + if ( numqua.eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,4,4), + > (lequad(kaux),kaux=1,numqua) +#endif +c +c 2.2.0. ==> On passe par des tableaux locaux pour les numeros +c d'arete pour eviter les problemes d'optimisation +c avec le compilateur intel ... +c + do 220 , kaux = 1 , 4 + arequ1(kaux) = arequa(lequad(1),kaux) + arequ2(kaux) = arequa(lequad(2),kaux) + arequ3(kaux) = arequa(lequad(3),kaux) + 220 continue + +c +c 2.2.1. ==> L'arete commune aux 1er et 2nd quadrangle +c + if ( codret.eq.0 ) then +c + arco12 = 0 + do 221 , kaux = 1 , 4 + if ( ( arequ1(kaux).eq.arequ2(1) ) .or. + > ( arequ1(kaux).eq.arequ2(2) ) .or. + > ( arequ1(kaux).eq.arequ2(3) ) .or. + > ( arequ1(kaux).eq.arequ2(4) ) ) then + arco12 = arequ1(kaux) + endif + 221 continue +c +#ifdef _DEBUG_HOMARD_ +c +#else + if ( arco12.eq.0 ) then +#endif + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad(1) + write (ulsort,texte(langue,7)) mess14(langue,3,1), + > (arequa(lequad(1),kaux),kaux=1,4) + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad(2) + write (ulsort,texte(langue,7)) mess14(langue,3,1), + > (arequa(lequad(2),kaux),kaux=1,4) + write (ulsort,texte(langue,10)) mess14(langue,2,1), arco12 +#ifdef _DEBUG_HOMARD_ +c +#else + endif +#endif + if ( arco12.eq.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1) + codret = 1 + endif +c + endif +c +c 2.2.2. ==> L'arete commune aux 2nd et 3eme quadrangle +c + if ( codret.eq.0 ) then +c + arco23 = 0 + do 222 , kaux = 1 , 4 + if ( ( arequ3(kaux).eq.arequ2(1) ) .or. + > ( arequ3(kaux).eq.arequ2(2) ) .or. + > ( arequ3(kaux).eq.arequ2(3) ) .or. + > ( arequ3(kaux).eq.arequ2(4) ) ) then + arco23 = arequ3(kaux) + endif + 222 continue +c +#ifdef _DEBUG_HOMARD_ +c +#else + if ( arco23.eq.0 ) then +#endif + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad(2) + write (ulsort,texte(langue,7)) mess14(langue,3,1), + > (arequa(lequad(2),kaux),kaux=1,4) + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad(3) + write (ulsort,texte(langue,7)) mess14(langue,3,1), + > (arequa(lequad(3),kaux),kaux=1,4) + write (ulsort,texte(langue,10)) mess14(langue,2,1), arco23 +#ifdef _DEBUG_HOMARD_ +c +#else + endif +#endif + if ( arco23.eq.0 ) then + write (ulsort,texte(langue,8)) mess14(langue,1,1) + codret = 1 + endif +c + endif +c +c 2.2.3. ==> Le noeud commun est le noeud commun a ces 2 aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,2,1), arco12 + write (ulsort,texte(langue,10)) mess14(langue,2,1), arco23 +#endif + if ( somare(1,arco12).eq.somare(1,arco23) .or. + > somare(1,arco12).eq.somare(2,arco23) ) then + noecom = somare(1,arco12) + elseif ( somare(2,arco12).eq.somare(1,arco23) .or. + > somare(2,arco12).eq.somare(2,arco23) ) then + noecom = somare(2,arco12) + else + write (ulsort,texte(langue,8)) mess14(langue,1,-1) + codret = 223 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) mess14(langue,2,-1), noecom +#endif + nbnoce = nbnoce + 1 + tabaux(nbnoce) = noecom +c + endif +c +c 2.2.3. ==> On verifie que ce noeud commun appartient bien au dernier +c quadrangle de la fratrie +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,4), lequad(4) +#endif + a1 = arequa(lequad(4),1) + a2 = arequa(lequad(4),2) + a3 = arequa(lequad(4),3) + a4 = arequa(lequad(4),4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + if ( ( noecom.ne.sa1a2 ) .and. + > ( noecom.ne.sa2a3 ) .and. + > ( noecom.ne.sa3a4 ) .and. + > ( noecom.ne.sa4a1 ) ) then + write (ulsort,texte(langue,4)) mess14(langue,1,4), + > lequad(4) + write (ulsort,texte(langue,7)) mess14(langue,3,-1), + > sa1a2, sa2a3, sa3a4, sa4a1 + write (ulsort,texte(langue,10)) mess14(langue,2,-1), noecom + write (ulsort,texte(langue,9)) mess14(langue,1,4) + codret = 1 + endif +c + endif +c + endif +c + 21 continue +c +c==== +c 3. Etablissement de la table de renumerotation des noeuds +c Les noeuds communs doivent etre mis au bout de la numerotation. +c On descend les autres numeros d'autant. +c Attention a ne pas permuter brutalement car les actuels grands +c numeros le sont du fait de la renumerotation precedente. Ils +c doivent donc rester grands, juste avant ceux que l'on traite ici. +c Exemple : +c On veut repousser les noeuds 4, 2 et 8 sur les 20 possibles. +c 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 +c Etapes de 'do 32' : +c ... pour tabaux(1) = 4 +c 1 2 3 4 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 +c ... pour tabaux(2) = 2 +c 1 2 2 3 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 +c ... pour tabaux(3) = 8 +c 1 2 2 3 3 4 5 6 6 7 8 9 10 11 12 13 14 15 16 17 +c Etapes de 'do 33' : +c ... pour tabaux(1) = 4 +c 1 2 2 20 3 4 5 6 6 7 8 9 10 11 12 13 14 15 16 17 +c ... pour tabaux(2) = 2 +c 1 19 2 20 3 4 5 6 6 7 8 9 10 11 12 13 14 15 16 17 +c ... pour tabaux(3) = 8 +c 1 19 2 20 3 4 5 18 6 7 8 9 10 11 12 13 14 15 16 17 +c==== +c + if ( codret.eq.0 ) then +c +c 3.1. ==> Aucune renumerotation au depart +c + do 31 , iaux = 0 , nbnoto + nounoe(iaux) = iaux + 31 continue +c +c 3.2. ==> Pour chaque noeud de numero superieur a un noeud a bouger, +c on diminue de 1 son rang +c +cgn write(ulsort,*) 'nbnoce = ',nbnoce +cgn print *,(tabaux(iaux),iaux=1,nbnoce) + do 32 , iaux = 1 , nbnoce + jaux = tabaux(iaux)+1 + do 321 , kaux = jaux, nbnoto + nounoe(kaux) = nounoe(kaux) - 1 + 321 continue + 32 continue +cgn print *,(nounoe(iaux),iaux=1,nbnoto) +c +c 3.3. ==> Les noeuds a bouger sont a mettre au bout +c + do 33 , iaux = 1 , nbnoce + jaux = tabaux(iaux) + nounoe(jaux) = nbnoto + 1 - iaux + 33 continue +cgn print *,(nounoe(iaux),iaux=1,nbnoto) +c +cgn do 34 , iaux = 1 , nbnoto +cgn do 34 , jaux = iaux+1 , nbnoto +cgn if ( nounoe(jaux).eq.nounoe(iaux)) then +cgn print *,iaux +cgn endif +cgn 34 continue +cgn jaux=nbnoto +cgn do 341 , iaux = 1 , nbnoce +cgn jaux = min(jaux,nounoe(tabaux(iaux))) +cgn 341 continue +cgn print *,'nbnoto - nbnoce + 1 = ',nbnoto - nbnoce + 1 +cgn print *,'le mini = ',jaux +c + endif +c +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,1,4), lepere + do 40 , iaux = 1 , 4 + write (ulsort,texte(langue,6)) mess14(langue,1,4), lequad(iaux) + 40 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnc16.F b/src/tool/Utilitaire/utnc16.F new file mode 100644 index 00000000..ae1c1543 --- /dev/null +++ b/src/tool/Utilitaire/utnc16.F @@ -0,0 +1,485 @@ + subroutine utnc16 ( hettri, aretri, filtri, + > hetqua, arequa, filqua, + > filare, + > quahex, coquhe, volqua, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Non Conformite - phase 16 +c -- - - -- +c On cherche a reorienter les faces recouvertes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . filtri . e . nbtrto . premier fils des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . arequa . es .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c . filare . e . nbarto . premiere fille des aretes . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . es .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . volqua . e .nbquto*2. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 3 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNC16' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "ope1a4.h" +#include "j1234j.h" +#include "impr02.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer hettri(nbtrto), aretri(nbtrto,3) + integer filtri(nbtrto) + integer hetqua(nbquto), arequa(nbquto,4) + integer filqua(nbquto) + integer filare(nbarto) + integer quahex(nbhecf,6), coquhe(nbhecf,6) + integer volqua(2,nbquto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux, laux + integer iauxm1 + integer lepere, lefils + integer arei, areim1 + integer f1ai, f2ai, f1aim1, f2aim1 + integer aretf(4) + integer jdei, jdeim1 + integer areti1, areti2 + integer orient + integer lehexa, codefa +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(a,''Examen du '',a,'' numero'',i10)' + texte(1,5) = '(''.. couvert par le '',a,'' numero'',i10)' + texte(1,6) = '(a,''dont les '',a,'' sont :'',6i10)' + texte(1,7) = '(''. Arete'',i10,'' de'',i10,'' a'',i10)' + texte(1,8) = '(''2 hexaedres voisins ?'')' + texte(1,9) = '(''Incoherence de voisins'')' + texte(1,10) = '(5x,''Le '',a,'' numero'',i10,'' est la face'',i2)' + texte(1,11) = '(5x,''Le code '',a,'' vaut'',i2)' +c + texte(2,4) = '(a,''Examination of '',a,'' #'',i10)' + texte(2,5) = '(''.. covered by '',a,'' #'',i10)' + texte(2,6) = '(a,''with '',a,'' # :'',6i10)' + texte(2,7) = '(''. Edge #'',i10,'' from'',i10,'' to'',i10)' + texte(2,8) = '(''2 hexa for this quad ?'')' + texte(2,9) = '(''Non coherence for neighbours.'')' +c + codret = 0 +c +c==== +c 2. On explore les quadrangles decoupes en 4 +c On doir arriver a la convention decrite par cmrdqu : +c +c Quadrangle pere : +c ak = numero de la k-eme arete du quadrangle pere +c sajak = numero du noeud commun aux aretes aj et ak +c +c sa4a1 a4 sa3a4 +c ._________________________________________________. +c . . +c . . +c . . +c . . +c . . +c . . +c a1 . . a3 +c . . +c . . +c . . +c . . +c . . +c . . +c ._________________________________________________. +c sa1a2 a2 sa2a3 +c +c Remarque : on appelle ici le sens standard celui correspondant +c a l'enchainement (a1,a2,a3,a4) +c +c Quadrangles fils : +c n0 = numero du noeud barycentre des 4 sommets du quadrangle pere +c nk = numero du noeud milieu de la k-eme arete du quadrangle pere +c akf1/2 = numero des filles de la k-eme arete du quadrangle pere +c akf1 : la premiere dans le sens standard +c akf2 : la seconde dans le sens standard +c nfk = numero du k-eme quadrangle fils : celui qui contient la +c premiere (au sens standard) des filles de l'arete ak +c ankn0 = numero de l'arete qui va de nk a n0. (Par construction, +c n0>nk). Elle est commune aux filles nfk et nf(k+1). +c +c sa4a1 a4f2 a4/n4 a4f1 sa3a4 +c .________________________.________________________. +c . . . +c . . . +c . .an4n0 . +c a1f1 . nf1 . nf4 . a3f2 +c . . . +c . . . +c a1/n1 .________________________.________________________. a3/n3 +c . an1n0 .n0 an3n0 . +c . . . +c . .an2n0 . +c a1f2 . nf2 . nf3 . a3f1 +c . . . +c . . . +c .________________________.________________________. +c sa1a2 a2f1 a2/n2 a2f2 sa2a3 +c +c +c==== +c + do 20 , lepere = 1 , nbquto +cgn write (ulsort,*) ' lepere = ', lepere +c + if ( hetqua(lepere).eq.4 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,4)//'pere', + > lepere + write (ulsort,texte(langue,6)) ' ', mess14(langue,3,1), + > arequa(lepere,1), arequa(lepere,2), + > arequa(lepere,3), arequa(lepere,4) +#endif +c +c On examine chacun des fils : +c + do 21 , iaux = 1 , 4 +c + if ( codret.eq.0 ) then +c + lefils = filqua(lepere)+iaux-1 +c +c 2.1. ==> Les 2 aretes i et i-1 du pere ainsi que leurs filles +c + arei = arequa(lepere,iaux) + f1ai = filare(arei) + f2ai = f1ai + 1 +c + iauxm1 = per1a4(-1,iaux) + areim1 = arequa(lepere,iauxm1) + f1aim1 = filare(areim1) + f2aim1 = f1aim1 + 1 +c +c 2.2. ==> Les aretes du fils +c + do 221 , jaux = 1 , 4 + aretf(jaux) = arequa(lefils,jaux) + 221 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '.. ', + > mess14(langue,1,4)//'fils', lefils + write (ulsort,texte(langue,6)) ' ',mess14(langue,3,1), + > aretf +#endif +c +c 2.3. ==> Quelle arete du fils est fille de l'arete i ? +c + do 231 , jaux = 1 , 4 +c + if ( aretf(jaux).eq.f1ai .or. + > aretf(jaux).eq.f2ai ) then + jdei = jaux + goto 232 + endif +c + 231 continue +c + 232 continue +c +c 2.4. ==> Quelle arete du fils est fille de l'arete i-1 ? +c + do 241 , jaux = 1 , 4 +c + if ( aretf(jaux).eq.f1aim1 .or. + > aretf(jaux).eq.f2aim1 ) then + jdeim1 = jaux + goto 242 + endif +c + 241 continue +c + 242 continue +c +c 2.5. ==> On cherche le changement d'orientation +c orient = nombre de 1/4 de tours a faire dans le sens de +c l'orientation de la mere pour que la 1ere arete +c du fils soit bien placee. +c + if ( jdei.eq.1 ) then + if ( jdeim1.eq.4 ) then + orient = 0 + elseif ( jdeim1.eq.2 ) then + orient = -2 + else + codret = 142 + endif +c + elseif ( jdei.eq.2 ) then + if ( jdeim1.eq.1 ) then + orient = 1 + elseif ( jdeim1.eq.3 ) then + orient = -5 + else + codret = 213 + endif +c + elseif ( jdei.eq.3 ) then + if ( jdeim1.eq.2 ) then + orient = 2 + elseif ( jdeim1.eq.4 ) then + orient = -4 + else + codret = 324 + endif +c + elseif ( jdei.eq.4 ) then + if ( jdeim1.eq.3 ) then + orient = 3 + elseif ( jdeim1.eq.1 ) then + orient = -3 + else + codret = 431 + endif +c + else + write (ulsort,texte(langue,4)) 'Pere : ', + > mess14(langue,1,4), lepere + write (ulsort,texte(langue,6)) ' ', mess14(langue,3,1), + > arequa(lepere,1), arequa(lepere,2), + > arequa(lepere,3), arequa(lepere,4) + write (ulsort,texte(langue,4)) 'Fils : ', + > mess14(langue,1,4), lefils + write (ulsort,texte(langue,6)) ' ', mess14(langue,3,1), + > aretf + codret = 1 + endif +cgn write (ulsort,*) 'orient = ', orient +c + endif +c +c 2.6. ==> Permutation des aretes du fils +c + if ( orient.ne.0 ) then +c + if ( codret.eq.0 ) then +c + do 261 , jaux = 1 , 4 + arequa(lefils,jaux) = aretf(per1a4(orient,jaux)) + 261 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) '.... ', + > mess14(langue,1,4)//'fils', lefils + write (ulsort,texte(langue,6)) ' ', + > mess14(langue,3,1)//'apres', + > arequa(lefils,1), arequa(lefils,2), + > arequa(lefils,3), arequa(lefils,4) +#endif +c + endif +c + endif +c +c 2.7. ==> Changement de code de la face dans l'hexaedre +c + if ( orient.ne.0 ) then +c + if ( codret.eq.0 ) then +c +c 2.7.1. ==> Controle du voisin de la face +c + if ( volqua(1,lefils).lt.0 ) then + codret = 12 + goto 33 + endif + lehexa = volqua(1,lefils) +c +#ifdef _DEBUG_HOMARD_ +cgn if ( lehexa.eq.4 ) then + write (ulsort,*) '.... orient = ', orient + write (ulsort,texte(langue,4)) '.... ', mess14(langue,1,6), + > lehexa + write (ulsort,texte(langue,6)) ' ', mess14(langue,3,4), + > quahex(lehexa,1), quahex(lehexa,2), + > quahex(lehexa,3), quahex(lehexa,4), + > quahex(lehexa,5), quahex(lehexa,6) +cgn endif +#endif +c + if ( volqua(2,lefils).ne.0 ) then + write (ulsort,texte(langue,4)) 'Fils : ', + > mess14(langue,1,4), lefils + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,6), + > lehexa + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,6), + > volqua(2,lefils) + write (ulsort,texte(langue,8)) + codret = 1 + endif +c + do 271 , jaux = 1 , 6 + if ( quahex(lehexa,jaux).eq.lefils ) then + kaux = jaux + goto 2720 + endif + 271 continue +c + write (ulsort,texte(langue,4)) 'Fils : ', + > mess14(langue,1,4), lefils + write (ulsort,texte(langue,4)) ' ', mess14(langue,1,6), + > lehexa + write (ulsort,texte(langue,9)) + codret = 1 +c + endif +c +c 2.7.2. ==> Changement de code +c + 2720 continue +c + if ( codret.eq.0 ) then +c +c + codefa = coquhe(lehexa,kaux) +#ifdef _DEBUG_HOMARD_ +cgn if ( lehexa.eq.4 ) then + write (ulsort,texte(langue,10)) mess14(langue,1,4), + > lefils, kaux + write (ulsort,texte(langue,11)) 'ancien', codefa +cgn endif +#endif +cgn write (ulsort,*) 'kaux, codefa = ', kaux, codefa +cgn write (ulsort,*) 'j1(codefa) : ', j1(codefa) +cgn write (ulsort,*) 'j2(codefa) : ', j2(codefa) + laux = per1a4(orient,5) + areti1 = per1a4(laux,j1(codefa)) + areti2 = per1a4(laux,j2(codefa)) +cgn write (ulsort,*) areti1, areti2 +c + do 272 , jaux = 1 , 8 + if ( areti1.eq.j1(jaux) ) then + if ( areti2.eq.j2(jaux) ) then + codefa = jaux + goto 2721 + endif + endif + 272 continue +c + codret = 1 +c + 2721 continue +#ifdef _DEBUG_HOMARD_ +cgn if ( lehexa.eq.4 ) then + write (ulsort,texte(langue,11)) 'nouveau', codefa +cgn endif +#endif +c + coquhe(lehexa,kaux) = codefa +c + endif +c + endif +c + 21 continue +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + 33 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnhex.F b/src/tool/Utilitaire/utnhex.F new file mode 100644 index 00000000..1db76518 --- /dev/null +++ b/src/tool/Utilitaire/utnhex.F @@ -0,0 +1,148 @@ + subroutine utnhex ( lehexa, niveau, + > quahex, perhex, + > nivqua ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Niveau d'un HEXaedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . niveau . s . 1 . niveau . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . perhex . e . nbheto . pere des hexaedres . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision niveau +c + integer lehexa + integer quahex(nbhecf,6), perhex(nbheto) + integer nivqua(nbquto) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer lepere + integer iaux, jaux +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c +cgn write(*,90002) 'nbhema, nbhecf, nbheto', nbhema, nbhecf, nbheto +cgn write(*,90002) 'nbheco', nbheco +c +c==== +c 1. Du maillage initial +c==== +c + if ( lehexa.le.nbhema ) then +c + niveau = 0.d0 +c +c==== +c 2. Au dela +c==== +c + else +c +c 2.1. ==> Si l'hexaedre est decrit par faces : +c le plus haut niveau de ses faces +c + if ( lehexa.le.nbhecf ) then +c + lafac1 = quahex(lehexa,1) + lafac2 = quahex(lehexa,2) + lafac3 = quahex(lehexa,3) + lafac4 = quahex(lehexa,4) + lafac5 = quahex(lehexa,5) + lafac6 = quahex(lehexa,6) + jaux = max(nivqua(lafac1),nivqua(lafac2),nivqua(lafac3), + > nivqua(lafac4),nivqua(lafac5),nivqua(lafac6)) +c +c 2.2. ==> Si l'hexaedre est decrit par aretes : +c son niveau est le niveau du pere augmente d'un cran +c + else +c + iaux = perhex(lehexa) +c + if ( iaux.gt.0 ) then + lepere = iaux + else + write(*,90002) 'lehexa, iaux', lehexa, iaux + write(*,*) 'arret dans utnhex' + STOP + endif +cgn write(*,90002) 'iaux, lepere', iaux, lepere +c + if ( iaux.gt.0 ) then +c + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + jaux = max(nivqua(lafac1),nivqua(lafac2),nivqua(lafac3), + > nivqua(lafac4),nivqua(lafac5),nivqua(lafac6)) +c + endif +c + jaux = jaux + 1 +c + endif +c +cgn write(*,90002) '==> jaux',jaux + niveau = dble(jaux) +c +c==== +c 3. Si l'hexaedre est de conformite, on prend le niveau +c intermediaire immediatement inferieur +c==== +c + if ( lehexa.gt.nbhepe ) then + niveau = niveau - 0.5d0 + endif +c + endif +cgn write(*,90004) '==> niveau',niveau +c + end diff --git a/src/tool/Utilitaire/utniqu.F b/src/tool/Utilitaire/utniqu.F new file mode 100644 index 00000000..3df94276 --- /dev/null +++ b/src/tool/Utilitaire/utniqu.F @@ -0,0 +1,309 @@ + subroutine utniqu ( coonoe, + > hetnoe, arenoe, famnoe, + > hetare, somare, filare, + > np2are, + > nintri, + > arequa, hetqua, filqua, + > ninqua, + > indnoe, nouvno, nouvar, nouvtr, nouvqu, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation de Noeuds Internes +c -- - - +c apres decoupages de QUadrangles +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . caracteristiques des noeuds . +c . hetare . e . nouvar . historique de l'etat des aretes . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . filare . e . nouvar . premiere fille des aretes . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . nintri . es . nouvtr . noeud interne au triangle . +c . arequa . e .nouvqu*4. numeros des 4 aretes des quadrangles . +c . hetqua . e . nouvqu . historique de l'etat des quadrangles . +c . filqua . e . nouvqu . premier fils des quadrangles . +c . ninqua . es . nouvqu . noeud interne au quadrangle . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . nouvno . e . 1 . nombre total de noeuds a examiner . +c . nouvar . e . 1 . nombre total d'aretes a examiner . +c . nouvtr . e . 1 . nombre total de triangles a examiner . +c . option . e . 1 . 0 : decoupage standard . +c . . . . 1 : decoupage de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractb.h" +#include "fractc.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer indnoe, nouvno, nouvar, nouvtr, nouvqu + integer hetnoe(nouvno), arenoe(nouvno), famnoe(nouvno) + integer hetare(nouvar), somare(2,nouvar), filare(nouvar) + integer np2are(nouvar) + integer nintri(nouvtr) + integer arequa(nouvqu,4), hetqua(nouvqu), filqua(nouvqu) + integer ninqua(nouvqu) + integer option +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer lequad, lefils + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer n1, n2, n3, n4 + integer iaux1, iaux2, iaux3 + integer etan, etanp1 + integer lesomm + integer numdec + integer ai, aj, ak, al + integer afij, afil + integer saiaj, sajak, sakal, salai + integer ni +c +#include "impr03.h" +c ______________________________________________________________________ +c +c==== +c creation des noeuds internes aux nouveaux quadrangles +c on remarque que cette technique permet de garantir qu'un noeud +c interne a toujours un numero superieur a ceux des autres noeuds +c du quadrangle +c==== +c + do 11 , lequad = 1, nouvqu +c +cgn write (ulsort,90015) 'Quad', lequad, ' d''etat',hetqua(lequad) + etanp1 = mod(hetqua(lequad),100) +c +c==== +c 1. Ce quadrangle vient d'etre coupe en 4 : raffinement standard +c==== +c + if ( option.eq.0 .and. etanp1.eq.4 ) then +c + etan = (hetqua(lequad)-etanp1)/100 +cgn write (ulsort,90002) 'etan', etan +c + if ( etan.ne.4 .and. etan.ne.99 ) then +cgn write (ulsort,90015) 'Quadrangle', lequad, ' coupe en 4' +c +c 1.1. ==> on recupere ses sommets +c voir cmrdqu pour la convention +c sa4a1 a4 sa3a4 +c ._________. +c . . +c . . +c a1. .a3 +c . . +c ._________. +c sa1a2 a2 sa2a3 +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +cgn write (ulsort,90002) 'sommets du pere',sa1a2, sa2a3, sa3a4, sa4a1 +c +c 1.2. ==> Le noeud central +c + lesomm = ninqua(lequad) +cgn write (ulsort,90002) 'lesomm',lesomm +c +c 1.3. ==> les noeuds milieux des aretes +c + n1 = np2are(a1) + n2 = np2are(a2) + n3 = np2are(a3) + n4 = np2are(a4) +cgn write (ulsort,90002) 'noeuds milieux ',n1, n2, n3, n4 +c +c 1.2. ==> creation pour les fils +c + lefils = filqua(lequad) +c + do 12 , iaux = 0, 3 +c + if ( iaux.eq.0 ) then + iaux1 = sa4a1 + iaux2 = n4 + iaux3 = n1 + elseif ( iaux.eq.1 ) then + iaux1 = sa1a2 + iaux2 = n1 + iaux3 = n2 + elseif ( iaux.eq.2 ) then + iaux1 = sa2a3 + iaux2 = n2 + iaux3 = n3 + else + iaux1 = sa3a4 + iaux2 = n3 + iaux3 = n4 + endif +c + indnoe = indnoe + 1 +cgn write (ulsort,90002) '==> Creation du noeud', indnoe +cgn write (ulsort,90002) ' base sur', iaux1, iaux2, iaux3, lesomm + ninqua(lefils+iaux) = indnoe +c + if ( sdim.eq.2 ) then + coonoe(indnoe,1) = unsqu * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + + > coonoe(iaux3,1) + coonoe(lesomm,1) ) + coonoe(indnoe,2) = unsqu * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + + > coonoe(iaux3,2) + coonoe(lesomm,2) ) + else + coonoe(indnoe,1) = unsqu * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + + > coonoe(iaux3,1) + coonoe(lesomm,1) ) + coonoe(indnoe,2) = unsqu * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + + > coonoe(iaux3,2) + coonoe(lesomm,2) ) + coonoe(indnoe,3) = unsqu * + > ( coonoe(iaux1,3) + coonoe(iaux2,3) + + > coonoe(iaux3,3) + coonoe(lesomm,3) ) + endif + hetnoe(indnoe) = 54 + famnoe(indnoe) = 1 + arenoe(indnoe) = 0 +c + 12 continue +c + endif +c +c==== +c 2. Ce quadrangle vient d'etre coupe en 3 triangles : conformite +c==== +c + elseif ( option.eq.1 .and. + > ( etanp1.ge.31 .and. etanp1.le.34 ) ) then +c +cgn write (ulsort,90015) 'Quadrangle', lequad, ' coupe en 3' +c +c 2.1. ==> determination des aretes et des sommets, relativement +c au decoupage de l'arete +c voir cmcdqu pour la convention +c S4=sa4a1 a4 sa3a4=S3 +c ._________. +c . . +c . . +c a1. .a3 +c . . +c ._________. +c S1=sa1a2 a2 sa2a3=S2 +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utcoq3 ( hetare, somare, filare, a1, a2, a3, a4, + > numdec, ai, aj, ak, al, afij, afil, + > saiaj, sajak, sakal, salai, ni, + > ulsort, langue, codret ) +cgn write (ulsort,90002) 'numdec', numdec,etanp1 +cgn write (ulsort,90002) 'ni', ni +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +cgn write (ulsort,90002) 'sommets du pere',sa1a2, sa2a3, sa3a4, sa4a1 +c +c 2.3. ==> creation pour les trois fils +c + lefils = filqua(lequad) +cgn write (ulsort,90002) 'lefils', lefils +c + do 23 , iaux = 0, 2 +c + if ( iaux.eq.0 ) then + iaux1 = sajak + iaux2 = sakal + elseif ( iaux.eq.1 ) then + iaux1 = saiaj + iaux2 = sajak + else + iaux1 = salai + iaux2 = sakal + endif + indnoe = indnoe + 1 +cgn write (ulsort,90002) '==> Creation du noeud', indnoe +cgn write (ulsort,90002) ' base sur', iaux1, iaux2, ni + nintri(-lefils+iaux) = indnoe +c + if ( sdim.eq.2 ) then + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(ni,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(ni,2) ) + else + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(ni,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(ni,2) ) + coonoe(indnoe,3) = unstr * + > ( coonoe(iaux1,3) + coonoe(iaux2,3) + coonoe(ni,3) ) + endif + hetnoe(indnoe) = 54 + famnoe(indnoe) = 1 + arenoe(indnoe) = 0 +c + 23 continue +c + endif +c + 11 continue +c + end diff --git a/src/tool/Utilitaire/utnitr.F b/src/tool/Utilitaire/utnitr.F new file mode 100644 index 00000000..b0ea11f7 --- /dev/null +++ b/src/tool/Utilitaire/utnitr.F @@ -0,0 +1,288 @@ + subroutine utnitr ( coonoe, + > hetnoe, arenoe, famnoe, + > somare, np2are, + > aretri, hettri, filtri, + > nintri, + > indnoe, nouvno, nouvar, nouvtr, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation de Noeuds Internes +c -- - - +c apres decoupages de TRiangles +c -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . famnoe . es . nouvno . caracteristiques des noeuds . +c . somare . e .2*nouvar. numeros des extremites d'arete . +c . np2are . e . nouvar . numero des noeuds p2 milieux d'aretes . +c . aretri . e .nouvtr*3. numeros des 3 aretes des triangles . +c . hettri . e . nouvtr . historique de l'etat des triangles . +c . filtri . e . nouvtr . premier fils des triangles . +c . nintri . es . nouvtr . noeud interne au triangle . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . nouvno . e . 1 . nombre total de noeuds a examiner . +c . nouvar . e . 1 . nombre total d'aretes a examiner . +c . nouvtr . e . 1 . nombre total de triangles a examiner . +c . option . e . 1 . 0 : decoupage standard . +c . . . . 1 : decoupage de conformite . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractb.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +#include "ope1a3.h" +c +c 0.3. ==> arguments +c + integer indnoe, nouvno, nouvar, nouvtr + integer hetnoe(nouvno), arenoe(nouvno), famnoe(nouvno) + integer somare(2,nouvar), np2are(nouvar) + integer aretri(nouvtr,3), hettri(nouvtr), filtri(nouvtr) + integer nintri(nouvtr) + integer option +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letria, lefils + integer as2s3, as1s3, as1s2 + integer sa3a1, sa1a2, sa2a3 + integer an2n3, an1n3, an1n2 + integer n1, n2, n3 + integer somm(3) + integer iaux1, iaux2, iaux3 + integer etan, etanp1 + integer lesomm +c +#include "impr03.h" +c ______________________________________________________________________ +c +c==== +c creation des noeuds internes aux nouveaux triangles +c on remarque que cette technique permet de garantir qu'un noeud +c interne a toujours un numero superieur a ceux des autres noeuds +c du triangle +c==== +c + do 11 , letria = 1, nouvtr +c +cgn write (*,90015) 'Triangle', letria, ' d''etat',hettri(letria) + etanp1 = mod(hettri(letria),10) +c +c==== +c 1. Ce triangle vient d'etre coupe en 4 : raffinement standard +c==== +c + if ( option.eq.0 .and. + > ( ( etanp1.eq.4 ) .or. + > ( etanp1.ge.6 .and. etanp1.le.8 ) ) ) then +c + etan = (hettri(letria)-etanp1)/10 +c + if ( etan.ge.0 .and. etan.le.3 ) then +cgn write (*,90015) 'Triangle', letria, ' coupe en 4' +c +c 1.1. ==> on recupere ses sommets +c voir cmrdtr pour la convention +c S1 = sa2a3 +c * +c . . +c . . +c . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1 = S2*---------------*S3 = sa1a2 +c a1 +c + as2s3 = aretri(letria,1) + as1s3 = aretri(letria,2) + as1s2 = aretri(letria,3) +c + call utsotr ( somare, as2s3, as1s3, as1s2, + > sa1a2, sa2a3, sa3a1 ) +cgn write (*,90002) 'sommets du pere',sa2a3,sa3a1,sa1a2 +c +c 1.2. ==> le 1er triangle fils partage le meme noeud interne +c + lefils = filtri(letria) + nintri(lefils) = nintri(letria) +c +c 1.3. ==> Recuperation des sommets du fils +c + an2n3 = aretri(lefils,1) + an1n3 = aretri(lefils,2) + an1n2 = aretri(lefils,3) +c + call utsotr ( somare, an2n3, an1n3, an1n2, + > n3, n1, n2 ) +cgn write (*,90002) 'sommets du fils',n1,n2,n3 +c +c 1.4. ==> creation pour les fils suivants +c + do 14 , iaux = 1, 3 +c + if ( iaux.eq.1 ) then + iaux1 = sa2a3 + iaux2 = n2 + iaux3 = n3 + elseif ( iaux.eq.2 ) then + iaux1 = sa3a1 + iaux2 = n3 + iaux3 = n1 + else + iaux1 = sa1a2 + iaux2 = n1 + iaux3 = n2 + endif +c + indnoe = indnoe + 1 +cgn write (*,90002) '==> Creation du noeud', indnoe + nintri(lefils+iaux) = indnoe +c + if ( sdim.eq.2 ) then + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(iaux3,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(iaux3,2) ) + else + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(iaux3,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(iaux3,2) ) + coonoe(indnoe,3) = unstr * + > ( coonoe(iaux1,3) + coonoe(iaux2,3) + coonoe(iaux3,3) ) + endif + hetnoe(indnoe) = 54 + famnoe(indnoe) = 1 + arenoe(indnoe) = 0 +c + 14 continue +c + endif +c +c==== +c 2. Ce triangle vient d'etre coupe en 2 : conformite +c==== +c + elseif ( option.eq.1 .and. + > ( etanp1.ge.1 .and. etanp1.le.3 ) ) then +cgn write (*,90015) 'Triangle', letria, ' coupe en 2' +c +c 2.1. ==> on recupere ses sommets +c voir cmcdtr pour la convention +c S1 = sa2a3 +c * +c . . +c . . +c . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1 = S2*---------------*S3 = sa1a2 +c a1 +c + as2s3 = aretri(letria,1) + as1s3 = aretri(letria,2) + as1s2 = aretri(letria,3) +c + call utsotr ( somare, as2s3, as1s3, as1s2, + > sa1a2, sa2a3, sa3a1 ) +cgn write (*,90002) 'sommets du pere', sa1a2, sa2a3, sa3a1 + somm(1) = sa2a3 + somm(2) = sa3a1 + somm(3) = sa1a2 +c +c 2.2. ==> L'arete de decoupage +c + lesomm = np2are(aretri(letria,etanp1)) +cgn write (*,90002) 'lesomm', lesomm +c +c 2.3. ==> creation pour les deux fils +c + lefils = filtri(letria) +c + do 23 , iaux = 0, 1 +c + iaux1 = somm(etanp1) + if ( iaux.eq.0 ) then + iaux2 = somm(per1a3(-1,etanp1)) + else + iaux2 = somm(per1a3( 1,etanp1)) + endif +cgn print *,'pere',iaux1,lesomm,iaux2 + indnoe = indnoe + 1 +cgn write (*,90002) '==> Creation du noeud', indnoe + nintri(lefils+iaux) = indnoe +c + if ( sdim.eq.2 ) then + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(lesomm,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(lesomm,2) ) + else + coonoe(indnoe,1) = unstr * + > ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(lesomm,1) ) + coonoe(indnoe,2) = unstr * + > ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(lesomm,2) ) + coonoe(indnoe,3) = unstr * + > ( coonoe(iaux1,3) + coonoe(iaux2,3) + coonoe(lesomm,3) ) + endif + hetnoe(indnoe) = 54 + famnoe(indnoe) = 1 + arenoe(indnoe) = 0 +c + 23 continue +c + endif +c + 11 continue +c + end diff --git a/src/tool/Utilitaire/utnmhe.F b/src/tool/Utilitaire/utnmhe.F new file mode 100644 index 00000000..a53d1c91 --- /dev/null +++ b/src/tool/Utilitaire/utnmhe.F @@ -0,0 +1,172 @@ + subroutine utnmhe ( lehexa, noeumi, + > somare, aretri, arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, filhex, fhpyte, + > facpyr, cofapy, arepyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Noeud Milieu d'un HExaedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . noeumi . s . 1 . numero du noeud milieu . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . filhex . e . nbheto . premier fils des hexaedres . +c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide . +c . . . . fille de l'hexaedre k tel que filhex(k) =-j. +c . . . . fhpyte(2,j) = numero du 1er tetraedre . +c . . . . fils de l'hexaedre k tel que filhex(k) = -j. +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + integer lehexa, noeumi + integer somare(2,*) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), filhex(nbheto) + integer coquhe(nbhecf,6), fhpyte(2,nbheco) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c f1hp = Fils 1er de l'hexaedre en numerotation Homard a l'it. N+1 + integer f1hp + integer listar(12), listso(8) +c +c==== +c 1. Le fils enregistre. +c Si positif, c'est un decoupage standard en 8 hexaedres +c Si negatif, c'est un decoupage de conformite en pyramides et +c tetraedres. +c==== +c + f1hp = filhex(lehexa) +cgn print *,'f1hp =',f1hp +cgn print *,fhpyte(1,1),fhpyte(2,1) +c +c==== +c 2. Quand l'hexaedre est decoupe en 8 : pour trouver le noeud central, +c on examine le premier fils de l'hexaedre. +c Remarque : regarder cmrdhe pour ces conventions +c==== +c + if ( f1hp.gt.0) then +c +c les aretes et les sommets de l'hexaedre fils +c + call utarhe ( f1hp, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + call utsohe ( somare, listar, listso ) +c +c recuperation du noeud sommet central : le huitieme sommet +c + noeumi = listso(8) +c +c==== +c 3. Quand l'hexaedre est decoupe par conformite pour trouver le noeud +c central, on examine le premier fils de l'hexaedre, pyramide ou +c tetraedre +c Remarque : regarder cmcdhe pour ces conventions +c==== +c + else +c + iaux = fhpyte(1,abs(f1hp)) +cgn print *,'iaux =',iaux +c +c 3.1. ==> On a au moins une pyramide +c + if ( iaux.ne.0 ) then +c +c les aretes et les sommets de la 1ere pyramide fils +c +cgn print *,'==> pyramide =',iaux + call utaspy ( iaux, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +c recuperation du noeud sommet central : le cinquieme sommet +c + noeumi = listso(5) +c +c 3.2. ==> Il n'y a que des tetraedres +c + else +c + iaux = fhpyte(2,abs(f1hp)) +c +c les aretes et les sommets du 1er tetraedre fils +c +cgn print *,'==> tetraedre =',iaux + call utaste ( iaux, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c +c recuperation du noeud sommet central : le premier sommet +c + noeumi = listso(1) +c + endif +c + endif +cgn print *,'noeumi =',noeumi +c + end diff --git a/src/tool/Utilitaire/utnmpe.F b/src/tool/Utilitaire/utnmpe.F new file mode 100644 index 00000000..d25a6704 --- /dev/null +++ b/src/tool/Utilitaire/utnmpe.F @@ -0,0 +1,112 @@ + subroutine utnmpe ( lepent, noeumi, + > somare, aretri, arequa, + > tritet, cotrte, + > facpen, cofape, filpen, fppyte, + > facpyr, cofapy ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Noeud Milieu d'un PEntaedre +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . noeumi . s . 1 . numero du noeud milieu . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . cotrte . e .nbtecf*4. codes des triangles des tetraedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . cofape . e .nbpecf*5. codes des faces des pentaedres . +c . filpen . e . nbpeto . premier fils des pentaedres . +c . fppyte . e . 2** . fppyte(1,j) = numero de la 1ere pyramide . +c . . . . fille du pentaedre k tel que filpen(k) =-j . +c . . . . fppyte(2,j) = numero du 1er tetraedre . +c . . . . fils du pentaedre k tel que filpen(k) = -j . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lepent, noeumi + integer somare(2,*) + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4) + integer facpen(nbpecf,5), filpen(nbpeto) + integer cofape(nbpecf,5), fppyte(2,nbpeco) + integer facpyr(nbpycf,5), cofapy(nbpycf,5) +c +c 0.4. ==> variables locales +c + integer iaux +c f1hp = Fils 1er du pentaedre en numerotation Homard a l'it. N+1 + integer f1hp + integer listar(9), listso(6) +c +c==== +c 1. Quand le pentaedre est decoupe par conformite pour trouver le noeud +c central, on est toujours dans un cas ou on a produit des tetraedres +c si le noeud central est un de leurs sommets, c'est S1. +c en prenant le 4eme tetraedre, on couvre tous les cas de figure +c Remarque : regarder cmcdpe pour ces conventions +c==== +c + f1hp = filpen(lepent) +c + iaux = fppyte(2,abs(f1hp)) + 3 +c +c les aretes et les sommets du 4eme tetraedre fils +c +cgn print *,'==> tetraedre =',iaux + call utarte ( iaux, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + call utsote ( somare, listar, listso ) +c +c recuperation du noeud sommet central : le premier sommet +c + noeumi = listso(1) +cgn print *,'noeumi =',noeumi +c + end diff --git a/src/tool/Utilitaire/utnmqu.F b/src/tool/Utilitaire/utnmqu.F new file mode 100644 index 00000000..c6814cc8 --- /dev/null +++ b/src/tool/Utilitaire/utnmqu.F @@ -0,0 +1,78 @@ + subroutine utnmqu ( lequad, noeumi, + > somare, arequa, filqua ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Noeud Milieu d'un QUadrangle +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . numero du quadrangle a examiner . +c . noeumi . s . 1 . numero du noeud milieu . +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . filqua . e . nbquto . premier fils des quadrangles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombqu.h" +c +c 0.3. ==> arguments +c + integer lequad, noeumi + integer somare(2,*) + integer arequa(nbquto,4), filqua(*) +c +c 0.4. ==> variables locales +c +c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1 + integer f1hp +c +c==== +c 1. recherche du noeud sommet central +c Pour le connaitre, on examine le premier fils du quadrangle. C'est +c la seconde extremite de sa deuxieme arete. +c Remarque : regarder cmrdqu pour ces conventions +c==== +c +c le fils aine +c + f1hp = filqua(lequad) +c +c recuperation du noeud sommet central : le second sommet +c de la troisieme arete, que ce soit pour le decoupage standard +c en 4 quadrangles (cf. cmrdqu) ou pour le decoupage de +c conformite en 3 quadrangles (cf. cmcdqu) +c + noeumi = somare(2,arequa(f1hp,3)) +c + end diff --git a/src/tool/Utilitaire/utnoad.F b/src/tool/Utilitaire/utnoad.F new file mode 100644 index 00000000..70632963 --- /dev/null +++ b/src/tool/Utilitaire/utnoad.F @@ -0,0 +1,144 @@ + subroutine utnoad ( coonoe, + > hetnoe, arenoe, famnoe, + > somare, np2are, + > indnoe, nouvno, + > nuarde, nuarfi ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation de NOeuds sur les Aretes Droites +c -- -- - - +c ______________________________________________________________________ +c +c but : creation des noeuds p2 (milieux) sur les nouvelles aretes +c lorsque tous les elements sont a bords droits +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . es .nouvno*3. coordonnees des noeuds . +c . hetnoe . es . nouvno . historique de l'etat des noeuds . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . somare . e .2*nuarfi. numeros des extremites d'arete . +c . np2are . es . nuarfi . numero des noeuds p2 milieux d'aretes . +c . famnoe . es . nouvno . caracteristiques des noeuds . +c . indnoe . es . 1 . indice du dernier noeud cree . +c . nouvno . e . 1 . nombre total de noeuds a examiner . +c . nuarde . e . 1 . debut des numeros d'aretes a traiter . +c . nuarfi . e . 1 . fin des numeros d'aretes a traiter . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracta.h" +c +c 0.2. ==> communs +c +#include "envca1.h" +c +c 0.3. ==> arguments +c + integer indnoe, nouvno + integer nuarde, nuarfi + integer hetnoe(nouvno), arenoe(nouvno) + integer somare(2,nuarfi), np2are(nuarfi) + integer famnoe(nouvno) +c + double precision coonoe(nouvno,sdim) +c +c 0.4. ==> variables locales +c + integer larete, s1, s2 +c +#include "impr03.h" +c ______________________________________________________________________ +c +c creation des noeuds p2 sur les nouvelles aretes +c on remarque que cette technique permet de garantir qu'un noeud p2 +c a toujours un numero superieur a ceux des deux extremites de +c l'arete qui le porte. +c +c==== +c 1. En deux dimensions +c==== +c + if ( sdim.eq.2 ) then +c + do 11 , larete = nuarde , nuarfi +c +cgn write (*,90002) 'Arete', larete + if ( np2are(larete).eq.0 ) then +c +c c'est une nouvelle arete, il faut creer le noeud p2 +c + indnoe = indnoe + 1 +cgn write (*,90002) '==> Creation du noeud', indnoe + arenoe(indnoe) = larete + np2are(larete) = indnoe + s1 = somare(1,larete) + s2 = somare(2,larete) + coonoe(indnoe,1) = ( coonoe(s1,1) + coonoe(s2,1) ) * unsde + coonoe(indnoe,2) = ( coonoe(s1,2) + coonoe(s2,2) ) * unsde + hetnoe(indnoe) = 52 + famnoe(indnoe) = 1 +c + endif +c + 11 continue +c +c==== +c 2. En trois dimensions +c==== +c + else +c + do 21 , larete = nuarde , nuarfi +cgn write(1,*) 'np2are(',larete, ') = ', np2are(larete) +cgn write(1,*) 'arenoe(',indnoe, ') = ', arenoe(indnoe) +c + if ( np2are(larete).eq.0 ) then +c +c c'est une nouvelle arete, il faut creer le noeud p2 +c + indnoe = indnoe + 1 + arenoe(indnoe) = larete + np2are(larete) = indnoe + s1 = somare(1,larete) + s2 = somare(2,larete) + coonoe(indnoe,1) = ( coonoe(s1,1) + coonoe(s2,1) ) * unsde + coonoe(indnoe,2) = ( coonoe(s1,2) + coonoe(s2,2) ) * unsde + coonoe(indnoe,3) = ( coonoe(s1,3) + coonoe(s2,3) ) * unsde + hetnoe(indnoe) = 52 + famnoe(indnoe) = 1 +c + endif +c + 21 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utnomc.F b/src/tool/Utilitaire/utnomc.F new file mode 100644 index 00000000..6d83c524 --- /dev/null +++ b/src/tool/Utilitaire/utnomc.F @@ -0,0 +1,243 @@ + subroutine utnomc ( nocmai, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Nom des Objets du Maillage de Calcul +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocmai . e . char8 . nom de l'objet maillage de calcul . +c . sdim . s . 1 . dimension de l'espace . +c . mdim . s . 1 . dimension du maillage . +c . degre . s . 1 . degre du maillage . +c . mailet . s . 1 . presence de mailles etendues . +c . . . . 1 : aucune . +c . . . . 2x : TRIA7 . +c . . . . 3x : QUAD9 . +c . . . . 5x : HEXA27 . +c . maconf . s . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme sans contrainte . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . homolo . s . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . hierar . s . 1 . maillage hierarchique . +c . . . . 0 : non . +c . . . . 1 : oui . +c . nbnomb . s . 1 . longueur du tableau de la branche Nombres . +c . ncinfo . s . char8 . nom de la branche InfoGene . +c . ncnoeu . s . char8 . nom de la branche Noeud . +c . nccono . s . char8 . nom de la branche ConnNoeu . +c . nccode . s . char8 . nom de la branche ConnDesc . +c . nccoex . s . char8 . nom de la branche CodeExte . +c . ncfami . s . char8 . nom de la branche Famille . +c . ncequi . s . char8 . nom de la branche Equivalt . +c . ncfron . s . char8 . nom de la branche Frontier . +c . ncnomb . s . char8 . nom de la branche Nombres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNOMC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nocmai + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer sdim, mdim + integer degre, mailet, maconf, homolo, hierar + integer nbnomb +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7, codre8 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Noms des objets du maillage de calcul.'')' + texte(1,4) = '(''Au moins une branche est indefinie.'')' +c + texte(2,10) = '(''Names of calculation mesh objects.'')' + texte(2,4) = '(''At least one branch is undefined.'')' +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,10)) +#endif +c + codret = 0 +c +c==== +c 2. recuperation des donnees du maillage d'entree +c==== +c +c 2.1. ==> caracteristiques de base +c + if ( codret.eq.0 ) then +c + call gmliat ( nocmai, 1, sdim, codre1 ) + call gmliat ( nocmai, 2, mdim, codre2 ) + call gmliat ( nocmai, 3, degre, codre3 ) + call gmliat ( nocmai, 4, maconf, codre4 ) + call gmliat ( nocmai, 5, homolo, codre5 ) + call gmliat ( nocmai, 6, hierar, codre6 ) + call gmliat ( nocmai, 7, nbnomb, codre7 ) + call gmliat ( nocmai, 8, mailet, codre8 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7, codre8 ) +c + endif +c +c 2.2. ==> noms des branches +c +c le code de retour de gmnomc est : +c 0 : tout va bien +c -1 : l'objet n'est pas defini ; dans ce cas, le nom est "Indefini" +c -3 : le nom etendu est invalide +c +c Ici, on tolere le retour -1, car selon les endroits, les branches +c ne sont pas toutes definies. +c En revanche, le -3 est une vraie erreur car c'est que le nom +c de l'objet maillage est mauvais. +c + if ( codret.eq.0 ) then +c + call gmnomc ( nocmai//'.InfoGene', ncinfo, codre1 ) + call gmnomc ( nocmai//'.Noeud' , ncnoeu, codre2 ) + call gmnomc ( nocmai//'.ConnNoeu', nccono, codre3 ) + call gmnomc ( nocmai//'.ConnDesc', nccode, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c + if ( codret.eq.0 ) then +c + call gmnomc ( nocmai//'.CodeExte', nccoex, codre1 ) + call gmnomc ( nocmai//'.Famille' , ncfami, codre2 ) + call gmnomc ( nocmai//'.Equivalt', ncequi, codre3 ) + call gmnomc ( nocmai//'.Frontier', ncfron, codre4 ) + call gmnomc ( nocmai//'.Nombres' , ncnomb, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + if ( codret.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,4)) +#endif + codret = 0 + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnomh.F b/src/tool/Utilitaire/utnomh.F new file mode 100644 index 00000000..9bd381c0 --- /dev/null +++ b/src/tool/Utilitaire/utnomh.F @@ -0,0 +1,463 @@ + subroutine utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Nom des Objets du Maillage HOMARD +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . sdim . s . 1 . dimension de l'espace . +c . mdim . s . 1 . dimension du maillage . +c . degre . s . 1 . degre du maillage . +c . maconf . s . 1 . conformite du maillage . +c . . . . 0 : oui . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 par face . +c . . . . 2 : non-conforme avec 1 seul noeud pendant. +c . . . . par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 et des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . 10 : non-conforme sans autre connaissance . +c . homolo . s . 1 . type de relations par homologues . +c . . . . 0 : pas d'homologues . +c . . . . 1 : relations sur les noeuds . +c . . . . 2 : relations sur les noeuds et les aretes . +c . . . . 3 : relations sur les noeuds, les aretes . +c . . . . et les triangles . +c . hierar . s . 1 . maillage hierarchique . +c . . . . 0 : non . +c . . . . 1 : oui . +c . rafdef . s . 1 . 0 : macro-maillage . +c . . . . 1 : le maillage est inchange . +c . . . . 2 : le maillage est issu du raffinement pur. +c . . . . d'un autre maillage . +c . . . . 3 : le maillage est issu du deraffinement . +c . . . . pur d'un autre maillage . +c . . . . 4 : le maillage est issu de raffinement et . +c . . . . de deraffinement d'un autre maillage . +c . . . . 12 : le maillage est un maillage passe de . +c . . . . degre 1 a 2 . +c . . . . 21 : le maillage est un maillage passe de . +c . . . . degre 2 a 1 . +c . nbmane . s . 1 . nombre maximum de noeuds par element . +c . typcca . s . 1 . type du code de calcul . +c . typsfr . s . 1 . type du suivi de frontiere . +c . . . . 0 : aucun . +c . . . . 1 : maillage de degre 1, avec projection . +c . . . . des nouveaux sommets . +c . . . . 2 : maillage de degre 2, seuls les noeuds . +c . . . . P1 sont sur la frontiere ; les noeuds . +c . . . . P2 restent au milieu des P1 . +c . . . . 3 : maillage de degre 2, les noeuds P2 . +c . . . . etant sur la frontiere . +c . maextr . s . 1 . maillage extrude . +c . . . . 0 : non . +c . . . . 1 : selon X . +c . . . . 2 : selon Y . +c . . . . 3 : selon Z (cas de Saturne ou Neptune) . +c . mailet . s . 1 . presence de mailles etendues . +c . . . . 1 : aucune . +c . . . . 2x : TRIA7 . +c . . . . 3x : QUAD9 . +c . . . . 5x : HEXA27 . +c . norenu . s . char8 . nom de la branche RenuMail . +c . nhnoeu . s . char8 . nom de l'objet decrivant les noeuds . +c . nhmapo . s . char8 . nom de l'objet decrivant les mailles-points. +c . nharet . s . char8 . nom de l'objet decrivant les aretes . +c . nhtria . s . char8 . nom de l'objet decrivant les triangles . +c . nhquad . s . char8 . nom de l'objet decrivant les quadrangles . +c . nhtetr . s . char8 . nom de l'objet decrivant les tetraedres . +c . nhhexa . s . char8 . nom de l'objet decrivant les hexaedres . +c . nhpyra . s . char8 . nom de l'objet decrivant les pyramides . +c . nhpent . s . char8 . nom de l'objet decrivant les pentaedres . +c . nhelig . s . char8 . nom de l'objet decrivant les ignores . +c . nhvois . s . char8 . nom de la branche Voisins . +c . nhsupe . s . char8 . informations supplementaires entieres . +c . nhsups . s . char8 . informations supplementaires caracteres 8 . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNOMH' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*8 nomail +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + character*4 saux02(3,2) + character*8 saux08 + character*80 saux80 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Noms des objets du maillage : '',a)' + texte(1,5) = '(''.. L''''objet n''''est pas alloue.'')' + texte(1,6) = '(''.. L''''objet est un objet simple !'')' + texte(1,7) = '(''.. L''''objet a un nom bizarre.'')' + texte(1,8) = '(''Une branche est indefinie.'')' +c + texte(2,4) = '(''Names oj objects for mesh : '',a)' + texte(2,5) = '(''.. The object is not allocated.'')' + texte(2,6) = '(''.. The object is a simple object.'')' + texte(2,7) = '(''.. The object name is strange.'')' + texte(2,8) = '(''A branch is undefined.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nomail + call gmprsx (nompro, nomail ) + call gmprsx (nompro, nomail//'.RenuMail' ) + call gmprsx (nompro, nomail//'.Noeud' ) + call gmprsx (nompro, nomail//'.Arete' ) + call gmprsx (nompro, nomail//'.Face' ) + call gmprsx (nompro, nomail//'.Volume' ) +#endif +c +c==== +c 2. recuperation des donnees du maillage +c==== +c +c 2.1. ==> l'objet existe-t-il vraiment ? +c + call gmobal ( nomail, codret ) +c + if ( codret.eq.1 ) then +c + codret = 0 +c + else +c + write (ulsort,texte(langue,4)) nomail +c + if ( codret.eq.0 ) then + write (ulsort,texte(langue,5)) +c + elseif ( codret.eq.2 ) then + write (ulsort,texte(langue,6)) +c + else + write (ulsort,texte(langue,7)) +c + endif +c + codret = 1 +c + endif +c +c 2.2. ==> caracteristiques de base +c + if ( codret.eq.0 ) then +c + call gmliat ( nomail, 1, sdim , codre1 ) + call gmliat ( nomail, 2, mdim , codre2 ) + call gmliat ( nomail, 3, degre , codre3 ) + call gmliat ( nomail, 4, maconf, codre4 ) + call gmliat ( nomail, 5, homolo, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + call gmliat ( nomail, 6, hierar, codre1 ) + call gmliat ( nomail, 7, rafdef, codre2 ) + call gmliat ( nomail, 8, nbmane, codre3 ) + call gmliat ( nomail, 9, typcca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmliat ( nomail,10, typsfr, codre1 ) + call gmliat ( nomail,11, maextr, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.3. ==> noms des branches +c +c le code de retour de gmnomc est : +c 0 : tout va bien +c -1 : l'objet n'est pas defini ; dans ce cas, le nom est "Indefini" +c -3 : le nom etendu est invalide +c +c Ici, on tolere le retour -1, car selon les endroits, les branches +c ne sont pas toutes definies. +c En revanche, le -3 est une vraie erreur car c'est que le nom +c de l'objet maillage est mauvais. +c +c Consequence : Il faut cumuler le codret et le tester seulement +c a la fin du 2.3 +c + if ( codret.eq.0 ) then +c +c 2.3.1 ==> Renumerotations et noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro//' 2.3.1 Renum etc. ; codret = ', codret +#endif +c + call gmnomc ( nomail//'.RenuMail', norenu, codre1 ) + call gmnomc ( nomail//'.Noeud' , nhnoeu, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c 2.3.2 ==> Aretes, tetraedres, pyramides et pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro//' 2.3.2 Are etc. ; codret = ', codret +#endif +c +cgn call gmprsx ('nomail.Face dans '//nompro, nomail//'.Face') +cgn call gmprsx ('nomail.Volume dans '//nompro, nomail//'.Volume') + if ( degre.eq.1 ) then + call gmnomc ( nomail//'.Arete.HOM_Se02' , nharet, codre1 ) + call gmnomc ( nomail//'.Volume.HOM_Te04', nhtetr, codre2 ) + call gmnomc ( nomail//'.Volume.HOM_Py05', nhpyra, codre3 ) + call gmnomc ( nomail//'.Volume.HOM_Pe06', nhpent, codre4 ) + else + call gmnomc ( nomail//'.Arete.HOM_Se03' , nharet, codre1 ) + call gmnomc ( nomail//'.Volume.HOM_Te10', nhtetr, codre2 ) + call gmnomc ( nomail//'.Volume.HOM_Py13', nhpyra, codre3 ) + call gmnomc ( nomail//'.Volume.HOM_Pe15', nhpent, codre4 ) + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c +c 2.3.3 ==> Triangles, quadrangles et hexaedres : eventuellement etendu +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro//' 2.3.3 Tri etc. ; codret = ', codret +#endif +c + mailet = 1 +c + if ( degre.eq.1 ) then +c + call gmnomc ( nomail//'.Face.HOM_Tr03' , nhtria, codre1 ) + call gmnomc ( nomail//'.Face.HOM_Qu04' , nhquad, codre2 ) + call gmnomc ( nomail//'.Volume.HOM_He08', nhhexa, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + else +c +cgn call gmprsx ( nompro, nomail//'.Face' ) +cgn call gmprsx ( nompro, nomail//'.Volume' ) + saux02(1,1) = 'Tr06' + saux02(1,2) = 'Tr07' + saux02(2,1) = 'Qu08' + saux02(2,2) = 'Qu09' + saux02(3,1) = 'He20' + saux02(3,2) = 'He27' +c + do 233 , iaux = 1 , 3 +c + saux80 = blan80 + if ( iaux.le.2 ) then + kaux = 8 + 10 + saux80(1:kaux) = nomail//'.Face.HOM_' + else + kaux = 8 + 12 + saux80(1:kaux) = nomail//'.Volume.HOM_' + endif + do 2331 , jaux = 1 , 2 +c + saux80(kaux+1:kaux+4) = saux02(iaux,jaux) + call gmobal ( saux80 , codre0 ) +cgn write(ulsort,90002) 'gmobal pour '//saux80(1:kaux+4),codre0 + if ( codre0.eq.0 ) then + goto 2331 + elseif ( codre0.eq.1 ) then + call gmnomc ( saux80 , saux08, codre1 ) + if ( codre1.eq.0 ) then +cgn write(ulsort,90003) 'nom de '//saux80(1:kaux+4), saux08 + if ( iaux.eq.1 ) then + nhtria = saux08 + if ( jaux.eq.2 ) then + mailet = mailet*2 + endif + elseif ( iaux.eq.2 ) then + nhquad = saux08 + if ( jaux.eq.2 ) then + mailet = mailet*3 + endif + else + nhhexa = saux08 + if ( jaux.eq.2 ) then + mailet = mailet*5 + endif + endif + goto 233 + else + codret = 1 + endif + else + codret = 1 + endif +c + 2331 continue +c + 233 continue +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'mailet' , mailet + write(ulsort,90003) 'nhtria' , nhtria + write(ulsort,90003) 'nhquad' , nhquad + write(ulsort,90003) 'nhhexa' , nhhexa +#endif +c + endif +c +c 2.3.4 ==> Voisinages et autres +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro//' 2.3.4 Voisinages ; codret = ', codret +#endif +c + call gmnomc ( nomail//'.Voisins' , nhvois, codre1 ) + call gmnomc ( nomail//'.Ma_Point', nhmapo, codre2 ) + call gmnomc ( nomail//'.ElemIgno', nhelig, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmnomc ( nomail//'.InfoSupE', nhsupe, codre1 ) + call gmnomc ( nomail//'.InfoSupS', nhsups, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +c 2.3.5 ==> Corrections du code de retour +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) nompro//' 2.3.5 correction ; codret = ', codret +#endif +c + if ( codret.eq.1 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,8)) +#endif + codret = 0 +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utnpen.F b/src/tool/Utilitaire/utnpen.F new file mode 100644 index 00000000..bbe6674c --- /dev/null +++ b/src/tool/Utilitaire/utnpen.F @@ -0,0 +1,148 @@ + subroutine utnpen ( lepent, niveau, + > facpen, perpen, + > nivtri, nivqua ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Niveau d'un PENtaedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . niveau . s . 1 . niveau . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . perpen . e . nbpeto . pere des pentaedres . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision niveau +c + integer lepent + integer facpen(nbpecf,5), perpen(nbpeto) + integer nivtri(nbtrto), nivqua(nbquto) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac3, lafac4, lafac5 + integer lepere + integer iaux, jaux +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c +cgn write(*,90002) 'nbpema, nbpecf, nbpeto', nbpema, nbpecf, nbpeto +cgn write(*,90002) 'nbheco', nbheco +c +c==== +c 1. Du maillage initial +c==== +c + if ( lepent.le.nbpema ) then +c + niveau = 0.d0 +c +c==== +c 2. Au dela +c==== +c + else +c +c 2.1. ==> Si le pentaedre est decrit par faces : +c le plus haut niveau de ses faces +c + if ( lepent.le.nbpecf ) then +c + lafac1 = facpen(lepent,1) + lafac2 = facpen(lepent,2) + lafac3 = facpen(lepent,3) + lafac4 = facpen(lepent,4) + lafac5 = facpen(lepent,5) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5)) +c +c 2.2. ==> Si le pentaedre est decrit par aretes : +c son niveau est le niveau du pere augmente d'un cran +c + else +c + iaux = perpen(lepent) +c + if ( iaux.gt.0 ) then + lepere = iaux + else + write(*,90002) 'lepent, iaux', lepent, iaux + write(*,*) 'arret dans utnpen' + STOP + endif +cgn write(*,90002) 'iaux, lepere', iaux, lepere +c + if ( iaux.gt.0 ) then +c + lafac1 = facpen(lepere,1) + lafac2 = facpen(lepere,2) + lafac3 = facpen(lepere,3) + lafac4 = facpen(lepere,4) + lafac5 = facpen(lepere,5) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5)) +c + endif +c + jaux = jaux + 1 +c + endif +c +cgn write(*,90002) '==> jaux',jaux + niveau = dble(jaux) +c +c==== +c 3. Si le pentaedre est de conformite, on prend le niveau +c intermediaire immediatement inferieur +c==== +c + if ( lepent.gt.nbpepe ) then + niveau = niveau - 0.5d0 + endif +c + endif +cgn write(*,90004) '==> niveau',niveau +c + end diff --git a/src/tool/Utilitaire/utnpyr.F b/src/tool/Utilitaire/utnpyr.F new file mode 100644 index 00000000..32084a37 --- /dev/null +++ b/src/tool/Utilitaire/utnpyr.F @@ -0,0 +1,161 @@ + subroutine utnpyr ( lapyra, niveau, + > facpyr, perpyr, pphepe, + > nivtri, nivqua, + > quahex, facpen ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Niveau d'une PYRamide +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . niveau . s . 1 . niveau . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . perpyr . e . nbpyto . pere des pyramides . +c . . . . si perpyr(i) > 0 : numero de la pyramide . +c . . . . si perpyr(i) < 0 : -numero dans pphepe . +c . pphepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + double precision niveau +c + integer lapyra + integer facpyr(nbpycf,5), perpyr(nbpyto), pphepe(*) + integer nivtri(nbtrto), nivqua(nbquto) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer lepere + integer iaux, jaux +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c +c==== +c 1. Determination du niveau +c==== +c +cgn write(*,90002) 'nbpyma, nbpycf, nbpyto', nbpyma, nbpycf, nbpyto +cgn write(*,90002) 'nbheco', nbheco +c +c 1.1. ==> Du maillage initial +c + if ( lapyra.le.nbpyma ) then +c + niveau = 0.d0 +c +c 1.2. ==> Au dela +c + else +c +c 1.2.1. ==> Si la pyramide est decrit par faces : +c le plus haut niveau de ses faces +c + if ( lapyra.le.nbpycf ) then +c + lafac1 = facpyr(lapyra,1) + lafac2 = facpyr(lapyra,2) + lafac3 = facpyr(lapyra,3) + lafac4 = facpyr(lapyra,4) + lafac5 = facpyr(lapyra,5) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivtri(lafac3),nivtri(lafac4), + > nivqua(lafac5)) +c +c 1.2.2. ==> Si la pyramide est decrit par aretes : +c son niveau est le niveau du pere augmente d'un cran +c + else +c + iaux = perpyr(lapyra) + lepere = pphepe(-iaux) +cgn write(*,90002) 'iaux, lepere', iaux, lepere +c + if ( -iaux.le.nbheco ) then +c + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + jaux = max(nivqua(lafac1),nivqua(lafac2),nivqua(lafac3), + > nivqua(lafac4),nivqua(lafac5),nivqua(lafac6)) + else +c + lafac1 = facpen(lepere,1) + lafac2 = facpen(lepere,2) + lafac3 = facpen(lepere,3) + lafac4 = facpen(lepere,4) + lafac5 = facpen(lepere,5) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5)) +c + endif +c + jaux = jaux + 1 +c + endif +c +cgn write(*,90002) '==> jaux',jaux + niveau = dble(jaux) +c +c 1.2.3. ==> Si la pyramide est de conformite, on prend le niveau +c intermediaire immediatement inferieur +c + if ( lapyra.gt.nbpype ) then + niveau = niveau - 0.5d0 + endif +c + endif +cgn write(*,90004) '==> niveau',niveau +c + end \ No newline at end of file diff --git a/src/tool/Utilitaire/utnqua.F b/src/tool/Utilitaire/utnqua.F new file mode 100644 index 00000000..080e10c3 --- /dev/null +++ b/src/tool/Utilitaire/utnqua.F @@ -0,0 +1,105 @@ + subroutine utnqua ( lequad, normal, + > nbnoto, nbquto, + > coonoe, somare, arequa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Normale d'un QUAdrangle +c -- - --- +c Remarque : cela suppose que le quadrangle est plan +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . numero du quadrangle a examiner . +c . normal . s . 3 . vecteur de la normale (normalise) . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer lequad +c + integer nbnoto, nbquto +c + double precision normal(3), coonoe(nbnoto,*) +c + integer somare(2,*), arequa(nbquto,4) +c +c 0.4. ==> variables locales +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c + double precision aret1(3), aret2(3) +c +c 0.5. ==> initialisations +c +c==== +c 1. les sommets +c==== +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + aret1(1) = coonoe(sa1a2,1) - coonoe(sa4a1,1) + aret1(2) = coonoe(sa1a2,2) - coonoe(sa4a1,2) + aret1(3) = coonoe(sa1a2,3) - coonoe(sa4a1,3) +c + aret2(1) = coonoe(sa2a3,1) - coonoe(sa1a2,1) + aret2(2) = coonoe(sa2a3,2) - coonoe(sa1a2,2) + aret2(3) = coonoe(sa2a3,3) - coonoe(sa1a2,3) +c +c==== +c 2. normal = produit vectoriel +c==== +c + normal(1) = aret2(2)*aret1(3) - aret2(3)*aret1(2) + normal(2) = aret2(3)*aret1(1) - aret2(1)*aret1(3) + normal(3) = aret2(1)*aret1(2) - aret2(2)*aret1(1) +c + aret1(1) = sqrt ( normal(1)*normal(1) + + > normal(2)*normal(2) + + > normal(3)*normal(3) ) +c + normal(1) = normal(1)/aret1(1) + normal(2) = normal(2)/aret1(1) + normal(3) = normal(3)/aret1(1) +c + end diff --git a/src/tool/Utilitaire/utntet.F b/src/tool/Utilitaire/utntet.F new file mode 100644 index 00000000..3c6465ff --- /dev/null +++ b/src/tool/Utilitaire/utntet.F @@ -0,0 +1,160 @@ + subroutine utntet ( letetr, niveau, + > tritet, pertet, pthepe, + > nivtri, nivqua, + > quahex, facpen ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Niveau d'un TETraedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . niveau . s . 1 . niveau . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . pertet . e . nbteto . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . pthepe . e . * . si i <= nbheco : numero de l'hexaedre . +c . . . . si non : numero du pentaedre . +c . nivtri . e . nbtrto . niveau dans le raffinement/deraffinement . +c . nivqua . e . nbquto . niveau dans le raffinement/deraffinement . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision niveau +c + integer letetr + integer nivtri(nbtrto), nivqua(nbquto) + integer tritet(nbtecf,4), pertet(nbteto), pthepe(*) + integer quahex(nbhecf,6) + integer facpen(nbpecf,5) +c +c 0.4. ==> variables locales +c + integer lafac1, lafac2, lafac3, lafac4, lafac5, lafac6 + integer lepere + integer iaux, jaux +c +c 0.5. ==> initialisations +c +#include "impr03.h" +c +c==== +c 1. Determination du niveau +c==== +c +cgn write(*,90002) 'nbtema, nbtecf, nbteto', nbtema, nbtecf, nbteto +cgn write(*,90002) 'letetr', letetr +c +c 1.1. ==> Du maillage initial +c + if ( letetr.le.nbtema ) then +c + niveau = 0.d0 +c +c 1.2. ==> Au dela +c + else +c +c 1.2.1. ==> Si le tetraedre est decrit par faces : +c le plus haut niveau de ses faces +c + if ( letetr.le.nbtecf ) then +c + lafac1 = tritet(letetr,1) + lafac2 = tritet(letetr,2) + lafac3 = tritet(letetr,3) + lafac4 = tritet(letetr,4) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivtri(lafac3),nivtri(lafac4)) +c +c 1.2.2. ==> Si le tetraedre est decrit par aretes : +c son niveau est le niveau du pere augmente d'un cran +c + else +c + iaux = pertet(letetr) + lepere = pthepe(-iaux) +cgn write(*,90002) 'iaux, lepere', iaux, lepere +cgn write(*,90002) 'nbheco', nbheco +c + if ( -iaux.le.nbheco ) then +c + lafac1 = quahex(lepere,1) + lafac2 = quahex(lepere,2) + lafac3 = quahex(lepere,3) + lafac4 = quahex(lepere,4) + lafac5 = quahex(lepere,5) + lafac6 = quahex(lepere,6) + jaux = max(nivqua(lafac1),nivqua(lafac2),nivqua(lafac3), + > nivqua(lafac4),nivqua(lafac5),nivqua(lafac6)) + else +c + lafac1 = facpen(lepere,1) + lafac2 = facpen(lepere,2) + lafac3 = facpen(lepere,3) + lafac4 = facpen(lepere,4) + lafac5 = facpen(lepere,5) + jaux = max(nivtri(lafac1),nivtri(lafac2), + > nivqua(lafac3),nivqua(lafac4),nivqua(lafac5)) +c + endif +c + jaux = jaux + 1 +c + endif +c +cgn write(*,90002) '==> jaux',jaux + niveau = dble(jaux) +c +c 1.2.3. ==> Si le tetraedre est de conformite, on prend le niveau +c intermediaire immediatement inferieur +c + if ( letetr.gt.nbtepe ) then + niveau = niveau - 0.5d0 + endif +c + endif +cgn write(*,90004) '==> niveau',niveau +c + end diff --git a/src/tool/Utilitaire/utntri.F b/src/tool/Utilitaire/utntri.F new file mode 100644 index 00000000..334f5ad5 --- /dev/null +++ b/src/tool/Utilitaire/utntri.F @@ -0,0 +1,101 @@ + subroutine utntri ( letria, normal, + > coonoe, somare, aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Normale d'un TRIangle +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . numero du triangle a examiner . +c . normal . s . 3 . vecteur de la normale . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision normal(3), coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), aretri(nbtrto,3) +c + integer letria +c +c 0.4. ==> variables locales +c + integer a1, a2 +c + double precision aret1(3), aret2(3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes +c==== +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) +c + aret1(1) = coonoe(somare(2,a1),1) - coonoe(somare(1,a1),1) + aret1(2) = coonoe(somare(2,a1),2) - coonoe(somare(1,a1),2) + aret1(3) = coonoe(somare(2,a1),3) - coonoe(somare(1,a1),3) +c + aret2(1) = coonoe(somare(2,a2),1) - coonoe(somare(1,a2),1) + aret2(2) = coonoe(somare(2,a2),2) - coonoe(somare(1,a2),2) + aret2(3) = coonoe(somare(2,a2),3) - coonoe(somare(1,a2),3) +c +c==== +c 2. normal = produit vectoriel +c==== +c + normal(1) = aret2(2)*aret1(3) - aret2(3)*aret1(2) + normal(2) = aret2(3)*aret1(1) - aret2(1)*aret1(3) + normal(3) = aret2(1)*aret1(2) - aret2(2)*aret1(1) +c + aret1(1) = sqrt ( normal(1)*normal(1) + + > normal(2)*normal(2) + + > normal(3)*normal(3) ) +c + normal(1) = normal(1)/aret1(1) + normal(2) = normal(2)/aret1(1) + normal(3) = normal(3)/aret1(1) +c + end diff --git a/src/tool/Utilitaire/utnvaf.F b/src/tool/Utilitaire/utnvaf.F new file mode 100644 index 00000000..ab7373f7 --- /dev/null +++ b/src/tool/Utilitaire/utnvaf.F @@ -0,0 +1,163 @@ + subroutine utnvaf ( nombre, laface, + > aretri, arequa, posifa, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Nombre de faces Voisins des Aretes d'une Face +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nombre . s . 4 . nombre de faces voisines de chaque arete . +c . laface . e . 1 . numero de la face a examiner . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTNVAF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nombre(4), laface + integer aretri(nbtrto,3), arequa(nbquto,4) + integer posifa(0:nbarto) + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer larete(4), nbaret + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen du '',a,i10)' + texte(1,5) = '(''Aretes :'',4i10)' + texte(1,6) = '(''Nombre de voisins :'',4i10)' +c + texte(2,4) = '(''Examination of '',a,''#'',i10)' + texte(2,5) = '(''Edges :'',4i10)' + texte(2,6) = '(''Number of neighbours :'',4i10)' +c +#ifdef _DEBUG_HOMARD_ + if ( laface.gt.0 ) then + iaux = 2 + else + iaux = 4 + endif + write (ulsort,texte(langue,4)) mess14(langue,1,iaux), abs(laface) +#endif +c +c 1.2. ==> depart +c + codret = 0 +c +c==== +c 2. traitement +c==== +c + if ( laface.gt.0 ) then + nbaret = 3 + larete(1) = aretri(laface,1) + larete(2) = aretri(laface,2) + larete(3) = aretri(laface,3) + else + nbaret = 4 + larete(1) = arequa(-laface,1) + larete(2) = arequa(-laface,2) + larete(3) = arequa(-laface,3) + larete(4) = arequa(-laface,4) + endif +c + do 20 , iaux = 1 , nbaret + nombre(iaux) = posifa(larete(iaux)) - posifa(larete(iaux)-1) + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) (larete(iaux), iaux = 1, nbaret) + write (ulsort,texte(langue,6)) (nombre(iaux), iaux = 1, nbaret) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utora3.F b/src/tool/Utilitaire/utora3.F new file mode 100644 index 00000000..921eebf2 --- /dev/null +++ b/src/tool/Utilitaire/utora3.F @@ -0,0 +1,245 @@ + subroutine utora3 ( orient, + > a0, a1, a2, a3, + > coonoe, somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ORientation d'Aretes d'un paquet de 3 +c -- -- - - +c +c Determine dans quel sens le paquet des aretes (a1,a2,a3) tourne +c relativement a l'arete a0 +c +c Si a0 s'enfonce dans le plan courant : +c positif negatif +c a1 a1 +c . . +c . . +c . . +c a0 a0 +c . . . . +c . . . . +c . . . . +c a3 a2 a2 a3 +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . orient . s . 1 . 1 : dans le sens positif . +c . . . . -1 : dans le sens negatif . +c . a0 . e . 1 . arete orientant . +c . a1-3 . e . 1 . aretes a placer . +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTORA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer orient + integer a0, a1, a2, a3 + integer somare(2,nbarto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lenoeu +c + double precision daux(3) + double precision v0(3), v1(3), v2(3), v3(3) + double precision prm1, prm2, prm3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. Arete definissant l'orientation +c==== +c + lenoeu = somare(1,a0) + do 21 , iaux = 1 , sdim + daux(iaux) = coonoe(lenoeu,iaux) + v0(iaux) = coonoe(somare(2,a0),iaux) - daux(iaux) + 21 continue +c +#ifdef _DEBUG_HOMARD_ + if ( a0.eq.-8 ) then + write (ulsort,90001) 'origine arete orientante',a0,lenoeu + write (ulsort,90004) 'sommet origine ',(daux(iaux),iaux=1,sdim) + write (ulsort,90004) 'arete orientante',(v0(iaux),iaux=1,3) + endif +#endif +c +c==== +c 3. Aretes a positionner +c==== +c 3.1. ==> vecteur de l'arete 1 +c + if ( somare(1,a1).eq.lenoeu ) then + jaux = 2 + else + jaux = 1 + endif + do 31 , iaux = 1 , sdim + v1(iaux) = coonoe(somare(jaux,a1),iaux) - daux(iaux) + 31 continue +c +c 3.2. ==> vecteur de l'arete 2 +c + if ( somare(1,a2).eq.lenoeu ) then + jaux = 2 + else + jaux = 1 + endif + do 32 , iaux = 1 , sdim + v2(iaux) = coonoe(somare(jaux,a2),iaux) - daux(iaux) + 32 continue +c +c 3.3. ==> vecteur de l'arete 3 +c + if ( somare(1,a3).eq.lenoeu ) then + jaux = 2 + else + jaux = 1 + endif + do 33 , iaux = 1 , sdim + v3(iaux) = coonoe(somare(jaux,a3),iaux) - daux(iaux) + 33 continue +c +#ifdef _DEBUG_HOMARD_ + if ( a0.eq.-8 ) then + write (ulsort,90004) 'arete 1',(v1(iaux),iaux=1,3) + write (ulsort,90004) 'arete 2',(v2(iaux),iaux=1,3) + write (ulsort,90004) 'arete 3',(v3(iaux),iaux=1,3) + endif +#endif +c +c==== +c 4. calcul des produits mixtes +c Si a0 s'enfonce dans le plan courant : +c a1 +c . +c . +c . +c a0 +c . +c . +c . +c a2 +c Le produit mixte (a0,a1,a2) est >0 tant que a2 est "a droite" de a1, +c comme sur la figure. Il devient <0 quand a2 passe "a gauche". +c En examinant successivement les 3 produits, on en deduit la +c position relative de (a1,a2,a3) +c==== +c + call utprmi ( v0, v1, v2, prm1 ) + call utprmi ( v0, v1, v3, prm2 ) + call utprmi ( v0, v2, v3, prm3 ) +#ifdef _DEBUG_HOMARD_ + if ( a0.eq.-8 ) then + write (ulsort,90004) 'produits mixtes',prm1, prm2, prm3 + endif +#endif +c + if ( ( prm1.ge.0.d0 .and. prm2.le.0.d0 ) .or. + > ( prm1.ge.0.d0 .and. prm2.ge.0.d0 .and. prm3.ge.0.d0 ) .or. + > ( prm1.le.0.d0 .and. prm2.le.0.d0 .and. prm3.ge.0.d0 ) ) + > then + orient = 1 + else + orient = -1 + endif +#ifdef _DEBUG_HOMARD_ + if ( a0.eq.-8 ) then + write (ulsort,90002) 'orient',orient + endif +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utora4.F b/src/tool/Utilitaire/utora4.F new file mode 100644 index 00000000..5edfa9f8 --- /dev/null +++ b/src/tool/Utilitaire/utora4.F @@ -0,0 +1,255 @@ + subroutine utora4 ( orient, + > a0, a1, a2, a3, a4, + > coonoe, somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ORientation d'Aretes d'un paquet de 4 +c -- -- - - +c +c Determine dans quel sens le paquet des aretes (a1,a2,a3,a4) tourne +c relativement a l'arete a0 +c +c Si a0 s'enfonce dans le plan courant : +c positif negatif +c a1 a1 +c . . +c . . +c . . +c a0 a0 +c . . . . +c . . . . +c . . . . +c a3 a2 a2 a3 +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . orient . s . 4 . orient(1) = 1, puis numeros des aretes dans. +c . . . . le sens positif . +c . a0 . e . 1 . arete orientant . +c . a1-4 . e . 1 . aretes a placer . +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTORA3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer orient(4) + integer a0, a1, a2, a3, a4 + integer somare(2,nbarto) +c + double precision coonoe(nbnoto,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c + codret = 0 +c + orient(1) = 1 +c +c==== +c 2. Positionnement des 3 premieres aretes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3 123', nompro +#endif + call utora3 ( iaux, + > a0, a1, a2, a3, + > coonoe, somare, + > ulsort, langue, codret ) +c +c==== +c 3. Si les 3 premieres aretes tournent dans le sens positif, 3 cas : +c a1 a1 a1 +c . a4 . . +c . . . . +c . . . . +c a0 a0 a4......a0 +c . . .. . . . +c . . . . . . . +c . . . . . . . +c a3 a2 a3 a4 a2 a3 a2 +c==== +c + if ( iaux.ge.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3 124', nompro +#endif + call utora3 ( jaux, + > a0, a1, a2, a4, + > coonoe, somare, + > ulsort, langue, codret ) +c + if ( jaux.le.0 ) then +c + orient(2) = 4 + orient(3) = 2 + orient(4) = 3 +c + else +c + orient(2) = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3 234', nompro +#endif + call utora3 ( kaux, + > a0, a2, a3, a4, + > coonoe, somare, + > ulsort, langue, codret ) +c + if ( kaux.le.0 ) then + orient(3) = 4 + orient(4) = 3 + else + orient(3) = 3 + orient(4) = 4 + endif +c + endif +c +c==== +c 4. Si les 3 premieres aretes tournent dans le sens negatif, 3 cas : +c a1 a1 a1 +c . a4 . . +c . . . . +c . . . . +c a0 a0 a4......a0 +c . . .. . . . +c . . . . . . . +c . . . . . . . +c a2 a3 a2 a4 a3 a2 a3 +c==== +c + else +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3 134', nompro +#endif + call utora3 ( jaux, + > a0, a1, a3, a4, + > coonoe, somare, + > ulsort, langue, codret ) +c + if ( jaux.le.0 ) then +c + orient(2) = 4 + orient(3) = 3 + orient(4) = 2 +c + else +c + orient(2) = 3 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTORA3 234', nompro +#endif + call utora3 ( kaux, + > a0, a2, a3, a4, + > coonoe, somare, + > ulsort, langue, codret ) +c + if ( kaux.ge.0 ) then + orient(3) = 4 + orient(4) = 2 + else + orient(3) = 2 + orient(4) = 4 + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utoraq.F b/src/tool/Utilitaire/utoraq.F new file mode 100644 index 00000000..db18c334 --- /dev/null +++ b/src/tool/Utilitaire/utoraq.F @@ -0,0 +1,125 @@ + subroutine utoraq ( somare, a1, a2, a3, a4, + > or1, or2, or3, or4 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ORientation des Aretes d'un Quadrangle +c -- -- - - +c Remarque : cela suppose que les aretes a1, a2, a3, a4 sont donnees +c dans l'ordre standard +c Remarque : programme semblable a utsoqu +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c .a1,..,a4. e . 1 . les numeros d'aretes du quadrangle . +c . ori . s . 1 . 1 ou -1 , selon que l'arete ari est dans . +c . . . . le sens du quadrangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*) + integer a1, a2, a3, a4 + integer or1, or2, or3, or4 +c +c 0.4. ==> variables locales +c +c==== +c 1. recherche des orientations : +c l'orientation de l'arete i est positive si son second somemt est +c un des sommets de l'arete i+1 +c==== +c +c sa4a1 a4 sa3a4 +c ._________. +c . . +c . . +c a1. .a3 +c . . +c ._________. +c sa1a2 a2 sa2a3 +c +c + if ( somare(2,a1) .eq. somare(1,a2) .or. + > somare(2,a1) .eq. somare(2,a2) ) then +c le 2nd noeud de l'arete 1 est un sommet de a2 ; +c donc l'orientation est positive +c + or1 = 1 +c + else +c + or1 = -1 +c + endif +c + if ( somare(2,a2) .eq. somare(1,a3) .or. + > somare(2,a2) .eq. somare(2,a3) ) then +c le 2nd noeud de l'arete 2 est un sommet de a3 ; +c donc l'orientation est positive +c + or2 = 1 +c + else +c + or2 = -1 +c + endif +c + if ( somare(2,a3) .eq. somare(1,a4) .or. + > somare(2,a3) .eq. somare(2,a4) ) then +c le 2nd noeud de l'arete 3 est un sommet de a4 ; +c donc l'orientation est positive +c + or3 = 1 +c + else +c + or3 = -1 +c + endif +c + if ( somare(2,a4) .eq. somare(1,a1) .or. + > somare(2,a4) .eq. somare(2,a1) ) then +c le 2nd noeud de l'arete 4 est un sommet de a1 ; +c donc l'orientation est positive +c + or4 = 1 +c + else +c + or4 = -1 +c + endif +c + end diff --git a/src/tool/Utilitaire/utorat.F b/src/tool/Utilitaire/utorat.F new file mode 100644 index 00000000..83ae21ce --- /dev/null +++ b/src/tool/Utilitaire/utorat.F @@ -0,0 +1,115 @@ + subroutine utorat ( somare, a1, a2, a3, + > or1, or2, or3 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - ORientation des Aretes d'un Triangle +c -- -- - - +c Remarque : cela suppose que les aretes a1, a2, a3 sont donnees +c dans l'ordre standard +c Remarque : programme semblable a utsotr +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c .a1,a2,a3. e . 1 . les numeros d'aretes du triangle . +c . ori . s . 1 . 1 ou -1 , selon que l'arete ari est dans . +c . . . . le sens du triangle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*) + integer a1, a2, a3 + integer or1, or2, or3 +c +c 0.4. ==> variables locales +c +c==== +c 1. recherche des orientations : +c l'orientation de l'arete i est positive si son second somemt est +c un des sommets de l'arete i+1 +c==== +c +c S1 = sa2a3 +c * +c . . +c . . +c . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1 = S2*---------------*S3 = sa1a2 +c a1 +c +c + if ( somare(2,a1) .eq. somare(1,a2) .or. + > somare(2,a1) .eq. somare(2,a2) ) then +c le 2nd noeud de l'arete 1 est un sommet de a2 ; +c donc l'orientation est positive +c + or1 = 1 +c + else +c + or1 = -1 +c + endif +c + if ( somare(2,a2) .eq. somare(1,a3) .or. + > somare(2,a2) .eq. somare(2,a3) ) then +c le 2nd noeud de l'arete 2 est un sommet de a3 ; +c donc l'orientation est positive +c + or2 = 1 +c + else +c + or2 = -1 +c + endif +c + if ( somare(2,a3) .eq. somare(1,a1) .or. + > somare(2,a3) .eq. somare(2,a1) ) then +c le 2nd noeud de l'arete 3 est un sommet de a1 ; +c donc l'orientation est positive +c + or3 = 1 +c + else +c + or3 = -1 +c + endif +c + end diff --git a/src/tool/Utilitaire/utosde.F b/src/tool/Utilitaire/utosde.F new file mode 100644 index 00000000..afb165ad --- /dev/null +++ b/src/tool/Utilitaire/utosde.F @@ -0,0 +1,149 @@ + subroutine utosde ( typobs, ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : determine si un objet de nom symbolique donne a ete defini +c dans la configuration +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . ch8 . nom symbolique de l'objet . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 2 : pas de nom dans la base . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTOSDE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 typobs +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer iaux + integer adnore + integer nbfich +c + character*8 nomaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(1x,''Objet '',a,'' : recuperation impossible.'')' + texte(1,5) = '(1x,''Objet '',a,'' : nom terminal introuvable.'')' +c + texte(2,4) = '(1x,''Object '',a,'': recovery is impossible.'')' + texte(2,5) = '(1x,''Object '',a,'': final name is missing.'')' +c +c==== +c 2. recherche des adresses des objets GM lies aux noms symboliques +c des objets +c==== +c + nomaux = osliob +c + call gmliat ( nomaux, 1, nbfich, codret ) +c + call gmadoj ( nomaux//'.NomRefer', adnore, iaux, codret) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) nomaux + codret = 2 + endif +c +c==== +c 3. recherche du nom de l'objet +c==== +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbfich +#ifdef _DEBUG_HOMARD_ + nomaux = smem(adnore+iaux-1) +#endif + if ( smem(adnore+iaux-1).eq.typobs ) then + goto 32 + endif + 31 continue +c + codret = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) typobs +#endif +c + 32 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utosme.F b/src/tool/Utilitaire/utosme.F new file mode 100644 index 00000000..9b93fe10 --- /dev/null +++ b/src/tool/Utilitaire/utosme.F @@ -0,0 +1,103 @@ + subroutine utosme ( typobs, ulsort, langue ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Objet Structure - Message d'Erreur +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . ch8 . nom symbolique de l'objet . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTOSME' ) +c +#include "nblang.h" +#include "motcle.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + character*8 typobs +c + integer ulsort, langue +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(1x,''Objet '',a,'' : recuperation impossible.'')' +c + texte(2,4) = '(1x,''Object '',a,'': recovery is impossible.'')' +c +c==== +c 2. message +c==== +c +#ifdef _DEBUG_HOMARD_ + iaux = 1 +#else + if ( typobs.eq.mclist ) then + iaux = 0 + else + iaux = 1 + endif +#endif +c + if ( iaux.eq.1 ) then +c + write (ulsort,texte(langue,4)) typobs +c + endif +c + end diff --git a/src/tool/Utilitaire/utosno.F b/src/tool/Utilitaire/utosno.F new file mode 100644 index 00000000..b75859e1 --- /dev/null +++ b/src/tool/Utilitaire/utosno.F @@ -0,0 +1,155 @@ + subroutine utosno ( typobs, nomobs, + > optimp, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : renvoyer le nom terminal de l'objet structure correspondant +c au un objet de nom symbolique donne +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typobs . e . ch8 . nom symbolique de l'objet . +c . nomobs . s . ch8 . nom unix de l'objet associe . +c . optimp . e . 1 . 0 : pas d'affichage de message . +c . . . . 1 : affichage de message d'erreur . +c . ulsort . e . 1 . unite logique d'impression . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 2 : pas de nom dans la base . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTOSNO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 typobs + character*8 nomobs +c + integer optimp +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "utliob.h" +c + integer iaux + integer adnore, adnoos + integer nbfich +c + character*8 nomaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Objet '',a,'' : recuperation impossible.'')' + texte(1,4) = '(''Objet '',a,'' : nom terminal introuvable.'')' +c + texte(2,10) = '(''Object '',a,'': recovery is impossible.'')' + texte(2,4) = '(''Object '',a,'': final name is missing.'')' +c +c==== +c 2. recherche des adresses des objets GM lies aux noms des objets +c==== +c + nomaux = osliob +c + call gmliat ( nomaux, 1, nbfich, codret ) +c + call gmadoj ( nomaux//'.NomRefer', adnore, iaux, codret) +c + call gmadoj ( nomaux//'.NomObjSt', adnoos, iaux, codret) +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,10)) nomaux + codret = 2 + endif +c +c==== +c 3. recherche du nom de l'objet +c==== +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbfich +#ifdef _DEBUG_HOMARD_ + nomaux = smem(adnore+iaux-1) +#endif + if ( smem(adnore+iaux-1).eq.typobs ) then + nomobs = smem(adnoos+iaux-1) + goto 32 + endif + 31 continue +c + codret = 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro +#else + if ( optimp.gt.0 ) then +#endif + write (ulsort,texte(langue,4)) typobs +#ifdef _DEBUG_HOMARD_ +c +#else + endif +#endif +c + 32 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utpd10.F b/src/tool/Utilitaire/utpd10.F new file mode 100644 index 00000000..f9ad14e6 --- /dev/null +++ b/src/tool/Utilitaire/utpd10.F @@ -0,0 +1,170 @@ + subroutine utpd10 ( val, val10, pd10, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Puissance De 10 +c -- - - -- +c on retourne val10 et pd10 tels que val = val10 * 10**pd10 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . val . e . 1 . valeur a tester . +c . val10 . s . 1 . triteur de la puissance de 10 . +c . pd10 . s . 1 . puissance de 10 de la valeur : . +c . . . . x = 0.abc*10**n . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPD10' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + double precision val, val10 +c + integer pd10 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision valabs, daux +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Valeur a traiter ='',g25.17)' + texte(1,5) = '(''Puissance de 10 ='',i4)' + texte(1,6) = '(''==> '',g25.17,'' * 10**'',i4)' +c + texte(2,4) = '(''Value ='',g25.17)' + texte(2,5) = '(''Power of 10 ='',i4)' + texte(2,6) = '(''==> '',g25.17,'' * 10**'',i4)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) val +#endif +c + codret = 0 +c +c==== +c 2. traitement +c==== +c + valabs = abs(val) +c +c 2.1. ==> cas de la valeur nulle +c + if ( valabs.le.zeroma ) then +c + pd10 = 0 + val10 = val +c +c 2.2. ==> valeur tres grande +c + elseif ( valabs.ge.vinfpo ) then +c + pd10 = 0 + val10 = val +c +c 2.3. ==> valeur moyenne +c + else +c + daux = log10(valabs) + pd10 = int(daux) +cgn print *,daux,pd10 + if ( daux.ge.0.d0 ) then + pd10 = 1+pd10 + endif +c + val10 = val * 10.d0**(-pd10) +cgn 1000 format(5g25.17) +cgn print 1000,val,val10,val10*10.d0**(pd10) +cgn print 1000,val-val10*10.d0**(pd10) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) pd10 + write (ulsort,texte(langue,6)) val10, pd10 +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utplco.F b/src/tool/Utilitaire/utplco.F new file mode 100644 index 00000000..a600fa30 --- /dev/null +++ b/src/tool/Utilitaire/utplco.F @@ -0,0 +1,894 @@ + subroutine utplco ( tyconf, + > decare, decfac, + > hetare, + > hettri, aretri, + > hetqua, arequa, + > hettet, tritet, + > hethex, quahex, coquhe, + > hetpen, facpen, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : PLace pour la COnformite +c -- -- -- +c ______________________________________________________________________ +c +c but : decompte les entites a creer lors du decoupage de conformite +c des triangles, des quadrangles, des tetraedres, des hexaedres +c et des pentaedres. +c remarque : met a jour les decisions de decoupage en 2 des +c faces (on suppose que cela n'a pas deja ete fait). +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tyconf . e . 1 . 0 : conforme (defaut) . +c . . . . 1 : non-conforme avec au minimum 2 aretes . +c . . . . non decoupees en 2 . +c . . . . 2 : non-conforme avec 1 seul noeud . +c . . . . pendant par arete . +c . . . . 3 : non-conforme fidele a l'indicateur . +c . . . . -1 : conforme, avec des boites pour les . +c . . . . quadrangles, hexaedres et pentaedres . +c . . . . -2 : non-conforme avec au maximum 1 arete . +c . . . . decoupee en 2 (boite pour les . +c . . . . quadrangles, hexaedres et pentaedres) . +c . decare . e . nbarto . decisions des aretes . +c . decfac . e . -permqu. decision sur les faces (quad. + tri.) . +c . . . :permtr. . +c . hetare . e . permar . historique de l'etat des aretes . +c . hettri . e . permtr . historique de l'etat des triangles . +c . aretri . e .permtr*3. numeros des 3 aretes des triangles . +c . hetqua . e . permqu . historique de l'etat des quadrangles . +c . arequa . e .permqu*4. numeros des 4 aretes des quadrangles . +c . hettet . e . permte . historique de l'etat des tetraedres . +c . tritet . e .permte*4. numeros des 4 triangles des tetraedres . +c . hethex . e . permhe . historique de l'etat des hexaedres . +c . quahex . e .permhe*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .permhe*6. codes des 6 quadrangles des hexaedres . +c . hetpen . e . permpe . historique de l'etat des pentaedres . +c . facpen . e .permpe*5. numeros des faces des pentaedres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPLCO' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer tyconf + integer decare(0:nbarto) + integer decfac(-permqu:permtr) + integer hetare(permar) + integer aretri(permtr,3), hettri(permtr) + integer arequa(permqu,4), hetqua(permqu) + integer tritet(permte,4), hettet(permte) + integer hethex(permhe) + integer quahex(permhe,6), coquhe(permhe,6) + integer facpen(permpe,5), hetpen(permpe) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer listar(12), etdare(12) + integer lamail + integer nbreso, nbrear, nbrepy, nbrete, nbrehe + integer cpt0, cpt1, cpt2, cpt3, cpt4, cpt5 + integer nbfad2, nbfad3, nbfad4 + integer nbfat4, nbfaq4, et, dt + integer fj + integer dectot +#ifdef _DEBUG_HOMARD_ + integer glop +#endif +c + logical noinma +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) + character*40 mess40(nblang,1) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1234567890123456789012345678901234567890 + mess40(1,1) = ' Nombres d''entites du nouveau maillage ' +c + mess40(2,1) = ' Number of entities of the new mesh ' +c +#include "impr03.h" +c +cgn write(ulsort,91040) decare +c +60000 format( + > 5x,'==========================================================', + >/,5x,'! ',a40 ,' !' + >/,5x,'==========================================================', + >/,5x,'! ', a14,' ! Total ! ', a14,' !', + >/,5x,'==========================================================') +c 1234567890 +61000 format( + > 5x,'! ', a14,' ! ', i10,' ! ', i10,' !') +62000 format( + > 5x,'==========================================================', + > /) +c +c==== +c 2. initialisation des nombres d'entites provisoires +c==== +c + provp1 = 0 + provp2 = 0 + provim = 0 + provar = 0 + provtr = 0 + provqu = 0 + provtf = 0 + provta = 0 + provte = 0 + provhf = 0 + provha = 0 + provhe = 0 + provyf = 0 + provya = 0 + provpy = 0 + provpf = 0 + provpa = 0 + provpe = 0 +c +c==== +c 3. entites nouvelles crees par decoupage des triangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( mod(mailet,2).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + cpt0 = 0 +c + do 30 , iaux = 1 , permtr +c + lamail = iaux +#ifdef _DEBUG_HOMARD_ + if ( lamail.eq.-830 ) then + glop = 1 + else + glop = 0 + endif +#endif +c +#ifdef _DEBUG_HOMARD_ + if ( glop .eq. 1 ) then + write (ulsort,*) '. Triangle ', lamail, + > ', de decision ',decfac(lamail), + > ', d''etat ',hettri(lamail) + do 222 , jaux =1,3 + write (ulsort,*) '. Arete ', aretri(lamail,jaux), + > ', d''etat ',hetare(aretri(lamail,jaux)) + 222 continue + endif +#endif +c + if ( mod(hettri(lamail),10).eq.0 ) then +c + dectot = mod(hetare(aretri(lamail,1)),10) + > + mod(hetare(aretri(lamail,2)),10) + > + mod(hetare(aretri(lamail,3)),10) +c + if ( dectot.eq.2 ) then +c +c decoupage du triangle en 2 triangles +c ------------------------------------ +c + cpt0 = cpt0 + 1 + decfac(lamail) = 2 +c + endif +c + endif +c + 30 continue +c + if ( degre.eq.2 ) then + provp2 = provp2 + cpt0 + endif + if ( noinma ) then + provim = provim + 2*cpt0 + endif + provar = provar + cpt0 + nbart2 = nbart2 + cpt0 + provtr = provtr + 2*cpt0 + nbtrt2 = nbtrt2 + 2*cpt0 +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'provar',provar + write(ulsort,90002) 'provtr',provtr +#endif +c +c==== +c 4. entites nouvelles crees par decoupage des quadrangles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. quadrangles ; codret', codret +#endif +c + if ( nbquto.ne.0 ) then +c + if ( mod(mailet,3).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + cpt2 = 0 + cpt3 = 0 + cpt5 = 0 +c + do 40 , iaux = 1 , permqu +c + lamail = iaux +c + if ( mod(hetqua(lamail),100).eq.0 ) then +c + jaux = mod(hetare(arequa(lamail,1)),10) + > + mod(hetare(arequa(lamail,3)),10) + kaux = mod(hetare(arequa(lamail,2)),10) + > + mod(hetare(arequa(lamail,4)),10) + dectot = jaux + kaux +c + if ( dectot.eq.2 ) then +c +c decoupage du quadrangle en 3 triangles +c -------------------------------------- +c + cpt3 = cpt3 + 1 + decfac(-lamail) = 3 +c + elseif ( dectot.eq.4 ) then +c + if ( ( jaux.eq.4 ) .or. ( kaux.eq.4 ) ) then +c +c decoupage du quadrangle en 2 quadrangles +c ---------------------------------------- +c + cpt2 = cpt2 + 1 + decfac(-lamail) = 2 +c + else +c +c decoupage du quadrangle en 3 quadrangles +c ---------------------------------------- +c + cpt5 = cpt5 + 1 + decfac(-lamail) = 5 +c + endif +c + endif +c + endif +c + 40 continue +c +cgn write (ulsort,90002) 'cpt2', cpt2 +cgn write (ulsort,90002) 'cpt3', cpt3 +cgn write (ulsort,90002) 'cpt5', cpt5 + provp1 = provp1 + cpt5 + if ( degre.eq.2 ) then + provp2 = provp2 + cpt2 + 2*cpt3 + 3*cpt5 + endif + if ( noinma ) then + provim = provim + 2*cpt2 + 3*cpt3 + 3*cpt5 + endif + provar = provar + cpt2 + 2*cpt3 + 3*cpt5 + nbarq2 = nbarq2 + cpt2 + nbarq3 = nbarq3 + 2*cpt3 + nbarq5 = nbarq5 + 3*cpt5 + provtr = provtr + 3*cpt3 + nbtrq3 = nbtrq3 + 3*cpt3 + provqu = provqu + 2*cpt2 + 3*cpt5 + nbquq2 = nbquq2 + 2*cpt2 + nbquq5 = nbquq5 + 3*cpt5 +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'provar',provar + write(ulsort,90002) 'provtr',provtr + write(ulsort,90002) 'provqu',provqu +#endif +c +c==== +c 5. entites nouvelles crees par decoupage des tetraedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. tetraedres ; codret', codret +#endif +c + if ( nbteto.ne.0 ) then +c + cpt0 = 0 + cpt1 = 0 + cpt2 = 0 +c + do 50 , iaux = 1 , permte +c + lamail = iaux +c + if ( mod(hettet(lamail),100).eq.0 ) then +c + nbfad2 = 0 + nbfad4 = 0 + do 500 , jaux = 1 , 4 + fj = tritet(lamail,jaux) + et = mod(hettri(fj),10) + dt = decfac(fj) +cgn write(ulsort,*) '. face numero', jaux,' :', fj, et, dt + if ( dt.eq.2 ) then + nbfad2 = nbfad2 + 1 + elseif ( et.eq.4 .or. dt.eq.4 ) then + nbfad4 = nbfad4 + 1 + endif + 500 continue +c + if ( nbfad2.eq.3 .and. nbfad4.eq.1 ) then +c +c decoupage en 4 pour mise en conformite par 1 face +c ------------------------------------------------- +c + cpt0 = cpt0 + 1 +c + elseif ( nbfad2.eq.4 .and. nbfad4.eq.0 ) then +c +c decoupage en 4 pour mise en conformite par 2 aretes +c --------------------------------------------------- +c + cpt1 = cpt1 + 1 +c + elseif ( nbfad2.eq.2 .and. nbfad4.eq.0 ) then +c +c decoupage en 2 pour mise en conformite par 1 arete +c -------------------------------------------------- +c + cpt2 = cpt2 + 1 +c + endif +c + endif +c + 50 continue +c + if ( degre.eq.2 ) then + provp2 = provp2 + cpt1 + endif + provar = provar + cpt1 + provtr = provtr + 3*cpt0 + 4*cpt1 + cpt2 + provtf = provtf + 4*cpt0 + 4*cpt1 + 2*cpt2 + nbarin = nbarin + cpt1 + nbtrtc = nbtrtc + 3*cpt0 + 4*cpt1 + cpt2 + nbtea2 = nbtea2 + 2*cpt2 + nbtea4 = nbtea4 + 4*cpt1 + nbtef4 = nbtef4 + 4*cpt0 +c + provte = provtf + provta +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'provar',provar + write(ulsort,90002) 'provtr',provtr + write(ulsort,90002) 'provtf',provtf + write(ulsort,90002) 'provta',provta +#endif +c +c==== +c 6. entites nouvelles crees par decoupage des hexaedres +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. hexaedres ; codret', codret +cgn write(ulsort,90002) 'nbheto',nbheto +cgn write(ulsort,90002) 'permhe',permhe +cgn write(ulsort,90002) 'provp1',provp1 +cgn write(ulsort,90002) 'provp2',provp2 +cgn write(ulsort,90002) 'provya',provya +#endif +c + if ( nbheto.ne.0 ) then +c + nbheco = 0 +c +c 6.1. ==> conforme, avec des boites pour les hexaedres +c + if ( tyconf.eq.-1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Option conforme avec des boites' +#endif +c + cpt0 = 0 + cpt1 = 0 + cpt2 = 0 + cpt3 = 0 +c +cgn write(ulsort,90002) 'permhe', permhe + do 61 , iaux = 1 , permhe +c + lamail = iaux +c +cgn write(ulsort,90112) 'hethex', lamail, hethex(lamail) + if ( mod(hethex(lamail),1000).eq.0 ) then +c + nbfad3 = 0 + nbfad4 = 0 + do 610 , jaux = 1 , 6 + fj = quahex(lamail,jaux) + et = mod(hetqua(fj),100) + dt = decfac(-fj) +cgn write(ulsort,90015) '.. face numero', jaux,' :', fj, et, dt + if ( dt.eq.3 ) then + nbfad3 = nbfad3 + 1 + elseif ( et.eq.4 .or. dt.eq.4 ) then + nbfad4 = nbfad4 + 1 + endif + 610 continue +c +cgn if ( nbfad3*nbfad4 > 0 ) then +cgn write(ulsort,90015) '. nbfad3 = ',nbfad3,', nbfad4 = ',nbfad4 +cgn endif +c +c 6.1.1 ==> decoupage a partir d'une face +c + if ( nbfad3.eq.4 .and. nbfad4.eq.1 ) then +cgn write(ulsort,*) '==> dec. en 4+5 a partir d''une face' + cpt0 = cpt0 + 1 +c +c 6.1.2 ==> decoupage a partir de 3 aretes +c + elseif ( nbfad3.eq.6 .and. nbfad4.eq.0 ) then +cgn write(ulsort,*) '==> dec. en 18 a partir de 3 aretes' + cpt1 = cpt1 + 1 +c +c 6.1.3 ==> decoupage a partir de 2 aretes +c + elseif ( nbfad3.eq.4 .and. nbfad4.eq.0 ) then +cgn write(ulsort,*) '==> dec. en 12+2 a partir de 2 aretes' + cpt2 = cpt2 + 1 +c +c 6.1.4 ==> decoupage a partir d'1 arete +c + elseif ( nbfad3.eq.2 ) then +cgn write(ulsort,*) '==> dec. en 14 a partir d''1 arete' + cpt3 = cpt3 + 1 +c + endif +c + endif +c + 61 continue +c +cgn write (ulsort,90002) 'cpt0', cpt0 +cgn write (ulsort,90002) 'cpt1', cpt1 +cgn write (ulsort,90002) 'cpt2', cpt2 +cgn write (ulsort,90002) 'cpt3', cpt3 + provp1 = provp1 + cpt1 + cpt2 +c + iaux = 4*cpt0 + 11*cpt1 + 10*cpt2 + 2*cpt3 + provar = provar + iaux + nbarin = nbarin + iaux + if ( degre.eq.2 ) then + provp2 = provp2 + iaux + endif +c + iaux = 12*cpt0 + 27*cpt1 + 22*cpt2 + 5*cpt3 + provtr = provtr + iaux + nbtrhc = nbtrhc + iaux +c + provtf = provtf + 4*cpt0 + 18*cpt1 + 12*cpt2 + nbteh1 = nbteh1 + 4*cpt0 + nbteh2 = nbteh2 + 18*cpt1 + nbteh3 = nbteh3 + 12*cpt2 +c + provyf = provyf + 5*cpt0 + 2*cpt2 + 4*cpt3 + nbpyh1 = nbpyh1 + 5*cpt0 + nbpyh3 = nbpyh3 + 2*cpt2 + nbpyh4 = nbpyh4 + 4*cpt3 +c + nbheco = nbheco + cpt0 + cpt1 + cpt2 + cpt3 +c +c 6.2. ==> conforme general +c + else +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Option conforme' +#endif +c + do 62 , iaux = 1 , permhe +c + lamail = iaux +c +cgn write(ulsort,90112) 'hethex', lamail, hethex(lamail) +c + if ( mod(hethex(lamail),1000).eq.0 ) then +c + call utarhe ( lamail, + > permqu, permhe, + > arequa, quahex, coquhe, + > listar ) +c + do 620 , jaux = 1 , 12 +cgn write(ulsort,90002) 'etat', hetare(listar(jaux)) + etdare(jaux) = 0 + if ( hetare(listar(jaux)).ne.50 ) then +cgn write(ulsort,90002) 'decare', decare(listar(jaux)) + et = mod(hetare(listar(jaux)),10) + dt = decare(listar(jaux)) + if ( et.eq.2 .or. et.eq.9 .or. dt.eq.2 ) then + etdare(jaux) = 1 + endif + endif + 620 continue +cgn write(ulsort,90015) 'etdare(', lamail, ') :', etdare +c + call uthcnb ( etdare, + > nbreso, nbrear, nbrepy, nbrete, nbrehe, + > ulsort, langue, codret ) +cgn write(ulsort,90002) 'nbreso, nbrear, nbrepy, nbrete, nbrehe', +cgn > nbreso, nbrear, nbrepy, nbrete, nbrehe +c + provp1 = provp1 + nbreso + provar = provar + nbrear + nbarin = nbarin + nbrear + provta = provta + nbrete + nbtedh = nbtedh + nbrete + provya = provya + nbrepy + nbpydh = nbpydh + nbrepy + provha = provha + nbrehe + nbhedh = nbhedh + nbrehe + if ( degre.eq.2 ) then + provp2 = provp2 + nbrear + endif +cgn print *, 'provp1',provp1,'provp2',provp2,'provar',provar +cgn print *, 'provte',provte,'provhe',provhe,'provya',provya +c + if ( nbrepy.gt.0 .or. nbrete.gt.0 ) then + nbheco = nbheco + 1 + endif + endif +c + 62 continue +c + endif +c + provte = provtf + provta + provpy = provyf + provya + provhe = provhf + provha +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbheco',nbheco + write(ulsort,90002) 'permhe',permhe + write(ulsort,90002) 'provp1',provp1 + write(ulsort,90002) 'provp2',provp2 + write(ulsort,90002) 'provar',provar + write(ulsort,90002) 'provtr',provtr + write(ulsort,90002) 'provqu',provqu + write(ulsort,90002) 'provta',provta + write(ulsort,90002) 'provtf',provtf + write(ulsort,90002) 'provya',provya + write(ulsort,90002) 'provyf',provyf + write(ulsort,90002) 'provha',provha + write(ulsort,90002) 'provhf',provhf +#endif +c +c==== +c 7. entites nouvelles crees par decoupage des pentaedres +c Remarque : l'indice 0, 1, ... 5 correspond a la dizaine de l'etat +c du pentaedre apres decoupage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '7. pentaedres ; codret', codret + write(ulsort,90002) 'permpe',permpe +cgn write(ulsort,90002) 'provp1',provp1 +cgn write(ulsort,90002) 'provp2',provp2 +cgn write(ulsort,90002) 'provar',provar +cgn write(ulsort,90002) 'provta',provta +cgn write(ulsort,90002) 'provya',provya +#endif +c + if ( nbpeto.ne.0 ) then +c + cpt0 = 0 + cpt1 = 0 + cpt2 = 0 + cpt3 = 0 + cpt4 = 0 + cpt5 = 0 +c + do 70 , iaux = 1 , permpe +c + lamail = iaux +c +cgn write(ulsort,*) '. pentaedre numero', lamail,' :',hetpen(lamail) + if ( mod(hetpen(lamail),100).eq.0 ) then +c + nbfad2 = 0 + nbfad3 = 0 + nbfat4 = 0 + nbfaq4 = 0 + do 701 , jaux = 1 , 2 + fj = facpen(lamail,jaux) +cgn write(ulsort,*) '. face numero', jaux,' :', fj + et = mod(hettri(fj),10) + dt = decfac(fj) +cgn write(ulsort,*) '. face numero', jaux,' :', fj, et, dt + if ( dt.eq.2 ) then + nbfad2 = nbfad2 + 1 + elseif ( et.eq.4 .or. dt.eq.4 ) then + nbfat4 = nbfat4 + 1 + endif + 701 continue + do 702 , jaux = 3 , 5 + fj = facpen(lamail,jaux) + et = mod(hetqua(fj),100) + dt = decfac(-fj) +cgn write(ulsort,*) '. face numero', jaux,' :', fj, et, dt + if ( dt.eq.3 ) then + nbfad3 = nbfad3 + 1 + elseif ( et.eq.4 .or. dt.eq.4 ) then + nbfaq4 = nbfaq4 + 1 + endif + 702 continue +cgn write(ulsort,*) '. nbfad2', nbfad2 +cgn write(ulsort,*) '. nbfad3', nbfad3 +cgn write(ulsort,*) '. nbfat4', nbfat4 +cgn write(ulsort,*) '. nbfaq4', nbfaq4 +c +c 7.1 ==> decoupage a partir d'1 arete de triangle +c + if ( nbfad2.eq.1 .and. nbfad3.eq.1 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +cgn write(ulsort,*) 'dec. en 2+1 a partir de 1 arete tri' + cpt0 = cpt0 + 1 +c +c 7.2 ==> decoupage a partir d'1 arete de quadrangle +c + elseif ( nbfad2.eq.0 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +cgn write(ulsort,*) 'dec. en 1+2 a partir de 1 arete qua' + cpt1 = cpt1 + 1 +c +c 7.3 ==> decoupage a partir de 1 arete de tria et +c 1 arete de quad + elseif ( nbfad2.eq.1 .and. nbfad3.eq.3 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +cgn write(ulsort,*) 'dec. en 6 a partir de 1 ar tri / 1 qua' + cpt2 = cpt2 + 1 +c +c 7.4 ==> decoupage a partir de 2 aretes de tria +c + elseif ( nbfad2.eq.2 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.0 ) then +cgn write(ulsort,*) 'dec. en 10+1 a partir de 2 ar tri' + cpt3 = cpt3 + 1 +c +c 7.5 ==> decoupage a partir de 1 face quad +c + elseif ( nbfad2.eq.2 .and. nbfad3.eq.2 .and. + > nbfaq4.eq.1 .and. nbfat4.eq.0 ) then +cgn write(ulsort,*) 'dec. en 4+2 a partir de 1 face qua' + cpt4 = cpt4 + 1 +c +c 7.4 ==> decoupage a partir de 1 face tria +c + elseif ( nbfad2.eq.0 .and. nbfad3.eq.3 .and. + > nbfaq4.eq.0 .and. nbfat4.eq.1 ) then +cgn write(ulsort,*) 'dec. en 11 te a partir de 1 face tria' + cpt5 = cpt5 + 1 +c + endif +c + endif +c + 70 continue +c + provp1 = provp1 + cpt3 + cpt5 +c + iaux = cpt0 + cpt2 + 8*cpt3 + 2*cpt4 + 6*cpt5 + provar = provar + iaux + nbarin = nbarin + iaux + if ( degre.eq.2 ) then + provp2 = provp2 + iaux + endif +c + iaux = 3*cpt0 + 2*cpt1 + 6*cpt2 + 17*cpt3 + 7*cpt4 + 15*cpt5 + provtr = provtr + iaux + nbtrpc = nbtrpc + iaux +c + provtf = provtf + cpt0 + 2*cpt1 + 6*cpt2 + 10*cpt3 + > + 2*cpt4 + 11*cpt5 + nbtep0 = nbtep0 + cpt0 + nbtep1 = nbtep1 + 2*cpt1 + nbtep2 = nbtep2 + 6*cpt2 + nbtep3 = nbtep3 + 10*cpt3 + nbtep4 = nbtep4 + 2*cpt4 + nbtep5 = nbtep5 + 11*cpt5 +c + provyf = provyf + 2*cpt0 + cpt1 + cpt3 + > + 4*cpt4 + nbpyp0 = nbpyp0 + 2*cpt0 + nbpyp1 = nbpyp1 + cpt1 + nbpyp2 = nbpyp2 + cpt3 + nbpyp4 = nbpyp4 + 4*cpt4 +c + nbpeco = cpt0 + cpt1 + cpt2 + cpt3 + cpt4 + cpt5 +c + provte = provtf + provta + provpy = provyf + provya +c + endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbpeco',nbpeco + write(ulsort,90002) 'provp1',provp1 + write(ulsort,90002) 'provp2',provp2 + write(ulsort,90002) 'provar',provar + write(ulsort,90002) 'provtr',provtr + write(ulsort,90002) 'provqu',provqu + write(ulsort,90002) 'provta',provta + write(ulsort,90002) 'provtf',provtf + write(ulsort,90002) 'provya',provya + write(ulsort,90002) 'provyf',provyf + write(ulsort,90002) 'provpa',provpa + write(ulsort,90002) 'provpf',provpf +#endif +c +c==== +c 8. bilan, initialisations et impressions +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '8. bilan ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +cgn write(ulsort,90002) 'nbteca', nbteca +cgn write (ulsort,90002) 'permno', permno +cgn write (ulsort,90002) 'provp1', provp1 +cgn write (ulsort,90002) 'provp2', provp2 +cgn write (ulsort,90002) 'provim', provim + nouvno = permno + provp1 + provp2 + provim + nouvp2 = permp2 + provp2 + nouvim = permim + provim + nouvar = permar + provar + nouvtr = permtr + provtr + nouvqu = permqu + provqu + nouvte = permte + provte + nouvtf = nouvtf + provtf + nouvta = nouvta + provta + nbteca = nbtedh + nbtedp + nouvhe = permhe + provhe + nouvhf = nouvhf + provhf + nouvha = nouvha + provha + nbheca = nbhedh + nouvpy = permpy + provpy + nouvyf = nouvyf + provyf + nouvya = nouvya + provya + nbpyca = nbpydh + nbpydp + nouvpe = permpe + provpe + nouvpf = nouvpf + provpf + nouvpa = nouvpa + provpa + nbpeca = nbpedp +c + write(ulsort,60000) mess40(langue,1), + > mess14(langue,2,10), mess14(langue,2,11) + write(ulsort,61000) mess14(langue,2,-1), + > nouvno, provp1 + provp2 + provim + write(ulsort,61000) mess14(langue,2,1), nouvar, provar + if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,2), nouvtr, provtr + endif + if ( nbquto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,4), nouvqu, provqu + endif + if ( nbteto.ne.0 .or. nbheto.ne.0 .or. nbpeto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,3), nouvte, provte + endif + if ( nbheto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,6), nouvhe, provhe + endif + if ( nbheto.ne.0 .or. nbpeto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,5), nouvpy, provpy + endif + if ( nbpeto.ne.0 ) then + write(ulsort,61000) mess14(langue,2,7), nouvpe, provpe + endif + write(ulsort,62000) +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utplra.F b/src/tool/Utilitaire/utplra.F new file mode 100644 index 00000000..8e010705 --- /dev/null +++ b/src/tool/Utilitaire/utplra.F @@ -0,0 +1,615 @@ + subroutine utplra ( optimp, + > indnoe, indnp2, indnim, indare, + > indtri, indqua, indtet, indhex, indpen, + > decare, decfac, + > hettri, + > hetqua, + > tritet, hettet, + > quahex, hethex, + > facpen, hetpen, + > nbsoan, nbsono, + > nbnoan, nbnono, + > nbaran, nbarno, + > nbtran, nbtrno, + > nbquan, nbquno, + > nbtean, nbteno, + > nbhean, nbheno, + > nbpean, nbpeno, + > nbpyan, nbpyno, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : PLace pour le RAffinement +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . optimp . e . 1 . impressions 0:non, 1:oui . +c . indnoe . e . 1 . indice du dernier noeud cree . +c . indnp2 . e . 1 . nombre de noeuds p2 en vigueur . +c . indnim . e . 1 . nombre de noeuds internes en vigueur . +c . indare . e . 1 . indice de la derniere arete creee . +c . indtri . e . 1 . indice du dernier triangle cree . +c . indqua . e . 1 . indice du dernier quadrangle cree . +c . indtet . e . 1 . indice du dernier tetraedre cree . +c . indhex . e . 1 . indice du dernier hexaedre cree . +c . indpen . es . 1 . indice du dernier pentaedre cree . +c . decare . e .0:nbarto. table des decisions sur les aretes . +c . decfac . e . -nbquto. decision sur les faces (quad. + tri.) . +c . . . :nbtrto. . +c . hettri . e . nbtrto . historique de l'etat des triangles . +c . hetqua . e . nbquto . historique de l'etat des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . hettet . e . nbteto . historique de l'etat des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . facpen . e .nbpecf*5. numeros des faces des pentaedres . +c . hetpen . e . nbpeto . historique de l'etat des pentaedres . +c . nbsoan . s . 1 . nombre de sommets - ancien . +c . nbsono . s . 1 . nombre de sommets - nouveau . +c . nbnoan . s . 1 . nombre de noeuds - ancien . +c . nbnono . s . 1 . nombre de noeuds - nouveau . +c . nbaran . s . 1 . nombre d'aretes - ancien . +c . nbarno . s . 1 . nombre d'aretes - nouveau . +c . nbtran . s . 1 . nombre de triangles - ancien . +c . nbtrno . s . 1 . nombre de triangles - nouveau . +c . nbquan . s . 1 . nombre de quadrangles - ancien . +c . nbquno . s . 1 . nombre de quadrangles - nouveau . +c . nbtean . s . 1 . nombre de tetraedres - ancien . +c . nbteno . s . 1 . nombre de tetraedres - nouveau . +c . nbhean . s . 1 . nombre d'hexaedres - ancien . +c . nbheno . s . 1 . nombre d'hexaedres - nouveau . +c . nbpean . s . 1 . nombre de pentaedres - ancien . +c . nbpeno . s . 1 . nombre de pentaedres - nouveau . +c . nbpyan . s . 1 . nombre de pyramides - ancien . +c . nbpyno . s . 1 . nombre de pyramides - nouveau . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPLRA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpe.h" +#include "nombpy.h" +#include "nouvnb.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer optimp +c + integer indnoe, indnp2, indnim, indare, indtri, indqua + integer indtet, indhex, indpen + integer decare(0:nbarto) + integer decfac(-nbquto:nbtrto) + integer hettri(nbtrto) + integer hetqua(nbquto) + integer tritet(nbtecf,4), hettet(nbteto) + integer quahex(nbhecf,6), hethex(nbheto) + integer facpen(nbpecf,5), hetpen(nbpeto) + integer nbsoan, nbsono + integer nbnoan, nbnono + integer nbaran, nbarno + integer nbtran, nbtrno + integer nbquan, nbquno + integer nbtean, nbteno + integer nbhean, nbheno + integer nbpean, nbpeno + integer nbpyan, nbpyno +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer cpt1, cpt2 + integer larete, letria, lequad, letetr, lehexa, lepent +c + logical opti00 + logical noinma +c + integer nbmess + parameter ( nbmess = 10 ) +c + character*80 texte(nblang,nbmess) + character*40 mess40(nblang,2) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1234567890123456789012345678901234567890 + mess40(1,1) = ' Nombres d''entites permanentes du ' + mess40(1,2) = ' nouveau maillage ' +c + mess40(2,1) = ' Number of permanent entities of ' + mess40(2,2) = ' the new mesh ' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + opti00 = .True. +#else + if ( optimp.eq.1 ) then + opti00 = .True. + else + opti00 = .False. + endif +#endif +c +50000 format( + > 5x,'==========================================', + >/,5x,'!',a40 ,'!', + >/,5x,'!',a40 ,'!', + >/,5x,'==========================================') +50010 format( + > 5x,'! ', a14,' ! ', i10,' !') +c 1234567890 +50020 format( + > 5x,'==========================================', + > /) +c +c==== +c 2. initialisation des nombres d'entites +c==== +c + permp1 = indnoe - indnp2 + permno = indnoe + permp2 = indnp2 + permim = indnim + permar = indare + permtr = indtri + permqu = indqua + permte = indtet + permhe = indhex + permpe = indpen +cgn write(ulsort,90002) 'depart permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 3. entites nouvelles crees par decoupage des aretes +c remarque : en degre 2, le decoupage d'une arete entraine la +c creation de 2 p2 et la transformation d'un p2 en p1. +c au bilan, il y a donc 2 noeuds en plus : 1 p1 et 1 p2. +c==== +c + cpt1 = 0 +c + do 30 , larete = 1 , nbarto +c + if ( decare(larete).eq.2 ) then +c +c decoupage en 2 de l'arete +c ------------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + 30 continue +c + if ( degre.eq.1 ) then + permno = permno + cpt1 + elseif ( degre.eq.2 ) then + permno = permno + 2*cpt1 + permp2 = permp2 + cpt1 + endif + permp1 = permp1 + cpt1 + permar = permar + 2*cpt1 +cgn write(ulsort,90002) 'aretes permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 4. entites nouvelles crees par decoupage standard des triangles +c==== +c + if ( nbtrto.ne.0 ) then +c + if ( mod(mailet,2).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + cpt1 = 0 +c + do 40 , letria = 1 , nbtrto +c + if ( decfac(letria).eq.4 ) then +c +c decoupage en 4 du triangle +c -------------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + 40 continue +c + if ( degre.eq.2 ) then + permno = permno + 3*cpt1 + permp2 = permp2 + 3*cpt1 + endif +c + if ( noinma ) then + permno = permno + 3*cpt1 + permim = permim + 3*cpt1 + endif +c + permar = permar + 3*cpt1 + permtr = permtr + 4*cpt1 +c + endif +cgn write(ulsort,90002) 'tria permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 5. entites nouvelles crees par decoupage standard des quadrangles +c==== +c + if ( nbquto.ne.0 ) then +c + if ( mod(mailet,3).eq.0 ) then + noinma = .true. + else + noinma = .false. + endif +c + cpt1 = 0 +c + do 50 , lequad = 1 , nbquto +c + if ( decfac(-lequad).eq.4 ) then +c +c decoupage en 4 du quadrangle +c ---------------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + 50 continue +c + if ( degre.eq.2 ) then + permno = permno + 4*cpt1 + permp2 = permp2 + 4*cpt1 + endif +c + if ( noinma ) then + permno = permno + 3*cpt1 + permp1 = permp1 + 3*cpt1 + permim = permim + 3*cpt1 + endif +c + permno = permno + cpt1 + permp1 = permp1 + cpt1 + permar = permar + 4*cpt1 + permqu = permqu + 4*cpt1 +c + endif +cgn write(ulsort,90002) 'quad permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 6. entites nouvelles crees par decoupage des tetraedres +c un tetraedre est a decouper si et seulement si : +c . il est actif +c . chacune de ses 4 faces est coupee ou a couper +c==== +c + if ( nbtecf.ne.0 ) then +c + cpt1 = 0 +c + do 60 , letetr = 1 , nbtecf +c + if ( mod( hettet(letetr) , 100 ).eq.0 ) then +c + cpt2 = 0 + do 61 , iaux = 1 , 4 + letria = tritet(letetr,iaux) + if ( mod(hettri(letria),10).eq.4 .or. + > mod(hettri(letria),10).eq.5 .or. + > mod(hettri(letria),10).eq.6 .or. + > mod(hettri(letria),10).eq.7 .or. + > mod(hettri(letria),10).eq.9) then + cpt2 = cpt2 + 1 + else if ( decfac(letria).eq.4 ) then + cpt2 = cpt2 + 1 + endif + 61 continue +c + if ( cpt2.eq.4 ) then +c +c decoupage standard en 8 +c ----------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + endif +c + 60 continue +c + if ( degre.eq.2 ) then + permno = permno + cpt1 + permp2 = permp2 + cpt1 + endif +c + permar = permar + cpt1 + permtr = permtr + 8*cpt1 + permte = permte + 8*cpt1 +c + endif +cgn write(ulsort,90002) 'tetr permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 7. entites nouvelles crees par decoupage des hexaedres +c un hexaedre est a decouper si et seulement si : +c . il est actif +c . chacune de ses 6 faces est coupee ou a couper +c==== +c + if ( nbheto.ne.0 ) then +c + cpt1 = 0 +c + do 70 , lehexa = 1 , nbheto +c + if ( mod( hethex(lehexa),1000 ).eq.0 ) then +c + cpt2 = 0 + do 71 , iaux = 1 , 6 + lequad = quahex(lehexa,iaux) + if ( mod(hetqua(lequad),100).eq.4 .or. + > mod(hetqua(lequad),100).eq.99) then + cpt2 = cpt2 + 1 + else if ( decfac(-lequad).eq.4 ) then + cpt2 = cpt2 + 1 + endif + 71 continue +c + if ( cpt2.eq.6 ) then +c +c decoupage standard en 8 +c ----------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + endif +c + 70 continue +c + if ( degre.eq.2 ) then + permno = permno +6*cpt1 + permp2 = permp2 +6*cpt1 + endif +c + permp1 = permp1 + cpt1 + permno = permno + cpt1 + permar = permar + 6*cpt1 + permqu = permqu +12*cpt1 + permhe = permhe + 8*cpt1 +c + endif +cgn write(ulsort,90002) 'hexa permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 8. entites nouvelles crees par decoupage des pentaedres +c un pentaedre est a decouper si et seulement si : +c . il est actif +c . chacune de ses 5 faces est coupee ou a couper +c==== +c + if ( nbpeto.ne.0 ) then +c + cpt1 = 0 +c + do 80 , lepent = 1 , nbpeto +c + if ( mod( hetpen(lepent) , 100 ).eq.0 ) then +c + cpt2 = 0 + do 81 , iaux = 1 , 2 + letria = facpen(lepent,iaux) + if ( mod(hettri(letria),10).eq.4 .or. + > mod(hettri(letria),10).eq.9) then + cpt2 = cpt2 + 1 + else if ( decfac(letria).eq.4 ) then + cpt2 = cpt2 + 1 + endif + 81 continue + do 82 , iaux = 3, 5 + lequad = facpen(lepent,iaux) + if ( mod(hetqua(lequad),100).eq.4 .or. + > mod(hetqua(lequad),100).eq.99) then + cpt2 = cpt2 + 1 + else if ( decfac(-lequad).eq.4 ) then + cpt2 = cpt2 + 1 + endif + 82 continue +c + if ( cpt2.eq.5 ) then +c +c decoupage standard en 8 +c ----------------------- +c + cpt1 = cpt1 + 1 +c + endif +c + endif +c + 80 continue +c + if ( degre.eq.2 ) then + permno = permno +3*cpt1 + permp2 = permp2 +3*cpt1 + endif +c + permno = permno + permar = permar + 3*cpt1 + permtr = permtr + 4*cpt1 + permqu = permqu + 6*cpt1 + permpe = permpe + 8*cpt1 +c + endif +cgn write(ulsort,90002) 'pent permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c +c==== +c 8. bilan, initialisations et impressions +c==== +c + nouvno = permno + nouvp2 = permp2 + nouvim = permim + nouvar = permar + nouvtr = permtr + nouvqu = permqu + nouvte = permte + nouvtf = nouvte + nouvhe = permhe + nouvhf = nouvhe + nouvpe = permpe + nouvpf = nouvpe +c + if ( opti00 ) then +c + write(ulsort,50000) mess40(langue,1), mess40(langue,2) + write(ulsort,50010) mess14(langue,2,-1), nouvno + write(ulsort,50010) mess14(langue,2,1), nouvar + if ( nbtrto.gt.0 ) then + write(ulsort,50010) mess14(langue,2,2), nouvtr + endif + if ( nbquto.gt.0 ) then + write(ulsort,50010) mess14(langue,2,4), nouvqu + endif + if ( nbteto.gt.0 ) then + write(ulsort,50010) mess14(langue,2,3), nouvte + endif + if ( nbheto.gt.0 ) then + write(ulsort,50010) mess14(langue,2,6), nouvhe + endif + if ( nbpeto.gt.0 ) then + write(ulsort,50010) mess14(langue,2,7), nouvpe + endif + write(ulsort,50020) +c + endif +cgn write(ulsort,90002) +cgn > 'fin de '//nompro//' permno, permp1, permp2, permim', +cgn > permno, permp1, permp2, permim +c + if ( codret.eq.0 ) then +c + nbsoan = nbnop1 + nbsono = permp1 + nbnoan = nbnoto + nbnono = permno + nbaran = nbarto + nbarno = permar + nbtran = nbtrto + nbtrno = permtr + nbquan = nbquto + nbquno = permqu + nbtean = nbteto + nbteno = permte + nbhean = nbheto + nbheno = permhe + nbpean = nbpeto + nbpeno = permpe + nbpyan = nbpyto + nbpyno = permpy +#ifdef _DEBUG_HOMARD_ + write(ulsort,90002) 'nbnoan, nbnono', nbnoan, nbnono + write(ulsort,90002) 'nbaran, nbarno', nbaran, nbarno + write(ulsort,90002) 'nbtran, nbtrno', nbtran, nbtrno + write(ulsort,90002) 'nbquan, nbquno', nbquan, nbquno + write(ulsort,90002) 'nbtean, nbteno', nbtean, nbteno + write(ulsort,90002) 'nbhean, nbheno', nbhean, nbheno + write(ulsort,90002) 'nbpean, nbpeno', nbpean, nbpeno + write(ulsort,90002) 'nbpyan, nbpyno', nbpyan, nbpyno +#endif +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpmhe.F b/src/tool/Utilitaire/utpmhe.F new file mode 100644 index 00000000..3fc4dc77 --- /dev/null +++ b/src/tool/Utilitaire/utpmhe.F @@ -0,0 +1,114 @@ + subroutine utpmhe ( lehexa, prmixt, + > som1, som2, som3, som4, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Produit Mixte d'un HExaedre +c -- - - -- +c selon (som1-som2, som1-som3, som1-som4) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero du tetraedre a examiner . +c . prmixt . s . 1 . produit mixte (12, 13, 14) . +c . som i . e . 1 . sommets definissant le produit mixte . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision prmixt, coonoe(nbnoto,3) +c + integer lehexa + integer som1, som2, som3, som4 + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12) + integer listso(8) +c + double precision v12(3), v13(3), v14(3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. traitement +c==== +c +c 1.1. ==> les aretes et sommets de cet hexaedre +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c 1.2. ==> memorisation des vecteurs lies +c aux aretes som1-som2, som1-som3, som1-som4 +c + v12(1) = coonoe(listso(som2),1) - coonoe(listso(som1),1) + v12(2) = coonoe(listso(som2),2) - coonoe(listso(som1),2) + v12(3) = coonoe(listso(som2),3) - coonoe(listso(som1),3) +c + v13(1) = coonoe(listso(som3),1) - coonoe(listso(som1),1) + v13(2) = coonoe(listso(som3),2) - coonoe(listso(som1),2) + v13(3) = coonoe(listso(som3),3) - coonoe(listso(som1),3) +c + v14(1) = coonoe(listso(som4),1) - coonoe(listso(som1),1) + v14(2) = coonoe(listso(som4),2) - coonoe(listso(som1),2) + v14(3) = coonoe(listso(som4),3) - coonoe(listso(som1),3) +c +c 1.3. ==> calcul du produit mixte (v12,v13,v14) +c + prmixt = ( v12(2)*v13(3) - v12(3)*v13(2) ) * v14(1) + > + ( v12(3)*v13(1) - v12(1)*v13(3) ) * v14(2) + > + ( v12(1)*v13(2) - v12(2)*v13(1) ) * v14(3) +c + end diff --git a/src/tool/Utilitaire/utpmte.F b/src/tool/Utilitaire/utpmte.F new file mode 100644 index 00000000..3d168255 --- /dev/null +++ b/src/tool/Utilitaire/utpmte.F @@ -0,0 +1,109 @@ + subroutine utpmte ( letetr, prmixt, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Produit Mixte d'un TEtraedre selon (12, 13, 14) +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . prmixt . s . 1 . produit mixte (12, 13, 14) . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + double precision prmixt, coonoe(nbnoto,3) +c + integer letetr + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(6) + integer listso(4) +c + double precision v12(3), v13(3), v14(3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. traitement +c==== +c +c 1.1. ==> les aretes et sommets de ce tetraedre +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c +c 1.2. ==> memorisation des vecteurs lies aux aretes 12, 13, 14 +c + v12(1) = coonoe(listso(2),1) - coonoe(listso(1),1) + v12(2) = coonoe(listso(2),2) - coonoe(listso(1),2) + v12(3) = coonoe(listso(2),3) - coonoe(listso(1),3) +c + v13(1) = coonoe(listso(3),1) - coonoe(listso(1),1) + v13(2) = coonoe(listso(3),2) - coonoe(listso(1),2) + v13(3) = coonoe(listso(3),3) - coonoe(listso(1),3) +c + v14(1) = coonoe(listso(4),1) - coonoe(listso(1),1) + v14(2) = coonoe(listso(4),2) - coonoe(listso(1),2) + v14(3) = coonoe(listso(4),3) - coonoe(listso(1),3) +c +c 1.3. ==> calcul du produit mixte (v12,v13,v14) +c + prmixt = ( v12(2)*v13(3) - v12(3)*v13(2) ) * v14(1) + > + ( v12(3)*v13(1) - v12(1)*v13(3) ) * v14(2) + > + ( v12(1)*v13(2) - v12(2)*v13(1) ) * v14(3) +c + end diff --git a/src/tool/Utilitaire/utppqt.F b/src/tool/Utilitaire/utppqt.F new file mode 100644 index 00000000..daf3e0fa --- /dev/null +++ b/src/tool/Utilitaire/utppqt.F @@ -0,0 +1,502 @@ + subroutine utppqt ( decisi, nbfato, nbvoto, nbvofa, + > typvol, typfac, + > facvol, hetvol, + > volfac, lgpype, pypefa, nupype, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Pyramides/Pentaedres - Quadrangles/Triangles +c -- - - - - +c ______________________________________________________________________ +c +c but : complete le tableau volfac et cree le tableau pypefa +c a partir du reciproque, facvol +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decisi . e . 1 . pilotage des voisins des faces : . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . . . . qu'une face n'appartient pas a plus de . +c . . . . 2 volumes . +c . nbfato . e . 1 . nombre de faces total . +c . nbvoto . e . 1 . nombre de volumes total . +c . nbvofa . e . 1 . nombre de volumes decrits par leurs faces . +c . typvol . e . 1 . type du volume en cours d'examen . +c . . . . 5 : pyramides . +c . . . . 7 : pentaedres . +c . typfac . e . 1 . type de la face en cours d'examen . +c . . . . 2 : triangles . +c . . . . 4 : quadrangles . +c . facvol . e .nbvoto*5. numeros des faces des volumes . +c . hetvol . e . nbvoto . historique de l'etat des volumes . +c . volfac . es .2*nbfato. numeros des 2 volumes par face . +c . . . . volfac(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre/tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypefa(1/2,j). +c . lgpype . e . 1 . taille du tableau pypefa . +c . pypefa . s .2*lgpype. pypefa(1,j) = numero de la pyramide voisine. +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . . . . pypefa(2,j) = numero du pentaedre voisin . +c . . . . de la face k tel que volfac(1/2,k) = -j . +c . nupype . es . 1 . dernier indice cree dans le tableau pypefa . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvais type de face . +c . . . . 2 : mauvais type de volume . +c . . . . 3 : probleme de volumes decoupees . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPPQT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer decisi + integer nbfato, nbvoto, nbvofa + integer typvol, typfac + integer hetvol(nbvoto), facvol(nbvofa,5) + integer volfac(2,nbfato) + integer lgpype, pypefa(2,lgpype), nupype +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer kfadeb, kfafin, nbface + integer etat + integer levolu, vois01, inpype, inpepy + integer listfa(4) + integer nbfa00, lifa00(2) +#ifdef _DEBUG_HOMARD_ + integer typvo1, typvo2 + integer glop + character*6 saux06(2) +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Voisinage '',a,''/ '',a)' + texte(1,5) = '(''Le type de '',a,'',i10,'' est inconnu.'')' + texte(1,6) = '(/,''Le '',a,'',i10,'' a plus de deux voisins ?'')' + texte(1,7) = '(''Voisins :'',3i10,/)' +c + texte(2,4) = '(''Neighbourhoud '',a,''/ '',a)' + texte(2,5) = '(''Type of '',a,'',i10,'' is unknown.'')' + texte(2,6) = '(/,a,i10,'' has more than 2 neighbours ?'')' + texte(2,7) = '(''Neighbours :'',3i10,/)' +c +#include "impr03.h" +c + codret = 0 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typvol', typvol + write (ulsort,90002) 'typfac', typfac +#endif +c +c==== +c 2. Grandeurs caracteristiques +c==== +c 2.1. ==> Pyramides +c + if ( typvol.eq.5 ) then +c + if ( typfac.eq.2 ) then + kfadeb = 1 + kfafin = 4 + elseif ( typfac.eq.4 ) then + kfadeb = 5 + kfafin = 5 + else + codret = 1 + endif + inpype = 1 + inpepy = 2 +c +c 2.2. ==> Pentaedres +c + elseif ( typvol.eq.7 ) then +c + if ( typfac.eq.2 ) then + kfadeb = 1 + kfafin = 2 + elseif ( typfac.eq.4 ) then + kfadeb = 3 + kfafin = 5 + else + codret = 1 + endif + inpype = 2 + inpepy = 1 +c +c 2.3. ==> Probleme +c + else +c + codret = 2 +c + endif +c +c==== +c 3. on parcourt les volumes +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. parcours des volumes ; codret', codret +cgn write (ulsort,90002) 'kfadeb, kfafin = ', kfadeb, kfafin +#endif +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,1,typvol), + > mess14(langue,1,typfac) + if ( typfac.eq.2 ) then + typvo1 = 3 + saux06(1) = 'voltri' + saux06(2) = 'pypetr' + else + typvo1 = 6 + saux06(1) = 'volqua' + saux06(2) = 'pypequ' + endif + if ( typvol.eq.5 ) then + typvo2 = 7 + else + typvo2 = 5 + endif +#endif +c + nbface = kfafin - kfadeb + 1 +c + do 30 , levolu = 1 , nbvofa +#ifdef _DEBUG_HOMARD_ + if ( levolu.ge.-1583 ) then +ccc if ( ( typvol.eq.5 .and. typfac.eq.4 .and. levolu.lt.0 ) .or. +ccc > ( typvol.eq.7 .and. typfac.eq.2 .and. levolu.lt.0 ) ) then + glop = 1 + else + glop = 0 + endif +#endif +c +c 3.1. ==> les faces du volume en cours d'examen +c + do 31 , iaux = kfadeb, kfafin + listfa(iaux-kfadeb+1) = facvol(levolu,iaux) + 31 continue +c +c 3.2. ==> quand le volume est decoupe par conformite, on se preoccupe +c des cas ou une face du volume se retrouve en tant que face +c d'un volume fils. +c La convention HOMARD veut que l'on ne memorise que le fils +c dans les voisins des faces. +c on va alors annuler le numero de la face pour ne rien +c archiver maintenant. +c C'est le cas dans les situations suivantes : +c . Pentaedre +c Etat | Face triangle | Face quadrangle +c 1 | 2 | 4 5 +c 2 | 2 | 5 3 +c 3 | 2 | 3 4 +c 4 | 1 | 5 4 +c 5 | 1 | 3 5 +c 6 | 1 | 4 3 +c 7 | 1 2 | 5 +c 8 | 1 2 | 3 +c 9 | 1 2 | 4 +c 31 | 2 | +c 32 | 1 | +c + etat = mod ( hetvol(levolu), 100 ) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) ' ' + write(ulsort,90015) mess14(langue,2,typvol), levolu, + > ', de '//mess14(langue,3,typfac), (listfa(iaux),iaux=1,nbface) + write(ulsort,90002) 'Etat', etat + endif +#endif + if ( etat.ne.0 .and. etat.ne.80 .and. etat.ne.99 ) then +#ifdef _DEBUG_HOMARD_ + write(ulsort,*) 'Creation de ', saux06(1),'/', saux06(2) +#endif +c + nbfa00 = 0 +c +c 3.2.1. ==> Pentaedre et triangle +c + if ( typvol.eq.7 .and. typfac.eq.2 ) then +c + if ( ( etat.ge.1 .and. etat.le.3 ) .or. etat.eq.31 ) then + nbfa00 = 1 + lifa00(1) = 2 + elseif ( ( etat.ge.4 .and. etat.le.6 ) .or. + > etat.eq.32 ) then + nbfa00 = 1 + lifa00(1) = 1 + elseif ( etat.ge.7 .and. etat.le.8 ) then + nbfa00 = 2 + lifa00(1) = 1 + lifa00(2) = 2 + endif +c +c 3.2.2. ==> Pentaedre et quadrangle +c + elseif ( typvol.eq.7 .and. typfac.eq.4 ) then +c + if ( etat.eq.2 .or. etat.eq.3 .or. etat.eq.5 .or. + > etat.eq.6 .or. etat.eq.8 ) then + nbfa00 = nbfa00 + 1 + lifa00(nbfa00) = 3 + endif + if ( etat.eq.1 .or. etat.eq.3 .or. etat.eq.4 .or. + > etat.eq.6 .or. etat.eq.9 ) then + nbfa00 = nbfa00 + 1 + lifa00(nbfa00) = 4 + endif + if ( etat.eq.1 .or. etat.eq.2 .or. etat.eq.4 .or. + > etat.eq.5 .or. etat.eq.7 ) then + nbfa00 = nbfa00 + 1 + lifa00(nbfa00) = 5 + endif +c + endif +c +c 3.2.3. ==> Menage +c + do 323 , iaux = 1 , nbfa00 +cgn write (ulsort,90002) 'face', facvol(levolu,lifa00(iaux)) + do 3231 , jaux = 1 , nbface +cgn write (ulsort,90002) '... face', listfa(jaux) + if ( facvol(levolu,lifa00(iaux)).eq.listfa(jaux) ) then + listfa(jaux) = 0 + endif + 3231 continue + 323 continue +c + endif +c +c 3.3. ==> pour chaque face a traiter +c + do 33 , iaux = 1 , nbface +c + if ( listfa(iaux).ne.0 ) then +c + jaux = 0 + vois01 = volfac(1,listfa(iaux)) +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.. ', mess14(langue,2,typfac), listfa(iaux) + write (ulsort,90002) ' de voisins', vois01, + > volfac(2,listfa(iaux)) + endif +#endif +c +c 3.3.1. ==> aucun voisin n'a ete enregistre : on met le volume +c courant comme premier voisin +c + if ( vois01.eq.0 ) then +c + jaux = 1 +c + else +c +c 3.3.2. ==> un premier voisin a ete enregistre : on met le volume +c courant comme second voisin +c Pour un pentaedre, trois cas de figure : +c . Si le premier voisin est un tetraedre ou un hexaedre : +c vois01>0, il faut creer un nouvel indice dans le +c tableau pypefa +c . Sinon, le premier voisin est une pyramide ou un pentaedre +c . Si le premier voisin est une pyramide, c'est-a-dire +c vois01<0 et pypefa(1,-vois01)/=0, il faut stocker +c le volume dans pypefa(2,-vois01) +c . Si le premier voisin est deja un pentaedre, +c c'est-a-dire vois01<0 et pypefa(2,-vois01)/=0, il faut +c creer un nouvel indice dans le tableau pypefa +c Pour une pyramide, le raisonnement est symetrique. +c +c C'est ainsi qu'il faut stocker pour etre coherent avec +c le decodage des voisins (cf. infovo par exemple) +c + if ( vois01.gt.0 ) then + jaux = 2 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux), + >'est deja voisin de ',mess14(langue,1,typvo1), + > volfac(1,listfa(iaux)) + endif +#endif + else +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '.. '//saux06(2)//'(*,-vois01)', + > pypefa(1,-vois01), pypefa(2,-vois01) + endif +#endif + if ( pypefa(inpepy,-vois01).eq.0 ) then + jaux = 2 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux), + > 'est voisin de ',mess14(langue,1,typvol), pypefa(inpype,-vois01) + endif +#endif + else + jaux = -1 +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux), + > 'est voisin de ',mess14(langue,1,typvo2), pypefa(inpepy,-vois01) + endif +#endif + endif + endif +c +c 3.3.2.1. ==> il y a deja un second volume comme voisin de cette face ! +c + if ( decisi.eq.2 ) then +c + if ( volfac(2,listfa(iaux)).ne.0 ) then +c + write(ulsort,texte(langue,6)) mess14(langue,1,typfac), + > listfa(iaux) + write(ulsort,texte(langue,7)) vois01, + > volfac(2,listfa(iaux)), + > levolu + codret = 3 +c + endif +c + endif +c + endif +c +c 3.3.3. ==> mise en place du voisin +c . Si jaux est > 0, on cree un nouvel indice dans pypefa et +c ce sera pour le jaux-eme voisin +c . Si jaux < 0, on complete un voisinage, donc c'est +c forcement un second voisin. +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) '.... ==> jaux', jaux + endif +#endif +c 3.3.3.1. ==> creation d'un nouvel indice du voisin +c + if ( jaux.gt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90015) '.... ==> enregistrement d''un',jaux, + > '-ieme voisin, avec nupype = ', nupype + 1 + endif +#endif + nupype = nupype + 1 + volfac(jaux,listfa(iaux)) = -nupype + pypefa(inpype,nupype) = levolu +c +c 3.3.3.2. ==> complement d'un existant +c + elseif ( jaux.lt.0 ) then +#ifdef _DEBUG_HOMARD_ + if ( glop.ne.0 ) then + write (ulsort,90002) + > '.... ==> enregistrement d''un 2-ieme voisin, avec nupype', + > vois01 + endif +#endif +c + volfac(2,listfa(iaux)) = vois01 + pypefa(inpype,-vois01) = levolu +c + endif +c + endif +c + 33 continue +c + 30 continue +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + if ( codret.le.2 ) then + write (ulsort,texte(langue,5)) mess14(langue,1,7+codret), iaux + endif +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr01.F b/src/tool/Utilitaire/utpr01.F new file mode 100644 index 00000000..45dd6b5f --- /dev/null +++ b/src/tool/Utilitaire/utpr01.F @@ -0,0 +1,215 @@ + subroutine utpr01 ( option, decala, + > nbento, profil, nensca, + > nbvapr, obprof, + > nbprof, liprof, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil - operation 01 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : on traite la liste brutalement . +c . . . . 2 : on doit utiliser une renumerotation . +c . decala . e . 1 . decalage eventuel dans la numerotation . +c . . . . (cf. pcmac1), 0 si pas de decalage . +c . nbento . e . 1 . nombre total d'entites . +c . profil . e . nbento . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nensca . e . * . numero des entites dans le calcul . +c . . . . utile si et seulement si option=2 . +c . nbvapr . s . 1 . nombre de valeurs du profil en sortie . +c . . . . -1, si pas de profil . +c . obprof . s . char*8 . nom de l'objet de type 'Profil' equivalent . +c . nbprof . es . 1 . nombre de profils enregistres . +c . liprof . es . char*8 . nom des objet de type 'Profil' enregistres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option, decala + integer nbento, nbvapr, nbprof + integer profil(nbento) + integer nensca(nbento) +c + character*8 obprof + character*8 liprof(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Nombre de profils connus : '',i8)' + texte(1,5) = '(''Nombre d''''entites : '',i10)' + texte(1,6) = '(''Decalage : '',i10)' + texte(1,7) = '(''Objet profil retenu : '',a)' +c + texte(2,4) = '(''Number of known profiles : '',i8)' + texte(2,5) = '(''Number of entities : '',i10)' + texte(2,6) = '(''Shift : '',i10)' + texte(2,7) = '(''Profil object which is kept : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nbprof + write (ulsort,texte(langue,5)) nbento + write (ulsort,texte(langue,6)) decala +#endif +c +c==== +c 2. prise en compte d'un eventuel decalage +c==== +c + if ( decala.gt.0 ) then +c + jaux = nbento - decala + do 21 , iaux = 1 , jaux + profil(iaux) = profil(iaux+decala) + 21 continue +c + do 22 , iaux = jaux+1 , nbento + profil(iaux) = 0 + 22 continue +c + endif +c +c==== +c 3. creation de l'objet obprof de type 'Profil' a partir de la +c liste profil +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR03', nompro +#endif + call utpr03 ( option, + > nbento, profil, nensca, + > nbvapr, obprof, + > ulsort, langue, codret ) +c +c==== +c 4. comparaison avec les profils existant +c . si on trouve un qui differe au plus par le nom, on +c fait le remplacement +c . si aucun profil connu n'est comparable, on l'enregistre +c==== +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 1 , nbprof +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR04', nompro +#endif + call utpr04 ( liprof(nbprof), obprof, + > jaux, + > ulsort, langue, codret ) +c + if ( jaux.le.1 ) then + call gmlboj (obprof, codret) + obprof = liprof(nbprof) + goto 42 + endif +c + endif +c + 41 continue +c + nbprof = nbprof + 1 + liprof(nbprof) = obprof +c + 42 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) obprof + write (ulsort,texte(langue,4)) nbprof +#endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr02.F b/src/tool/Utilitaire/utpr02.F new file mode 100644 index 00000000..cd95f9d6 --- /dev/null +++ b/src/tool/Utilitaire/utpr02.F @@ -0,0 +1,269 @@ + subroutine utpr02 ( option, + > nbentn, nbvapr, listpr, + > neneho, neneca, decala, + > lgneic, neneic, neneih, + > profil, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil - operation 02 +c -- -- -- +c +c On a en entree un profil, c'est-a-dire une liste d'entites exprimees +c en numerotation du calcul. Cette liste est compacte. On a en sortie +c un tableau indexe par la numerotation du calcul des entites du meme +c type. La valeur vaut 1 ou son rang dans le profil si l'entite +c appartient au profil, 0 sinon. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option du traitement . +c . . . . 1 : avec le rang . +c . nbentn . e . 1 . nombre total d'entites . +c . nbvapr . e . 1 . nombre de valeurs du profil . +c . . . . -1, si pas de profil . +c . listpr . e . * . liste contenant le profil en numerotation . +c . . . . du calcul . +c . neneho . e . * . numero des entites dans HOMARD . +c . neneca . e . * . numero des entites dans Calcul (cf. vcmren). +c . decala . e . 1 . decalage des numerotations selon le type . +c . neneic . e . * . numero des entites dans Calcul (cf. vcmren). +c . neneih . e . * . reciproque de neneic . +c . profil . s . nbentn . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . >0 : l'entite est presente dans le profil . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -1 : mauvaise demande pour le type de nom . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . -3 : probleme sur le tableau a convertir . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option + integer nbentn, nbvapr + integer listpr(*) + integer neneho(nbentn) + integer neneca(*), decala + integer lgneic, neneic(*) + integer neneih(*) + integer profil(nbentn) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,6) = '(''Nombre total d''''entites :'',i10)' + texte(1,7) = '(''Longueur du profil : '',i10)' + texte(1,8) = '(''... Premiere(s) valeur(s) : '',5i10)' + texte(1,9) = '(''... Derniere(s) valeur(s) : '',5i10)' +c + texte(2,4) = '(''Option:'',i4)' + texte(2,5) = '(''Bad request for the option:'',i8)' + texte(2,6) = '(''Total number of entities:'',i10)' + texte(2,7) = '(''Length of profile: '',i10)' + texte(2,8) = '(''... First value(s): '',5i10)' + texte(2,9) = '(''... Last value(s) : '',5i10)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) option + write (ulsort,texte(langue,6)) nbentn + write (ulsort,texte(langue,7)) nbvapr + if ( nbvapr.gt.0 ) then + write (ulsort,texte(langue,8)) + > (listpr(iaux),iaux=1,min(5,nbvapr)) + endif + if ( nbvapr.gt.5 ) then + write (ulsort,texte(langue,9)) + > (listpr(iaux),iaux=nbvapr-4,nbvapr) + endif + write(ulsort,90002) 'lgneic', lgneic + write(ulsort,90002) 'decala', decala +#endif +c +c==== +c 2. ==> aucune entite ne fait partie du filtre +c==== +c + do 20 , iaux = 1 , nbentn + profil(iaux) = 0 + 20 continue +c +c==== +c 3. traitement sans profil : on prend tout +c==== +cgn write (ulsort,*)nompro//'-neneic' +cgn write (ulsort,91020)(neneic(iaux),iaux=1,lgneic/2) +c + if ( nbvapr.le.0 ) then +c +c 3.1. ==> option simple : changement de presentation +c on restitue le rang de l'entite dans le profil quand +c l'entite est presente, 0 sinon +c + if ( option.eq.1 ) then +c + jaux = 0 + if ( lgneic.eq.0 ) then + do 311 , iaux = 1 , nbentn +cgn write(ulsort,90002) 'iaux, neneho(iaux)',iaux, neneho(iaux) + if ( neneho(iaux).ne.0 ) then + jaux = jaux + 1 + profil(iaux) = neneca(neneho(iaux)) - decala + endif + 311 continue + else + do 312 , iaux = 1 , nbentn +cgn write(ulsort,90002) 'iaux, neneho(iaux)',iaux, neneho(iaux) + if ( neneho(iaux).ne.0 ) then + jaux = jaux + 1 +cgn write(ulsort,90002) 'jaux, neneho, profil', +cgn > jaux, neneho(iaux), neneic(neneho(iaux)) + profil(iaux) = neneic(neneho(iaux)) + endif + 312 continue + endif +c +c 3.n. ==> erreur +c + else +c + write (ulsort,texte(langue,5)) option + codret = -2 +c + endif +c +c==== +c 4. traitement avec profil +c==== +c + else +cgn write (ulsort,*) nompro//'-listpr',(listpr(iaux),iaux=1,nbvapr) +cgn write (ulsort,*)nompro//'-neneic',(neneic(iaux),iaux=1,10) +c +c 4.1. ==> option simple : changement de presentation +c on restitue le rang de l'entite dans le profil quand +c l'entite est presente, 0 sinon +c + if ( option.eq.1 ) then +c + if ( lgneic.eq.0 ) then + do 411 , iaux = 1 , nbvapr +c iaux : i-eme valeur du tableau +c listpr(iaux) : rang MED de la maille dans sa categorie +c neneih(listpr(iaux)) : numero HOMARD associe +c neneca(neneih(listpr(iaux))) : numero du calcul associe +cgn write (ulsort,*)'listpr(',iaux,')=',listpr(iaux) + profil(listpr(iaux)+decala) = iaux + 411 continue + else + do 412 , iaux = 1 , nbvapr +c iaux : i-eme valeur du tableau +c listpr(iaux) : rang MED de la maille dans sa categorie +c neneih(listpr(iaux)) : numero HOMARD associe +c neneca(neneih(listpr(iaux))) : numero du calcul associe +cgn write (ulsort,*)'listpr(',iaux,')=',listpr(iaux) + jaux = neneih(listpr(iaux)) +cgn write (ulsort,*)'neneih(listpr(',iaux,'))=',jaux +cgn write (ulsort,*)'neneca(',jaux,')=',neneca(jaux) + profil(neneca(jaux)) = iaux + 412 continue + endif +c +c 4.n. ==> erreur +c + else +c + write (ulsort,texte(langue,5)) option + codret = -2 +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +cgn write (ulsort,*)nompro//'-profil',(profil(iaux),iaux=1,nbentn) + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr03.F b/src/tool/Utilitaire/utpr03.F new file mode 100644 index 00000000..8f72c8b5 --- /dev/null +++ b/src/tool/Utilitaire/utpr03.F @@ -0,0 +1,241 @@ + subroutine utpr03 ( option, + > nbento, profil, nensca, + > nbvapr, obprof, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil operation 03 +c -- -- -- +c +c On a en entree un tableau indexe par la numerotation HOMARD des +c entites d'un type donne. La valeur vaut 1 si l'entite appartient au +c profil, 0 sinon. On a en sortie un profil de calcul, c'est-a-dire une +c liste d'entites exprimees en numerotation du calcul. Cette liste est +c compacte. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . 1 : on traite la liste brutalement . +c . . . . 2 : on doit utiliser une renumerotation . +c . nbento . e . 1 . nombre total d'entites . +c . profil . e . nbento . pour chaque entite en numerotation homard :. +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . nensca . e . * . numero des entites dans le calcul . +c . nbvapr . s . 1 . nombre de valeurs du profil en sortie . +c . . . . -1, si pas de profil . +c . obprof . s . char*8 . nom de l'objet de type 'Profil' equivalent . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . -2 : mauvaise demande pour l'option . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer option + integer nbento, nbvapr + integer profil(nbento) + integer nensca(*) +c + character*8 obprof +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer adlipr + integer numero +c + character*64 noprof +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data numero / 0 / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Option :'',i4)' + texte(1,5) = '(''Mauvaise demande d''''option :'',i8)' + texte(1,6) = '(''Nom du profil cree : '',a)' + texte(1,7) = '(''Longueur du profil : '',i10)' + texte(1,8) = '(''Objet profil cree : '',a)' +c + texte(2,4) = '(''Option :'',i4)' + texte(2,5) = '(''Bad request for the option :'',i8)' + texte(2,6) = '(''Name of created profile : '',a)' + texte(2,7) = '(''Length of profile : '',i10)' + texte(2,8) = '(''Created profile object : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) option +#endif +c +c==== +c 2. creation du profil +c==== +c 2.1. ==> nom du profil +c + numero = numero + 1 + call utench ( numero, '0', iaux, noprof, + > ulsort, langue, codret ) +c + noprof(1:8) = 'PROFIL__' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) noprof +#endif +c +c 2.2. ==> longueur du profil +c + if ( codret.eq.0 ) then +c + nbvapr = 0 + do 22 , iaux = 1 , nbento + if ( profil(iaux).eq.1 ) then + nbvapr = nbvapr + 1 + endif + 22 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbvapr +#endif +c + endif +c +c 2.3. ==> allocation de l'objet +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALPR', nompro +#endif + call utalpr ( obprof, + > nbvapr, noprof, + > adlipr, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) obprof +#endif +c +c 2.4. ==> remplissage du profil +c + if ( codret.eq.0 ) then +c +c 2.4.1. ==> brutalement +c + if ( option.eq.1 ) then +c + nbvapr = 0 + do 241 , iaux = 1 , nbento + if ( profil(iaux).eq.1 ) then + imem(adlipr+nbvapr) = iaux + nbvapr = nbvapr + 1 + endif + 241 continue +c +c 2.4.2. ==> avec renumerotation +c + elseif ( option.eq.2 ) then +c + nbvapr = 0 + do 242 , iaux = 1 , nbento + if ( profil(iaux).eq.1 ) then + imem(adlipr+nbvapr) = nensca(iaux) + nbvapr = nbvapr + 1 + endif + 242 continue +c +c 2.n. ==> erreur +c + else +c + write (ulsort,texte(langue,5)) option + codret = -2 +c + endif +c + endif +cgn call gmprsx (nompro,obprof) +cgn call gmprsx (nompro,obprof//'.NomProfi') +cgn call gmprsx (nompro,obprof//'.ListEnti') +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr04.F b/src/tool/Utilitaire/utpr04.F new file mode 100644 index 00000000..67dad6a4 --- /dev/null +++ b/src/tool/Utilitaire/utpr04.F @@ -0,0 +1,256 @@ + subroutine utpr04 ( obpro1, obpro2, + > bilan, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil operation 04 +c -- -- -- +c +c Compare deux profils +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . obpro1 . e . char*8 . nom de l'objet de type 'Profil' numero 1 . +c . obpro2 . e . char*8 . nom de l'objet de type 'Profil' numero 2 . +c . bilan . s . 1 . bilan de la comparaison : . +c . . . . 0 : identite totale . +c . . . . 1 : liste identique, mais noms differents . +c . . . . 2 : liste differente avec meme nombre . +c . . . . de valeurs . +c . . . . 3 : nombre de valeurs differents . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer bilan +c + character*8 obpro1, obpro2 +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer nbvap1, adlip1, lgnop1 + integer nbvap2, adlip2, lgnop2 +c + character*64 nopro1, nopro2 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Profil numero '',i1)' + texte(1,5) = '(''. Objet de type ''''Profil'''' associe : '',a)' + texte(1,6) = '(''. Longueur : '',i10)' + texte(1,7) = '(''. Nom : '',a)' + texte(1,8) = '(''. 1ere valeur : '',i10)' + texte(1,9) = '(''. Derniere valeur : '',i10)' +c + texte(2,4) = '(''Profil # '',i1)' + texte(2,5) = + > '(''. Object of type ''''Profil'''' connected to : '',a)' + texte(2,6) = '(''. Length : '',i10)' + texte(2,7) = '(''. Name : '',a)' + texte(2,8) = '(''. First value : '',i10)' + texte(2,9) = '(''. Last value : '',i10)' +c +c==== +c 2. caracteristiques +c==== +c 2.1. ==> profil 1 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 1 + write (ulsort,texte(langue,5)) obpro1 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( obpro1, + > nbvap1, nopro1, adlip1, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbvap1 + write (ulsort,texte(langue,7)) nopro1 + write (ulsort,texte(langue,8)) imem(adlip1) + write (ulsort,texte(langue,9)) imem(adlip1+nbvap1-1) +#endif +c +c 2.2. ==> profil 2 +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) 2 + write (ulsort,texte(langue,5)) obpro2 +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPR', nompro +#endif + call utcapr ( obpro2, + > nbvap2, nopro2, adlip2, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) nbvap2 + write (ulsort,texte(langue,7)) nopro2 + write (ulsort,texte(langue,8)) imem(adlip2) + write (ulsort,texte(langue,9)) imem(adlip2+nbvap2-1) +#endif +c + endif +c +c==== +c 3. tri sur le nombre de valeurs +c==== +c + if ( codret.eq.0 ) then +c + if ( nbvap1.ne.nbvap2 ) then +c + bilan = 3 + goto 9999 +c + endif +c + endif +c +c==== +c 4. tri sur les valeurs +c==== +c + if ( codret.eq.0 ) then +c + do 41 , iaux = 0 , nbvap1-1 +c + if ( imem(adlip1+iaux).ne.imem(adlip2+iaux) ) then +c + bilan = 2 + goto 9999 +c + endif +c + 41 continue +c + endif +c +c==== +c 5. tri sur le nom +c==== +c + if ( codret.eq.0 ) then +c + call utlgut ( lgnop1, nopro1, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + call utlgut ( lgnop2, nopro2, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + if ( lgnop1.eq.lgnop2 ) then +c + if ( nopro1.eq.nopro2 ) then + bilan = 0 + else + bilan = 1 + endif +c + else +c + bilan = 1 +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + 9999 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr05.F b/src/tool/Utilitaire/utpr05.F new file mode 100644 index 00000000..c48dc689 --- /dev/null +++ b/src/tool/Utilitaire/utpr05.F @@ -0,0 +1,242 @@ + subroutine utpr05 ( option, nnvapr, listpr, + > nbentn, nbentp, + > neneho, neneca, decala, + > lgneic, neneic, neneih, + > obpcan, obpcap, + > adpcan, adpcap, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil operation 05 +c -- -- -- +c +c Cree deux profils etendus pour les interpolations +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . -1 : on cree l'etape n . +c . . . . 0 : on cree les 2 etapes . +c . . . . 1 : on cree l'etape p . +c . nnvapr . e . 1 . nombre de valeurs du profil en entree . +c . . . . -1, si pas de profil . +c . listpr . e . * . liste des numeros d'entites ou la fonction . +c . . . . est definie. . +c . nbentn . e . 1 . nombre d'entites calcul a l'etape n . +c . nbentp . e . 1 . nombre d'entites calcul a l'etape p . +c . neneho . e . * . numero des entites en entree dans HOMARD . +c . neneca . e . * . numero des entites dans Calcul (cf. vcmren). +c . decala . e . 1 . decalage des numerotations selon le type . +c . neneic . e . * . numero des entites dans Calcul (cf. vcmren). +c . neneih . e . * . reciproque de neneic . +c . obpcan . s . char*8 . nom de l'objet profil etendu a l'etape n . +c . obpcap . s . char*8 . nom de l'objet profil etendu a l'etape p . +c . . . . ce profil est mis a 0 par defaut . +c . adpcan . s . 1 . adresse du tableau entier associe a obpcan . +c . adpcap . s . 1 . adresse du tableau entier associe a obpcap . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR05' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer option, nnvapr + integer nbentn, nbentp + integer listpr(*) + integer neneho(*) + integer neneca(*), decala + integer lgneic, neneic(*) + integer neneih(*) + integer adpcan, adpcap +c + character*8 obpcan, obpcap +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Longueur du profil etendu a l''''etape '',a1,'' : '',i10)' + texte(1,5) = + > '(''Creation du profil etendu a l''''etape '',a1,'' : '',a)' +c + texte(2,4) = + > '(''Longueur du profil etendu a l''''etape '',a1,'': '',i10)' + texte(2,5) = + > '(''Creation of long profile at stage '',a1,'': '',a)' +c +#include "impr03.h" +cgn write (ulsort,*)nompro//'-neneic' +cgn write (ulsort,91020)(neneic(iaux),iaux=1,lgneic/2) +c +c==== +c 2. allocations des deux tableaux entiers des profils etendus +c==== +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,90002) 'option', option + if ( option.le.0 ) then + write (ulsort,texte(langue,4)) 'n', nbentn + endif + if ( option.ge.0 ) then + write (ulsort,texte(langue,4)) 'p', nbentp + endif +#endif +c + if ( option.le.0 ) then + call gmalot ( obpcan, 'entier ', nbentn, adpcan, codre1 ) + else + codre1 = 0 + endif +c + if ( option.ge.0 ) then + call gmalot ( obpcap, 'entier ', nbentp, adpcap, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + if ( option.le.0 ) then + write (ulsort,texte(langue,5)) 'n', obpcan + endif + if ( option.ge.0 ) then + write (ulsort,texte(langue,5)) 'p', obpcap + endif +#endif +c +c==== +c 3. remplissage du tableau a l'etape n +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. remplissage n ; codret', codret +#endif +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPR02', nompro +#endif + call utpr02 ( iaux, + > nbentn, nnvapr, listpr, + > neneho, neneca, decala, + > lgneic, neneic, neneih, + > imem(adpcan), + > ulsort, langue, codret ) +c + endif +c +cgn call gmprsx (nompro, obpcan ) +c + endif +c +c==== +c 4. remplissage du tableau a l'etape p : rien a priori +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. remplissage p ; codret', codret +#endif +c + if ( option.ge.0 ) then +c + if ( codret.eq.0 ) then +c + do 41 , iaux = adpcap , adpcap+nbentp-1 + imem(iaux) = 0 + 41 continue +c +cgn call gmprsx (nompro, obpcap ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utpr06.F b/src/tool/Utilitaire/utpr06.F new file mode 100644 index 00000000..13ab4d1a --- /dev/null +++ b/src/tool/Utilitaire/utpr06.F @@ -0,0 +1,239 @@ + subroutine utpr06 ( option, + > nbentn, nbentp, + > volfac, neneho, + > nvolho, nvolca, + > obpcan, obpcap, + > adpcan, adpcap, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - PRofil operation 06 +c -- -- -- +c +c Cree deux profils etendus pour les interpolations si extrusion +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . -1 : on cree l'etape n . +c . . . . 0 : on cree les 2 etapes . +c . . . . 1 : on cree l'etape p . +c . nbentn . e . 1 . nombre d'entites calcul a l'etape n . +c . nbentp . e . 1 . nombre d'entites calcul a l'etape p . +c . volfac . e . * . volumes de la face . +c . neneho . e . * . numero des entites en entree dans HOMARD . +c . nvolho . e . * . numero des entites volumes en entree . +c . nvolca . e . * . numero des entites volumes (cf. vcmext) . +c . obpcan . s . char*8 . nom de l'objet profil etendu a l'etape n . +c . obpcap . s . char*8 . nom de l'objet profil etendu a l'etape p . +c . . . . ce profil est mis a 0 par defaut . +c . adpcan . s . 1 . adresse du tableau entier associe a obpcan . +c . adpcap . s . 1 . adresse du tableau entier associe a obpcap . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . autre : probleme dans l'allocation . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTPR06' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer option + integer nbentn, nbentp + integer neneho(*) + integer volfac(*) + integer nvolho(*) + integer nvolca(*) + integer adpcan, adpcap +c + character*8 obpcan, obpcap +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Longueur du profil etendu a l''''etape '',a1,'' : '',i10)' + texte(1,5) = + > '(''Creation du profil etendu a l''''etape '',a1,'' : '',a)' +c + texte(2,4) = + > '(''Longueur du profil etendu a l''''etape '',a1,'': '',i10)' + texte(2,5) = + > '(''Creation of long profile at stage '',a1,'': '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c +c==== +c 2. allocations des deux tableaux entiers des profils etendus +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( option.le.0 ) then + write (ulsort,texte(langue,4)) 'n', nbentn + endif + if ( option.ge.0 ) then + write (ulsort,texte(langue,4)) 'p', nbentp + endif +#endif +c + if ( option.le.0 ) then + call gmalot ( obpcan, 'entier ', nbentn, adpcan, codre1 ) + else + codre1 = 0 + endif +c + if ( option.ge.0 ) then + call gmalot ( obpcap, 'entier ', nbentp, adpcap, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + if ( option.le.0 ) then + write (ulsort,texte(langue,5)) 'n', obpcan + endif + if ( option.ge.0 ) then + write (ulsort,texte(langue,5)) 'p', obpcap + endif +#endif +c +c==== +c 3. remplissage du tableau a l'etape n +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. remplissage n ; codret', codret +#endif +c + if ( option.le.0 ) then +c + if ( codret.eq.0 ) then +c + do 31 , iaux = 1 , nbentn + jaux = neneho(iaux) + if ( jaux.gt.0 ) then +cgn write (ulsort,90002) 'iaux', iaux +cgn write (ulsort,90112) '- volfac', jaux, volfac(jaux) +cgn write (ulsort,90002) '- nvolca', nvolca(volfac(jaux)) +cgn write (ulsort,90002) '- profil', nvolho(nvolca(volfac(jaux))) + imem(adpcan-1+iaux) = nvolho(nvolca(volfac(jaux))) + else + imem(adpcan-1+iaux) = 0 + endif + 31 continue +c + endif +c +cgn call gmprsx (nompro, obpcan ) +c + endif +c +c==== +c 4. remplissage du tableau a l'etape p : rien a priori +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. remplissage p ; codret', codret +#endif +c + if ( option.ge.0 ) then +c + if ( codret.eq.0 ) then +c + do 41 , iaux = adpcap , adpcap+nbentp-1 + imem(iaux) = 0 + 41 continue +c +cgn call gmprsx (nompro, obpcap ) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utprma.F b/src/tool/Utilitaire/utprma.F new file mode 100644 index 00000000..da6cd82e --- /dev/null +++ b/src/tool/Utilitaire/utprma.F @@ -0,0 +1,133 @@ + subroutine utprma ( sommet, arete1, arete2, arete3, + > somare, nbnoto, coonoe, + > promix, promin ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : PRoduit Mixte - par Arete +c -- -- - - +c effectue promix = A1.(A2^A3) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sommet . e . 1 . sommet du triedre . +c . arete1 . e . 1 . premiere arete du triedre . +c . arete2 . e . 1 . premiere arete du triedre . +c . arete3 . e . 1 . premiere arete du triedre . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . nbnoto . e . 1 . nombre de noeuds . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . promix . s . 1 . le produit mixte brut . +c . promin . s . 1 . le produit mixte des vecteurs normalises . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer sommet + integer arete1, arete2, arete3 + integer nbnoto + integer somare(2,*) +c + double precision coonoe(nbnoto,*) + double precision promix, promin +c +c 0.4. ==> variables locales +c + integer iaux + integer ideb, ifin +c + double precision daux, daux0 + double precision v1(3), v2(3), v3(3) + double precision vn(3) +c ______________________________________________________________________ +c +c==== +c 1. Les vecteurs des aretes +c==== +c + if ( somare(1,arete1).eq.sommet ) then + ideb = 1 + ifin = 2 + else + ideb = 2 + ifin = 1 + endif +c + daux0 = 0.d0 + do 11 , iaux = 1 , 3 + v1(iaux) = coonoe(somare(ifin,arete1),iaux) + > - coonoe(somare(ideb,arete1),iaux) + daux0 = daux0 + v1(iaux)**2 + 11 continue + daux = sqrt(daux0) +c + if ( somare(1,arete2).eq.sommet ) then + ideb = 1 + ifin = 2 + else + ideb = 2 + ifin = 1 + endif +c + daux0 = 0.d0 + do 12 , iaux = 1 , 3 + v2(iaux) = coonoe(somare(ifin,arete2),iaux) + > - coonoe(somare(ideb,arete2),iaux) + daux0 = daux0 + v2(iaux)**2 + 12 continue + daux = daux*sqrt(daux0) +c + if ( somare(1,arete3).eq.sommet ) then + ideb = 1 + ifin = 2 + else + ideb = 2 + ifin = 1 + endif +c + daux0 = 0.d0 + do 13 , iaux = 1 , 3 + v3(iaux) = coonoe(somare(ifin,arete3),iaux) + > - coonoe(somare(ideb,arete3),iaux) + daux0 = daux0 + v3(iaux)**2 + 13 continue + daux = daux*sqrt(daux0) +c + vn(1) = v2(2)*v3(3) - v2(3)*v3(2) + vn(2) = v2(3)*v3(1) - v2(1)*v3(3) + vn(3) = v2(1)*v3(2) - v2(2)*v3(1) +c + promix = v1(1)*vn(1) + v1(2)*vn(2) + v1(3)*vn(3) + promin = promix/daux +c + end diff --git a/src/tool/Utilitaire/utprmi.F b/src/tool/Utilitaire/utprmi.F new file mode 100644 index 00000000..96c417a6 --- /dev/null +++ b/src/tool/Utilitaire/utprmi.F @@ -0,0 +1,61 @@ + subroutine utprmi ( v1, v2, v3, res ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : PRoduit MIxte +c -- -- -- +c effectue res = V1.(V2^V3) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . V1 . e . 3 . premier vecteur . +c . V2 . e . 3 . deuxieme vecteur . +c . V3 . e . 3 . troisieme vecteur . +c . res . s . 1 . Le resultat . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c +c 0.3. ==> arguments +c + double precision v1(3), v2(3), v3(3), res +c +c 0.4. ==> variables locales +c + double precision vn(3) +c + vn(1) = v2(2)*v3(3) - v2(3)*v3(2) + vn(2) = v2(3)*v3(1) - v2(1)*v3(3) + vn(3) = v2(1)*v3(2) - v2(2)*v3(1) +c + res = v1(1)*vn(1) + v1(2)*vn(2) + v1(3)*vn(3) +c + end diff --git a/src/tool/Utilitaire/utprve.F b/src/tool/Utilitaire/utprve.F new file mode 100644 index 00000000..e2bcc7ba --- /dev/null +++ b/src/tool/Utilitaire/utprve.F @@ -0,0 +1,55 @@ + subroutine utprve ( v1, v2, res ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : PRoduit VEctoriel +c -- -- -- +c effectue res = V1^V2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c . V1 . e . 3 . premier vecteur . +c . V2 . e . 3 . deuxieme vecteur . +c . res . s . 3 . Le resultat . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c +c 0.3. ==> arguments +c + double precision v1(3), v2(3), res(3) +c +c 0.4. ==> variables locales +c + res(1) = v1(2)*v2(3) - v1(3)*v2(2) + res(2) = v1(3)*v2(1) - v1(1)*v2(3) + res(3) = v1(1)*v2(2) - v1(2)*v2(1) +c + end diff --git a/src/tool/Utilitaire/utqco2.F b/src/tool/Utilitaire/utqco2.F new file mode 100644 index 00000000..dab852af --- /dev/null +++ b/src/tool/Utilitaire/utqco2.F @@ -0,0 +1,170 @@ + subroutine utqco2 ( qual, coonoe, + > are, somare, facare, posifa, + > aretri, voltri, + > tritet, cotrte, aretet, filtet, hettet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c but : calcul de la qualite d'une coquille autour d'une arete qui vient +c d'etre decoupee (on suppose donc que les tetraedres sont peres ou +c grand-peres) +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'une COquille (descendants d'ordre 2 au plus) +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e .nbnoto*3. coordonnees des noeuds . +c . are . e . 1 . numero de l'arete d'enroulement . +c . somare . es .2*nbarto. numeros des extremites d'arete . +c . facare . es . nbfaar . liste des faces contenant une arete . +c . posifa . e . nbarto . pointeur sur tableau facare . +c . aretri . es .nbtrto*3. numeros des 3 aretes des triangles . +c . voltri . e .2*nbtrto. numeros des 2 tetraedres des faces . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . filtet . e . nbteto . premier fils des tetraedres . +c . hettet . e . nbtrto . historique de l'etat des tetraedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,3) +c + integer are + integer somare(2,nbarto), posifa(0:nbarto), facare(nbfaar) + integer aretri(nbtrto,3), voltri(2,nbtrto) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer filtet(nbteto), hettet(nbteto) +c +c 0.4. ==> variables locales +c + integer etat + integer ifa, fac + integer nfils, ifils, nfil2, ifil2 + integer ite, tet, te2, tef +c + double precision qual, qualte + double precision daux, daux0 +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + qual = 0.d0 +c +c boucle sur les faces de la coquille +c + do 1 , ifa=posifa(are-1)+1,posifa(are) +c + fac = facare(ifa) +c +c recuperation des 2 tetraedres +c + do 11 , ite=1,2 +c + tet = voltri(ite,fac) +c + if (tet.gt.0) then +c + if (filtet(tet).gt.0) then +c +c premier passage (sur 2) +c + etat = mod(hettet(tet),100) + if (etat.lt.30) then + nfils = 2 + elseif (etat.lt.50) then + nfils = 4 + elseif (etat.lt.60) then + nfils = 0 + else + nfils = 8 + endif +c +c qualite des descendants +c + do 111 , ifils=1,nfils +c + tef = filtet(tet)+ifils-1 +c + if (filtet(tef).eq.0) then +c +c si le fils est actif : sa qualite +c + call utqtet ( tef, qualte, daux0, daux, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + qual = max ( qual, qualte ) + else +c +c si le fils est inactif : petits-fils +c + etat = mod(hettet(tef),100) + if (etat.lt.30) then + nfil2 = 2 + elseif (etat.lt.50) then + nfil2 = 4 + elseif (etat.lt.60) then + nfil2 = 0 + else + nfil2 = 8 + endif + do 1111 , ifil2=1,nfil2 + te2 = filtet(tef)+ifil2-1 + call utqtet ( te2, qualte, daux0, daux, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) + qual = max ( qual, qualte ) + qual = max ( qual, qualte ) + 1111 continue + endif +c + 111 continue +c + endif +c + filtet(tet) = -filtet(tet) +c + endif +c + 11 continue +c + 1 continue +c + end diff --git a/src/tool/Utilitaire/utqhex.F b/src/tool/Utilitaire/utqhex.F new file mode 100644 index 00000000..4be5c954 --- /dev/null +++ b/src/tool/Utilitaire/utqhex.F @@ -0,0 +1,261 @@ + subroutine utqhex ( lehexa, qualit, qualij, volume, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un HEXaedre +c -- - --- +c ______________________________________________________________________ +c +c . max de la qualite des tetraedres inclus +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . qualit . s . 1 . qualite des tetraedres inclus . +c . qualij . s . 1 . qualite par le jacobien normalise . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision qualit, qualij, volume + double precision coonoe(nbnoto,3) +c + integer lehexa + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c +c 0.4. ==> variables locales +c + integer iaux + integer aresom(0:3,8) + integer listar(12), listso(8) + integer s1, s2, s3, s4, s5, s6, s7,s8 +c + double precision daux + double precision of1(3),of2(3),of3(3),of4(3),of5(3),of6(3) + double precision centr(3), qual(24), volu(24) +c +c==== +c 1. les aretes et les sommets +c==== +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + s1 = listso(1) + s2 = listso(2) + s3 = listso(3) + s4 = listso(4) + s5 = listso(5) + s6 = listso(6) + s7 = listso(7) + s8 = listso(8) +c +c==== +c 2. les points caracteristiques +c==== +c Le centre de l'hexaedre + centr(1) = unshu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s3,1)+coonoe(s4,1)+coonoe(s5,1) + > + coonoe(s6,1)+coonoe(s7,1)+coonoe(s8,1) ) + centr(2) = unshu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s3,2)+coonoe(s4,2)+coonoe(s5,2) + > + coonoe(s6,2)+coonoe(s7,2)+coonoe(s8,2) ) + centr(3) = unshu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s3,3)+coonoe(s4,3)+coonoe(s5,3) + > + coonoe(s6,3)+coonoe(s7,3)+coonoe(s8,3) ) +c Le centre de la face 1 + of1(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s3,1)+coonoe(s4,1)) + of1(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s3,2)+coonoe(s4,2)) + of1(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s3,3)+coonoe(s4,3)) +c Le centre de la face 2 + of2(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s5,1)+coonoe(s6,1)) + of2(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s5,2)+coonoe(s6,2)) + of2(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s5,3)+coonoe(s6,3)) +c Le centre de la face 3 + of3(1) = unsqu*(coonoe(s1,1)+coonoe(s4,1) + > + coonoe(s6,1)+coonoe(s7,1)) + of3(2) = unsqu*(coonoe(s1,2)+coonoe(s4,2) + > + coonoe(s6,2)+coonoe(s7,2)) + of3(3) = unsqu*(coonoe(s1,3)+coonoe(s4,3) + > + coonoe(s6,3)+coonoe(s7,3)) +c Le centre de la face 4 + of4(1) = unsqu*(coonoe(s2,1)+coonoe(s3,1) + > + coonoe(s5,1)+coonoe(s8,1)) + of4(2) = unsqu*(coonoe(s2,2)+coonoe(s3,2) + > + coonoe(s5,2)+coonoe(s8,2)) + of4(3) = unsqu*(coonoe(s2,3)+coonoe(s3,3) + > + coonoe(s5,3)+coonoe(s8,3)) +c Le centre de la face 5 + of5(1) = unsqu*(coonoe(s3,1)+coonoe(s4,1) + > + coonoe(s7,1)+coonoe(s8,1)) + of5(2) = unsqu*(coonoe(s3,2)+coonoe(s4,2) + > + coonoe(s7,2)+coonoe(s8,2)) + of5(3) = unsqu*(coonoe(s3,3)+coonoe(s4,3) + > + coonoe(s7,3)+coonoe(s8,3)) +c Le centre de la face 6 + of6(1) = unsqu*(coonoe(s5,1)+coonoe(s6,1) + > + coonoe(s7,1)+coonoe(s8,1)) + of6(2) = unsqu*(coonoe(s5,2)+coonoe(s6,2) + > + coonoe(s7,2)+coonoe(s8,2)) + of6(3) = unsqu*(coonoe(s5,3)+coonoe(s6,3) + > + coonoe(s7,3)+coonoe(s8,3)) +c +c==== +c 3. volume et qualite des tetraedres +c==== +c +c 4 qual de tetra touchant la face 1 + call utqte2 ( qual( 1), volu( 1), coonoe, s1, s2, centr, of1 ) + call utqte2 ( qual( 2), volu( 2), coonoe, s2, s3, centr, of1 ) + call utqte2 ( qual( 3), volu( 3), coonoe, s3, s4, centr, of1 ) + call utqte2 ( qual( 4), volu( 4), coonoe, s1, s4, centr, of1 ) +c 4 qual( de tetra touchant la face 2 + call utqte2 ( qual( 5), volu( 5), coonoe, s1, s2, centr, of2 ) + call utqte2 ( qual( 6), volu( 6), coonoe, s2, s5, centr, of2 ) + call utqte2 ( qual( 7), volu( 7), coonoe, s5, s6, centr, of2 ) + call utqte2 ( qual( 8), volu( 8), coonoe, s1, s6, centr, of2 ) +c 4 qual( de tetra touchant la face 3 + call utqte2 ( qual( 9), volu( 9), coonoe, s1, s4, centr, of3 ) + call utqte2 ( qual(10), volu(10), coonoe, s4, s7, centr, of3 ) + call utqte2 ( qual(11), volu(11), coonoe, s6, s7, centr, of3 ) + call utqte2 ( qual(12), volu(12), coonoe, s1, s6, centr, of3 ) +c 4 qual( de tetra touchant la face 4 + call utqte2 ( qual(13), volu(13), coonoe, s2, s3, centr, of4 ) + call utqte2 ( qual(14), volu(14), coonoe, s3, s8, centr, of4 ) + call utqte2 ( qual(15), volu(15), coonoe, s5, s8, centr, of4 ) + call utqte2 ( qual(16), volu(16), coonoe, s2, s5, centr, of4 ) +c 4 qual( de tetra touchant la face 5 + call utqte2 ( qual(17), volu(17), coonoe, s3, s4, centr, of5 ) + call utqte2 ( qual(18), volu(18), coonoe, s4, s7, centr, of5 ) + call utqte2 ( qual(19), volu(19), coonoe, s7, s8, centr, of5 ) + call utqte2 ( qual(20), volu(20), coonoe, s3, s8, centr, of5 ) +c 4 qual( de tetra touchant la face 6 + call utqte2 ( qual(21), volu(21), coonoe, s5, s6, centr, of6 ) + call utqte2 ( qual(22), volu(22), coonoe, s6, s7, centr, of6 ) + call utqte2 ( qual(23), volu(23), coonoe, s7, s8, centr, of6 ) + call utqte2 ( qual(24), volu(24), coonoe, s5, s8, centr, of6 ) +c + volume = volu(1) + qualit = qual(1) + do 10 , iaux = 2 , 24 + if (qual(iaux).gt.qualit) then + qualit = qual(iaux) + endif + volume = volume + volu(iaux) + 10 continue +c +c==== +c 4. qualite par le jacobien normalise +c==== +c 4.1. ==> Liens sommet/aretes +c + aresom(0,1) = 1 + aresom(1,1) = 1 + aresom(2,1) = 5 + aresom(3,1) = 2 +c + aresom(0,2) = 2 + aresom(1,2) = 1 + aresom(2,2) = 3 + aresom(3,2) = 6 +c + aresom(0,3) = 3 + aresom(1,3) = 4 + aresom(2,3) = 8 + aresom(3,3) = 3 +c + aresom(0,4) = 4 + aresom(1,4) = 4 + aresom(2,4) = 2 + aresom(3,4) = 7 +c + aresom(0,5) = 5 + aresom(1,5) = 6 + aresom(2,5) = 11 + aresom(3,5) = 9 +c + aresom(0,6) = 6 + aresom(1,6) = 5 + aresom(2,6) = 9 + aresom(3,6) = 10 +c + aresom(0,7) = 7 + aresom(1,7) = 10 + aresom(2,7) = 12 + aresom(3,7) = 7 +c + aresom(0,8) = 8 + aresom(1,8) = 11 + aresom(2,8) = 8 + aresom(3,8) = 12 +c +c 4.2. ==> fonction generique +c + iaux = 8 + daux = 1.d0 + call utqjno ( iaux, aresom, daux, + > listar, listso, somare, coonoe, + > qualij ) +cgn write(1,*) '==> qualij : ', qualij +c + end diff --git a/src/tool/Utilitaire/utqjno.F b/src/tool/Utilitaire/utqjno.F new file mode 100644 index 00000000..48616b40 --- /dev/null +++ b/src/tool/Utilitaire/utqjno.F @@ -0,0 +1,149 @@ + subroutine utqjno ( nbsomm, aresom, consta, + > listar, listso, somare, coonoe, + > qualij ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite en Jacobien NOrmalise +c -- - - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbsomm . e . 1 . nombre de sommets a considerer . +c . aresom . e . 0:3 . connection autour de chaque sommet retenu . +c . . . *nbsomm. 0 : numero du sommet dans listso . +c . . . . 1, 2, 3 : numeros des 3 aretes dans listar . +c . consta . e . 1 . constante de normalisation de la qualite . +c . listar . e . * . Liste des aretes de la maille . +c . listso . e . * . Liste des sommets de la maille . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . qualij . s . 1 . qualite selon le jacobien normalise . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "infini.h" +c +c 0.3. ==> arguments +c + integer nbsomm, aresom(0:3,nbsomm) + integer listar(*), listso(*) + integer somare(2,nbarto) +c + double precision consta + double precision coonoe(nbnoto,3) + double precision qualij +c +c 0.4. ==> variables locales +c + integer iaux + integer nbnega + integer sommet + integer arete1, arete2, arete3 +c + double precision jens + double precision promix, promin + double precision jensmi, jensma +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. Parcours +c==== +c +cgn write(1,90002) 'nbsomm', nbsomm + nbnega = 0 + jensmi = vinfpo + jensma = vinfne +c + do 11 , iaux = 1 , nbsomm +c +c 1.1. ==> sommet et aretes a considerer +c + sommet = listso(aresom(0,iaux)) + arete1 = listar(aresom(1,iaux)) + arete2 = listar(aresom(2,iaux)) + arete3 = listar(aresom(3,iaux)) +c +cgn write(1,90012) 'aretes du sommet',sommet,arete1,arete2,arete3 +c +c 1.2. ==> calcul du produit mixte normalise +c + call utprma ( sommet, arete1, arete2, arete3, + > somare, nbnoto, coonoe, + > promix, promin ) +c +c 1.3. ==> formule du jacobien pour ce sommet +c + if ( promin.gt.consta ) then + jens = 1.d0 + consta - promin + elseif ( promin.gt.-consta ) then + jens = promin/consta + else + jens = -1.d0 - consta - promin + endif +cgn write(1,*) 'promin, jens=', promin, jens +c +c 1.4. ==> tri entre >0 et <0 et memorisation des extremes +c + jensmi = min(jensmi, jens) + if ( jens.lt.0.d0 ) then + jensma = max(jensma,jens) + nbnega = nbnega + 1 + else + jensmi = min(jensmi, jens) + endif +cgn write(1,*) 'jensmi, jensma, nbnega =', jensmi, jensma, nbnega +c + 11 continue +c +c==== +c 2. Bilan +c==== +c + if ( nbnega.eq.nbsomm ) then + qualij = -jensma + elseif ( nbnega.gt.0 ) then + qualij = jensma + else + qualij = jensmi + endif +c +cgn write(1,90002) 'nbnega', nbnega +cgn write(1,90004) '==> qualij', qualij +c + end diff --git a/src/tool/Utilitaire/utqpen.F b/src/tool/Utilitaire/utqpen.F new file mode 100644 index 00000000..834fd9c3 --- /dev/null +++ b/src/tool/Utilitaire/utqpen.F @@ -0,0 +1,149 @@ + subroutine utqpen ( lepent, qualit, qualij, volume, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un PENtaedre +c -- - --- +c ______________________________________________________________________ +c +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . qualit . s . 1 . qualite non definie . +c . qualij . s . 1 . qualite par le jacobien normalise . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision qualit, qualij, volume + double precision coonoe(nbnoto,3) +c + integer lepent + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c +c 0.4. ==> variables locales +c + integer iaux + integer aresom(0:3,6) + integer listar(9), listso(6) +c + double precision daux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et les sommets +c==== +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c==== +c 2. volume +c==== +c + call utvope ( coonoe, listso, volume ) +c +c==== +c 3. qualite bidon +c==== +c + qualit = -1789.d0 +c +c==== +c 4. qualite par le jacobien normalise +c==== +c 4.1. ==> Liens sommet/aretes +c + aresom(0,1) = 1 + aresom(1,1) = 2 + aresom(2,1) = 1 + aresom(3,1) = 7 +c + aresom(0,2) = 2 + aresom(1,2) = 3 + aresom(2,2) = 2 + aresom(3,2) = 8 +c + aresom(0,3) = 3 + aresom(1,3) = 1 + aresom(2,3) = 3 + aresom(3,3) = 9 +c + aresom(0,4) = 4 + aresom(1,4) = 4 + aresom(2,4) = 5 + aresom(3,4) = 7 +c + aresom(0,5) = 5 + aresom(1,5) = 5 + aresom(2,5) = 6 + aresom(3,5) = 8 +c + aresom(0,6) = 6 + aresom(1,6) = 6 + aresom(2,6) = 4 + aresom(3,6) = 9 +c +c 4.2. ==> fonction generique +c + iaux = 6 + daux = sqrt(3.d0)/2.d0 + call utqjno ( iaux, aresom, daux, + > listar, listso, somare, coonoe, + > qualij ) +cgn write(1,*) '==> qualij : ', qualij +c + end diff --git a/src/tool/Utilitaire/utqpyr.F b/src/tool/Utilitaire/utqpyr.F new file mode 100644 index 00000000..0aa87e57 --- /dev/null +++ b/src/tool/Utilitaire/utqpyr.F @@ -0,0 +1,180 @@ + subroutine utqpyr ( lapyra, qualit, qualij, volume, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'une PYRamide +c -- - --- +c ______________________________________________________________________ +c +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . qualit . s . 1 . qualite non definie . +c . qualij . s . 1 . qualite par le jacobien normalise . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + double precision qualit, qualij, volume + double precision coonoe(nbnoto,3) +c + integer lapyra + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c +c 0.4. ==> variables locales +c + integer iaux + integer aresom(0:3,8) + integer listar(8), listso(5) +c + double precision daux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c S5 +c x +c . . . . +c . . . . +c . . a4. . +c . . . . +c . . x . . +c a1 . . . S4 . .a3 +c . . . . . +c . . . . +c . . . a7 . . +c . .a8 . . . +c . . . . . +c S1 . .a2 . . +c x . . . . +c a5 . . . +c x--------------------------------------------------------x +c S2 a6 S3 +c La face f5 est le quadrangle. +c La face fi, i<5, est le triangle s'appuyant sur l'arete ai. +c +c==== +c 1. les aretes et les sommets +c==== +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +c==== +c 2. volume +c==== +c + call utvopy ( coonoe, listso, volume ) +c +c==== +c 3. qualite bidon +c==== +c + qualit = -1789.d0 +c +c==== +c 4. qualite par le jacobien normalise +c==== +c 4.1. ==> Liens sommet/aretes +c + aresom(0,1) = 1 + aresom(1,1) = 5 + aresom(2,1) = 8 + aresom(3,1) = 1 +c + aresom(0,2) = 2 + aresom(1,2) = 6 + aresom(2,2) = 5 + aresom(3,2) = 2 +c + aresom(0,3) = 3 + aresom(1,3) = 7 + aresom(2,3) = 6 + aresom(3,3) = 3 +c + aresom(0,4) = 4 + aresom(1,4) = 8 + aresom(2,4) = 7 + aresom(3,4) = 4 +c + aresom(0,5) = 5 + aresom(1,5) = 2 + aresom(2,5) = 1 + aresom(3,5) = 4 +c + aresom(0,6) = 5 + aresom(1,6) = 3 + aresom(2,6) = 2 + aresom(3,6) = 1 +c + aresom(0,7) = 5 + aresom(1,7) = 4 + aresom(2,7) = 3 + aresom(3,7) = 2 +c + aresom(0,8) = 5 + aresom(1,8) = 1 + aresom(2,8) = 4 + aresom(3,8) = 3 +c +c 4.2. ==> fonction generique +c + iaux = 8 + daux = sqrt(2.d0)/2.d0 + call utqjno ( iaux, aresom, daux, + > listar, listso, somare, coonoe, + > qualij ) +cgn write(1,*) '==> qualij : ', qualij +c + end diff --git a/src/tool/Utilitaire/utqqu0.F b/src/tool/Utilitaire/utqqu0.F new file mode 100644 index 00000000..84519201 --- /dev/null +++ b/src/tool/Utilitaire/utqqu0.F @@ -0,0 +1,288 @@ + subroutine utqqu0 ( qualit, surf, sdim, coonoe ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un QUadrangle - phase 0 +c -- - -- - +c ______________________________________________________________________ +c +c on utilise le critere decrit dans +c 'Pascal Jean Frey, Paul-Louis George' +c 'Maillages - applications aux elements finis, Hermes, 1999' +c +c Chapitre 8 'Optimisation des maillages', page 610 +c +c hmax * hs +c le critere de qualite, q, vaut alpha * --------- +c Smin +c hmax est la plus grande longueur entre les 4 cotes et les +c 2 diagonales +c hs est la moyenne quadratique des longueur des cotes +c Smin est la plus petite des surfaces des 4 triangles que l'on +c peut tracer dans le quadrangle +c alpha est un coefficient de normalisation pour que le critere q +c vaille 1 pour un carre ==> alpha = racine(2)/8 +c +c pour tout autre quadrangle, le critere est donc superieur a 1 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . qualit . s . 1 . qualite . +c . surf . s . 1 . surface . +c . sdim . e . 1 . dimension du probleme . +c . coonoe . e . 4*sdim . coordonnees des 4 noeuds du quadrangle . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTQQU0' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer sdim + double precision qualit, surf, coonoe(4,sdim) +c +c 0.4. ==> variables locales +c + double precision daux1, daux2, daux3, daux4 + double precision v1(3), v2(3), vdiag(3), vn(3) + double precision lgar(6) + double precision alpha +c + logical prem +c +#include "fracta.h" +#include "fractc.h" +c +c 0.5. ==> initialisations +c + data prem / .true. / +c ______________________________________________________________________ +c Pour calculer la surface, on coupe le quadrangle en deux triangles +c On rappelle que la surface d'un triangle est egale a la moitie de +c la norme du produit vectoriel de deux des vecteurs representant +c ses aretes. +c +c==== +c 1. le coefficient normalisateur +c==== +c + if ( prem ) then + alpha = sqrt(2.d0)*unsqu + prem = .false. + endif +c +c==== +c 2. calculs des surfaces triangles inscrits +c==== +c +c 2.1. ==> en coupant selon la premiere diagonale +c v1 : arete a1 +c v2 : arete a4 +c vdiag = diagonale(4-2) +c +c 4 a4 3 +c ._______. +c .. . +c . . . +c a1. . .a3 +c . . . +c . . . +c . . . +c . .. +c ._______. +c 1 a2 2 +c +c daux1 = double de la surface de (a1,a2,diagonale) +c daux2 = double de la surface de (a4,a3,diagonale) +c + if ( sdim.eq.2 ) then +c + v1(1) = coonoe(1,1) - coonoe(4,1) + v1(2) = coonoe(1,2) - coonoe(4,2) +c + v2(1) = coonoe(3,1) - coonoe(4,1) + v2(2) = coonoe(3,2) - coonoe(4,2) +c + vdiag(1) = coonoe(2,1) - coonoe(4,1) + vdiag(2) = coonoe(2,2) - coonoe(4,2) +c + daux1 = abs ( v1(1)*vdiag(2) - v1(2)*vdiag(1) ) +c + daux2 = abs ( v2(1)*vdiag(2) - v2(2)*vdiag(1) ) +c + lgar(1) = v1(1)*v1(1) + v1(2)*v1(2) + lgar(4) = v2(1)*v2(1) + v2(2)*v2(2) + lgar(5) = vdiag(1)*vdiag(1) + vdiag(2)*vdiag(2) +c + else +c + v1(1) = coonoe(1,1) - coonoe(4,1) + v1(2) = coonoe(1,2) - coonoe(4,2) + v1(3) = coonoe(1,3) - coonoe(4,3) +c + v2(1) = coonoe(3,1) - coonoe(4,1) + v2(2) = coonoe(3,2) - coonoe(4,2) + v2(3) = coonoe(3,3) - coonoe(4,3) +c + vdiag(1) = coonoe(2,1) - coonoe(4,1) + vdiag(2) = coonoe(2,2) - coonoe(4,2) + vdiag(3) = coonoe(2,3) - coonoe(4,3) +c + vn(1) = v1(2)*vdiag(3) - v1(3)*vdiag(2) + vn(2) = v1(3)*vdiag(1) - v1(1)*vdiag(3) + vn(3) = v1(1)*vdiag(2) - v1(2)*vdiag(1) +c + daux1 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + vn(1) = v2(2)*vdiag(3) - v2(3)*vdiag(2) + vn(2) = v2(3)*vdiag(1) - v2(1)*vdiag(3) + vn(3) = v2(1)*vdiag(2) - v2(2)*vdiag(1) +c + daux2 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + lgar(1) = v1(1)*v1(1) + v1(2)*v1(2) + v1(3)*v1(3) + lgar(4) = v2(1)*v2(1) + v2(2)*v2(2) + v2(3)*v2(3) + lgar(5) = + > vdiag(1)*vdiag(1) + vdiag(2)*vdiag(2) + vdiag(3)*vdiag(3) +c + endif +c +c 2.2. ==> en coupant selon la seconde diagonale +c v1 : arete a1 +c v2 : arete a2 +c vdiag = diagonale(1-3) +c +c 4 a4 3 +c .______. +c . .. +c . . . +c a1. . .a3 +c . . . +c . . . +c .. . +c .______. +c 1 a2 2 +c +c daux3 = double de la surface de (a1,a4,diagonale) +c daux4 = double de la surface de (a2,a3,diagonale) +c + if ( sdim.eq.2 ) then +c + v2(1) = coonoe(2,1) - coonoe(1,1) + v2(2) = coonoe(2,2) - coonoe(1,2) +c + vdiag(1) = coonoe(3,1) - coonoe(1,1) + vdiag(2) = coonoe(3,2) - coonoe(1,2) +c + daux3 = abs ( v1(1)*vdiag(2) - v1(2)*vdiag(1) ) +c + daux4 = abs ( v2(1)*vdiag(2) - v2(2)*vdiag(1) ) +c + lgar(2) = v2(1)*v2(1) + v2(2)*v2(2) + lgar(6) = vdiag(1)*vdiag(1) + vdiag(2)*vdiag(2) +c + else +c + v2(1) = coonoe(2,1) - coonoe(1,1) + v2(2) = coonoe(2,2) - coonoe(1,2) + v2(3) = coonoe(2,3) - coonoe(1,3) +c + vdiag(1) = coonoe(3,1) - coonoe(1,1) + vdiag(2) = coonoe(3,2) - coonoe(1,2) + vdiag(3) = coonoe(3,3) - coonoe(1,3) +c + vn(1) = v1(2)*vdiag(3) - v1(3)*vdiag(2) + vn(2) = v1(3)*vdiag(1) - v1(1)*vdiag(3) + vn(3) = v1(1)*vdiag(2) - v1(2)*vdiag(1) +c + daux3 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + vn(1) = v2(2)*vdiag(3) - v2(3)*vdiag(2) + vn(2) = v2(3)*vdiag(1) - v2(1)*vdiag(3) + vn(3) = v2(1)*vdiag(2) - v2(2)*vdiag(1) +c + daux4 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + lgar(2) = v2(1)*v2(1) + v2(2)*v2(2) + v2(3)*v2(3) + lgar(6) = + > vdiag(1)*vdiag(1) + vdiag(2)*vdiag(2) + vdiag(3)*vdiag(3) +c + endif +c +c==== +c 3. surface : la somme des surfaces des 2 triangles +c==== +c + surf = unsde * ( daux1 + daux2 ) +c +c==== +c 4. qualite +c==== +c +c 4.1. ==> surface minimale des triangles (le double) +c + daux1 = min ( daux1, daux2, daux3, daux4 ) +c +c 4.2. ==> carre de la longueur de l'arete a3 +c + if ( sdim.eq.2 ) then +c + v1(1) = coonoe(3,1) - coonoe(2,1) + v1(2) = coonoe(3,2) - coonoe(2,2) +c + lgar(3) = v1(1)*v1(1) + v1(2)*v1(2) +c + else +c + v1(1) = coonoe(3,1) - coonoe(2,1) + v1(2) = coonoe(3,2) - coonoe(2,2) + v1(3) = coonoe(3,3) - coonoe(2,3) +c + lgar(3) = v1(1)*v1(1) + v1(2)*v1(2) + v1(3)*v1(3) +c + endif +c +c 4.3. ==> moyenne quadratique des longueurs des cotes +c + daux2 = sqrt ( lgar(1) + lgar(2) + lgar(3) + lgar(4) ) +c +c 4.4. ==> plus grande valeur des longueurs (cotes et diagonales) +c + daux3 = max ( lgar(1), lgar(2), lgar(3), lgar(4), + > lgar(5), lgar(6) ) + daux3 = sqrt(daux3) +c +c 4.5. ==> qualite +c + qualit = alpha * daux3 * daux2 / daux1 +c + end diff --git a/src/tool/Utilitaire/utqqua.F b/src/tool/Utilitaire/utqqua.F new file mode 100644 index 00000000..2a242118 --- /dev/null +++ b/src/tool/Utilitaire/utqqua.F @@ -0,0 +1,125 @@ + subroutine utqqua ( lequad, qualit, surf, + > coonoe, somare, arequa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un QUAdrangle +c -- - --- +c ______________________________________________________________________ +c +c on utilise le critere decrit dans +c 'Pascal Jean Frey, Paul-Louis George' +c 'Maillages - applications aux elements finis, Hermes, 1999' +c +c Chapitre 8 'Optimisation des maillages', page 610 +c +c hmax * hs +c le critere de qualite, q, vaut alpha * --------- +c Smin +c hmax est la plus grande longueur entre les 4 cotes et les +c 2 diagonales +c hs est la moyenne quadratique des longueur des cotes +c Smin est la plus petite des surfaces des 4 triangles que l'on +c peut tracer dans le quadrangle +c alpha est un coefficient de normalisation pour que le critere q +c vaille 1 pour un carre ==> alpha = racine(2)/8 +c +c pour tout autre quadrangle, le critere est donc superieur a 1 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . numero du quadrangle a examiner . +c . qualit . s . 1 . qualite . +c . surf . s . 1 . surface . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTQQUA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision qualit, surf, coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), arequa(nbquto,4) +c + integer lequad +c +c 0.4. ==> variables locales +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 + integer iaux +c + double precision cooloc(4,3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. le calcul +c==== +c +c 1.1. ==> les aretes +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c +c 1.2. ==> les sommets +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c + do 12 , iaux = 1 , sdim + cooloc(1,iaux) = coonoe(sa1a2,iaux) + cooloc(2,iaux) = coonoe(sa2a3,iaux) + cooloc(3,iaux) = coonoe(sa3a4,iaux) + cooloc(4,iaux) = coonoe(sa4a1,iaux) + 12 continue +c +c 1.3. ==> qualite et surface +c + call utqqu0 ( qualit, surf, sdim, cooloc ) +c + end diff --git a/src/tool/Utilitaire/utqte2.F b/src/tool/Utilitaire/utqte2.F new file mode 100644 index 00000000..1677198c --- /dev/null +++ b/src/tool/Utilitaire/utqte2.F @@ -0,0 +1,138 @@ + subroutine utqte2 ( qualit, volume, + > coonoe, s1, s2, cooso3, cooso4 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un TEtraedre 2 +c -- - --- _ +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . qualit . s . 1 . qualite . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . s1 . e . 1 . numero global du sommet 1 . +c . s2 . e . 1 . numero global du sommet 2 . +c . cooso3 . e . 3 . coordonnees du sommet 3 . +c . cooso4 . e . 3 . coordonnees du sommet 4 . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "fracte.h" +c +c 0.3. ==> arguments +c + double precision qualit, volume + double precision coonoe(nbnoto,3) + integer s1,s2 + double precision cooso3(3), cooso4(3) +c +c 0.4. ==> variables locales +c + double precision sf1, sf2, sf3, sf4, sixvol + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision v1(3), v3(3), v4(3), v6(3), vn(3) +c +c 1.3. ==> on ne memorise que les vecteurs des aretes 1 3 4 et 6 +c + v1(1) = coonoe(s2,1)-coonoe(s1,1) + v1(2) = coonoe(s2,2)-coonoe(s1,2) + v1(3) = coonoe(s2,3)-coonoe(s1,3) + ar1 = sqrt ( v1(1)*v1(1) + v1(2)*v1(2) + v1(3)*v1(3) ) +c longueur arete 2 + vn(1) = cooso3(1)-coonoe(s1,1) + vn(2) = cooso3(2)-coonoe(s1,2) + vn(3) = cooso3(3)-coonoe(s1,3) + ar2 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + v3(1) = cooso4(1)-coonoe(s1,1) + v3(2) = cooso4(2)-coonoe(s1,2) + v3(3) = cooso4(3)-coonoe(s1,3) + ar3 = sqrt ( v3(1)*v3(1) + v3(2)*v3(2) + v3(3)*v3(3) ) +c + v4(1) = cooso3(1)-coonoe(s2,1) + v4(2) = cooso3(2)-coonoe(s2,2) + v4(3) = cooso3(3)-coonoe(s2,3) + ar4 = sqrt ( v4(1)*v4(1) + v4(2)*v4(2) + v4(3)*v4(3) ) +c + vn(1) = cooso4(1)-coonoe(s2,1) + vn(2) = cooso4(2)-coonoe(s2,2) + vn(3) = cooso4(3)-coonoe(s2,3) + ar5 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + v6(1) = cooso4(1)-cooso3(1) + v6(2) = cooso4(2)-cooso3(2) + v6(3) = cooso4(3)-cooso3(3) + ar6 = sqrt ( v6(1)*v6(1) + v6(2)*v6(2) + v6(3)*v6(3) ) +c +c 1.4. ==> calcul des 4 surfaces (plutot 2 fois les surfaces) +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c + vn(1) = v6(2)*v4(3) - v6(3)*v4(2) + vn(2) = v6(3)*v4(1) - v6(1)*v4(3) + vn(3) = v6(1)*v4(2) - v6(2)*v4(1) + sf1 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v6(2)*v3(3) - v6(3)*v3(2) + vn(2) = v6(3)*v3(1) - v6(1)*v3(3) + vn(3) = v6(1)*v3(2) - v6(2)*v3(1) + sf2 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v1(2)*v3(3) - v1(3)*v3(2) + vn(2) = v1(3)*v3(1) - v1(1)*v3(3) + vn(3) = v1(1)*v3(2) - v1(2)*v3(1) + sf3 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v1(2)*v4(3) - v1(3)*v4(2) + vn(2) = v1(3)*v4(1) - v1(1)*v4(3) + vn(3) = v1(1)*v4(2) - v1(2)*v4(1) + sf4 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c +c 1.5. ==> calcul du volume du tetraedre (plutot de 6 fois le volume) +c on rappelle que le volume d'un tetraedre est egal au +c sixieme de la valeur absolue du produit mixte de trois +c des vecteurs representant les aretes. +c vn = v1xv4 --> volume = 1/6 * produit mixte (v1,v4,v3) +c + sixvol = abs ( vn(1)*v3(1) + vn(2)*v3(2) + vn(3)*v3(3) ) +c +c 1.6. ==> volume et qualite +c + volume = unssix * sixvol +c +c 7.65 est la normalisation pour 1 cube + qualit = max(ar1,ar2,ar3,ar4,ar5,ar6)/7.6569d0 + > * (sqrt(sf1)+sqrt(sf2)+sqrt(sf3)+sqrt(sf4)) / sixvol +c + end diff --git a/src/tool/Utilitaire/utqtet.F b/src/tool/Utilitaire/utqtet.F new file mode 100644 index 00000000..81177d62 --- /dev/null +++ b/src/tool/Utilitaire/utqtet.F @@ -0,0 +1,264 @@ + subroutine utqtet ( letetr, qualit, qualij, volume, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un TETraedre +c -- - --- +c ______________________________________________________________________ +c +c on utilise le critere decrit dans +c 'Maillages, applications aux elements finis' +c Pascal Jean Frey, Paul-Louis George +c Hermes, 1999 +c Chapitre 18.2, page 606 +c h +c le critere de qualite, q, vaut alpha * - +c r +c h est le diametre du tetraedre, i.e. son plus grand cote +c r est le rayon de la sphere inscrite +c alpha est un coefficient de normalisation pour que le critere q +c vaille 1 pour un tetraedre regulier ==> alpha = 1/racine(24) +c +c pour tout autre tetraedre, le critere est donc superieur a 1 +c +c max(ak) * somme des si +c tous calculs faits q vaut ---------------------- +c 3 * racine(24) * vol +c +c ou si est la surface de la i-eme face, +c ak est la longueur du k-eme cote +c vol le volume du tetraedre. +c +c Un tetraedre regulier : +c noeud 1 +c x = 0.5d0 +c y = 0.5d0*sqrt(3.0d0)/3.d0 +c z = sqrt(2.0d0/3.0d0) +c noeud 2 +c x = 0.0d0 +c y = 0.0d0 +c z = 0.0d0 +c noeud 3 +c x = 1.0d0 +c y = 0.0d0 +c z = 0.0d0 +c noeud 4 +c x = 0.5d0 +c y = 0.5d0*sqrt(3.0d0) +c z = 0.0d0 +c +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . qualit . s . 1 . qualite . +c . qualij . s . 1 . qualite par le jacobien normalise . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractl.h" +#include "fracte.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + double precision qualit, qualij, volume, coonoe(nbnoto,3) +c + integer letetr + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer aresom(0:3,4) + integer listar(6), listso(4) +c + double precision coosom(3,4) + double precision sf1, sf2, sf3, sf4, sixvol + double precision ar1, ar2, ar3, ar4, ar5, ar6 + double precision v1(3), v3(3), v4(3), v6(3), vn(3) + double precision daux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et sommets de ce tetraedre +c==== +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + do 11 , jaux = 1, 4 + do 111 , iaux = 1, 3 + coosom(iaux,jaux) = coonoe(listso(jaux),iaux) + 111 continue + 11 continue +c +c==== +c 2. longueurs des aretes 2 (n1-n3) et 5 (n2-n4) +c==== +c + vn(1) = coosom(1,3) - coosom(1,1) + vn(2) = coosom(2,3) - coosom(2,1) + vn(3) = coosom(3,3) - coosom(3,1) + ar2 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c + vn(1) = coosom(1,4) - coosom(1,2) + vn(2) = coosom(2,4) - coosom(2,2) + vn(3) = coosom(3,4) - coosom(3,2) + ar5 = sqrt ( vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) ) +c +c==== +c 3. memorisation des vecteurs liees aux aretes 1 (n1-n2), +c 3 (n1-n4), 4 (n2-n3) et 6 (n3-n4) +c et calcul des longueurs de ces aretes +c==== +c + v1(1) = coosom(1,2) - coosom(1,1) + v1(2) = coosom(2,2) - coosom(2,1) + v1(3) = coosom(3,2) - coosom(3,1) + ar1 = sqrt ( v1(1)*v1(1) + v1(2)*v1(2) + v1(3)*v1(3) ) +c + v3(1) = coosom(1,4) - coosom(1,1) + v3(2) = coosom(2,4) - coosom(2,1) + v3(3) = coosom(3,4) - coosom(3,1) + ar3 = sqrt ( v3(1)*v3(1) + v3(2)*v3(2) + v3(3)*v3(3) ) +c + v4(1) = coosom(1,3) - coosom(1,2) + v4(2) = coosom(2,3) - coosom(2,2) + v4(3) = coosom(3,3) - coosom(3,2) + ar4 = sqrt ( v4(1)*v4(1) + v4(2)*v4(2) + v4(3)*v4(3) ) +c + v6(1) = coosom(1,4) - coosom(1,3) + v6(2) = coosom(2,4) - coosom(2,3) + v6(3) = coosom(3,4) - coosom(3,3) + ar6 = sqrt ( v6(1)*v6(1) + v6(2)*v6(2) + v6(3)*v6(3) ) +cgn write(1,*) ar1,ar2,ar3,ar4,ar5,ar6 +c +c==== +c 4. calcul des 4 surfaces (plutot 2 fois les surfaces) +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c==== +c + vn(1) = v6(2)*v4(3) - v6(3)*v4(2) + vn(2) = v6(3)*v4(1) - v6(1)*v4(3) + vn(3) = v6(1)*v4(2) - v6(2)*v4(1) + sf1 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v6(2)*v3(3) - v6(3)*v3(2) + vn(2) = v6(3)*v3(1) - v6(1)*v3(3) + vn(3) = v6(1)*v3(2) - v6(2)*v3(1) + sf2 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v1(2)*v3(3) - v1(3)*v3(2) + vn(2) = v1(3)*v3(1) - v1(1)*v3(3) + vn(3) = v1(1)*v3(2) - v1(2)*v3(1) + sf3 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +c + vn(1) = v1(2)*v4(3) - v1(3)*v4(2) + vn(2) = v1(3)*v4(1) - v1(1)*v4(3) + vn(3) = v1(1)*v4(2) - v1(2)*v4(1) + sf4 = vn(1)*vn(1) + vn(2)*vn(2) + vn(3)*vn(3) +cgn write(1,*) sf1,sf2,sf3,sf4 +c +c==== +c 5. calcul du volume du tetraedre +c==== +c + call utvot0 ( coosom, volume ) +c +c==== +c 6. volume et qualite +c==== +c + sixvol = 6.d0*volume +c + qualit = sqrt(uns24) * max(ar1,ar2,ar3,ar4,ar5,ar6) + > * (sqrt(sf1)+sqrt(sf2)+sqrt(sf3)+sqrt(sf4)) / sixvol +c +c==== +c 7. qualite par le jacobien normalise +c==== +c 7.1. ==> Liens sommet/aretes +c + aresom(0,1) = 1 + aresom(1,1) = 1 + aresom(2,1) = 3 + aresom(3,1) = 2 +c + aresom(0,2) = 2 + aresom(1,2) = 5 + aresom(2,2) = 1 + aresom(3,2) = 4 +c + aresom(0,3) = 3 + aresom(1,3) = 4 + aresom(2,3) = 2 + aresom(3,3) = 6 +c + aresom(0,4) = 4 + aresom(1,4) = 6 + aresom(2,4) = 3 + aresom(3,4) = 5 +c +c 7.2. ==> fonction generique +c + iaux = 4 + daux = sqrt(2.d0)/2.d0 + call utqjno ( iaux, aresom, daux, + > listar, listso, somare, coonoe, + > qualij ) +cgn write(1,*) '==> qualij : ', qualij +c + end diff --git a/src/tool/Utilitaire/utqtr0.F b/src/tool/Utilitaire/utqtr0.F new file mode 100644 index 00000000..36b8ab26 --- /dev/null +++ b/src/tool/Utilitaire/utqtr0.F @@ -0,0 +1,172 @@ + subroutine utqtr0 ( qualit, surf, sdim, coonoe ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un TRiangle - phase 0 +c -- - -- - +c ______________________________________________________________________ +c +c on utilise le critere decrit dans +c 'Maillages, applications aux elements finis' +c Pascal Jean Frey, Paul-Louis George +c Hermes, 1999 +c Chapitre 18.2, page 606 +c h +c le critere de qualite, q, vaut alpha * - +c r +c h est le diametre du triangle, i.e. son plus grand cote +c r est le rayon du cercle inscrit +c alpha est un coefficient de normalisation pour que le critere q +c vaille 1 pour un triangle equilateral ==> alpha = 1/racine(12) +c +c pour tout autre triangle, le critere est donc superieur a 1 +c +c max(ak) * somme des ak +c tous calculs faits q vaut ---------------------- +c racine(48) * surface +c +c ou si est la surface du i-eme triangle, +c ak est la longueur du k-eme cote +c surface est la surface du triangle. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . qualit . s . 1 . qualite . +c . surf . s . 1 . surface . +c . sdim . e . 1 . dimension du probleme . +c . coonoe . e . 3*sdim . coordonnees des 3 noeuds du triangle . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTQTR0' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer sdim + double precision qualit, surf, coonoe(3,sdim) +c +c 0.4. ==> variables locales +c + double precision ar1, ar2, ar3 + double precision v1(3), v2(3), v3(3) + double precision alpha +c + logical prem +c +#include "fract0.h" +#include "fracta.h" +c +c 0.5. ==> initialisations +c + data prem / .true. / +c ______________________________________________________________________ +c +c==== +c 1. le coefficient normalisateur +c==== +c + if ( prem ) then + alpha = sqrt(unsdz) + prem = .false. + endif +c +c==== +c 2. les diverses longueurs et la surface +c==== +c +c 2.1. ==> en dimension 2 +c + if ( sdim.eq.2 ) then +c +c 2.1.1. ==> calcul des longueurs des aretes +c + v1(1) = coonoe(2,1) - coonoe(1,1) + v1(2) = coonoe(2,2) - coonoe(1,2) + ar1 = sqrt ( v1(1)*v1(1) + v1(2)*v1(2) ) +c + v2(1) = coonoe(3,1) - coonoe(2,1) + v2(2) = coonoe(3,2) - coonoe(2,2) + ar2 = sqrt ( v2(1)*v2(1) + v2(2)*v2(2) ) +c + v3(1) = coonoe(1,1) - coonoe(3,1) + v3(2) = coonoe(1,2) - coonoe(3,2) + ar3 = sqrt ( v3(1)*v3(1) + v3(2)*v3(2) ) +c +c 2.1.2. ==> calcul de la surface (plutot 2 fois la surface) +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c + surf = abs ( v1(1)*v3(2) - v1(2)*v3(1) ) +c +c 2.2. ==> en dimension 3 +c + else +c +c 2.2.1. ==> calcul des longueurs des aretes +c + v1(1) = coonoe(2,1) - coonoe(1,1) + v1(2) = coonoe(2,2) - coonoe(1,2) + v1(3) = coonoe(2,3) - coonoe(1,3) + ar1 = sqrt ( v1(1)*v1(1) + v1(2)*v1(2) + v1(3)*v1(3) ) +c + v2(1) = coonoe(3,1) - coonoe(2,1) + v2(2) = coonoe(3,2) - coonoe(2,2) + v2(3) = coonoe(3,3) - coonoe(2,3) + ar2 = sqrt ( v2(1)*v2(1) + v2(2)*v2(2) + v2(3)*v2(3) ) +c + v3(1) = coonoe(1,1) - coonoe(3,1) + v3(2) = coonoe(1,2) - coonoe(3,2) + v3(3) = coonoe(1,3) - coonoe(3,3) + ar3 = sqrt ( v3(1)*v3(1) + v3(2)*v3(2) + v3(3)*v3(3) ) +c +c 2.2.2. ==> calcul de la surface (plutot 2 fois la surface) +c on rappelle que la surface d'un triangle est egale +c a la moitie de la norme du produit vectoriel de deux +c des vecteurs representant les aretes. +c + v2(1) = v1(2)*v3(3) - v1(3)*v3(2) + v2(2) = v1(3)*v3(1) - v1(1)*v3(3) + v2(3) = v1(1)*v3(2) - v1(2)*v3(1) + surf = sqrt ( v2(1)*v2(1) + v2(2)*v2(2) + v2(3)*v2(3) ) +c + endif +c +c==== +c 3. qualite et surface +c==== +c + qualit = alpha * max(ar1,ar2,ar3) * (ar1+ar2+ar3) / surf +c + surf = unsde * surf +c + end diff --git a/src/tool/Utilitaire/utqtri.F b/src/tool/Utilitaire/utqtri.F new file mode 100644 index 00000000..8aa8c914 --- /dev/null +++ b/src/tool/Utilitaire/utqtri.F @@ -0,0 +1,101 @@ + subroutine utqtri ( letria, qualit, surf, + > coonoe, somare, aretri ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Qualite d'un TRIangle +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letria . e . 1 . numero du triangle a examiner . +c . qualit . s . 1 . qualite . +c . surf . s . 1 . surface . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTQTRI' ) +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision qualit, surf, coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), aretri(nbtrto,3) +c + integer letria +c +c 0.4. ==> variables locales +c + integer sa1a2, sa2a3, sa3a1 + integer a1, a2, a3 + integer iaux +c + double precision cooloc(3,3) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. le calcul +c==== +c +c 1.1. ==> les aretes +c + a1 = aretri(letria,1) + a2 = aretri(letria,2) + a3 = aretri(letria,3) +c +c 1.2. ==> les sommets +c + call utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c + do 12 , iaux = 1 , sdim + cooloc(1,iaux) = coonoe(sa1a2,iaux) + cooloc(2,iaux) = coonoe(sa2a3,iaux) + cooloc(3,iaux) = coonoe(sa3a1,iaux) + 12 continue +c +c 1.3. ==> qualite et surface +c + call utqtr0 ( qualit, surf, sdim, cooloc ) +c + end diff --git a/src/tool/Utilitaire/utqun2.F b/src/tool/Utilitaire/utqun2.F new file mode 100644 index 00000000..c02b307a --- /dev/null +++ b/src/tool/Utilitaire/utqun2.F @@ -0,0 +1,206 @@ + subroutine utqun2 ( dedans, + > v1, v2, v3, v4, vn, typbor ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - QUadrangle - Noeud - dimension 2 +c -- -- - - +c ______________________________________________________________________ +c +c teste si le noeud de coordonnees vn est a l'interieur d'un quadrangle +c programme en dimension 2 +c +c Conventions d'orientation : +c +c 4 .--------------------. 3 +c . . +c . . +c . . +c 1 .--------------------. 2 +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dedans . s . 1 . vrai ou faux selon que le noeud est dedans . +c . . . . ou hors du triangle . +c . v1 . e . 2 . coordonnees du sommet 1 du quadrangle . +c . v2 . e . 2 . coordonnees du sommet 2 du quadrangle . +c . v3 . e . 2 . coordonnees du sommet 3 du quadrangle . +c . v4 . e . 2 . coordonnees du sommet 4 du quadrangle . +c . vn . e . 2 . coordonnees du noeud a tester . +c . typbor . e . 1 . 1, si on accepte un noeud sur le bord . +c . . . . 0, si on rejette un noeud sur le bord . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTTRN2' ) +c +c 0.2. ==> communs +c +#include "precis.h" +c +c 0.3. ==> arguments +c + integer typbor +c + double precision v1(2), v2(2), v3(2), v4(2), vn(2) +c + logical dedans +c +c 0.4. ==> variables locales +c + double precision pvnoeu, pvtria + double precision xmax, xmin, ymax, ymin + double precision prosca + double precision daux + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c +cgn print 1789 ,'........ v1 = ',v1 +cgn print 1789 ,'........ v2 = ',v2 +cgn print 1789 ,'........ v3 = ',v3 +cgn print 1789 ,'........ v4 = ',v4 +cgn print 1789 ,'........ vn = ',vn +cgn 1789 format(a,4g14.7) +c==== +c 2. controle +c 4 .--------------------. 3 +c . . +c . . +c . . +c 1 .--------------------. 2 +c==== +c + xmin = min(v1(1),v2(1),v3(1),v4(1)) + xmax = max(v1(1),v2(1),v3(1),v4(1)) + ymin = min(v1(2),v2(2),v3(2),v4(2)) + ymax = max(v1(2),v2(2),v3(2),v4(2)) +c +c 2.1. ==> controle elementaire : le noeud doit etre dans le quadrangle +c enveloppe du quadrangle +c + if ( vn(1).lt.xmin .or. vn(1).gt.xmax .or. + > vn(2).lt.ymin .or. vn(2).gt.ymax ) then +c + dedans = .false. +c + else +c +c 2.2. ==> n est-il dans le triangle ? +c cela est vrai si le noeud et un sommet sont du meme cote +c de l'arete formee par les deux autres sommets, et cela pour +c toutes les aretes. +c on regarde si les produits vectoriels (ab,ac) et (ab,an) +c sont de meme orientation pour les trois permutations +c circulaires sur (a,b,c), c'est-a-dire si le produit +c scalaire des deux produits vectoriels est positif. +c pour pouvoir pieger les cas ou le noeud est sur une arete, on +c teste le caractere strictement positif ou positif du produit +c scalaire, selon la demande. +c +c + if ( typbor.eq.0 ) then + daux = 1.d-10 + else + daux = -epsima + endif +c + dedans = .true. +c +c 2.2.1. ==> arete (s1,s2) : comparaison de sn et de s4 +c pvnoeu represente le produit vectoriel s1s2 x s1s4 + pvnoeu = (v2(1)-v1(1)) * (v4(2)-v1(2)) + > - (v2(2)-v1(2)) * (v4(1)-v1(1)) +c pvtria represente le produit vectoriel s1s2 x s1n. + pvtria = (v2(1)-v1(1)) * (vn(2)-v1(2)) + > - (v2(2)-v1(2)) * (vn(1)-v1(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +c +cgn print 1789 ,'........ prosca s1s2 = ',prosca + if ( prosca.le.daux ) then + dedans = .false. + goto 30 + endif +c +c 2.2.2. ==> arete (s2,s3) : comparaison de sn et de s1 +c pvnoeu represente le produit vectoriel s2s3 x s2s1 + pvnoeu = (v3(1)-v2(1)) * (v1(2)-v2(2)) + > - (v3(2)-v2(2)) * (v1(1)-v2(1)) +c pvtria represente le produit vectoriel s2s3 x s2sn. + pvtria = (v3(1)-v2(1)) * (vn(2)-v2(2)) + > - (v3(2)-v2(2)) * (vn(1)-v2(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +c +cgn print 1789 ,'........ prosca s2s3 = ',prosca + if ( prosca.le.daux ) then + dedans = .false. + goto 30 + endif +c +c 2.2.3. ==> arete (s3,s4) : comparaison de sn et de s2 +c pvnoeu represente le produit vectoriel s3s4 x s3s2 + pvnoeu = (v4(1)-v3(1)) * (v2(2)-v3(2)) + > - (v4(2)-v3(2)) * (v2(1)-v3(1)) +c pvtria represente le produit vectoriel s3s4 x s3n. + pvtria = (v4(1)-v3(1)) * (vn(2)-v3(2)) + > - (v4(2)-v3(2)) * (vn(1)-v3(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +cgn print 1789 ,'........ prosca s3s1 = ',prosca +c + if ( prosca.le.daux ) then + dedans = .false. + goto 30 + endif +c +c 2.2.3. ==> arete (s4,s1) : comparaison de sn et de s3 +c pvnoeu represente le produit vectoriel s4s1 x s4s3 + pvnoeu = (v1(1)-v4(1)) * (v3(2)-v4(2)) + > - (v1(2)-v4(2)) * (v3(1)-v4(1)) +c pvtria represente le produit vectoriel s4s1 x s4n. + pvtria = (v1(1)-v4(1)) * (vn(2)-v4(2)) + > - (v1(2)-v4(2)) * (vn(1)-v4(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +cgn print 1789 ,'........ prosca s3s1 = ',prosca +c + if ( prosca.le.daux ) then + dedans = .false. + endif +c + 30 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utqure.F b/src/tool/Utilitaire/utqure.F new file mode 100644 index 00000000..89516ee0 --- /dev/null +++ b/src/tool/Utilitaire/utqure.F @@ -0,0 +1,277 @@ + subroutine utqure ( chaine, + > nbsign, typsig, valcha, valent, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : QUestions / REponses +c -- -- -- +c ______________________________________________________________________ +c +c Decodage d'un texte composee de caracteres et d'entiers +c On retourne pour chaque signe son type et sa valeur +c Attention : on n'accepte que des caracteres*1 ou *2 +c Attention : la taille des tableaux de retour n'est pas controlee +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . chaine . e . char* . chaine a decoder . +c . nbsign . s . 1 . nombre de signes dans la chaine . +c . typsig . s . 3 . type des signes : . +c . . . . -1 : rien . +c . . . . 0 : entier . +c . . . . 1 : caractere*1 . +c . . . . 2 : caractere*2 . +c . valcha . s . 3 . valeur du signe s'il est caractere . +c . valent . s . 3 . valeur du signe s'il est entier . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTQURE' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) chaine + character*2 valcha(3) +c + integer nbsign + integer typsig(3), valent(3) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer lgchai, lgsign + integer iaux, ideb + integer iaux1, iaux2 +c + character*5 fmt +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + > '(''Impossible de lire cette chaine en tant que nombre :'')' +c + texte(2,10) = '(''This string cannot be read as a number :'')' +c +c 1.2. ==> valeurs par defaut +c + do 12 , iaux = 1 , 3 + typsig(iaux) = -1 + valent(iaux) = 0 + valcha(iaux) = ' ' + 12 continue +c +c==== +c 2. longueur de la chaine +c==== +c + call utlgut ( lgchai, chaine, + > ulsort, langue, codret ) +c +c==== +c 2. Decodage +c==== +c + if ( codret.eq.0 ) then +c + ideb = 1 + nbsign = 0 +c + 20 continue +c +c 2.1. ==> iaux1 = premier caractere non-blanc +c + iaux1 = 0 + do 211 , iaux = ideb , lgchai + if ( chaine(iaux:iaux).ne.' ' ) then + iaux1 = iaux + goto 212 + endif + 211 continue +c + 212 continue + if ( iaux1.eq.0 ) then + goto 30 + endif +c +c 2.2. ==> iaux2 = premier caractere blanc suivant +c + ideb = iaux1 + 1 + iaux2 = lgchai + 1 + do 221 , iaux = ideb , lgchai + if ( chaine(iaux:iaux).eq.' ' ) then + iaux2 = iaux + goto 222 + endif + 221 continue +c + 222 continue +c +c 2.3. ==> quel type de signe ? +c + nbsign = nbsign + 1 +c + lgsign = iaux2 - iaux1 +c + if ( lgsign.eq.1 ) then +c + if ( chaine(iaux1:iaux1).eq.'0' .or. + > chaine(iaux1:iaux1).eq.'1' .or. + > chaine(iaux1:iaux1).eq.'2' .or. + > chaine(iaux1:iaux1).eq.'3' .or. + > chaine(iaux1:iaux1).eq.'4' .or. + > chaine(iaux1:iaux1).eq.'5' .or. + > chaine(iaux1:iaux1).eq.'6' .or. + > chaine(iaux1:iaux1).eq.'7' .or. + > chaine(iaux1:iaux1).eq.'8' .or. + > chaine(iaux1:iaux1).eq.'9' ) then +c + typsig(nbsign) = 0 +c + else +c + typsig(nbsign) = 1 + valcha(nbsign)(1:2) = chaine(iaux1:iaux1)//' ' +c + endif +c + elseif ( lgsign.eq.2 ) then +c + iaux = iaux1+ 1 +c + if ( + > ( chaine(iaux1:iaux1).eq.'-' .or. chaine(iaux1:iaux1).eq.'0' .or. + > chaine(iaux1:iaux1).eq.'1' .or. chaine(iaux1:iaux1).eq.'2' .or. + > chaine(iaux1:iaux1).eq.'3' .or. chaine(iaux1:iaux1).eq.'4' .or. + > chaine(iaux1:iaux1).eq.'5' .or. chaine(iaux1:iaux1).eq.'6' .or. + > chaine(iaux1:iaux1).eq.'7' .or. chaine(iaux1:iaux1).eq.'8' .or. + > chaine(iaux1:iaux1).eq.'9' ) .and. + > ( chaine(iaux:iaux).eq.'0' .or. chaine(iaux:iaux).eq.'1' .or. + > chaine(iaux:iaux).eq.'2' .or. chaine(iaux:iaux).eq.'3' .or. + > chaine(iaux:iaux).eq.'4' .or. chaine(iaux:iaux).eq.'5' .or. + > chaine(iaux:iaux).eq.'6' .or. chaine(iaux:iaux).eq.'7' .or. + > chaine(iaux:iaux).eq.'8' .or. chaine(iaux:iaux).eq.'9' ) ) then +c + typsig(nbsign) = 0 +c + else +c + typsig(nbsign) = 2 + valcha(nbsign)(1:2) = chaine(iaux1:iaux) +c + endif +c + else +c + typsig(nbsign) = 0 +c + endif +c +c 2.4. ==> decodage du numero eventuel +c + if ( typsig(nbsign).eq.0 ) then +c + fmt = '(I )' + if ( lgsign.lt.10 ) then + write(fmt(3:3),'(i1)') lgsign + else + write(fmt(3:4),'(i2)') lgsign + endif + read (chaine(iaux1:iaux2-1),fmt,err=24,end=24) valent(nbsign) + goto 25 + 24 continue + typsig(nbsign) = -1 + write (ulsort,texte(langue,10)) + write (ulsort,*) chaine(iaux1:iaux2) + codret = 1 +c + endif +c +c 2.5. ==> on recommence +c + 25 continue +c + ideb = iaux2 +c + goto 20 +c + endif +c==== +c 3. la fin +c==== +c + 30 continue +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utre01.F b/src/tool/Utilitaire/utre01.F new file mode 100644 index 00000000..9b08154a --- /dev/null +++ b/src/tool/Utilitaire/utre01.F @@ -0,0 +1,240 @@ + subroutine utre01 ( typenh, option, + > norenu, nbelem, nbento, + > adenho, adenca, adenic, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - REnumerotation - 01 +c -- -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : nombre d'entites actives . +c . . . . 3 : nombre d'entites . +c . . . . 5 : branche HOMARD . +c . . . . 7 : branche Calcul . +c . . . . 11 : branche InfoSupE associee . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . nbelem . e . 1 . nbr d'elements utiles et contenant entites . +c . nbento . e . 1 . nombre d'entites . +c . adenho . s . 1 . adresse de la numerotation dans HOMARD . +c . adenca . s . 1 . adresse de la numerotation dans le calcul . +c . adenic . s . 1 . adresse de la numerotation dans le calcul . +c . . . . supplementaire (InfoSupE) . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : probleme d'ecriture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTRE01' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, option + integer nbelem, nbento + integer adenho, adenca, adenic +c + character*8 norenu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 +c + character*1 saux01 + character*3 saux03 +#ifdef _DEBUG_HOMARD_ + character*6 saux06 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Allocations des renumerotations relatives aux '',a)' + texte(1,5) = '(''Attributs impossibles a ecrire.'')' + texte(1,6) = '(''Allocations impossibles.'')' +c + texte(2,4) = '(''Allocations of renumbering for '',a)' + texte(2,5) = '(''Attributes cannot be written.'')' + texte(2,6) = '(''Allocations cannot be done.'')' +c +#ifdef _DEBUG_HOMARD_ + if ( typenh.gt.0 ) then +c + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + write(ulsort,*) 'nbelem = ', nbelem + saux06 = 'nb'//suffix(2,typenh)(1:2)//'to' + write(ulsort,*) saux06, ' = ', nbento +c + endif +#endif +c +c 1.2. ==> types d'entites +c + saux03 = '.'//suffix(3,typenh)(1:2) +cgn if (saux03(2:3).eq.'Ar' )then +cgn write(ulsort,*) 'glop' +cgn endif +c +c==== +c 2. Les attributs +c==== +c + iaux = 3 + 2*typenh +c + if ( mod(option,2).eq.0 ) then + call gmecat ( norenu, iaux , nbelem, codre1 ) + else + codre1 = 0 + endif +c + if ( mod(option,3).eq.0 ) then + call gmecat ( norenu, iaux+1, nbento, codre2 ) + else + codre2 = 0 + endif +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) + if ( codret.ne.0 ) then + codret = 1 + endif +c +c==== +c 3. Allocations +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. Allocations ; codret = ', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( mod(option,5).eq.0 .and. nbelem.ne.0 ) then + call gmaloj ( norenu//saux03//'HOMARD', ' ', + > nbelem, adenho, codre1 ) + else + codre1 = 0 + endif +c + if ( mod(option,7).eq.0 .and. nbento.ne.0 ) then + call gmaloj ( norenu//saux03//'Calcul', ' ', + > nbento, adenca, codre2 ) + else + codre2 = 0 + endif +c + if ( mod(option,11).eq.0 .and. nbento.ne.0 ) then + write(saux01,'(i1)') typenh+2 + call gmaloj ( norenu//'.InfoSupE.Tab'//saux01, ' ', + > nbento, adenic, codre3 ) + call gmecat ( norenu//'.InfoSupE', typenh+2, nbento, codre4 ) + else + codre3 = 0 + codre4 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) + if ( codret.ne.0 ) then + codret = 2 + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + write(ulsort,texte(langue,4+codret)) + call gmprsx (nompro,norenu) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utre02.F b/src/tool/Utilitaire/utre02.F new file mode 100644 index 00000000..284cbf59 --- /dev/null +++ b/src/tool/Utilitaire/utre02.F @@ -0,0 +1,212 @@ + subroutine utre02 ( typenh, option, norenu, + > nbena0, nbent0, nbenac, nbento, + > adenho, adenca, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - REnumerotation - 02 +c -- -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des tailles a modifier . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : branche HOMARD . +c . . . . 3 : branche Calcul . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . nbena0 . e . 1 . ancien nbr d'el utiles et contenant entites. +c . nbent0 . e . 1 . ancien nombre d'entites . +c . nbenac . e . 1 . nombre d'entites actives . +c . nbento . e . 1 . nombre d'entites . +c . adenho . s . 1 . adresse de la numerotation dans HOMARD . +c . adenca . s . 1 . adresse de la numerotation dans le calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : probleme d'ecriture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTRE02' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, option + integer nbena0, nbent0, nbenac, nbento + integer adenho, adenca +c + character*8 norenu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 + integer un +c + character*3 saux03 +#ifdef _DEBUG_HOMARD_ + character*6 saux06 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Modification des renumerotations relatives aux '',a)' + texte(1,5) = '(''Option :'',i10)' +c + texte(2,4) = '(''Modifications of renumbering for '',a)' + texte(2,5) = '(''Option :'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> types d'entites +c + saux03 = '.'//suffix(3,typenh)(1:2) +c + codret = 0 +c +c==== +c 2. Modification +c==== +c + if ( option.ne.0 ) then +c + un = 1 + iaux = 3 + 2*typenh +c +c 2.1. ==> Branche HOMARD +c + if ( mod(option,2).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + saux06 = 'nb'//suffix(2,typenh)(1:2)//'a0' + write(ulsort,*) saux06, ' = ', nbena0 + saux06 = 'nb'//suffix(2,typenh)(1:2)//'ac' + write(ulsort,*) saux06, ' = ', nbenac +#endif +c + call gmecat ( norenu, iaux , nbenac, codre1 ) + call gmmod ( norenu//saux03//'HOMARD', + > adenho, nbena0, nbenac, un, un, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.2. ==> Branche Calcul +c + if ( mod(option,3).eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + saux06 = 'nb'//suffix(2,typenh)(1:2)//'t0' + write(ulsort,*) saux06, ' = ', nbent0 + saux06 = 'nb'//suffix(2,typenh)(1:2)//'to' + write(ulsort,*) saux06, ' = ', nbento +#endif +c + call gmecat ( norenu, iaux+1, nbento, codre1 ) + call gmmod ( norenu//saux03//'Calcul', + > adenca, nbent0, nbento, un, un, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + call gmprsx (nompro,norenu) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utre03.F b/src/tool/Utilitaire/utre03.F new file mode 100644 index 00000000..0ff07b33 --- /dev/null +++ b/src/tool/Utilitaire/utre03.F @@ -0,0 +1,281 @@ + subroutine utre03 ( typenh, option, + > norenu, + > nbenac, nbento, adenho, adenca, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - REnumerotation - 03 +c -- -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des adresses a chercher . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : nombre d'entites actives . +c . . . . 3 : nombre d'entites . +c . . . . 5 : branche HOMARD . +c . . . . 7 : branche Calcul . +c . . . . Si option<0, on controle avant de chercher . +c . . . . les adresses que le tableau est vraiment . +c . . . . alloue ; il faut donc decoder les attributs. +c . . . . avant les adresses . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . nbenac . es . 1 . nombre d'entites actives . +c . nbento . es . 1 . nombre d'entites . +c . adenho . s . 1 . adresse de la numerotation dans HOMARD . +c . adenca . s . 1 . adresse de la numerotation dans le calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : probleme d'ecriture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTRE03' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, option + integer nbenac, nbento + integer adenho, adenca +c + character*8 norenu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + character*3 saux03 +#ifdef _DEBUG_HOMARD_ + character*6 saux06 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Adresses des renumerotations relatives aux '',a)' + texte(1,5) = '(''Option :'',i10)' + texte(1,6) = '(''Erreur dans le decodage de nbenac'')' + texte(1,7) = '(''Erreur dans le decodage de nbento'')' + texte(1,8) = '(''Erreur dans l''''adresse de EnHOMARD'')' + texte(1,9) = '(''Erreur dans l''''adresse de EnCalcul'')' +c + texte(2,4) = '(''Adresses of renumbering for '',a)' + texte(2,5) = '(''Option :'',i10)' + texte(2,6) = '(''Error while uncoding nbenac'')' + texte(2,7) = '(''Error while uncodin nbento'')' + texte(2,8) = '(''Error in address of EnHOMARD'')' + texte(2,9) = '(''Error in address of EnCalcul'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> types d'entites +c + saux03 = '.'//suffix(3,typenh)(1:2) +c + codret = 0 +c +c==== +c 2. Recuperation +c==== +c + if ( option.ne.0 ) then +c + iaux = 3 + 2*typenh +c +c 2.1. ==> Nombre d'entites actives +c + if ( codret.eq.0 ) then +c + if ( mod(option,2).eq.0 .or. + > mod(option,5).eq.0 .or. mod(option,7).eq.0 ) then +c + call gmliat ( norenu, iaux , nbenac, codret ) + if ( codret.ne.0 ) then + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + saux06 = 'nb'//suffix(2,typenh)(1:2)//'ac' + write (ulsort,*) '==> ', saux06, ' = ', nbenac + endif +#endif +c + endif +c + endif +c +c 2.2. ==> Nombre d'entites +c + if ( codret.eq.0 ) then +c + if ( mod(option,3).eq.0 ) then +c + call gmliat ( norenu, iaux+1, nbento, codret ) + if ( codret.ne.0 ) then + codret = 2 + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + saux06 = 'nb'//suffix(2,typenh)(1:2)//'to' + write (ulsort,*) '==> ', saux06, ' = ', nbento + endif +#endif +c + endif +c + endif +c +c 2.3. ==> Branche HOMARD +c + if ( codret.eq.0 ) then +c + if ( mod(option,5).eq.0 ) then +c + if ( option.gt.0 .or. + > ( option.lt.0 .and. nbenac.gt.0 ) ) then + call gmadoj ( norenu//saux03//'HOMARD', adenho, jaux, codret ) + if ( codret.ne.0 ) then + codret = 3 + endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + saux06 = 'ad'//suffix(2,typenh)(1:2)//'ho' + write (ulsort,*) '==> ', saux06, ' = ', adenho + endif +#endif + endif +c + endif +c + endif +c +c 2.4. ==> Branche Calcul +c + if ( codret.eq.0 ) then +c + if ( mod(option,7).eq.0 ) then +c + jaux = 0 + if ( option.gt.0 ) then + jaux = 1 + elseif ( mod(option,2).lt.0 .and. + > nbento.gt.0 .and. nbenac.gt.0 ) then + jaux = 1 + elseif ( option.lt.0 .and. nbenac.gt.0 ) then + jaux = 1 + endif +c + if ( jaux.gt.0 ) then + call gmadoj ( norenu//saux03//'Calcul', adenca, jaux, codret ) + if ( codret.ne.0 ) then + codret = 4 + endif +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + saux06 = 'ad'//suffix(2,typenh)(1:2)//'ca' + write (ulsort,*) '==> ', saux06, ' = ', adenca + endif +#endif + endif +c + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5+codret)) + call gmprsx (nompro,norenu) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utre04.F b/src/tool/Utilitaire/utre04.F new file mode 100644 index 00000000..eff9f0b0 --- /dev/null +++ b/src/tool/Utilitaire/utre04.F @@ -0,0 +1,190 @@ + subroutine utre04 ( typenh, option, + > norenu, + > lgenin, adenin, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - REnumerotation - 04 +c -- -- -- +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des adresses a chercher . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 11 : branche InfoSupE associee . +c . . . . Si option<0, on controle avant de chercher . +c . . . . les adresses que le tableau est vraiment . +c . . . . alloue ; il faut donc decoder les attributs. +c . . . . avant les adresses . +c . norenu . e . char8 . nom de la branche Renum du maillage HOMARD . +c . lgenin . s . 1 . longueur de la numer. init dans le calcul n. +c . adenin . s . 1 . adresse de la numer. init dans le calcul n . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : probleme d'ecriture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTRE04' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, option + integer lgenin, adenin +c + character*8 norenu +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + character*1 saux01 +#ifdef _DEBUG_HOMARD_ + character*6 saux06 +#endif +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Adresses des renumerotations relatives aux '',a)' + texte(1,5) = '(''Option :'',i10)' + texte(1,10) = '(''Erreur dans l''''adresse de InfoSupe'')' +c + texte(2,4) = '(''Adresses of renumbering for '',a)' + texte(2,5) = '(''Option :'',i10)' + texte(2,10) = '(''Error in address of InfoSupe'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> types d'entites +c + codret = 0 +c + if ( option.ne.0 ) then +c +c==== +c 2. Recuperation +c==== +c + iaux = 3 + 2*typenh +c + if ( mod(option,11).eq.0 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( norenu//'.InfoSupE', typenh+2, lgenin, codret ) +c + endif +c + if ( lgenin.gt.0 ) then +c + if ( codret.eq.0 ) then +c + write(saux01,'(i1)') typenh+2 + call gmadoj ( norenu//'.InfoSupE.Tab'//saux01, + > adenin, jaux, codret ) +c + endif +c + endif +c + if ( codret.ne.0 ) then + codret = 5 + endif +c + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5+codret)) + call gmprsx (nompro,norenu) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utrech.F b/src/tool/Utilitaire/utrech.F new file mode 100644 index 00000000..dfe30896 --- /dev/null +++ b/src/tool/Utilitaire/utrech.F @@ -0,0 +1,189 @@ + subroutine utrech ( reel, cadrag, lgchac, chacar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - convertit un REel en CHaine de caractere +c -- -- -- +c +c Si la chaine fournie est plus longue que le nombre de chiffres a +c ecrire, on complete par des blancs a droite ou a gauche, ou des 0 +c a gauche selon le type de cadrage demande. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . reel . e . 1 . reel a convertir . +c . cadrag . e . char*1 . type de cadrage d'entier ecrit . +c . . . . g/G : le nombre est cadre a gauche : '83 '. +c . . . . d/D : le nombre est cadre a droite : ' 83'. +c . . . . et on complete par des blancs . +c . lgchac . s . 1 . longueur de la chaine obtenue . +c . chacar . s .char*(*). chaine de caractere . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c . . . . 2 : le nombre est trop grand . +c . . . . 3 : type de cadrage inconnu . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTENCH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + double precision reel +c + integer lgchac +c + character*1 cadrag + character*(*) chacar +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer lgfmt + parameter ( lgfmt = 14 ) +c + integer iaux, lgch00 +c + logical cadgau +c + character*7 fmt +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = '(''Reel a convertir : '',g14.5)' + texte(1,4) = '(''La chaine est trop petite : longueur = '',i4)' + texte(1,5) = '(''Il faudrait au moins '',i4,'' places.'')' + texte(1,7) = '(''Le type de cadrage est mauvais : '',a1)' +c + texte(2,10) = '(''Real to convert : '',g14.5)' + texte(2,4) = '(''The string is too short : length = '',i4)' + texte(2,5) = '(''At less'',i4,'' places are needed.'')' + texte(2,7) = '(''Bad choice : '',a1)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) reel +#endif +c +c==== +c 2. decodage +c==== +c + codret = 0 +c +c 2.1. ==> type de cadrage +c + if ( cadrag.eq.'d' .or. cadrag.eq.'D' ) then + cadgau = .false. + elseif ( cadrag.eq.'g' .or. cadrag.eq.'G' ) then + cadgau = .true. + else + codret = 3 + endif +c +c 2.2. ==> verification de la longueur +c + lgch00 = len(chacar) + if ( lgfmt.gt.lgch00 ) then + codret = 1 + endif +c +c 2.3. ==> ecriture +c + if ( codret.eq.0 ) then +c + fmt = '(G .5)' + write(fmt(3:4),'(i2)') lgfmt +c + do 23 , iaux = 1 , lgch00 + chacar(iaux:iaux) = ' ' + 23 continue +c + if ( cadgau ) then + write (chacar(1:lgfmt),fmt) reel + lgchac = lgfmt + else + write (chacar(lgch00-lgfmt+1:lgch00),fmt) reel + lgchac = lgch00 + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,10)) reel + if ( codret.eq.1 ) then + write (ulsort,texte(langue,4)) lgch00 + write (ulsort,texte(langue,5)) lgfmt + elseif ( codret.eq.3 ) then + write (ulsort,texte(langue,7)) cadrag + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utrptc.F b/src/tool/Utilitaire/utrptc.F new file mode 100644 index 00000000..d302bc06 --- /dev/null +++ b/src/tool/Utilitaire/utrptc.F @@ -0,0 +1,138 @@ + subroutine utrptc ( nomobj, + > nombre, lgtabl, + > adpoin, adtail, adtabl, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Recuperation d'un objet de type PtTabC08 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomobj . es . char8 . nom de l'objet PtTabC08 . +c . nombre . s . 1 . nombre d'entrees ; le tableau Pointeur est . +c . . . . dimensionne (0:nombre) . +c . lgtabl . s . 1 . longueur commune a Taille et Table . +c . adpoin . s . 1 . adresse de Pointeur . +c . adtail . s . 1 . adresse de Taille . +c . adtabl . s . 1 . adresse de Table . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTRPTC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + character*(*) nomobj +c + integer nombre, lgtabl + integer adpoin, adtail, adtabl +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj ) + call gmprsx (nompro, nomobj//'.Pointeur' ) + call gmprsx (nompro, nomobj//'.Taille' ) + call gmprsx (nompro, nomobj//'.Table' ) +#endif +c +c==== +c 2. Recuperation +c==== +c + call gmliat ( nomobj, 1, nombre, codre1 ) + call gmadoj ( nomobj//'.Pointeur', adpoin, iaux, codre2 ) + call gmliat ( nomobj, 2, lgtabl, codre3 ) + call gmadoj ( nomobj//'.Taille', adtail, iaux, codre4 ) + call gmadoj ( nomobj//'.Table' , adtabl, iaux, codre5 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uts8ch.F b/src/tool/Utilitaire/uts8ch.F new file mode 100644 index 00000000..8635bde8 --- /dev/null +++ b/src/tool/Utilitaire/uts8ch.F @@ -0,0 +1,168 @@ + subroutine uts8ch ( tabch8, lgchac, chacar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - transfere un tableau de String*8 dans une CHaine +c -- - - -- +c Remarque : on transfere stricto sensu le nombre de caracteres +c demandes, sans se preoccuper de savoir s'il y a des +c blancs ou des "mauvais" caracteres. +c Remarque : si la chaine est declaree plus grande que le nombre de +c caracteres a transferer, on complete a droite par des +c blancs. +c Exemple : +c 12345678 +c : tabch8 (1) = 'Sous le ' +c tabch8 (2) = 'pont Mir' +c tabch8 (3) = 'abeau co' +c tabch8 (4) = 'ule la S' +c tabch8 (5) = 'eine ' +c +c lgchac = 43 +c chacar = 'Sous le pont Mirabeau coule la Seine ' +c 1234567890123456789012345678901234567890123 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . tabch8 . e . * . tableau a transferer . +c . lgchac . e . 1 . nombre de caracteres a transferer . +c . chacar . s .char*(*). chaine de caractere . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : chaine trop courte . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTS8CH' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer lgchac +c + character*8 tabch8(*) + character*(*) chacar +c + integer ulsort, langue, codret +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lencha, nbchar, nbpack +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''La chaine est declaree en char*'',i4)' + texte(1,5) = '(''mais on veut transferer '',i4,'' caracteres !'')' +c + texte(2,4) = '(''The string is declared as char*'',i4)' + texte(2,5) = '(''but, '',i4,'' characters must be moved !'')' +c +c==== +c 2. verification de la longueur +c==== +c + codret = 0 +c + lencha = len(chacar) + if ( lgchac.gt.lencha ) then + codret = 1 + endif +c +c==== +c 3. transfert +c==== +c + if ( codret.eq.0 ) then +c + nbchar = mod(lgchac,8) + nbpack = ( lgchac - nbchar ) / 8 +c + jaux = 1 + do 31 , iaux = 1 , nbpack + chacar(jaux:jaux+7) = tabch8(iaux) + jaux = jaux + 8 + 31 continue +c + if ( nbchar.gt.0 ) then + chacar(jaux:jaux+nbchar-1) = tabch8(nbpack+1)(1:nbchar) + endif +c + jaux = jaux+nbchar + do 32 , iaux = jaux , lencha + chacar(iaux:iaux) = ' ' + 32 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) lencha + write (ulsort,texte(langue,5)) lgchac + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsen2.F b/src/tool/Utilitaire/utsen2.F new file mode 100644 index 00000000..39eef793 --- /dev/null +++ b/src/tool/Utilitaire/utsen2.F @@ -0,0 +1,126 @@ + subroutine utsen2 ( memeco, + > coose1, coose2, coo1, coo2, choix ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SEgment - Noeud - dimension 2 +c -- -- - - +c ______________________________________________________________________ +c +c teste si les deux noeuds de coordonnees coo1 et coo2 sont du meme cote +c par rapport au segment delimite par les sommets de coordonnees +c coose1, coose2 +c programme en dimension 2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . memeco . s . 1 . vrai ou faux selon que les noeuds sont du . +c . . . . meme cote du segment ou non . +c . coose1 . e . 2 . coordonnees du sommet 1 du segment . +c . coose2 . e . 2 . coordonnees du sommet 2 du segment . +c . coo1 . e . 2 . coordonnees du premier noeud . +c . coo2 . e . 2 . coordonnees du second noeud . +c . choix . e . 1 . 1, si on accepte un noeud sur le segment . +c . . . . 0, si on rejette un noeud sur le segment . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSEN2' ) +c +c 0.2. ==> communs +c +#include "precis.h" +c +c 0.3. ==> arguments +c + integer choix +c + double precision coose1(2), coose2(2), coo1(2), coo2(2) +c + logical memeco +c +c 0.4. ==> variables locales +c + double precision pvect1, pvect2 + double precision daux1 + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c pour analyser les cas ou le noeud est sur le segment, on utilise +c deux versions du test selon la demande. +c si on exclut le segment, il faut tester strictement positif +c si on l'accepte, on tolere une egalite a zero. +c + if ( choix.eq.0 ) then + daux1 = epsima + else + daux1 = -epsima + endif +c +c==== +c 2. Controle +c On compare les directions des produits vectoriels entre le +c vecteur directeur du segment et le vecteur entre un sommet et +c le noeud a tester. +c Pour pouvoir pieger les cas ou le noeud est sur le segment, on +c teste le caractere strictement positif ou positif du produit +c scalaire selon la demande. +c==== +cgn 1000 format('. ',a,' :',3g13.5) +cgn write (1,1000) 'coose1 ', coose1(1), coose1(2) +cgn write (1,1000) 'coose2 ', coose2(1), coose2(2) +cgn write (1,1000) 'coo1', coo1(1), coo1(2) +cgn write (1,1000) 'coo2', coo2(1), coo2(2) +c +c 2.1. ==> pvect1 represente la composante z du produit +c vectoriel s1s2 x s1n1 +c + pvect1 = (coose2(1)-coose1(1)) * (coo1(2)-coose1(2)) + > - (coose2(2)-coose1(2)) * (coo1(1)-coose1(1)) +c +c 2.2. ==> represente la composante z du produit +c vectoriel s1s2 x s1n2 +c + pvect2 = (coose2(1)-coose1(1)) * (coo2(2)-coose1(2)) + > - (coose2(2)-coose1(2)) * (coo2(1)-coose1(1)) +c +cgn write (1,1000) 'pvect1', pvect1 +cgn write (1,1000) 'pvect2', pvect2 + if ( pvect1*pvect2.lt.daux1 ) then + memeco = .false. + else + memeco = .true. + endif +c + end diff --git a/src/tool/Utilitaire/utsen3.F b/src/tool/Utilitaire/utsen3.F new file mode 100644 index 00000000..abe769c2 --- /dev/null +++ b/src/tool/Utilitaire/utsen3.F @@ -0,0 +1,142 @@ + subroutine utsen3 ( memeco, + > coose1, coose2, coo1, coo2, choix ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SEgment - Noeud - dimension 3 +c -- -- - - +c ______________________________________________________________________ +c +c teste si les deux noeuds de coordonnees coo1 et coo2 sont du meme cote +c par rapport au segment delimite par les sommets de coordonnees +c coose1, coose2 +c programme en dimension 3 +c remarque : on suppose que tous les noeuds sont dans le meme plan +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . memeco . s . 1 . vrai ou faux selon que les noeuds sont du . +c . . . . meme cote du segment ou non . +c . coose1 . e . 3 . coordonnees du sommet 1 du segment . +c . coose2 . e . 3 . coordonnees du sommet 2 du segment . +c . coo1 . e . 3 . coordonnees du premier noeud . +c . coo2 . e . 3 . coordonnees du second noeud . +c . choix . e . 1 . 1, si on accepte un noeud sur le segment . +c . . . . 0, si on rejette un noeud sur le segment . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSEN3' ) +c +c 0.2. ==> communs +c +#include "precis.h" +c +c 0.3. ==> arguments +c + integer choix +c + double precision coose1(3), coose2(3), coo1(3), coo2(3) +c + logical memeco +c +c 0.4. ==> variables locales +c + double precision pvect1(3), pvect2(3) + double precision daux1 + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c pour analyser les cas ou le noeud est sur le segment, on utilise +c deux versions du test selon la demande. +c si on exclut le segment, il faut tester strictement positif +c si on l'accepte, on tolere une egalite a zero. +c + if ( choix.eq.0 ) then + daux1 = epsima + else + daux1 = -epsima + endif +c +c==== +c 2. Controle +c On compare les directions des produits vectoriels entre le +c vecteur directeur du segment et le vecteur entre un sommet et +c le noeud a tester. +c Pour pouvoir pieger les cas ou le noeud est sur le segment, on +c teste le caractere strictement positif ou positif du produit +c scalaire selon la demande. +c==== +cgn 1000 format('. ',a,' :',3g13.5) +cgn write (1,1000) 'coose1 ', coose1(1), coose1(2), coose1(3) +cgn write (1,1000) 'coose2 ', coose2(1), coose2(2), coose2(3) +cgn write (1,1000) 'coo1', coo1(1), coo1(2), coo1(3) +cgn write (1,1000) 'coo2', coo2(1), coo2(2), coo2(3) +c +c 2.1. ==> pvect1 represente le produit vectoriel s1s2 x s1n1 +c + pvect1(1) = (coose2(2)-coose1(2)) * (coo1(3)-coose1(3)) + > - (coose2(3)-coose1(3)) * (coo1(2)-coose1(2)) +c + pvect1(2) = (coose2(3)-coose1(3)) * (coo1(1)-coose1(1)) + > - (coose2(1)-coose1(1)) * (coo1(3)-coose1(3)) +c + pvect1(3) = (coose2(1)-coose1(1)) * (coo1(2)-coose1(2)) + > - (coose2(2)-coose1(2)) * (coo1(1)-coose1(1)) +c +c 2.2. ==> pvect2 represente le produit vectoriel s1s2 x s1n2 + + pvect2(1) = (coose2(2)-coose1(2)) * (coo2(3)-coose1(3)) + > - (coose2(3)-coose1(3)) * (coo2(2)-coose1(2)) +c + pvect2(2) = (coose2(3)-coose1(3)) * (coo2(1)-coose1(1)) + > - (coose2(1)-coose1(1)) * (coo2(3)-coose1(3)) +c + pvect2(3) = (coose2(1)-coose1(1)) * (coo2(2)-coose1(2)) + > - (coose2(2)-coose1(2)) * (coo2(1)-coose1(1)) +c +cgn write (1,1000) 'pvect1', pvect1 +cgn write (1,1000) 'pvect2', pvect2 +cgn write (1,1000) 'pvect1*pvect2', pvect1(1)*pvect2(1) + +cgn > pvect1(2)*pvect2(2) + +cgn > pvect1(3)*pvect2(3) + if ( ( pvect1(1)*pvect2(1) + + > pvect1(2)*pvect2(2) + + > pvect1(3)*pvect2(3) ) .lt.daux1 ) then + memeco = .false. + else + memeco = .true. + endif +c + end diff --git a/src/tool/Utilitaire/utsex0.F b/src/tool/Utilitaire/utsex0.F new file mode 100644 index 00000000..72001237 --- /dev/null +++ b/src/tool/Utilitaire/utsex0.F @@ -0,0 +1,283 @@ + subroutine utsex0 ( nocsol, option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - EXtrusion - phase 0 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . e . char8 . nom de l'objet solution a modifier . +c . option . e . 1 . option de la modification . +c . . . . 1 : passage du 3D au 2D . +c . . . . 2 : passage du 2D au 3D . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSEX0' ) +c +#include "nblang.h" +#include "consts.h" +#include "meddc0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "op0012.h" +#include "nbutil.h" +#include "nombqu.h" +#include "nombhe.h" +c +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer option +c + character*8 nocsol +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer tbiaux(2,3) +c + integer edsuav, edsuap, edsaav, edsaap, nbenti + integer nuedel +c + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Solution sur le domaine '',i1,''D'')' + texte(1,6) = '(''Option de conversion '',i8,'' invalide.'')' + texte(1,7) = '(''Il faut 1 ou 2.'')' + texte(1,8) = '(''Nombre de champs : '', i3)' + texte(1,9) = '(''Nombre de paquets de fonctions : '', i3)' +c + texte(2,4) = '(''Solution to convert for '',i1,''D'')' + texte(2,6) = '(''Option for conversion '',i8,'' is uncorrect.'')' + texte(2,7) = '(''1 or 2 is needed.'')' + texte(2,8) = '(''Number of fields : '', i3)' + texte(2,9) = '(''Number of packs of functions: '', i3)' +c +#include "impr03.h" +c +c==== +c 2. Les types MED a echanger +c==== +c + if ( option.eq.1 ) then + tbiaux(1,1) = edhex8 + tbiaux(1,2) = edqua4 + tbiaux(1,3) = nbquad + tbiaux(2,1) = edpen6 + tbiaux(2,2) = edtri3 + tbiaux(2,3) = nbtria + elseif ( option.eq.2 ) then + tbiaux(1,1) = edqua4 + tbiaux(1,2) = edhex8 + tbiaux(1,3) = nbhexa + tbiaux(2,1) = edtri3 + tbiaux(2,2) = edpen6 + tbiaux(2,3) = nbpent + else + write (ulsort,texte(langue,6)) option + write (ulsort,texte(langue,7)) + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ +10000 format(43('=')) + write (ulsort,10000) + write (ulsort,90002) 'nbquac', nbquac, nbquto + write (ulsort,90002) 'nbheac', nbheac, nbheto + write (ulsort,90002) 'nbtria', nbtria + write (ulsort,90002) 'nbquad', nbquad + write (ulsort,90002) 'nbhexa', nbhexa + write (ulsort,90002) 'nbpent', nbpent + write (ulsort,texte(langue,4)) 1+fp0012(option) + write (ulsort,90002) 'tbiaux', tbiaux + call gmprsx (nompro//' - nocsol', nocsol ) +cgn call gmprsx ('nocsol.InfoCham', nocsol//'.InfoCham' ) +cgn call gmprsx (' ', '%%%%%%18' ) +cgn call gmprsx ('nocsol.InfoPaFo', nocsol//'.InfoPaFo' ) + if ( option.eq.22 ) then + call gmprsx (' ', '%%%%%%22' ) + call gmprsx (' ', '%%Fo0054' ) + call gmprsx (' ', '%%%%%%20' ) + call gmprsx (' ', '%%%%%%20.ValeursR' ) + call gmprsx (' ', '%%%%%%21' ) + call gmprsx (' ', '%%%%%%21.ValeursR' ) + elseif ( option.eq.11 ) then + call gmprsx (' ', '%%%%%%25' ) + call gmprsx (' ', '%%Fo0059' ) + call gmprsx (' ', '%%%%%%28' ) + call gmprsx (' ', '%%%%%%28.ValeursR' ) + call gmprsx (' ', '%%%%%%30' ) + call gmprsx (' ', '%%%%%%30.ValeursR' ) + endif +cgn call gmprsx (nompro, nocsol//'.InfoProf' ) + write (ulsort,10000) +#endif +c +c==== +c 3. recuperation des pointeurs lies a la solution +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call utcaso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) nbcham + write (ulsort,texte(langue,9)) nbpafo +#endif +c + endif +c +c==== +c 4. Pour chacun des deux types de mailles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. chacun des deux types ; codret', codret +#endif +c + do 40 , nuedel = 1 , 2 +c +c 4.1. ==> Les types de mailles a echanger +c + edsuav = tbiaux(nuedel,1) + edsuap = tbiaux(nuedel,2) + edsaav = tbiaux(fp0012(nuedel),1) + edsaap = tbiaux(fp0012(nuedel),2) + nbenti = tbiaux(nuedel,3) +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Passage de', edsuav,' a', edsuap + write (ulsort,90015) 'Type associe de', edsaav,' a', edsaap + write (ulsort,90002) 'nbenti', nbenti +#endif +c +c 4.2. ==> exploration des paquets de fonctions +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. paquets ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEX1', nompro +#endif + call utsex1 ( nbpafo, smem(adinpf), + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c + endif +c +c 4.3. ==> exploration des champs +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. champs ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEX3', nompro +#endif + call utsex3 ( nbcham, smem(adinch), + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c + endif +c + 40 continue +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then +cgn write (ulsort,10000) + write (ulsort,texte(langue,4)) 1+option + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) +cgn write (ulsort,10000) + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsex1.F b/src/tool/Utilitaire/utsex1.F new file mode 100644 index 00000000..6c17641f --- /dev/null +++ b/src/tool/Utilitaire/utsex1.F @@ -0,0 +1,260 @@ + subroutine utsex1 ( nbpafo, nopafo, + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - EXtrusion - phase 1 +c -- - -- - +c Changement du support dans un paquet de fonctions +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbpafo . e . 1 . nombre de paquets de fonctions a traiter . +c . nopafo . e . nbpafo . nom des objets qui contiennent la . +c . . . . description de chaque paquets de fonctions . +c . edsuav . e . 1 . type med avant . +c . edsuap . e . 1 . type med apres . +c . edsaav . e . 1 . type med associe avant . +c . edsaap . e . 1 . type med associe apres . +c . nbenti . e . 1 . nombre d'entites apres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSEX1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + integer nbpafo + integer edsuav, edsuap, edsaav, edsaap, nbenti +c + character*8 nopafo(nbpafo) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer nrpafo, nbsupp +c + integer nbfopa, nbtyas, ngauss, carsup, typint + integer adobfo, adtyge +c + character*8 obpafo +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Paquet de fonctions numero'',i3)' +c + texte(2,4) = '(''Pack of functions #'',i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Passage de', edsuav,' a', edsuap + write (ulsort,90015) 'S. associe. Passage de', edsaav,' a', edsaap + write (ulsort,90002) 'nbenti', nbenti +#endif +c + codret = 0 +c +c==== +c 2. exploration des paquets de fonctions +c==== +c + do 20 , nrpafo = 1 , nbpafo +c + obpafo = nopafo(nrpafo) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrpafo +#endif +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obpafo ) + call gmprsx (nompro, obpafo//'.Fonction' ) + call gmprsx (nompro, obpafo//'.TypeSuAs' ) + call gmprsx (nompro, '%%%%%%18' ) +#endif +c +c 2.1. ==> caracterisation du paquet de fonctions courant +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.1. caracterisation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCAPF', nompro +#endif + call utcapf ( obpafo, + > nbfopa, nbtyas, ngauss, carsup, typint, + > adobfo, adtyge, + > ulsort, langue, codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'nbfopa', nbfopa + write (ulsort,90002) 'nbtyas', nbtyas + write (ulsort,90002) 'ngauss', ngauss + write (ulsort,90002) 'carsup', carsup + write (ulsort,90002) 'typint', typint + endif +#endif +c +c 2.2. ==> types de support du paquet +c Attribut 2, nbtyas : +c si >0 : le type geometrique global quand il est unique +c si <0 : le nombre total de types geometriques associe +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.2. types de support ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + jaux = 0 + if ( nbtyas.gt.0 ) then +c + nbsupp = 1 + if ( nbtyas.eq.edsuav ) then + jaux = 1 + endif +c + else +c + nbsupp = abs(nbtyas) +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) + > 'Supports',(imem(adtyge-1+iaux),iaux=1,nbsupp) +#endif +c + do 22 , iaux = 1 , nbsupp + if ( imem(adtyge-1+iaux).eq.edsuav ) then + jaux = iaux + endif + 22 continue +c + endif +c + endif +c + endif +c +c 2.3. ==> Si l'un des supports est le bon, changement +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2.3. changement ; codret', codret +#endif +c + if ( jaux.gt.0 ) then +c +c 2.3.1. ==> modification de chaque fonction du paquet courant +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEX2', nompro +#endif + call utsex2 ( nbfopa, smem(adobfo), + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c + endif +c +c 2.3.2. ==> mise a jour du support du paquet +c + if ( codret.eq.0 ) then +c + if ( nbsupp.eq.1 ) then + call gmecat ( obpafo, 2, edsuap, codret ) + else + imem(adtyge-1+jaux) = edsuap + endif +c + endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsex2.F b/src/tool/Utilitaire/utsex2.F new file mode 100644 index 00000000..c7cc369b --- /dev/null +++ b/src/tool/Utilitaire/utsex2.F @@ -0,0 +1,213 @@ + subroutine utsex2 ( nbfonc, nofonc, + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - EXtrusion - phase 2 +c -- - -- - +c Changement des caracteristiques d'une fonction +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbfonc . e . 1 . nombre de fonctions a traiter . +c . nofonc . e . nbfonc . nom des objets qui contiennent la . +c . . . . description de chaque fonction . +c . edsuav . e . 1 . type med avant . +c . edsuap . e . 1 . type med apres . +c . edsaav . e . 1 . type med associe avant . +c . edsaap . e . 1 . type med associe apres . +c . nbenti . e . 1 . nombre d'entites apres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSEX2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer nbfonc + integer edsuav, edsuap, edsaav, edsaap, nbenti +c + character*8 nofonc(nbfonc) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 +c + integer nrfonc, nbtyas, typgeo + integer adtyas +c + character*8 obfonc +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Fonction numero'',i3)' +c + texte(2,4) = '(''Function #'',i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Fonctions. Passage de', edsuav,' a', edsuap + write (ulsort,90015) 'S. associe. Passage de', edsaav,' a', edsaap + write (ulsort,90002) 'nbenti', nbenti +#endif +c + codret = 0 +c +c==== +c 2. exploration des fonctions +c==== +c + do 20 , nrfonc = 1 , nbfonc +c + obfonc = nofonc(nrfonc) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrfonc +#endif +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, obfonc ) +#endif +c +c 2.1. ==> caracteristiques de la fonction +c + if ( codret.eq.0 ) then +c + call gmliat ( obfonc, 1, typgeo, codre1 ) + call gmliat ( obfonc, 5, nbtyas, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'typgeo', typgeo + write (ulsort,90002) 'nbtyas', nbtyas +#endif +c +c 2.2. ==> modification des caracteristiques entieres des fonctions +c + if ( typgeo.eq.edsuav ) then +c +c 2.2.1. ==> type geometrique du support et nombre de valeurs +c + if ( codret.eq.0 ) then +c + call gmecat ( obfonc, 1, edsuap, codre1 ) + call gmecat ( obfonc, 3, nbenti, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.2.2. ==> type associes eventuels +c + if ( nbtyas.gt.0 ) then +c + if ( codret.eq.0 ) then +c + call gmadoj ( obfonc//'.TypeSuAs', adtyas, iaux, codre0) +c + codret = max ( abs(codre0), codret ) +c + if ( codret.eq.0 ) then + do 222 , iaux = 1 , nbtyas + if ( imem(adtyas-1+iaux).eq.edsaav ) then + imem(adtyas-1+iaux) = edsaap + endif + 222 continue + endif +c + endif +c + endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsex3.F b/src/tool/Utilitaire/utsex3.F new file mode 100644 index 00000000..2eb3d002 --- /dev/null +++ b/src/tool/Utilitaire/utsex3.F @@ -0,0 +1,228 @@ + subroutine utsex3 ( nbcham, nocham, + > edsuav, edsuap, edsaav, edsaap, nbenti, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - EXtrusion - phase 3 +c -- - -- - +c Changement du support dans un champ +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbcham . e . 1 . nombre de champs a traiter . +c . nocham . e . nbcham . nom des objets qui contiennent la . +c . . . . description de chaque champ . +c . edsuav . e . 1 . type med avant . +c . edsuap . e . 1 . type med apres . +c . edsaav . e . 1 . type med associe avant . +c . edsaap . e . 1 . type med associe apres . +c . nbenti . e . 1 . nombre d'entites apres . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSEX3' ) +c +#include "nblang.h" +#include "esutil.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + integer nbcham + integer edsuav, edsuap, edsaav, edsaap, nbenti +c + character*8 nocham(nbcham) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer codre1, codre2 + integer codre0 +c + integer nrcham, nbtv +c + integer adcaen +c + character*8 obcham +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Champ numero'',i3)' +c + texte(2,4) = '(''Field #'',i3)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90015) 'Support. Passage de', edsuav,' a', edsuap + write (ulsort,90015) 'S. associe. Passage de', edsaav,' a', edsaap + write (ulsort,90002) 'nbenti', nbenti +#endif +c + codret = 0 +c +c==== +c 2. exploration des champs +c==== +c + do 20 , nrcham = 1 , nbcham +c + if ( codret.eq.0 ) then +c + obcham = nocham(nrcham) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nrcham +#endif +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, obcham ) + call gmprsx (nompro//' - entree', obcham//'.Cham_Ent' ) +#endif +c +c 2.1. ==> caracteristiques du champ +c + if ( codret.eq.0 ) then +c + call gmliat ( obcham, 2, nbtv, codre1 ) + call gmadoj ( obcham//'.Cham_Ent', adcaen, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + write (ulsort,90002) 'nbtv', nbtv + endif +#endif +c +c 2.2. ==> modification des caracteristiques entieres des champs +c + if ( codret.eq.0 ) then +c + do 22 , iaux = 1 , nbtv +c + jaux = adcaen +c + if ( imem(jaux).eq.edsuav ) then +c +c 2.2.1. ==> Support +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> conversion support', edsuav, edsuap +#endif + imem(jaux) = edsuap +c +c 2.2.2. ==> Nombre d'entites +c + jaux = adcaen + 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> conversion nbenti', imem(jaux), nbenti +#endif + imem(jaux) = nbenti +c +c 2.2.3. ==> Support associe eventuel +c + jaux = adcaen + 20 + if ( mod(imem(jaux),edsaav).eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '==> conversion support associe', + > imem(jaux), imem(jaux)*edsaap/edsaav +#endif + imem(jaux) = imem(jaux)*edsaap/edsaav + endif +c + endif +c + adcaen = adcaen + nbinec +c + 22 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ +cgn write (ulsort,texte(langue,4)) nrcham + call gmprsx (nompro//' - sortie', obcham//'.Cham_Ent' ) +#endif +c + endif +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsext.F b/src/tool/Utilitaire/utsext.F new file mode 100644 index 00000000..264ea320 --- /dev/null +++ b/src/tool/Utilitaire/utsext.F @@ -0,0 +1,204 @@ + subroutine utsext ( nocsol, option, typcca, + > lgetco, taetco, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - EXTrusion +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . e . char8 . nom de l'objet solution a modifier . +c . option . e . 1 . option de la modification . +c . . . . 1 : passage du 3D au 2D . +c . . . . 2 : passage du 2D au 3D . +c . typcca . e . 1 . type du code de calcul . +c . . . . 26 : SATURNE_2D (format MED) . +c . . . . 36 : SATURNE (format MED) . +c . . . . 46 : NEPTUNE_2D (format MED) . +c . . . . 56 : NEPTUNE (format MED) . +c . . . . 66 : CARMEL_2D (format MED) . +c . . . . 76 : CARMEL (format MED) . +c . lgetco . e . 1 . longueur du tableau de l'etat courant . +c . taetco . e . lgetco . tableau de l'etat courant . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSEXT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer option, typcca +c + character*8 nocsol +c + integer lgetco + integer taetco(lgetco) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codava + integer nretap, nrsset + integer iaux +c + integer sdimav, sdimap +c + character*6 saux + character*9 saux09 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + codava = codret +c +c======================================================================= + if ( codava.eq.0 ) then +c======================================================================= +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + if ( typcca.eq.26 ) then + saux09 = 'SATURNE ' + elseif ( typcca.eq.46 ) then + saux09 = 'NEPTUNE ' + else + saux09 = 'EXTRUSION' + endif +c + texte(1,4) = + > '(/,a6,1x,'''//saux09//' - PASSAGE DU CHAMP '',i1, + > ''D EN '',i1,''D'')' + texte(1,5) = '(44(''=''),/)' + texte(1,6) = '(''Option de conversion '',i8,'' invalide.'')' + texte(1,7) = '(''Il faut 1 ou 2.'')' +c + texte(2,4) = '(/,a6,1x,'''//saux09//' - FROM '',i1, + > ''D FIELD TO '',i1,''D'')' + texte(2,5) = '(38(''=''),/)' + texte(2,6) = '(''Option for conversion '',i8,'' is uncorrect.'')' + texte(2,7) = '(''1 or 2 is needed.'')' +c +c 1.4. ==> le numero de sous-etape +c + nretap = taetco(1) + nrsset = taetco(2) + 1 + taetco(2) = nrsset +c + call utcvne ( nretap, nrsset, saux, iaux, codret ) +c +c 1.5 ==> le titre +c + if ( option.eq.1 ) then + sdimav = 3 + sdimap = 2 + elseif ( option.eq.2 ) then + sdimav = 2 + sdimap = 3 + else + sdimav = 0 + sdimap = 0 + codret = 1 + endif +c + write (ulsort,texte(langue,4)) saux, sdimav, sdimap + write (ulsort,texte(langue,5)) +c + if ( codret.eq.1 ) then + write (ulsort,texte(langue,6)) option + write (ulsort,texte(langue,7)) + endif +c +#include "impr03.h" +c +c==== +c 2. conversion de la solution +c==== +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSEX0', nompro +#endif + call utsex0 ( nocsol, option, + > ulsort, langue, codret ) +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c +c======================================================================= + endif +c======================================================================= +c + end diff --git a/src/tool/Utilitaire/utsohe.F b/src/tool/Utilitaire/utsohe.F new file mode 100644 index 00000000..f9a41306 --- /dev/null +++ b/src/tool/Utilitaire/utsohe.F @@ -0,0 +1,124 @@ + subroutine utsohe ( somare, listar, listso ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : SOmmets d'un HExaedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . listar . e . 12 . Liste des aretes de l'hexaedre . +c . listso . s . 8 . Liste des sommets de l'hexaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), listar(12), listso(8) +c +c 0.4. ==> variables locales +c + integer iaux +c +c==== +c 1. Recherche des sommets +c==== +c + iaux = somare(1,listar(1)) + if ( iaux.eq.somare(1,listar(2)) ) then + listso(1) = iaux + listso(2) = somare(2,listar(1)) + listso(4) = somare(2,listar(2)) + if ( listso(4).eq.somare(1,listar(4)) ) then + listso(3) = somare(2,listar(4)) + else + listso(3) = somare(1,listar(4)) + endif + elseif ( iaux.eq.somare(2,listar(2)) )then + listso(1) = iaux + listso(2) = somare(2,listar(1)) + listso(4) = somare(1,listar(2)) + if ( listso(4).eq.somare(1,listar(4)) ) then + listso(3) = somare(2,listar(4)) + else + listso(3) = somare(1,listar(4)) + endif + else + listso(1) = somare(2,listar(1)) + listso(2) = iaux + if ( listso(1).eq.somare(1,listar(2)) ) then + listso(4) = somare(2,listar(2)) + else + listso(4) = somare(1,listar(2)) + endif + if ( listso(4).eq.somare(1,listar(4)) ) then + listso(3) = somare(2,listar(4)) + else + listso(3) = somare(1,listar(4)) + endif + endif +c + iaux = somare(1,listar(9)) + if ( iaux.eq.somare(1,listar(11)) ) then + listso(5) = iaux + listso(6) = somare(2,listar(9)) + listso(8) = somare(2,listar(11)) + if ( listso(8).eq.somare(1,listar(12)) ) then + listso(7) = somare(2,listar(12)) + else + listso(7) = somare(1,listar(12)) + endif + elseif ( iaux.eq.somare(2,listar(11)) )then + listso(5) = iaux + listso(6) = somare(2,listar(9)) + listso(8) = somare(1,listar(11)) + if ( listso(8).eq.somare(1,listar(12)) ) then + listso(7) = somare(2,listar(12)) + else + listso(7) = somare(1,listar(12)) + endif + else + listso(5) = somare(2,listar(9)) + listso(6) = iaux + if ( listso(5).eq.somare(1,listar(11)) ) then + listso(8) = somare(2,listar(11)) + else + listso(8) = somare(1,listar(11)) + endif + if ( listso(8).eq.somare(1,listar(12)) ) then + listso(7) = somare(2,listar(12)) + else + listso(7) = somare(1,listar(12)) + endif + endif +c + end diff --git a/src/tool/Utilitaire/utsope.F b/src/tool/Utilitaire/utsope.F new file mode 100644 index 00000000..c5a109b8 --- /dev/null +++ b/src/tool/Utilitaire/utsope.F @@ -0,0 +1,97 @@ + subroutine utsope ( somare, listar, sommet) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : SOmmets d'un PEntaedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . listar . e . 9 . Liste des aretes ordonnees suivant le penta. +c . sommet . s . * . Liste des sommets ordonnes suivant le penta. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), listar(9), sommet(*) +c +c 0.4. ==> variables locales +c + integer iaux +c +c==== +c 1. Recherche des sommets +c==== +c 1.1. ==> du cote de la face 1 +c + iaux = somare(1,listar(1)) + if ( iaux.eq.somare(1,listar(2)) ) then + sommet(1) = iaux + sommet(2) = somare(2,listar(2)) + sommet(3) = somare(2,listar(1)) + elseif ( iaux.eq.somare(2,listar(2)) )then + sommet(1) = iaux + sommet(2) = somare(1,listar(2)) + sommet(3) = somare(2,listar(1)) + else + sommet(1) = somare(2,listar(1)) + if ( sommet(1).eq.somare(1,listar(2)) ) then + sommet(2) = somare(2,listar(2)) + else + sommet(2) = somare(1,listar(2)) + endif + sommet(3) = iaux + endif +c +c 1.2. ==> du cote de la face 2 +c + iaux = somare(1,listar(4)) + if ( iaux.eq.somare(1,listar(5)) ) then + sommet(4) = iaux + sommet(5) = somare(2,listar(5)) + sommet(6) = somare(2,listar(4)) + elseif ( iaux.eq.somare(2,listar(5)) )then + sommet(4) = iaux + sommet(5) = somare(1,listar(5)) + sommet(6) = somare(2,listar(4)) + else + sommet(4) = somare(2,listar(4)) + if ( sommet(4).eq.somare(1,listar(5)) ) then + sommet(5) = somare(2,listar(5)) + else + sommet(5) = somare(1,listar(5)) + endif + sommet(6) = iaux + endif +c + end diff --git a/src/tool/Utilitaire/utsopy.F b/src/tool/Utilitaire/utsopy.F new file mode 100644 index 00000000..5aee28bb --- /dev/null +++ b/src/tool/Utilitaire/utsopy.F @@ -0,0 +1,113 @@ + subroutine utsopy ( somare, listar, sommet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : SOmmets d'une PYramide +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . listar . e . 8 . Liste des aretes ordonnees suivant la pyra . +c . sommet . s . 5 . Liste des sommets ordonnes suivant la pyra . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), listar(8), sommet(5) +c +c 0.4. ==> variables locales +c + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c S5 +c x +c . . . . +c . . . . +c . . a4. . +c . . . . +c . . x . . +c a1 . . . S4 . .a3 +c . . . . . +c . . . . +c . . . a7 . . +c . .a8 . . . +c . . . . . +c S1 . .a2 . . +c x . . . . +c a5 . . . +c x--------------------------------------------------------x +c S2 a6 S3 +c La face f5 est le quadrangle. +c La face fi, i<5, est le triangle s'appuyant sur l'arete ai. +c +c==== +c 1. Recherche des sommets +c==== +c + iaux = somare(1,listar(1)) + if ( iaux.eq.somare(1,listar(2)) ) then + sommet(5) = iaux + sommet(1) = somare(2,listar(1)) + sommet(2) = somare(2,listar(2)) + elseif ( iaux.eq.somare(2,listar(2)) )then + sommet(5) = iaux + sommet(1) = somare(2,listar(1)) + sommet(2) = somare(1,listar(2)) + else + sommet(5) = somare(2,listar(1)) + sommet(1) = iaux + if ( sommet(5).eq.somare(1,listar(2)) ) then + sommet(2) = somare(2,listar(2)) + else + sommet(2) = somare(1,listar(2)) + endif + endif +c + iaux = somare(1,listar(6)) + if ( iaux.eq.sommet(2) ) then + sommet(3) = somare(2,listar(6)) + else + sommet(3) = iaux + endif +c + iaux = somare(1,listar(7)) + if ( iaux.eq.sommet(3) ) then + sommet(4) = somare(2,listar(7)) + else + sommet(4) = iaux + endif +c + end diff --git a/src/tool/Utilitaire/utsoqu.F b/src/tool/Utilitaire/utsoqu.F new file mode 100644 index 00000000..8e1cab71 --- /dev/null +++ b/src/tool/Utilitaire/utsoqu.F @@ -0,0 +1,106 @@ + subroutine utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SOmmets d'un QUadrangle +c -- -- -- +c Remarque : cela suppose que les aretes a1, a2, a3, a4 soient donnees +c dans l'ordre standard +c Remarque : programme semblable a utoraq +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c .a1,..,a4. e . 1 . les numeros d'aretes du quadrangle . +c . sa1a2 . s . 1 . sommet commun aux aretes a1 et a2 . +c . sa2a3 . s . 1 . sommet commun aux aretes a2 et a3 . +c . sa3a4 . s . 1 . sommet commun aux aretes a3 et a4 . +c . sa4a1 . s . 1 . sommet commun aux aretes a4 et a1 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*) + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c +c 0.4. ==> variables locales +c +c==== +c 1. recherche des sommets +c==== +c +c sa4a1 a4 sa3a4 +c ._________. +c . . +c . . +c a1. .a3 +c . . +c ._________. +c sa1a2 a2 sa2a3 +c +c + if ( somare(1,a1).eq.somare(1,a2) .or. + > somare(1,a1).eq.somare(2,a2) ) then +c le 1er noeud de l'arete 1 est un sommet de a2 ; +c donc le 2nd noeud de l'arete 1 est un sommet de a4 +c + sa1a2 = somare(1,a1) + sa4a1 = somare(2,a1) +c + else +c le 1er noeud de l'arete 1 n'est pas un sommet de a2 ; +c donc c'est qu'il est un des sommets de a4 +c donc le 2nd noeud de l'arete 1 est un sommet de a2 + sa1a2 = somare(2,a1) + sa4a1 = somare(1,a1) +c + endif +c + if ( somare(1,a3).eq.somare(1,a4) .or. + > somare(1,a3).eq.somare(2,a4) ) then +c le 1er noeud de l'arete 3 est un sommet de a4 ; +c donc le 2nd noeud de l'arete 3 est un sommet de a2 + sa3a4 = somare(1,a3) + sa2a3 = somare(2,a3) +c + else +c le 1er noeud de l'arete 3 n'est pas un sommet de a4 ; +c donc c'est qu'il est un des sommets de a2 +c donc le 2nd noeud de l'arete 3 est un sommet de a4 + sa3a4 = somare(2,a3) + sa2a3 = somare(1,a3) +c + endif +c + end diff --git a/src/tool/Utilitaire/utsote.F b/src/tool/Utilitaire/utsote.F new file mode 100644 index 00000000..8a929c43 --- /dev/null +++ b/src/tool/Utilitaire/utsote.F @@ -0,0 +1,110 @@ + subroutine utsote ( somare, listar, listso ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SOmmets d'un TEtraedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c . listar . e . 6 . Liste des aretes ordonnees suivant le tetr . +c . listso . s . 4 . Liste des sommets ordonnes suivant le tetr . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*), listar(6), listso(4) +c +c 0.4. ==> variables locales +c + integer iaux +c +c==== +c 1. recherche des sommets +c==== +c la face fi est opposee au sommet ni +c n1 +c * +c . .. +c . . . a3 +c . . . +c . . . +c a1 . a2 . . n4 +c . . * +c . . . . +c . a5 . . . a6 +c . . . . +c . . .. +c . . . +c *..................................* +c n2 a4 n3 +c + iaux = somare(1,listar(1)) + if ( iaux.eq.somare(1,listar(2)) ) then +c + listso(1) = iaux + listso(2) = somare(2,listar(1)) + listso(3) = somare(2,listar(2)) +c + elseif ( iaux.eq.somare(2,listar(2)) ) then +c + listso(1) = iaux + listso(2) = somare(2,listar(1)) + listso(3) = somare(1,listar(2)) +c + elseif ( somare(2,listar(1)).eq.somare(1,listar(2)) ) then +c + listso(1) = somare(2,listar(1)) + listso(2) = iaux + listso(3) = somare(2,listar(2)) +c + else +c + listso(1) = somare(2,listar(1)) + listso(2) = iaux + listso(3) = somare(1,listar(2)) +c + endif +c + if ( somare(1,listar(6)).eq.somare(1,listar(3)) .or. + > somare(1,listar(6)).eq.somare(2,listar(3)) ) then +c + listso(4) = somare(1,listar(6)) +c + else +c + listso(4) = somare(2,listar(6)) +c + endif +c + end diff --git a/src/tool/Utilitaire/utsotr.F b/src/tool/Utilitaire/utsotr.F new file mode 100644 index 00000000..c00114e4 --- /dev/null +++ b/src/tool/Utilitaire/utsotr.F @@ -0,0 +1,100 @@ + subroutine utsotr ( somare, a1, a2, a3, + > sa1a2, sa2a3, sa3a1 ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SOmmets d'un TRiangle +c -- -- -- +c Remarque : programme semblable a utorat +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . somare . e .2*nbaret. numeros des extremites d'arete . +c .a1,a2,a3. e . 1 . les numeros d'aretes du triangle . +c . sa1a2 . s . 1 . sommet commun aux aretes 1 et 2 = S3 . +c . sa2a3 . s . 1 . sommet commun aux aretes 2 et 3 = S1 . +c . sa3a1 . s . 1 . sommet commun aux aretes 3 et 4 = S2 . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer somare(2,*) + integer a1, a2, a3 + integer sa1a2, sa2a3, sa3a1 +c +c 0.4. ==> variables locales +c +c==== +c 1. recherche des sommets +c==== +c S1 = sa2a3 +c * +c . . +c . . +c . . +c a3 . . a2 +c . . +c . . +c . . +c sa3a1 = S2*---------------*S3 = sa1a2 +c a1 +c +c Cas 1 : les aretes a1 et a3 se coupent sur le premier sommet de a1 +c + if ( somare(1,a1).eq.somare(1,a3) .or. + > somare(1,a1).eq.somare(2,a3) ) then +c + sa3a1 = somare(1,a1) + if (somare(2,a1).eq.somare(1,a2)) then + sa1a2 = somare(1,a2) + sa2a3 = somare(2,a2) + else + sa1a2 = somare(2,a2) + sa2a3 = somare(1,a2) + endif +c +c Cas 2 : les aretes a1 et a3 se coupent sur le second sommet de a1 +c + else +c + sa3a1 = somare(2,a1) + if (somare(1,a1).eq.somare(1,a2)) then + sa1a2 = somare(1,a2) + sa2a3 = somare(2,a2) + else + sa1a2 = somare(2,a2) + sa2a3 = somare(1,a2) + endif +c + endif +c + end diff --git a/src/tool/Utilitaire/utsrc1.F b/src/tool/Utilitaire/utsrc1.F new file mode 100644 index 00000000..eb7fd0a3 --- /dev/null +++ b/src/tool/Utilitaire/utsrc1.F @@ -0,0 +1,92 @@ + subroutine utsrc1 ( nbtafo, nbento, + > profil, vafott, vafosc ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - Renumeration du Calcul - option 1 +c -- - - - - +c remarque : utsrc1 et utsrc3 sont des clones +c 1 : double precision +c 3 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbento . e . 1 . nombre d'entites . +c . profil . e . nbento . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafott . a . nbtafo*. tableau temporaire de la solution . +c . . . * . . +c . vafosc . s . nbtafo*. variables en sortie pour le calcul . +c . . . * . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtafo, nbento + integer profil(nbento) +c + double precision vafott(nbtafo,*) + double precision vafosc(nbtafo,*) +c +c 0.4. ==> variables locales +c + integer nuv + integer iaux, jaux +c ______________________________________________________________________ +c +c==== +c 1. on compacte +c==== +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (1,*)'UTSRC1' + write (1,90002)' nbtafo', nbtafo + write (1,90002)' nbento', nbento +#endif + do 11 , nuv = 1, nbtafo +cgn write (1,*)'Composante', nuv + jaux = 0 + do 111, iaux = 1, nbento +cgn write (1,90112) 'profil',iaux, profil(iaux) + if ( profil(iaux).gt.0 ) then + jaux = jaux + 1 + vafosc(nuv,jaux) = vafott(nuv,iaux) +cgn write (1,90124) ' vafott',nuv,iaux,vafott(nuv,iaux) + endif + 111 continue + 11 continue +c + end diff --git a/src/tool/Utilitaire/utsrc2.F b/src/tool/Utilitaire/utsrc2.F new file mode 100644 index 00000000..182e9586 --- /dev/null +++ b/src/tool/Utilitaire/utsrc2.F @@ -0,0 +1,85 @@ + subroutine utsrc2 ( nbtafo, ngauss, nbento, + > profil, vafott, vafosc ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - Renumeration du Calcul - option 2 +c -- - - - - +c remarque : utsrc2 et utsrc4 sont des clones +c 2 : double precision +c 4 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbento . e . 1 . nombre d'entites . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . profil . e . nbento . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafott . a . nbtafo*. tableau temporaire de la solution . +c . . . * . . +c . vafosc . s . nbtafo*. variables en sortie pour le calcul . +c . . . * . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtafo, ngauss, nbento + integer profil(nbento) +c + double precision vafott(nbtafo,ngauss,*) + double precision vafosc(nbtafo,ngauss,*) +c +c 0.4. ==> variables locales +c + integer nuv, nugaus + integer iaux, jaux +c ______________________________________________________________________ +c +c==== +c 1. on compacte +c==== +c + do 11 , nuv = 1, nbtafo + jaux = 0 + do 111 , iaux = 1, nbento + if ( profil(iaux).gt.0 ) then + jaux = jaux + 1 + do 1111 , nugaus = 1 , ngauss + vafosc(nuv,nugaus,jaux) = vafott(nuv,nugaus,iaux) + 1111 continue + endif + 111 continue + 11 continue +c + end diff --git a/src/tool/Utilitaire/utsrc3.F b/src/tool/Utilitaire/utsrc3.F new file mode 100644 index 00000000..b585c533 --- /dev/null +++ b/src/tool/Utilitaire/utsrc3.F @@ -0,0 +1,92 @@ + subroutine utsrc3 ( nbtafo, nbento, + > profil, vafott, vafosc ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - Renumeration du Calcul - option 3 +c -- - - - - +c remarque : utsrc1 et utsrc3 sont des clones +c 1 : double precision +c 3 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbento . e . 1 . nombre d'entites . +c . profil . e . nbento . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafott . a . nbtafo*. tableau temporaire de la solution . +c . . . * . . +c . vafosc . s . nbtafo*. variables en sortie pour le calcul . +c . . . * . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtafo, nbento + integer profil(nbento) +c + integer vafott(nbtafo,*) + integer vafosc(nbtafo,*) +c +c 0.4. ==> variables locales +c + integer nuv + integer iaux, jaux +c ______________________________________________________________________ +c +c==== +c 1. on compacte +c==== +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (1,*)'UTSRC3' + write (1,90002)' nbtafo', nbtafo + write (1,90002)' nbento', nbento +#endif + do 11 , nuv = 1, nbtafo +cgn write (1,*)'Composante', nuv + jaux = 0 + do 111, iaux = 1, nbento +cgn write (1,90112) 'profil',iaux, profil(iaux) + if ( profil(iaux).gt.0 ) then + jaux = jaux + 1 + vafosc(nuv,jaux) = vafott(nuv,iaux) +cgn write (1,90124) ' vafott',nuv,iaux,vafott(nuv,iaux) + endif + 111 continue + 11 continue +c + end diff --git a/src/tool/Utilitaire/utsrc4.F b/src/tool/Utilitaire/utsrc4.F new file mode 100644 index 00000000..1f6c7883 --- /dev/null +++ b/src/tool/Utilitaire/utsrc4.F @@ -0,0 +1,85 @@ + subroutine utsrc4 ( nbtafo, ngauss, nbento, + > profil, vafott, vafosc ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Solution - Renumeration du Calcul - option 2 +c -- - - - - +c remarque : utsrc2 et utsrc4 sont des clones +c 2 : double precision +c 4 : entier +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbtafo . e . 1 . nombre de tableaux de la fonction . +c . nbento . e . 1 . nombre d'entites . +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . profil . e . nbento . pour chaque entite : . +c . . . . 0 : l'entite est absente du profil . +c . . . . 1 : l'entite est presente dans le profil . +c . vafott . a . nbtafo*. tableau temporaire de la solution . +c . . . * . . +c . vafosc . s . nbtafo*. variables en sortie pour le calcul . +c . . . * . . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbtafo, ngauss, nbento + integer profil(nbento) +c + integer vafott(nbtafo,ngauss,*) + integer vafosc(nbtafo,ngauss,*) +c +c 0.4. ==> variables locales +c + integer nuv, nugaus + integer iaux, jaux +c ______________________________________________________________________ +c +c==== +c 1. on compacte +c==== +c + do 11 , nuv = 1, nbtafo + jaux = 0 + do 111 , iaux = 1, nbento + if ( profil(iaux).gt.0 ) then + jaux = jaux + 1 + do 1111 , nugaus = 1 , ngauss + vafosc(nuv,nugaus,jaux) = vafott(nuv,nugaus,iaux) + 1111 continue + endif + 111 continue + 11 continue +c + end diff --git a/src/tool/Utilitaire/utsuar.F b/src/tool/Utilitaire/utsuar.F new file mode 100644 index 00000000..d12f33d7 --- /dev/null +++ b/src/tool/Utilitaire/utsuar.F @@ -0,0 +1,173 @@ + subroutine utsuar ( disare, + > hetare, merare, filare, + > ancare, nouare, + > nbarre ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des ARetes +c -- -- -- +c ______________________________________________________________________ +c +c Attention : toutes les aretes n'ont pas forcement une mere ! +c celles crees en interne a des tetraedres/triangles +c sont de la premiere generation, meme si elles +c sont a des niveaux > 1 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disare . e . nouvar . indicateurs de disparition des aretes . +c . hetare . es . nouvar . historique de l'etat des aretes . +c . merare . es . nouvar . mere des aretes . +c . filare . es . nouvar . premiere fille des aretes . +c . ancare . s . nouvar . anciens numeros des aretes conservees . +c . nouare . s .0:nouvar. nouveaux numeros des aretes conservees . +c . nbarre . s . 1 . nombre d'aretes restantes . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUAR' ) +c +c 0.2. ==> communs +c +#include "nombar.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer hetare(nouvar), merare(nouvar), filare(nouvar) + integer disare(nouvar), ancare(nouvar) + integer nouare(0:nouvar) + integer nbarre +c +c 0.4. ==> variables locales +c + integer larete, lamere, gdmere, etgmer + integer cmptr, e1, e2, et +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux ancare et nouare +c==== +c + cmptr = 0 + nouare(0) = 0 +c +c 1.1 generation des tableaux reciproques +c + do 100 , larete = 1 , nbarpe +c + if ( disare(larete).ne.0 ) then +c + nouare(larete) = 0 + hetare(larete) = 10 * int( hetare(larete) / 10 ) + 5 +c + else +c + cmptr = cmptr + 1 + ancare(cmptr) = larete + nouare(larete) = cmptr +c + endif +c + 100 continue +c +c 1.2 nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbarre = cmptr +c +c==== +c 2. modification des etats des meres eventuelles des aretes disparues +c==== +c + do 200 , larete = 1 , nbarpe +c + if ( disare(larete).ne.0 ) then +c +c mise a zero de l'etat actuel de la mere +c + lamere = merare(larete) +c + if ( lamere.ne.0 ) then + hetare(lamere) = hetare(lamere) - mod(hetare(lamere),10) + endif +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des eventuelles grand-meres des aretes +c==== +c + do 300 , larete = 1 , nbarpe +c + if ( disare(larete).ne.0 ) then +c + lamere = merare(larete) +c + if ( lamere.ne.0 ) then +c + gdmere = merare(lamere) +c + if ( gdmere.ne.0 ) then +c +c 3.1 verification de l'etat de la grand-mere +c + etgmer = mod( hetare(gdmere) , 10 ) +c + if ( etgmer.ne.2 ) then +c +c 3.1.1 verification de l'etat des soeurs de la mere +c + e1 = mod( hetare(filare(gdmere)) , 10 ) + e2 = mod( hetare(filare(gdmere)+1) , 10 ) + et = e1 + e2 +c +c 3.1.2 attribution de l'etat 'coupee en 2' a l'entite +c + if ( et .eq. 0 ) then + hetare(gdmere) = hetare(gdmere) + > - mod(hetare(gdmere),10) + > + 2 + endif +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + end diff --git a/src/tool/Utilitaire/utsuex.F b/src/tool/Utilitaire/utsuex.F new file mode 100644 index 00000000..d441944b --- /dev/null +++ b/src/tool/Utilitaire/utsuex.F @@ -0,0 +1,423 @@ + subroutine utsuex ( disnoe, ancnoe, nbnore, nbp2re, nbimre, + > hetnoe, + > famnoe, arenoe, homnoe, + > nnoeca, nnoeho, + > coonoe, + > disare, ancare, nbarre, + > hetare, somare, merare, filare, + > famare, np2are, homare, + > posifa, facare, + > distri, anctri, nbtrre, + > hettri, aretri, pertri, filtri, + > famtri, nivtri, pentri, nintri, homtri, + > ntreca, ntreho, + > disqua, ancqua, nbqure, + > hetqua, arequa, perqua, filqua, + > famqua, nivqua, hexqua, ninqua, + > nqueca, nqueho, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des entites EXtrudees +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disnoe . e . nbnoto . indicateurs de disparition des noeuds . +c . disare . e . nbarto . indicateurs de disparition des aretes . +c . distri . e . nbtrto . indicateurs de disparition des triangles . +c . disqua . e . nbquto . indicateurs de disparition des quadrangles . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 5 : mauvais type de code de calcul associe . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSUEX' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "gmenti.h" +c +#include "envex1.h" +#include "envca1.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nouvnb.h" +#include "nomber.h" +c +c 0.3. ==> arguments +c + integer disnoe(nbnoto), ancnoe(nbnoto), nbnore + integer nbp2re, nbimre + integer hetnoe(nbnoto) + integer famnoe(nouvno), arenoe(nouvno), homnoe(nouvno) + integer nnoeca(nouvno), nnoeho(renoac) + integer disare(nbarto), ancare(nbarto), nbarre + integer hetare(nbarto), somare(2,nouvar) + integer famare(nouvar), merare(nouvar), filare(nouvar) + integer homare(nouvar) + integer np2are(nouvar) + integer posifa(0:nbarto), facare(nbfaar) + integer distri(nbtrto), anctri(nbtrto), nbtrre + integer hettri(nouvtr), aretri(nouvtr,3) + integer famtri(nouvtr), pertri(nouvtr), filtri(nouvtr) + integer nivtri(nouvtr), pentri(nouvtr), nintri(nouvtr) + integer homtri(nouvtr) + integer ntreca(nouvtr), ntreho(retrac) + integer disqua(nbquto), ancqua(nbquto), nbqure + integer hetqua(nouvqu), arequa(nouvqu,4) + integer famqua(nouvqu), perqua(nouvqu), filqua(nouvqu) + integer nivqua(nouvqu), hexqua(nouvqu), ninqua(nouvqu) + integer nqueca(nouvqu), nqueho(requac) +c + double precision coonoe(nouvno,sdim) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4 + integer codre0 + integer ptrav1, ptrav2, ptrav3 + integer pnouqu + integer pnoutr + integer pnouar + integer pnouno +c + character*8 nnouqu, nnoutr, nnouar, nnouno + character*8 ntrav1, ntrav2, ntrav3 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +#include "impr03.h" +c==== +c 2. Tableaux utilitaires +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Tableaux utilitaires ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = nbnoto + 1 + call gmalot ( nnouno, 'entier ', iaux, pnouno, codre1 ) + iaux = nbarto + 1 + call gmalot ( nnouar, 'entier ', iaux, pnouar, codre2 ) + iaux = nbtrto + 1 + call gmalot ( nnoutr, 'entier ', iaux, pnoutr, codre3 ) + iaux = nbquto + 1 + call gmalot ( nnouqu, 'entier ', iaux, pnouqu, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + iaux = max(nbarto, nbtrto+nbquto) + 1 + call gmalot ( ntrav1, 'entier ', iaux, ptrav1, codre1 ) + iaux = max ( nbarto, nbtrto, nbquto ) + call gmalot ( ntrav2, 'entier ', iaux, ptrav2, codre2 ) + call gmalot ( ntrav3, 'entier ', iaux, ptrav3, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c +c + endif +c +c==== +c 3. Suppression +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. destruction ; codret', codret +#endif +c 3.1. ==> Suppression des quadrangles inutiles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.1. quadrangles ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUQU', nompro +#endif + call utsuqu ( disqua, + > hetqua, perqua, filqua, + > ancqua, imem(pnouqu), + > nbqure ) +cgn write (ulsort,90002) 'nbqure', nbqure +c + endif +c +c 3.2. ==> Suppression des triangles inutiles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.2. triangles ; codret', codret +#endif +c + if ( nbtrto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUTR', nompro +#endif + call utsutr ( distri, + > hettri, pertri, filtri, + > anctri, imem(pnoutr), + > nbtrre ) +cgn write (ulsort,90002) 'nbtrre', nbtrre +c + endif +c + endif +c +c 3.3. ==> Suppression des aretes inutiles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.3. aretes ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUAR', nompro +#endif + call utsuar ( disare, + > hetare, merare, filare, + > ancare, imem(pnouar), + > nbarre ) +cgn write (ulsort,90002) 'nbarre', nbarre +c + endif +c +c 3.4. ==> Suppression des noeuds inutiles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3.4. noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSUNO', nompro +#endif + call utsuno ( nbnoto, nbnoto, disnoe, + > hetnoe, ancnoe, imem(pnouno), + > nbnore, nbp2re, nbimre ) +cgn write (ulsort,90002) 'nbnore', nbnore +cgn write (ulsort,90002) 'nbp2re', nbp2re +cgn write (ulsort,90002) 'nbimre', nbimre +c + endif +c +c==== +c 4. Compactage des numerotation des entites detruites +c==== +c 4.1. ==> compactage des triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.1. compactage tria ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c + iaux = 77 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*2 + endif + if ( homolo.ge.3 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNTR', nompro +#endif + call utcntr ( iaux, + > hettri, famtri, imem(ptrav1), nivtri, + > filtri, pertri, pentri, nintri, homtri, + > ntreca, ntreho, + > anctri, imem(pnoutr), imem(pnouar), aretri, + > nbtrre, + > imem(ptrav2), imem(ptrav3) ) +c + endif +c + endif +c +c 4.2. ==> compactage des quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. compactage quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 77 + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*3 + endif + if ( homolo.ge.3 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNQU', nompro +#endif + call utcnqu ( iaux, + > hetqua, famqua, imem(ptrav1), nivqua, + > filqua, perqua, hexqua, ninqua, + > nqueca, nqueho, + > ancqua, imem(pnouqu), imem(pnouar), arequa, + > nbqure, + > imem(ptrav2), imem(ptrav3) ) +c + endif +c +c 4.3. ==> compactage des aretes +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. compactage aret ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNAR', nompro +#endif + call utcnar ( somare, hetare, famare, imem(ptrav1), + > filare, merare, homare, np2are, + > aretri, arequa, + > posifa, facare, + > ancare, imem(pnouar), imem(pnouno), + > nbtrre, nbqure, nbarre, + > imem(ptrav2), imem(ptrav3) ) +c + endif +c +c 4.4. ==> compactage des noeuds +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. compactage noeuds ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + iaux = 7 + if ( mod(mailet,2).eq.0 ) then + iaux = iaux*2 + endif + if ( mod(mailet,3).eq.0 ) then + iaux = iaux*3 + endif + if ( homolo.ge.1 ) then + iaux = iaux*5 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTCNNO', nompro +#endif + call utcnno ( iaux, + > coonoe, + > hetnoe, famnoe, arenoe, homnoe, + > nnoeca, nnoeho, + > nintri, + > ninqua, + > imem(pnouar), imem(pnouno), nbnoto ) +c + endif +c +c==== +c 5. Menage +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. menage ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmlboj ( ntrav1 , codre1 ) + call gmlboj ( ntrav2 , codre2 ) + call gmlboj ( ntrav3 , codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + call gmlboj ( nnouno , codre1 ) + call gmlboj ( nnouar , codre2 ) + call gmlboj ( nnoutr , codre3 ) + call gmlboj ( nnouqu , codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsuhe.F b/src/tool/Utilitaire/utsuhe.F new file mode 100644 index 00000000..6cd03dad --- /dev/null +++ b/src/tool/Utilitaire/utsuhe.F @@ -0,0 +1,173 @@ + subroutine utsuhe ( dishex, + > hethex, perhex, filhex, + > anchex, nouhex, + > nbhere ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des HExaedres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dishex . e . nouvhe . indicateurs de disparition des hexaedres . +c . hethex . es . nouvhe . historique de l'etat des hexaedres . +c . perhex . es . nouvhe . pere des hexaedres . +c . filhex . es . nouvhe . premier fils des hexaedres . +c . anchex . s . nouvhe . anciens numeros des hexaedres conserves . +c . nouhex . s .0:nouvhe. nouveaux numeros des hexaedres conserves . +c . nbhere . s . 1 . nombre de hexaedres restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUHE' ) +c +c 0.2. ==> communs +c +#include "nombhe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer dishex(nouvhe) + integer hethex(nouvhe), perhex(nouvhe), filhex(nouvhe) + integer anchex(nouvhe), nouhex(0:nouvhe) + integer nbhere +c +c 0.4. ==> variables locales +c + integer lehexa, gdpere, lepere, lefrer + integer etgper, htfrer, etfrer + integer cmptr, actifs +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux anchex et nouhex +c==== +c + cmptr = 0 + nouhex(0) = 0 +c +c 1.1 generation des tableaux reciproques +c + do 100 , lehexa = 1 , nbhepe +c + if ( dishex(lehexa).eq.1 ) then +c + nouhex(lehexa) = 0 + hethex(lehexa) = 1000 * int( hethex(lehexa)/1000 ) + 5 +c + else +c + cmptr = cmptr + 1 + anchex(cmptr) = lehexa + nouhex(lehexa) = cmptr +c + endif +c + 100 continue +c +c 1.2 nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbhere = cmptr +c +c==== +c 2. modification des etats des peres des hexaedres +c remarque : on le fait 8 fois de suite mais tant pis ! +c==== +c + do 200 , lehexa = 1 , nbhepe +c + if ( dishex(lehexa).eq.1 ) then +c +c mise a zero de l'etat actuel du pere +c + lepere = perhex(lehexa) + hethex(lepere) = hethex(lepere) - mod(hethex(lepere),1000) +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des grand-peres des hexaedres, +c s'ils existent +c==== +c + do 300 , lehexa = 1 , nbhepe +c + if ( dishex(lehexa).eq.1 ) then +c +c 3.1 verification de l'etat du grand-pere +c + lepere = perhex(lehexa) + gdpere = perhex(lepere) +c + if ( gdpere.ne.0 ) then +c + etgper = mod(hethex(gdpere),1000) +c + if ( etgper.ne.8 ) then +c +c 3.1.1 verification de l'etat des freres du pere +c + lefrer = filhex(gdpere) + actifs = 1 +c + do 310 , htfrer = lefrer , lefrer + 7 +c + etfrer = mod(hethex(htfrer),1000) +c + if ( etfrer.ne.0 ) then + actifs = 0 + endif +c + 310 continue +c + if ( actifs.eq.1 ) then +c +c 3.1.3 attribution de l'etat de l'entite +c + hethex(gdpere) = hethex(gdpere) - etgper + 8 +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + end diff --git a/src/tool/Utilitaire/utsuno.F b/src/tool/Utilitaire/utsuno.F new file mode 100644 index 00000000..99d0eb23 --- /dev/null +++ b/src/tool/Utilitaire/utsuno.F @@ -0,0 +1,131 @@ + subroutine utsuno ( nbnold, nbnnew, disnoe, + > hetnoe, ancnoe, nounoe, + > nbnore, nbp2re, nbimre ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des NOeuds +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnold . e . 1 . ancien nombre de noeuds . +c . nbnnew . e . 1 . nouveau nombre de noeuds . +c . disnoe . e . nbnnew . indicateurs de disparition des aretes . +c . hetnoe . es . nbnold . historique de l'etat des noeuds . +c . ancnoe . s . nbnold . anciens numeros des noeuds conserves . +c . nounoe . s .0:nbnold. nouveaux numeros des noeuds conserves . +c . nbnore . s . 1 . nombre de noeuds restants . +c . nbp2re . s . 1 . nombre de noeuds p2 restants . +c . nbimre . s . 1 . nombre de noeuds internes restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUNO' ) +c +c 0.2. ==> communs +c 0.3. ==> arguments +c + integer nbnold, nbnnew + integer disnoe(nbnnew), ancnoe(nbnold) + integer nounoe(0:nbnold) + integer hetnoe(nbnold) + integer nbnore, nbp2re, nbimre +c +c 0.4. ==> variables locales +c + integer iaux + integer lenoeu + integer cmptr, cmptr1 +c ______________________________________________________________________ +c +#include "impr03.h" +c +c==== +c 1. fabrication des tableaux ancnoe et nounoe +c==== +c +cgn write(1,90002) 'nbnold', nbnold +cgn write(1,90002) 'nbnnew', nbnnew + nbnore = 0 + nounoe(0) = 0 +c +c 1.1. ==> generation des tableaux reciproques +c + do 100 , lenoeu = 1 , nbnold +cgn print 90001,'disnoe du noeud', lenoeu, disnoe(lenoeu) +c +c 1.1.1. ==> le noeud disparait : +c . son etat anterieur, la dizaine, est conserve +c . son etat courant devient 5, pour "inexistant" +c + if ( disnoe(lenoeu).ne.0 ) then +c + nounoe(lenoeu) = 0 + iaux = hetnoe(lenoeu) - mod(hetnoe(lenoeu),10) + hetnoe(lenoeu) = 10*iaux + 5 +c +c 1.1.2. ==> le noeud reste ; on le compte +c + else +c + nbnore = nbnore + 1 + ancnoe(nbnore) = ancnoe(lenoeu) + nounoe(lenoeu) = nbnore +cgn write(1,*) 'ancnoe(',lenoeu,')',ancnoe(lenoeu) +cgn write(1,*) 'ecriture dans ancnoe(', nbnore,') =',ancnoe(nbnore) +c + endif +cgn print *,'ecriture dans nounoe(', lenoeu,')' +c + 100 continue +cgn print 90002, '==> apres 100, nbnore', nbnore +c +c 1.2. ==> nombre de noeuds restants apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + cmptr = 0 + cmptr1 = 0 + do 120 , lenoeu = 1 , nbnold +cgn write(*,90002) 'hetnoe(lenoeu)', hetnoe(lenoeu) + if ( mod (hetnoe(lenoeu),10).eq.2 ) then + cmptr = cmptr + 1 + elseif ( mod (hetnoe(lenoeu),10).eq.4 ) then + cmptr1 = cmptr1 + 1 + endif + 120 continue + nbp2re = cmptr + nbimre = cmptr1 +c +cgn write(*,90002) 'nbnore', nbnore +cgn write(*,90002) 'nbp2re', nbp2re +cgn write(*,90002) 'nbimre', nbimre +c + end diff --git a/src/tool/Utilitaire/utsupe.F b/src/tool/Utilitaire/utsupe.F new file mode 100644 index 00000000..fedb7182 --- /dev/null +++ b/src/tool/Utilitaire/utsupe.F @@ -0,0 +1,176 @@ + subroutine utsupe ( dispen, + > hetpen, perpen, filpen, + > ancpen, noupen, + > nbpere ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des PEntaedres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dispen . e . nouvpe . indicateurs de disparition des pentaedres . +c . hetpen . es . nouvpe . historique de l'etat des pentaedres . +c . perpen . es . nouvpe . pere des pentaedres . +c . filpen . es . nouvpe . premier fils des pentaedres . +c . ancpen . s . nouvpe . anciens numeros des pentaedres conserves . +c . noupen . s .0:nouvpe. nouveaux numeros des pentaedres conserves . +c . nbpere . s . 1 . nombre de pentaedres restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUPE' ) +c +c 0.2. ==> communs +c +#include "nombpe.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer dispen(nouvpe) + integer hetpen(nouvpe), perpen(nouvpe), filpen(nouvpe) + integer ancpen(nouvpe), noupen(0:nouvpe) + integer nbpere +c +c 0.4. ==> variables locales +c + integer lepent, gdpere, lepere, lefrer + integer etgper, htfrer, etfrer + integer cmptr, actifs + integer iaux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux ancpen et noupen +c==== +c + cmptr = 0 + noupen(0) = 0 +c +c 1.1 generation des tableaux reciproques +c + do 100 , lepent = 1 , nbpepe +c + if ( dispen(lepent).eq.1 ) then +c + noupen(lepent) = 0 + hetpen(lepent) = 100 * int( hetpen(lepent)/100 ) + 55 +c + else +c + cmptr = cmptr + 1 + ancpen(cmptr) = lepent + noupen(lepent) = cmptr +c + endif +c + 100 continue +c +c 1.2 nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbpere = cmptr +c +c==== +c 2. modification des etats des peres des pentaedres +c==== +c + do 200 , lepent = 1 , nbpepe +c + if ( dispen(lepent).eq.1 ) then +c +c mise a zero de l'etat actuel du pere +c + lepere = perpen(lepent) + hetpen(lepere) = hetpen(lepere) - mod(hetpen(lepere),100) +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des grand-peres des pentaedres, +c s'ils existent +c==== +c + do 300 , lepent = 1 , nbpepe +c + if ( dispen(lepent).eq.1 ) then +c +c 3.1 verification de l'etat du grand-pere +c + lepere = perpen(lepent) + gdpere = perpen(lepere) +c + if ( gdpere.ne.0 ) then +c + iaux = mod(hetpen(gdpere),100) + etgper = (iaux-mod(iaux,10)) / 10 +c + if ( etgper.ne.8 ) then +c +c 3.1.1 verification de l'etat des freres du pere +c + lefrer = filpen(gdpere) + actifs = 1 +c + do 310 , htfrer = lefrer , lefrer + 7 +c + etfrer = mod( hetpen(htfrer) , 100) +c + if ( etfrer.ne.0 ) then + actifs = 0 + endif +c + 310 continue +c + if ( actifs.eq.1 ) then +c +c 3.1.3 attribution de l'etat de l'entite +c + hetpen(gdpere) = hetpen(gdpere) + > - mod(hetpen(gdpere),100) + > + 80 +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + end diff --git a/src/tool/Utilitaire/utsuqu.F b/src/tool/Utilitaire/utsuqu.F new file mode 100644 index 00000000..7353217d --- /dev/null +++ b/src/tool/Utilitaire/utsuqu.F @@ -0,0 +1,181 @@ + subroutine utsuqu ( disqua, + > hetqua, perqua, filqua, + > ancqua, nouqua, + > nbqure ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des QUadrangles +c -- -- -- +c ______________________________________________________________________ +c +c Attention : tous les quadrangles n'ont pas forcement un pere ! +c en effet ceux crees en interne a des volumes +c sont de la premiere generation, meme s'ils +c sont a des niveaux > 1 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . disqua . e . nouvqu . indicateurs de disparition des quadrangles . +c . hetqua . es . nouvqu . historique de l'etat des quadrangles . +c . perqua . es . nouvqu . pere des quadrangles . +c . filqua . es . nouvqu . premier fils des quadrangles . +c . ancqua . s . nouvqu . anciens numeros des quadrangles conserves . +c . nouqua . s .0:nouvqu. nouveaux numeros des quadrangles conserves . +c . nbqure . s . 1 . nombre de quadrangles restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUQU' ) +c +c 0.2. ==> communs +c +#include "nombqu.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer disqua(nouvqu) + integer hetqua(nouvqu), perqua(nouvqu), filqua(nouvqu) + integer ancqua(nouvqu), nouqua(0:nouvqu) + integer nbqure +c +c 0.4. ==> variables locales +c + integer lequad, lepere, gdpere, etgper, lefrer + integer cmptr, e1, e2, e3, e4, et +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux ancqua et nouqua +c==== +c + cmptr = 0 + nouqua(0) = 0 +c +c 1.1 generation des tableaux reciproques +c + do 100 , lequad = 1 , nbqupe +c + if ( disqua(lequad).ne.0 ) then +c + nouqua(lequad) = 0 + hetqua(lequad) = 100 * int( hetqua(lequad) / 100 ) + 55 +c + else +c + cmptr = cmptr + 1 + ancqua(cmptr) = lequad + nouqua(lequad) = cmptr +c + endif +c + 100 continue +c +c 1.2 nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbqure = cmptr +c +c==== +c 2. modification des etats des peres eventuels des quadrangles disparus +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains quadrangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c==== +c + do 200 , lequad = 1 , nbqupe +c + if ( disqua(lequad).ne.0 ) then +c +c mise a zero de l'etat actuel du pere eventuel +c + lepere = perqua(lequad) + if ( lepere.gt.0 ) then + hetqua(lepere) = hetqua(lepere) - mod(hetqua(lepere),100) + endif +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des eventuels grand-peres des quadrangles +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains quadrangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c==== +c + do 300 , lequad = 1 , nbqupe +c + if ( disqua(lequad).ne.0 ) then +c + lepere = perqua(lequad) +c + if ( lepere.gt.0 ) then +c + gdpere = perqua(lepere) +c + if ( gdpere.gt.0 ) then +c +c 3.1 verification de l'etat du grand-pere +c + etgper = mod( hetqua(gdpere) , 100 ) +c + if ( etgper.ne.4 ) then +c +c 3.1.1 verification de l'etat des freres du pere +c + lefrer = filqua(gdpere) + e1 = mod( hetqua(lefrer) , 100 ) + e2 = mod( hetqua(lefrer+1) , 100 ) + e3 = mod( hetqua(lefrer+2) , 100 ) + e4 = mod( hetqua(lefrer+3) , 100 ) + et = e1 + e2 + e3 + e4 +c +c 3.1.2 attribution de l'etat 'coupee en 4' a l'entite +c + if ( et.eq.0 ) then + hetqua(gdpere) = hetqua(gdpere) + > - mod(hetqua(gdpere),100) + > + 4 + endif +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + end diff --git a/src/tool/Utilitaire/utsute.F b/src/tool/Utilitaire/utsute.F new file mode 100644 index 00000000..d4fb6bb2 --- /dev/null +++ b/src/tool/Utilitaire/utsute.F @@ -0,0 +1,210 @@ + subroutine utsute ( distet, + > hettet, pertet, filtet, + > tritet, cotrte, + > arenoe, + > somare, + > aretri, + > anctet, noutet, + > nbtere, + > codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des TEtraedres +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . distet . e . nouvte . indicateurs de disparition des tetraedres . +c . hettet . es . nouvte . historique de l'etat des tetraedres . +c . pertet . es . nouvte . pere des tetraedres . +c . . . . si pertet(i) > 0 : numero du tetraedre . +c . . . . si pertet(i) < 0 : -numero dans pthepe . +c . filtet . es . nouvte . premier fils des tetraedres . +c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . +c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . +c . arenoe . es . nouvno . arete liee a un nouveau noeud . +c . somare . es .2*nouvar. numeros des extremites d'arete . +c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . +c . anctet . s . nouvte . anciens numeros des tetraedres conserves . +c . noutet . s .0:nouvte. nouveaux numeros des tetraedres conserves . +c . nbtere . s . 1 . nombre de tetraedres restants . +c . codret . s . 1 . code de retour, 0 si ok, (no tetra) si pb . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUTE' ) +c +c 0.2. ==> communs +c +#include "nombte.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer distet(nouvte) + integer hettet(nouvte), pertet(nouvte), filtet(nouvte) + integer tritet(nouvtf,4), cotrte(nouvtf,4) + integer arenoe(nouvno) + integer somare(2,nouvar) + integer aretri(nouvtr,3) + integer anctet(nouvte), noutet(0:nouvte) + integer nbtere + integer codret +c +c 0.4. ==> variables locales +c + integer letetr, gdpere, lepere, lefrer + integer etgper, htfrer, etfrer, ardiag + integer cmptr, actifs, decoup + integer iaux +c +c 0.5. ==> initialisations +c + codret = 0 +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux anctet et noutet +c==== +c + cmptr = 0 + noutet(0) = 0 +c +c 1.1 generation des tableaux reciproques +c + do 100 , letetr = 1 , nbtepe +c + if ( distet(letetr).eq.1 ) then +c + noutet(letetr) = 0 + hettet(letetr) = 100 * int( hettet(letetr)/100 ) + 55 +c + else +c + cmptr = cmptr + 1 + anctet(cmptr) = letetr + noutet(letetr) = cmptr +c + endif +c + 100 continue +c +c 1.2 nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbtere = cmptr +c +c==== +c 2. modification des etats des peres des tetraedres +c==== +c + do 200 , letetr = 1 , nbtepe +c + if ( distet(letetr).eq.1 ) then +c +c mise a zero de l'etat actuel du pere +c + lepere = pertet(letetr) + hettet(lepere) = hettet(lepere) - mod(hettet(lepere),100) +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des grand-peres des tetraedres, +c s'ils existent +c==== +c + do 300 , letetr = 1 , nbtepe +c + if ( distet(letetr).eq.1 ) then +c +c 3.1 verification de l'etat du grand-pere +c + lepere = pertet(letetr) + gdpere = pertet(lepere) +c + if ( gdpere.ne.0 ) then +c + iaux = mod(hettet(gdpere),100) + etgper = (iaux-mod(iaux,10)) / 10 +c + if ( etgper.ne.8 ) then +c +c 3.1.1 verification de l'etat des freres du pere +c + lefrer = filtet(gdpere) + actifs = 1 +c + do 310 , htfrer = lefrer , lefrer + 7 +c + etfrer = mod( hettet(htfrer) , 100) +c + if ( etfrer.ne.0 ) then + actifs = 0 + endif +c + 310 continue +c + if ( actifs.eq.1 ) then +c +c 3.1.2 recherche de la diagonale de decoupe et de l'etat du +c tetraedre +c + call utdiag (gdpere, + > filtet, tritet, aretri, + > arenoe, somare, cotrte, + > ardiag, decoup, codret ) +c + if (codret.ne.0) then + goto 320 + endif +c +c 3.1.3 attribution de l'etat de l'entite +c + hettet(gdpere) = hettet(gdpere) + > - mod(hettet(gdpere),100) + > + decoup +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + 320 continue +c + end diff --git a/src/tool/Utilitaire/utsutr.F b/src/tool/Utilitaire/utsutr.F new file mode 100644 index 00000000..ab5d6fcc --- /dev/null +++ b/src/tool/Utilitaire/utsutr.F @@ -0,0 +1,186 @@ + subroutine utsutr ( distri, + > hettri, pertri, filtri, + > anctri, noutri, + > nbtrre ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SUppression des TRiangles +c -- -- -- +c ______________________________________________________________________ +c +c Attention : tous les triangles n'ont pas forcement un pere ! +c en effet ceux crees en interne a des tetraedres +c sont de la premiere generation, meme s'ils +c sont a des niveaux > 1 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . distri . e . nouvtr . indicateurs de disparition des triangles . +c . hettri . es . nouvtr . historique de l'etat des triangles . +c . pertri . es . nouvtr . pere des triangles . +c . filtri . es . nouvtr . premier fils des triangles . +c . anctri . s . nouvtr . anciens numeros des triangles conserves . +c . noutri . s .0:nouvtr. nouveaux numeros des triangles conserves . +c . nbtrre . s . 1 . nombre de triangles restants . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTSUTR' ) +c +c 0.2. ==> communs +c +#include "nombtr.h" +#include "nouvnb.h" +c +c 0.3. ==> arguments +c + integer distri(nouvtr) + integer hettri(nouvtr), pertri(nouvtr), filtri(nouvtr) + integer anctri(nouvtr), noutri(0:nouvtr) + integer nbtrre +c +c 0.4. ==> variables locales +c + integer letria, lepere, gdpere, etgper, lefrer + integer cmptr, e1, e2, e3, e4, et +c ______________________________________________________________________ +c +c==== +c 1. fabrication des tableaux anctri et noutri +c==== +c + cmptr = 0 + noutri(0) = 0 +c +c 1.1 ==> generation des tableaux reciproques +c + do 100 , letria = 1 , nbtrto +c + if ( distri(letria).ne.0 ) then +c + noutri(letria) = 0 + hettri(letria) = 10 * int( hettri(letria) / 10 ) + 5 +c + else +c + cmptr = cmptr + 1 + anctri(cmptr) = letria + noutri(letria) = cmptr +c + endif +c + 100 continue +c +c 1.2 ==> nombre d'entites restantes apres suppression +c (pour la remise a jour du nombre d'entites du maillage) +c + nbtrre = cmptr +c +c==== +c 2. mise a zero de l'etat actuel des peres eventuels des triangles +c disparus +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains triangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c Le cas des peres negatif parce que quadrangle de conformite +c n'existe plus a ce stade : ces triangles ont ete detruits +c en amont +c==== +c + do 200 , letria = 1 , nbtrpe +c + if ( distri(letria).ne.0 ) then +c + lepere = pertri(letria) + if ( lepere.gt.0 ) then + hettri(lepere) = hettri(lepere) - mod(hettri(lepere),10) + endif +c + endif +c + 200 continue +c +c==== +c 3. modification des etats des eventuels grand-peres des triangles +c Remarque : si on est parti d'un macro-maillage non conforme, +c certains triangles ont des peres adoptifs de numero +c negatif. Il ne faut pas changer leur etat +c Le cas des peres negatif parce que quadrangle de conformite +c n'existe plus a ce stade : ces triangles ont ete detruits +c en amont +c==== +c + do 300 , letria = 1 , nbtrpe +c + if ( distri(letria).ne.0 ) then +c + lepere = pertri(letria) +c + if ( lepere.gt.0 ) then +c + gdpere = pertri(lepere) +c + if ( gdpere.gt.0 ) then +c +c 3.1 verification de l'etat du grand-pere +c + etgper = mod( hettri(gdpere) , 10 ) +c + if ( etgper.ne.4 ) then +c +c 3.1.1 verification de l'etat des freres du pere +c + lefrer = filtri(gdpere) + e1 = mod( hettri(lefrer) , 10 ) + e2 = mod( hettri(lefrer+1) , 10 ) + e3 = mod( hettri(lefrer+2) , 10 ) + e4 = mod( hettri(lefrer+3) , 10 ) + et = e1 + e2 + e3 + e4 +c +c 3.1.2 attribution de l'etat 'coupee en 4' a l'entite +c + if ( et .eq. 0 ) then + hettri(gdpere) = hettri(gdpere) + > - mod(hettri(gdpere),10) + > + 4 + endif +c + endif +c + endif +c + endif +c + endif +c + 300 continue +c + end diff --git a/src/tool/Utilitaire/utsvm0.F b/src/tool/Utilitaire/utsvm0.F new file mode 100644 index 00000000..be1235bc --- /dev/null +++ b/src/tool/Utilitaire/utsvm0.F @@ -0,0 +1,200 @@ + subroutine utsvm0 ( typenh, option, nhenti, nosvmn, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation de SauVegardes du Maillage iteration N - 0 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typenh . e . 1 . code des entites au sens homard . +c . . . . -1 : noeuds . +c . . . . 0 : mailles-points . +c . . . . 1 : segments . +c . . . . 2 : triangles . +c . . . . 3 : tetraedres . +c . . . . 4 : quadrangles . +c . . . . 5 : pyramides . +c . . . . 6 : hexaedres . +c . . . . 7 : pentaedres . +c . option . e . 1 . option de pilotage des sauvegardes . +c . . . . c'est un multiple des entiers suivants : . +c . . . . 2 : Fille et HistEtat . +c . . . . 3 : EntiFamm . +c . . . . 5 : InfoSup2 . +c . nhenti . e . ch8 . nom de l'objet contenant l'entite . +c . nosvmn . s . ch8 . nom de l'objet contenant les sauvegardes du. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSVM0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "enti01.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typenh, option + character*8 nhenti, nosvmn +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2 + integer codre0 +c + character*2 saux02 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Sauvegardes des branches relatives aux '',a)' + texte(1,5) = '(''Option :'',i10)' +c + texte(2,4) = '(''Saving of arrays for '',a)' + texte(2,5) = '(''Option :'',i10)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,typenh) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> types d'entites +c + saux02 = suffix(3,typenh)(1:2) +c + codret = 0 +c +c==== +c 2. Sauvegarde +c==== +c + if ( option.ne.0 ) then +c +c 2.1. ==> Fille et Etat +c + if ( mod(option,2).eq.0 ) then +c + call gmcpoj ( nhenti//'.Fille', + > nosvmn//'.Fille_'//saux02, codre1 ) + call gmcpoj ( nhenti//'.HistEtat', + > nosvmn//'.HEtat_'//saux02, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +c 2.2. ==> Branche Famille +c + if ( mod(option,3).eq.0 ) then +c + call gmcpoj ( nhenti//'.Famille.EntiFamm', + > nosvmn//'.Famil_'//saux02, codre0 ) +c + codret = max ( abs(codre0), codret ) +c + endif +c +c 2.5. ==> Branche InfoSup2 (eventuellement) +c + if ( mod(option,5).eq.0 ) then +c + call gmobal ( nhenti//'.InfoSup2', codre1 ) +c + if ( codre1.eq.0 ) then + codre0 = 0 + elseif ( codre1.eq.2 ) then + call gmcpoj ( nhenti//'.InfoSup2', + > nosvmn//'.Insu2_'//saux02, codre0 ) + else + codre0 = 1 + endif +c + codret = max ( abs(codre0), codret ) +c + endif +c + endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write(ulsort,texte(langue,4)) mess14(langue,3,typenh) + call gmprsx (nompro,nhenti) + call gmprsx (nompro,nosvmn) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsvmn.F b/src/tool/Utilitaire/utsvmn.F new file mode 100644 index 00000000..1ef772d3 --- /dev/null +++ b/src/tool/Utilitaire/utsvmn.F @@ -0,0 +1,315 @@ + subroutine utsvmn ( nomail, nosvmn, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation de SauVegardes du Maillage de l'iteration N +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . ch8 . nom de l'objet contenant le maillage . +c . nosvmn . s . ch8 . nom de l'objet contenant les sauvegardes du. +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSVMN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nosvmn +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux +c + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c==== +c 2. recuperation des pointeurs, initialisations +c==== +c +c 2.1. ==> les caracteristiques du maillage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> allocation de la sauvegarde +c + if ( codret.eq.0 ) then +c + call gmalot ( nosvmn, 'Sauve_HM', 0, iaux, codret ) +c + endif +c +c==== +c 3. parente +c==== +c +c 3.1. ==> Les attributs +c + if ( codret.eq.0 ) then +c + call gmecat ( nosvmn, 1, nbarto, codre1 ) + call gmecat ( nosvmn, 2, nbtrto, codre2 ) + call gmecat ( nosvmn, 3, nbteto, codre3 ) + call gmecat ( nosvmn, 4, nbquto, codre4 ) + call gmecat ( nosvmn, 5, nbpyto, codre5 ) + call gmecat ( nosvmn, 6, nbheto, codre6 ) + call gmecat ( nosvmn, 7, nbpeto, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c 3.2. ==> sur les aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_ar', nompro +#endif + iaux = 1 + jaux = 2 + call utsvm0 ( iaux, jaux, nharet, nosvmn, + > ulsort, langue, codret ) +c + endif +c +c 3.3. ==> sur les triangles +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_tr', nompro +#endif + iaux = 2 + jaux = 6 + call utsvm0 ( iaux, jaux, nhtria, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.4. ==> sur les quadrangles +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_qu', nompro +#endif + iaux = 4 + jaux = 2 + call utsvm0 ( iaux, jaux, nhquad, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.5. ==> sur les tetraedres +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_te', nompro +#endif + iaux = 3 + jaux = 2 + call utsvm0 ( iaux, jaux, nhtetr, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.6. ==> sur les pyramides +c + if ( codret.eq.0 ) then +c + if ( nbpyto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_py', nompro +#endif + iaux = 5 + jaux = 2 + call utsvm0 ( iaux, jaux, nhpyra, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.7. ==> sur les hexaedres +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_he', nompro +#endif + iaux = 6 + jaux = 10 + call utsvm0 ( iaux, jaux, nhhexa, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.8. ==> sur les pentaedres +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTSVM0_pe', nompro +#endif + iaux = 7 + jaux = 10 + call utsvm0 ( iaux, jaux, nhpent, nosvmn, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.9. ==> la renumerotation +c + if ( codret.eq.0 ) then +c + call gmcpgp ( norenu, nosvmn//'.RenuMail', codret ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro,nosvmn) + call gmprsx (nompro,nosvmn//'.RenuMail') + call gmprsx (nompro,nosvmn//'.HEtat_Tr') +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utsynt.F b/src/tool/Utilitaire/utsynt.F new file mode 100644 index 00000000..18a4e4a4 --- /dev/null +++ b/src/tool/Utilitaire/utsynt.F @@ -0,0 +1,237 @@ + subroutine utsynt ( repere, lgrepe, + > vatype, vaenti, vareel, vachar, lgchar, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - SYNThese de l'adaptation +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . repere . e . lgrepe . texte reperant l'information a ecrire . +c . lgrepe . e . 1 . longueur du texte . +c . vatype . e . 1 . type de la variable associee : . +c . . . . 1 : entier . +c . . . . 2 : reel . +c . . . . 3 : caracteres . +c . vaenti . e . 1 . valeur entiere a ecrire . +c . vareel . e . 1 . valeur reelle a ecrire . +c . vachar . e . 1 . valeur caractere a ecrire . +c . lgchar . e . lgchar . longueur de la valeur caractere a ecrire . +c . ulsort . e . 1 . unite logique de la sortie generale . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTSYNT' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envada.h" +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer lgrepe + integer vatype + integer lgchar + integer vaenti +c + character*(*) repere + character*(*) vachar +c + double precision vareel +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nuroul, lnomfl +c + character*08 saux08 + character*09 mess09(nblang,3) + character*200 nomflo +c + integer nbmess + parameter (nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. Messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> Messages generaux +c +c 123456789 + mess09(1,1) = 'entier ' + mess09(1,2) = 'reel ' + mess09(1,3) = 'caractere' + mess09(2,1) = 'integer ' + mess09(2,2) = 'real ' + mess09(2,3) = 'character' +c + texte(1,4) = '(''Texte de reperage : '',a)' + texte(1,5) = '(''Type de valeur a traiter : '', a)' + texte(1,6) = '(''--> valeur a ecrire :'',i10)' + texte(1,7) = '(''--> valeur a ecrire :'',g15.6)' + texte(1,8) = '(''--> valeur a ecrire : '',a)' + texte(1,9) = '(''Type inconnu.'')' +c + texte(2,4) = '(''Text: '',a)' + texte(2,5) = '(''Type of value: '', a)' + texte(2,6) = '(''--> value:'',i10)' + texte(2,7) = '(''--> value:'',g15.6)' + texte(2,8) = '(''--> value: '',a)' + texte(2,9) = '(''Unknown type.'')' +c +#include "impr03.h" +c + codret = 0 +c +c==== +c 2. controle +c==== +c + if ( vatype.lt.1 .or. vatype.gt.3 ) then + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + iaux = 1 +#else + iaux = codret +#endif +c + if ( iaux.ne.0 ) then +c + write (ulsort,texte(langue,4)) repere(1:lgrepe) + write (ulsort,texte(langue,5)) mess09(langue,vatype) + if ( vatype.eq.1 ) then + write (ulsort,texte(langue,6)) vaenti + elseif ( vatype.eq.2 ) then + write (ulsort,texte(langue,7)) vareel + elseif ( vatype.eq.3 ) then + write (ulsort,texte(langue,8)) vachar(1:lgchar) + else + write (ulsort,texte(langue,9)) + endif +c + endif +c +c==== +c 3. fichier de sortie de la synthese +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. fichier sortie ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + saux08 = ' ' + iaux = 7 + jaux = -1 + kaux = nbiter +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI', nompro +#endif + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux08, jaux, kaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. Ecriture de l'information +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Ecriture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( vatype.eq.1 ) then + write (nuroul,90002) repere(1:lgrepe), vaenti + elseif ( vatype.eq.2 ) then + write (nuroul,90004) repere(1:lgrepe), vareel + else + write (nuroul,90003) repere(1:lgrepe), vachar(1:lgchar) + endif +c + endif +c +c==== +c 5. Fermeture du fichier +c==== +c + if ( codret.eq.0 ) then +c + call gufeul ( nuroul , codret) +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttbrc.F b/src/tool/Utilitaire/uttbrc.F new file mode 100644 index 00000000..d48a21f5 --- /dev/null +++ b/src/tool/Utilitaire/uttbrc.F @@ -0,0 +1,141 @@ + subroutine uttbrc ( option, + > lgtb1, tab1, lgtb2, tab2, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TaBleau - ReCiproque +c -- - - - - +c ______________________________________________________________________ +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . option . e . 1 . option de pilotage . +c . . . . 0 : mise a zero initiale . +c . . . . 1 : rien . +c . lgtb1 . e . 1 . longueur du tableau 1 . +c . tab1 . e . 1 . tableau a mettre a l'envers . +c . lgtb2 . s . 1 . longueur du tableau 2 . +c . tab2 . s . 1 . tableau reciproque . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 6 : probleme d'ecriture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTTBRC' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer option + integer lgtb1, tab1(lgtb1) + integer lgtb2, tab2(lgtb2) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> les messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'option', option +#endif +c + codret = 0 +c +c==== +c 2. Mise a zero +c==== +c + if ( option.eq.0 ) then +c + do 21 , iaux = 1 , lgtb2 + tab2(iaux) = 0 + 21 continue +c + endif +c +c==== +c 3. Reciproque +c==== +c + do 31 , iaux = 1 , lgtb1 + tab2(tab1(iaux)) = iaux + 31 continue +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttetr.F b/src/tool/Utilitaire/uttetr.F new file mode 100644 index 00000000..f718f243 --- /dev/null +++ b/src/tool/Utilitaire/uttetr.F @@ -0,0 +1,291 @@ + subroutine uttetr ( decisi, + > nbtrto, nbteto, nbtecf, + > tritet, hettet, filtet, voltri, + > ulsort, langue, codret ) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TEtraedres - TRiangles +c -- -- -- +c ______________________________________________________________________ +c +c but : etablit le tableau voltri a partir de son reciproque, tritet +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . decisi . e . 1 . pilotage des voisins des triangles : . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . . . . a. qu'il n'y a pas de tetraedre doubles . +c . . . . b. qu'un triangle n'appartient pas a plus . +c . . . . de 2 tetraedres . +c . nbtrto . e . 1 . nombre de triangles total . +c . nbteto . e . 1 . nombre de tetraedres total . +c . nbtecf . e . 1 . nombre de tetraedres decrits par faces . +c . tritet . e .nbtecf*4. numeros des triangles des tetraedres . +c . hettet . e . nbtecf . historique des etats des tetraedres . +c . filtet . e . nbtecf . fils des tetraedres . +c . voltri . s .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme dans le controle . +c . . . . 3 : probleme de tetraedres doubles . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTTETR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer decisi + integer nbtrto, nbteto, nbtecf + integer filtet(nbteto), hettet(nbteto), tritet(nbtecf,4) + integer voltri(2,nbtrto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer codre1, codre2 + integer etat + integer fils1, fils2 + integer letetr + integer letria, tria(4), tribis(4), triacl(4), tribcl(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,10) = + > '(/,''Le triangle'',i10,'' a plus de deux voisins ?'')' + texte(1,4) = '(''Volumes :'',3i10,/)' + texte(1,5) = + > '(/,''Les deux tetraedres suivants sont identiques.'')' + texte(1,6) = + > '(''Triangles du tetraedre numero :'',i10,'' : '',4i10)' +c + texte(2,10) = + > '(/,''Triangle'',i10,'' has more than 2 neighbours ?'')' + texte(2,4) = '(''Volumes :'',3i10,/)' + texte(2,5) = '(/,''The following two tetraedra are the same.'')' + texte(2,6) = '(''Triangles of tetrahedron # :'',i10,'' : '',4i10)' +c +#include "impr03.h" +c + iaux = 4 +c + codret = 0 +c +c==== +c 2. liste des tetraedres s'appuyant sur chaque triangle +c attention : a priori, un triangle borde 0, 1 ou 2 tetraedres +c==== +c +c 2. ==> on regarde tous les tetraedres decrits par leurs faces +c + do 20 , letetr = 1 , nbtecf +c +c 2.1. ==> les triangles du tetraedre en cours d'examen +c + tria(1) = tritet(letetr,1) + tria(2) = tritet(letetr,2) + tria(3) = tritet(letetr,3) + tria(4) = tritet(letetr,4) +cgn write(ulsort,90015) 'tetr', letetr,' : ', tria +c +c 2.2. ==> quand un tetraedre est decoupe en 2 pour la mise en +c conformite, deux de ses triangles sont des bords du +c tetraedre et de son fils. +c La convention HOMARD veut que l'on ne memorise que le fils +c dans les voisins du triangle. +c on va alors annuler le numero du triangle pour ne rien +c archiver maintenant. +c + etat = mod ( hettet(letetr), 100 ) +cgn write(ulsort,1000) letetr,etat + if ( etat.ge.21 .and. etat.le.26 ) then +c + fils1 = filtet(letetr) +c + if ( fils1.gt.0 ) then +c + fils2 = fils1 + 1 + do 22 , letria = 1 , 4 + if ( tria(letria).eq.tritet(fils1,1) .or. + > tria(letria).eq.tritet(fils1,2) .or. + > tria(letria).eq.tritet(fils1,3) .or. + > tria(letria).eq.tritet(fils1,4) .or. + > tria(letria).eq.tritet(fils2,1) .or. + > tria(letria).eq.tritet(fils2,2) .or. + > tria(letria).eq.tritet(fils2,3) .or. + > tria(letria).eq.tritet(fils2,4) ) then + tria(letria) = 0 + endif + 22 continue +c + endif +c + endif +c +c 2.3. ==> pour chacun des 4 triangles encore a traiter +c + do 23 , letria = 1 , 4 +c + if ( tria(letria).ne.0 ) then +c +c 2.3.1. ==> aucun voisin n'existe : on met le tetraedre courant +c comme premier voisin +c + if ( voltri(1,tria(letria)).eq.0 ) then + voltri(1,tria(letria)) = letetr +c + else +c +c 2.3.2. ==> il existe un premier voisin +c +c 2.3.2.1. ==> en cas de controle : +c + if ( decisi.eq.2 ) then +c +c 2.3.2.1.1. ==> on verifie que le second tetraedre n'est pas identique +c au premier. Pour cela, on trie les tableaux des +c triangles par numero de triangles croissant et +c on compare. +c + if ( voltri(2,tria(letria)).eq.0 ) then +c + if ( voltri(1,tria(letria)).gt.0 ) then +c + tribis(1) = tritet(voltri(1,tria(letria)),1) + tribis(2) = tritet(voltri(1,tria(letria)),2) + tribis(3) = tritet(voltri(1,tria(letria)),3) + tribis(4) = tritet(voltri(1,tria(letria)),4) +c + call uttrii ( triacl, jaux, kaux, + > iaux, tria, + > ulsort, langue, codre1 ) +c + call uttrii ( tribcl, jaux, kaux, + > iaux, tribis, + > ulsort, langue, codre2 ) +c + if ( codre1.eq.0 .and. codre2.eq.0 ) then + if ( tria(triacl(1)).eq.tribis(tribcl(1)) .and. + > tria(triacl(2)).eq.tribis(tribcl(2)) .and. + > tria(triacl(3)).eq.tribis(tribcl(3)) .and. + > tria(triacl(4)).eq.tribis(tribcl(4)) ) then + write(ulsort,texte(langue,5)) + write(ulsort,texte(langue,6)) letetr, tria + write(ulsort,texte(langue,6)) + > voltri(1,tria(letria)), tribis + codret = 3 + endif + else + codret = 1 + endif +c + endif +c +c 2.3.2.1.2. ==> il y a deja un second volume comme voisin de ce +c triangle ! +c + else +c + write(ulsort,texte(langue,10)) tria(letria) + write(ulsort,texte(langue,4)) voltri(1,tria(letria)), + > voltri(2,tria(letria)), + > letetr + codret = 3 +c + endif +c + endif +c +c 2.3.2.2. ==> il existe un premier voisin : on met le tetraedre +c courant comme second voisin +c + voltri(2,tria(letria)) = letetr +c + endif +c + endif +c + 23 continue +c + 20 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttfi1.F b/src/tool/Utilitaire/uttfi1.F new file mode 100644 index 00000000..56de3fa8 --- /dev/null +++ b/src/tool/Utilitaire/uttfi1.F @@ -0,0 +1,125 @@ + subroutine uttfi1 ( sss, ttt, + > v1, v2, v3, vn ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TFI - option 1 +c -- --- - +c ______________________________________________________________________ +c +c Creation d'un noeud par methode TFI a l'interieur d'un triangle +c programme en dimension 2 +c +c Conventions d'orientation : +c +c 3 . +c . . +c . . +c . . +c 1 .--------------------------. 2 +c +c remarque : c'est une version simplifiee, issue de la version pour +c quadrangle en fusionnant les sommets 3 et 4 (uttfi2) +c On peut faire mieux avec les coordonnees barycentriques. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sss . e . 1 . abscisse curviligne selon 12 . +c . ttt . e . 1 . abscisse curviligne selon 13/23 . +c . v1 . e . 2 . coordonnees du sommet 1 du triangle . +c . v2 . e . 2 . coordonnees du sommet 2 du triangle . +c . v3 . e . 2 . coordonnees du sommet 3 du triangle . +c . vn . s . 2 . coordonnees du noeud cree . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTTFI2' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision v1(2), v2(2), v3(2), vn(2) + double precision sss, ttt +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision v12(2), v43(2), v14(2), v23(2) + double precision unmsss, unmttt + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. abscisses curvilignes +c==== +c +cgn print *,'sss =',sss,', ttt =',ttt + unmsss = 1.d0 - sss + unmttt = 1.d0 - ttt +c +c==== +c 2. noeuds de bord +c==== +c + do 20 , iaux = 1 , 2 +c + v12(iaux) = v1(iaux) + sss*(v2(iaux)-v1(iaux)) + v43(iaux) = v3(iaux) + v14(iaux) = v1(iaux) + ttt*(v3(iaux)-v1(iaux)) + v23(iaux) = v2(iaux) + ttt*(v3(iaux)-v2(iaux)) +c + 20 continue +cgn print *,'v12 =',v12 +cgn print *,'v43 =',v43 +cgn print *,'v14 =',v14 +cgn print *,'v23 =',v23 +c +c==== +c 3. Calcul +c==== +c + do 30 , iaux = 1 , 2 +c + vn(iaux) = unmttt * v12(iaux) + > + ttt * v43(iaux) + > + unmsss * v14(iaux) + > + sss * v23(iaux) + > - unmsss * unmttt * v1(iaux) + > - unmsss * ttt * v3(iaux) + > - sss * unmttt * v2(iaux) + > - sss * ttt * v3(iaux) +c + 30 continue +cgn print *,'vn =',vn +c + end diff --git a/src/tool/Utilitaire/uttfi2.F b/src/tool/Utilitaire/uttfi2.F new file mode 100644 index 00000000..c890d6be --- /dev/null +++ b/src/tool/Utilitaire/uttfi2.F @@ -0,0 +1,131 @@ + subroutine uttfi2 ( sss, ttt, + > v1, v2, v3, v4, vn ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TFI - option 2 +c -- --- - +c ______________________________________________________________________ +c +c Creation d'un noeud par methode TFI a l'interieur d'un quadrangle +c programme en dimension 2 +c +c Conventions d'orientation : +c +c 4 .--------------------. 3 +c . . +c . . +c . . +c 1 .--------------------. 2 +c +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . sss . e . 1 . abscisse curviligne selon 12/43 . +c . ttt . e . 1 . abscisse curviligne selon 14/23 . +c . v1 . e . 2 . coordonnees du sommet 1 du quadrangle . +c . v2 . e . 2 . coordonnees du sommet 2 du quadrangle . +c . v3 . e . 2 . coordonnees du sommet 3 du quadrangle . +c . v4 . e . 2 . coordonnees du sommet 4 du quadrangle . +c . vn . s . 2 . coordonnees du noeud cree . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTTFI2' ) +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + double precision v1(2), v2(2), v3(2), v4(2), vn(2) + double precision sss, ttt +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision v12(2), v43(2), v14(2), v23(2) + double precision unmsss, unmttt + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. abscisses curvilignes +c==== +c + unmsss = 1.d0 - sss + unmttt = 1.d0 - ttt +cgn print 1789 ,'........ sss = ',sss +cgn print 1789 ,'........ ttt = ',ttt +cgn print 1789 ,'........ v1 = ',v1 +cgn print 1789 ,'........ v2 = ',v2 +cgn print 1789 ,'........ v3 = ',v3 +cgn print 1789 ,'........ v4 = ',v4 +c +c==== +c 2. noeuds de bord +c==== +c + do 20 , iaux = 1 , 2 +c + v12(iaux) = v1(iaux) + sss*(v2(iaux)-v1(iaux)) + v43(iaux) = v4(iaux) + sss*(v3(iaux)-v4(iaux)) + v14(iaux) = v1(iaux) + ttt*(v4(iaux)-v1(iaux)) + v23(iaux) = v2(iaux) + ttt*(v3(iaux)-v2(iaux)) +c + 20 continue +cgn print 1789,'v12 =',v12 +cgn print 1789,'v43 =',v43 +cgn print 1789,'v14 =',v14 +cgn print 1789,'v23 =',v23 +cgn 1789 format(a,2g14.7) +c +c==== +c 3. Calcul +c==== +c + do 30 , iaux = 1 , 2 +c + vn(iaux) = unmttt * v12(iaux) + > + ttt * v43(iaux) + > + unmsss * v14(iaux) + > + sss * v23(iaux) + > - unmsss * unmttt * v1(iaux) + > - unmsss * ttt * v4(iaux) + > - sss * unmttt * v2(iaux) + > - sss * ttt * v3(iaux) +c + 30 continue +cgn print 1789 ,'........ vn = ',vn +cgn print 1789 ,'........ pv = ', +cgn > vn(2)*(v4(1)-v1(1)) - vn(1)*(v4(2)-v1(2)) +c + end diff --git a/src/tool/Utilitaire/utthex.F b/src/tool/Utilitaire/utthex.F new file mode 100644 index 00000000..0339f75a --- /dev/null +++ b/src/tool/Utilitaire/utthex.F @@ -0,0 +1,123 @@ + subroutine utthex ( lehexa, torsio, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) + +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Torsion d'un HEXaedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . torsio . s . 1 . torsion de l'hexaedre . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision torsio, coonoe(nbnoto,3) +c + integer lehexa + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c +c 0.4. ==> variables locales +c + integer listar(12), listso(8) +c + double precision daux +c +c==== +c 1. Les aretes et les sommets de l'hexaedre +c==== +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c +c==== +c 2. traitement +c==== +c +c 2.1. ==> face 1 +c + call uttoqu ( listso(1), listso(2), listso(3), listso(4), + > coonoe, daux ) + torsio = daux +c +c 2.2. ==> face 2 +c + call uttoqu ( listso(1), listso(2), listso(5), listso(6), + > coonoe, daux ) + torsio = max(torsio, daux) +c +c 2.3. ==> face 3 +c + call uttoqu ( listso(1), listso(6), listso(7), listso(4), + > coonoe, daux ) + torsio = max(torsio, daux) +c +c 2.4. ==> face 4 +c + call uttoqu ( listso(5), listso(2), listso(3), listso(8), + > coonoe, daux ) + torsio = max(torsio, daux) +c +c 2.5. ==> face 5 +c + call uttoqu ( listso(7), listso(8), listso(3), listso(4), + > coonoe, daux ) + torsio = max(torsio, daux) +c +c 2.6. ==> face 6 +c + call uttoqu ( listso(5), listso(6), listso(7), listso(8), + > coonoe, daux ) + torsio = max(torsio, daux) +c + end diff --git a/src/tool/Utilitaire/uttoqu.F b/src/tool/Utilitaire/uttoqu.F new file mode 100644 index 00000000..569d2fb8 --- /dev/null +++ b/src/tool/Utilitaire/uttoqu.F @@ -0,0 +1,188 @@ + subroutine uttoqu (s1, s2, s3, s4, coonoe, torsio) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : TOrsion d'un QUadrangle +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c .s1/2/3/4. e . 1 . les noeuds de la face . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . torsio . s . 1 . torsion de la face entre 0, plane, et 2 . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +c +c 0.3. ==> arguments +c + integer s1, s2, s3, s4 +c + double precision coonoe(nbnoto,3) + double precision torsio +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision n1(3), n2(3) + double precision vs1s2(3), vs1s3(3) + double precision vs1s4(3), vs2s4(3), vs3s4(3) + double precision daux +c +#include "impr03.h" +c +c==== +c 1. Traitement par la diagonale s1/s3 +c==== +c +c s1 s2 +c ------------------------- +c . . . +c . . . +c . . . +c . . . +c . . . +c ------------------------- +c s4 s3 +c Attention a prendre la meme orientation pour les deux normales ! +c +c 1.1. ==> Vecteur normal au triangle (s1,s2,s3) +c +cgn write(*,90002) 'triangle des sommets', s1, s2, s3 + vs1s2(1) = coonoe(s2,1) - coonoe(s1,1) + vs1s2(2) = coonoe(s2,2) - coonoe(s1,2) + vs1s2(3) = coonoe(s2,3) - coonoe(s1,3) +c + vs1s3(1) = coonoe(s3,1) - coonoe(s1,1) + vs1s3(2) = coonoe(s3,2) - coonoe(s1,2) + vs1s3(3) = coonoe(s3,3) - coonoe(s1,3) +c + n1(1) = vs1s3(2)*vs1s2(3) - vs1s3(3)*vs1s2(2) + n1(2) = vs1s3(3)*vs1s2(1) - vs1s3(1)*vs1s2(3) + n1(3) = vs1s3(1)*vs1s2(2) - vs1s3(2)*vs1s2(1) +c + daux = sqrt(n1(1)*n1(1)+n1(2)*n1(2)+n1(3)*n1(3)) + do 11 , iaux = 1 , 3 + n1(iaux) = n1(iaux)/daux + 11 continue +cgn write(*,92010) 11, n1 +c +c 1.2. ==> Vecteur normal au triangle (s1,s4,s3) +c +cgn write(*,90002) 'triangle des sommets', s1, s3, s4 + vs1s4(1) = coonoe(s4,1) - coonoe(s1,1) + vs1s4(2) = coonoe(s4,2) - coonoe(s1,2) + vs1s4(3) = coonoe(s4,3) - coonoe(s1,3) +c + n2(1) = vs1s3(2)*vs1s4(3) - vs1s3(3)*vs1s4(2) + n2(2) = vs1s3(3)*vs1s4(1) - vs1s3(1)*vs1s4(3) + n2(3) = vs1s3(1)*vs1s4(2) - vs1s3(2)*vs1s4(1) +c + daux = sqrt(n2(1)*n2(1)+n2(2)*n2(2)+n2(3)*n2(3)) + do 12 , iaux = 1 , 3 + n2(iaux) = -n2(iaux)/daux + 12 continue +cgn write(*,92010) 12, n2 +c +c 1.3. ==> Produit scalaire des vecteurs normaux +c + torsio = n1(1)*n2(1) + n1(2)*n2(2) + n1(3)*n2(3) +cgn write(*,92010) n1(1)*n2(1) + n1(2)*n2(2) + n1(3)*n2(3) +c +c==== +c 2. Traitement par la diagonale s2/s4 +c==== +c +c s1 s2 +c ------------------------- +c . . . +c . . . +c . . . +c . . . +c . . . +c ------------------------- +c s4 s3 +c Attention a prendre la meme orientation pour les deux normales ! +c +c 2.1. ==> Vecteur normal au triangle (s4,s1,s2) +c +cgn write(*,90002) 'triangle des sommets', s4,s1,s2 + vs2s4(1) = coonoe(s4,1) - coonoe(s2,1) + vs2s4(2) = coonoe(s4,2) - coonoe(s2,2) + vs2s4(3) = coonoe(s4,3) - coonoe(s2,3) +c + n1(1) = vs2s4(2)*vs1s4(3) - vs2s4(3)*vs1s4(2) + n1(2) = vs2s4(3)*vs1s4(1) - vs2s4(1)*vs1s4(3) + n1(3) = vs2s4(1)*vs1s4(2) - vs2s4(2)*vs1s4(1) +c + daux = sqrt(n1(1)*n1(1)+n1(2)*n1(2)+n1(3)*n1(3)) + do 21 , iaux = 1 , 3 + n1(iaux) = n1(iaux)/daux + 21 continue +cgn write(*,92010) 21, n1 +c +c 2.2. ==> Vecteur normal au triangle (s1,s4,s3) +c +cgn write(*,90002) 'triangle des sommets', s4, s2, s3 + vs3s4(1) = coonoe(s4,1) - coonoe(s3,1) + vs3s4(2) = coonoe(s4,2) - coonoe(s3,2) + vs3s4(3) = coonoe(s4,3) - coonoe(s3,3) +c + n2(1) = vs3s4(2)*vs2s4(3) - vs3s4(3)*vs2s4(2) + n2(2) = vs3s4(3)*vs2s4(1) - vs3s4(1)*vs2s4(3) + n2(3) = vs3s4(1)*vs2s4(2) - vs3s4(2)*vs2s4(1) +c + daux = sqrt(n2(1)*n2(1)+n2(2)*n2(2)+n2(3)*n2(3)) + do 22 , iaux = 1 , 3 + n2(iaux) = n2(iaux)/daux + 22 continue +cgn write(*,92010) 22, n2 +c +c 2.3. ==> Produit scalaire des vecteurs normaux +c + torsio = min ( torsio, n1(1)*n2(1) + n1(2)*n2(2) + n1(3)*n2(3) ) +cgn write(*,92010) n1(1)*n2(1) + n1(2)*n2(2) + n1(3)*n2(3) +c +c==== +c 3. Torsion : Le produit scalaire des vecteurs normaux vaut 1 s'ils +c sont colineaires. La torsion vaudra alors 0. A l'extreme, pour +c deux triangles opposes, le produit scalaire vaut -1 et la +c torsion vaudra 2. +c Remarque : on prend la valeur absolue pour eviter les affichages +c en -0.00000 +c==== +c + torsio = abs(1.d0 - torsio) +c + end diff --git a/src/tool/Utilitaire/uttpen.F b/src/tool/Utilitaire/uttpen.F new file mode 100644 index 00000000..e155f4a7 --- /dev/null +++ b/src/tool/Utilitaire/uttpen.F @@ -0,0 +1,108 @@ + subroutine uttpen ( lepent, torsio, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) + +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Torsion d'un PENtaedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . torsio . s . 1 . torsion du pentaedre . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. codes des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision torsio, coonoe(nbnoto,3) +c + integer lepent + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c +c 0.4. ==> variables locales +c + integer listar(9), listso(6) +c + double precision daux +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et les sommets du pentaedre +c==== +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c==== +c 2. Traitement +c==== +c +c 2.1. ==> face 3 +c + call uttoqu ( listso(1), listso(4), listso(6), listso(3), + > coonoe, daux ) + torsio = daux +c +c 2.2. ==> face 4 +c + call uttoqu ( listso(2), listso(5), listso(4), listso(1), + > coonoe, daux ) + torsio = max(torsio, daux) +c +c 2.3. ==> face 5 +c + call uttoqu ( listso(3), listso(6), listso(5), listso(2), + > coonoe, daux ) + torsio = max(torsio, daux) +c + end diff --git a/src/tool/Utilitaire/uttpyr.F b/src/tool/Utilitaire/uttpyr.F new file mode 100644 index 00000000..eb5ac23b --- /dev/null +++ b/src/tool/Utilitaire/uttpyr.F @@ -0,0 +1,90 @@ + subroutine uttpyr ( lapyra, torsio, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) + +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Torsion d'une PYRamide +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . torsio . s . 1 . torsion de la pyramide . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*4. numeros des 4 aretes des quadrangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + double precision torsio, coonoe(nbnoto,3) +c + integer lapyra + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c +c 0.4. ==> variables locales +c + integer listar(8), listso(5) +c +c==== +c 1. les aretes et les sommets de la pyramide +c==== +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +c==== +c 2. Traitement +c La face f5 est le quadrangle. +c Elle s'appuie sur les sommets s1, s2, s3, s4. +c==== +c + call uttoqu ( listso(1), listso(2), listso(3), listso(4), + > coonoe, torsio ) +c + end diff --git a/src/tool/Utilitaire/uttqua.F b/src/tool/Utilitaire/uttqua.F new file mode 100644 index 00000000..86d70ff5 --- /dev/null +++ b/src/tool/Utilitaire/uttqua.F @@ -0,0 +1,87 @@ + subroutine uttqua ( lequad, torsio, + > coonoe, somare, arequa ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Torsion d'un QUAdrangle +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . numero du quadrangle a examiner . +c . torsio . s . 1 . torsion du quadrangle . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision torsio, coonoe(nbnoto,sdim) +c + integer somare(2,nbarto), arequa(nbquto,4) +c + integer lequad +c +c 0.4. ==> variables locales +c + integer a1, a2, a3, a4 + integer sa1a2, sa2a3, sa3a4, sa4a1 +c +c 0.5. ==> initialisations +c +c==== +c 1. les sommets +c==== +c + a1 = arequa(lequad,1) + a2 = arequa(lequad,2) + a3 = arequa(lequad,3) + a4 = arequa(lequad,4) +c + call utsoqu ( somare, a1, a2, a3, a4, + > sa1a2, sa2a3, sa3a4, sa4a1 ) +c +c==== +c 2. Traitement +c==== +c + call uttoqu ( sa1a2, sa2a3, sa3a4, sa4a1, + > coonoe, torsio ) +c + end diff --git a/src/tool/Utilitaire/uttrii.F b/src/tool/Utilitaire/uttrii.F new file mode 100644 index 00000000..d8c8135b --- /dev/null +++ b/src/tool/Utilitaire/uttrii.F @@ -0,0 +1,196 @@ + subroutine uttrii ( classt, vmin, vmax, + > nbval, valeur, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TRI d'un tableau Entier +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . classt . s . nbval . classement des numeros associes aux valeurs. +c . . . . 1 : le numero de la plus petite valeur . +c . . . . nbval : le numero de la plus grande valeur . +c . vmin . s . 1 . valeur minimale atteinte . +c . vmax . s . 1 . valeur maximale atteinte . +c . nbval . e . 1 . nombre de valeurs a traiter . +c . valeur . e . nbval . liste des valeurs a ranger . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTTRII' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbval + integer classt(nbval) +c + integer valeur(nbval), vmin, vmax +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numero, nbvtri +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Tri d''''un tableau entier.'')' + texte(1,5) = '(''Nombre de valeurs a trier :'',i13)' + texte(1,6) = '(''Valeur minimale :'',i13)' + texte(1,7) = '(''Valeur maximale :'',i13)' +c + texte(2,4) = '(''Sort of an integer array.'')' + texte(2,5) = '(''Number of valeurs to sort :'',i13)' + texte(2,6) = '(''Minimum value :'',i13)' + texte(2,7) = '(''Maximum value :'',i13)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) nbval + 1000 format (a,'(',i13,') = ',i13) + 1001 format (a) +#endif +c +c==== +c 2. Tri +c==== +c + nbvtri = 0 +c + do 21 , iaux = 1 , nbval +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' ' + write (ulsort,1000) 'valeur',iaux, valeur(iaux) +#endif +c +c 2.1. ==> recherche de la valeur superieure a la courante parmi +c les valeurs deja classees +c + do 211 , jaux = 1 , nbvtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) ' classt',valeur(jaux), classt(jaux) +#endif + if ( valeur(classt(jaux)).gt.valeur(iaux) ) then + numero = jaux +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) ' ==> numero',valeur(iaux), numero +#endif + goto 212 + endif + 211 continue +c + numero = nbvtri + 1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) ' on met au bout' +#endif +c +c 2.2. ==> insertion de l'element courant a la bonne place dans la liste +c + 212 continue +c + do 213 , jaux = nbvtri, numero, -1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' deplacement de', + > valeur(classt(jaux)),' en',jaux+1 +#endif + classt(jaux+1) = classt(jaux) + 213 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) ' placement de ',valeur(iaux),' en',numero +#endif + classt(numero) = iaux +c + nbvtri = nbvtri + 1 +c + 21 continue +c + vmin = valeur(classt(1)) + vmax = valeur(classt(nbval)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) vmin + write (ulsort,texte(langue,7)) vmax + do 219 , jaux = 1 , nbvtri + write (ulsort,1000) 'classt',valeur(jaux), classt(jaux) + 219 continue +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttrir.F b/src/tool/Utilitaire/uttrir.F new file mode 100644 index 00000000..488c490f --- /dev/null +++ b/src/tool/Utilitaire/uttrir.F @@ -0,0 +1,183 @@ + subroutine uttrir ( classt, vmin, vmax, + > nbval, valeur, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TRI d'un tableau Reel +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . classt . s . nbval . classement des numeros associes aux valeurs. +c . . . . 1 : le numero de la plus petite valeur . +c . . . . nbval : le numero de la plus grande valeur . +c . vmin . s . 1 . valeur minimale atteinte . +c . vmax . s . 1 . valeur maximale atteinte . +c . nbval . e . 1 . nombre de valeurs a traiter . +c . valeur . e . nbval . liste des valeurs a ranger . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTTRIR' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbval + integer classt(nbval) +c + double precision valeur(nbval), vmin, vmax +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer numero, nbvtri +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Tri d''''un tableau reel.'')' + texte(1,5) = '(''Nombre de valeurs a trier :'',i13)' + texte(1,6) = '(''Valeur minimale :'',g13.7)' + texte(1,7) = '(''Valeur maximale :'',g13.7)' +c + texte(2,4) = '(''Sort of a real array.'')' + texte(2,5) = '(''Number of valeurs to sort :'',i13)' + texte(2,6) = '(''Minimum value :'',g13.7)' + texte(2,7) = '(''Maximum value :'',g13.7)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) nbval + 1000 format (a,'(',i13,') = ',g13.8) + 1001 format (a,'(',g13.8,') = ',g13.8) +#endif +c +c==== +c 2. Tri +c==== +c + nbvtri = 0 +c + do 21 , iaux = 1 , nbval +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) 'valeur',iaux, valeur(iaux) +#endif +c +c 2.1. ==> recherche de la valeur superieure a la courante parmi +c les valeurs deja classees +c + do 211 , jaux = 1 , nbvtri +#ifdef _DEBUG_HOMARD_ + write (ulsort,1000) ' classt',jaux, classt(jaux) +#endif + if ( valeur(classt(jaux)).gt.valeur(iaux) ) then + numero = jaux + goto 212 + endif + 211 continue +c + numero = nbvtri + 1 +c +c 2.2. ==> insertion de l'element courant a la bonne place dans la liste +c + 212 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,1001) ' ==> numero',valeur(iaux), numero +#endif +c + do 213 , jaux = nbvtri, numero, -1 + classt(jaux+1) = classt(jaux) + 213 continue +c + classt(numero) = iaux +c + nbvtri = nbvtri + 1 +c + 21 continue +c + vmin = valeur(classt(1)) + vmax = valeur(classt(nbval)) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) vmin + write (ulsort,texte(langue,7)) vmax +#endif +c +c==== +c 4. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttris.F b/src/tool/Utilitaire/uttris.F new file mode 100644 index 00000000..3b6c1cae --- /dev/null +++ b/src/tool/Utilitaire/uttris.F @@ -0,0 +1,440 @@ + subroutine uttris ( seuil, + > typtri, classt, + > fracti, nbval, valeur, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TRI d'un tableau reel pour un Seuil +c -- --- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . seuil . s . 1 . seuil correspondant . +c . typtri . e . 1 . 1 : grandes valeurs . +c . . . . 2 : faibles valeurs . +c . fracti . e . 1 . pourcentage d'entites a retenir . +c . classt . s . nbval . tableau auxiliaire . +c . nbval . e . 1 . nombre de valeurs a traiter . +c . valeur . e . nbval . liste des valeurs a ranger . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTTRIS' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "infini.h" +#include "precis.h" +c +c 0.3. ==> arguments +c + integer typtri, nbval + integer classt(nbval) +c + double precision seuil, fracti, valeur(nbval) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer numero, nombre, nbvtri +c + double precision daux, daux1 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Recherche du seuil'')' + texte(1,5) = '(''Nombre de valeurs a trier :'',i12)' + texte(1,6) = '(''Pourcentage demande :'',g13.7)' + texte(1,7) = '(''==> Nombre d''''entites :'',i12)' + texte(1,8) = '(''Tri sur les grandes valeurs'')' + texte(1,9) = '(''Tri sur les faibles valeurs'')' + texte(1,10) = '(''Seuil :'',g13.7)' + texte(1,11) = '(''Le pourcentage d''''entites est trop faible.'')' + texte(1,12) = '(''Une seule valeur a trier.'')' +c + texte(2,4) = '(''Sort of a real array'')' + texte(2,5) = '(''Number of valeurs to sort :'',i12)' + texte(2,6) = '(''Requested percentage :'',g13.7)' + texte(2,7) = '(''==> Number of entities :'',i12)' + texte(2,8) = '(''Sort for large values'')' + texte(2,9) = '(''Sort for small values'')' + texte(2,10) = '(''Threshold :'',g13.7)' + texte(2,11) = '(''Requested percentage is too small.'')' + texte(2,12) = '(''A unique value to sort.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) nbval + write (ulsort,texte(langue,6)) fracti +#endif +c +c==== +c 2. Prealable +c==== +c +c 2.1. ==> controle du type de recherche +c + if ( typtri.lt.1 .or. typtri.gt.2 ) then + codret = 1 + else + codret = 0 +#ifdef _DEBUG_HOMARD_ + if ( typtri.eq.1 ) then + write (ulsort,texte(langue,8)) + else + write (ulsort,texte(langue,9)) + endif +#endif + endif +cgn print 88,(valeur(iaux),iaux =1,nbval) +cgn 88 format(12g10.3) +c +c 2.2. ==> nombre de valeurs a traiter +c + if ( codret.eq.0 ) then +c +c 2.2.1. ==> Si 1 seule entite, le cas est particulier +c + if ( nbval.eq.1 ) then +c + nbvtri = 1 +c + else +c +c 2.2.2. ==> Avec au moins deux entites, on cherche le nombre +c correspondant au pourcentage demande par l'entier le plus +c proche. +c si on a au moins deux valeurs, on ajoute 1, sauf si on est +c deja au maximum. + + nbvtri = nint(fracti*dble(nbval)/100.d0) +c + if ( nbvtri.ge.2 ) then + nbvtri = min(nbvtri+1,nbval) + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) nbvtri +#endif +c + endif +c + endif +c +c==== +c 3. calcul du seuil pour les grandes valeurs +c==== +c + if ( codret.eq.0 ) then +c + if ( typtri.eq.1 ) then +c + if ( nbvtri.eq.0 ) then +c +c 3.1. ==> Si 0 entite, le seuil est au dessus du maximum +c + daux = vinfne + do 311 , iaux = 1 , nbval + daux = max(daux,valeur(iaux)) + 311 continue + seuil = 2.d0 * daux +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,11)) +#endif +c + elseif ( nbvtri.eq.1 ) then +c +c 3.2. ==> Si 1 entite, le seuil est juste au-dessous du maximum +c + daux = valeur(1) + daux1 = vinfpo + do 321 , iaux = 2 , nbval + if ( abs(valeur(iaux)-daux).gt.epsima ) then + daux1 = min(daux1,abs(valeur(iaux)-daux)) + endif + daux = max(daux,valeur(iaux)) + 321 continue +cgn print 88,daux,daux1 + seuil = daux - 0.5d0*daux1 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,12)) + write (ulsort,90004) 'seuil', seuil +#endif +c + else +c +c 3.3. ==> cas general +c on stocke dans le tableau classt les indices des valeurs les +c plus grandes. L'indice 1 correspond a la plus grande valeur +c et ainsi de suite. +c + nombre = 0 + daux = vinfne +c + do 331 , iaux = 1 , nbval +c +c 3.3.1. ==> si la valeur courante est plus grande que le mini des +c valeurs deja classees, ou si on n'a pas encore classe au +c moins nbvtri valeurs, il faut l'inserer dans le tableau. +c on recherche la valeur juste inferieure +c sinon, on passe a la valeur suivante +c +cgn print *,valeur(iaux),daux,(valeur(classt(jaux)), jaux =1,nombre) + if ( valeur(iaux).gt.daux .or. nombre.lt.nbvtri ) then +c + do 3311 , jaux = 1 , nombre + if ( valeur(classt(jaux)).lt.valeur(iaux) ) then + numero = jaux + goto 3312 + endif + 3311 continue +c + if ( nombre.eq.nbvtri ) then + numero = nbvtri + else + numero = nombre + 1 + endif +c + else +c +cgn print *,'goto 331' + goto 331 +c + endif +c +c 3.3.2. ==> insertion de l'element courant a la bonne place +c dans la liste +c + 3312 continue +cgn print *,'numero = ',numero +c + if ( nombre.eq.nbvtri ) then + kaux = nbvtri - 1 + else + kaux = nombre + endif + do 3313 , jaux = kaux, numero, -1 + classt(jaux+1) = classt(jaux) + 3313 continue +c + classt(numero) = iaux +c +c 3.3.3. ==> nombre de valeurs classees : une de plus qu'avant, sauf si +c on a deja classe toutes celles voulues. +c Il ne faut surtout pas tout classer sinon c'est extremement +c couteux (en o(n**2)) +c + if ( nombre.lt.nbvtri ) then + nombre = nombre + 1 + endif + daux = valeur(classt(nombre)) +cgn print *,daux,nombre +c + 331 continue +c +c 3.3.4. ==> le seuil est entre la valeur correspondant au pourcentage +c d'element et celle immediatement superieure +c +cgn print *,valeur(classt(nbvtri-1)) +cgn print *,valeur(classt(nbvtri)) + seuil = 0.5d0* + > (valeur(classt(nbvtri-1))+valeur(classt(nbvtri))) +c + endif +c +c==== +c 4. calcul du seuil pour les faibles valeurs +c==== +c + else +c + if ( nbvtri.eq.0 ) then +c +c 4.1. ==> Si 0 entite, le seuil est au dessous du minimum +c + daux = vinfpo + do 411 , iaux = 1 , nbval + daux = min(daux,valeur(iaux)) + 411 continue + seuil = 0.5d0 * daux +c + elseif ( nbvtri.eq.1 ) then +c +c 4.2. ==> Si 1 entite, le seuil est juste au-dessus du minimum +c + daux = valeur(1) + daux1 = vinfpo + do 421 , iaux = 2 , nbval + if ( abs(valeur(iaux)-daux).gt.epsima ) then + daux1 = min(daux1,abs(valeur(iaux)-daux)) + endif + daux = min(daux,valeur(iaux)) + 421 continue + seuil = daux + 0.5d0*daux1 +c + else +c +c 4.3. ==> cas general +c on stocke dans le tableau classt les indices des valeurs les +c plus grandes. L'indice 1 correspond a la plus petite valeur +c et ainsi de suite. +c + nombre = 0 + daux = vinfpo +c + do 431 , iaux = 1 , nbval +c +c 4.3.1. ==> si la valeur courante est plus petite que le maxi des +c valeurs deja classees, ou si on n'a pas encore classe au +c moins nbvtri valeurs, il faut l'inserer dans le tableau. +c on recherche la valeur juste superieure +c sinon, on passe a la valeur suivante +c +cgn print 88,valeur(iaux),daux,(valeur(classt(jaux)),jaux =1,nombre) +cgn 88 format(12g10.3) + if ( valeur(iaux).lt.daux .or. nombre.lt.nbvtri ) then +c + do 4311 , jaux = 1 , nombre + if ( valeur(classt(jaux)).gt.valeur(iaux) ) then + numero = jaux + goto 4312 + endif + 4311 continue +c + if ( nombre.eq.nbvtri ) then + numero = nbvtri + else + numero = nombre + 1 + endif +c + else +c +cgn print *,'goto 431' + goto 431 +c + endif +c +c 4.3.2. ==> insertion de l'element courant a la bonne place +c dans la liste +c + 4312 continue +cgn print *,'numero = ',numero +c + if ( nombre.eq.nbvtri ) then + kaux = nbvtri - 1 + else + kaux = nombre + endif + do 4313 , jaux = kaux, numero, -1 + classt(jaux+1) = classt(jaux) + 4313 continue +c + classt(numero) = iaux +c +c 4.3.3. ==> nombre de valeurs classees : une de plus qu'avant, sauf si +c on a deja classe toutes celles voulues. +c Il ne faut surtout pas tout classer sinon c'est extremement +c couteux (en o(n**2)) +c + if ( nombre.lt.nbvtri ) then + nombre = nombre + 1 + endif + daux = valeur(classt(nombre)) +cgn print *,daux,nombre +c + 431 continue +c +c 4.3.4. ==> le seuil est entre la valeur correspondant au pourcentage +c d'element et celle immediatement inferieure +c +cgn print *,valeur(classt(nbvtri-1)) +cgn print *,valeur(classt(nbvtri)) + seuil = 0.5d0* + > (valeur(classt(nbvtri-1))+valeur(classt(nbvtri))) +c + endif +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,10)) seuil +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/uttrn2.F b/src/tool/Utilitaire/uttrn2.F new file mode 100644 index 00000000..f754dfed --- /dev/null +++ b/src/tool/Utilitaire/uttrn2.F @@ -0,0 +1,181 @@ + subroutine uttrn2 ( dedans, + > v1, v2, v3, vn, typbor ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - TRiangle - Noeud - dimension 2 +c -- -- - - +c ______________________________________________________________________ +c +c teste si le noeud de coordonnees vn est a l'interieur du triangle +c dont les sommets ont pour coordonnees v1, v2, v3 +c programme en dimension 2 +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . dedans . s . 1 . vrai ou faux selon que le noeud est dedans . +c . . . . ou hors du triangle . +c . v1 . e . 2 . coordonnees du sommet 1 du triangle . +c . v2 . e . 2 . coordonnees du sommet 2 du triangle . +c . v3 . e . 2 . coordonnees du sommet 3 du triangle . +c . vn . e . 2 . coordonnees du noeud a tester . +c . typbor . e . 1 . 1, si on accepte un noeud sur le bord . +c . . . . 0, si on rejette un noeud sur le bord . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +cgn character*6 nompro +cgn parameter ( nompro = 'UTTRN2' ) +c +c 0.2. ==> communs +c +#include "precis.h" +c +c 0.3. ==> arguments +c + integer typbor +c + double precision v1(2), v2(2), v3(2), vn(2) +c + logical dedans +c +c 0.4. ==> variables locales +c + double precision pvnoeu, pvtria + double precision xmax, xmin, ymax, ymin + double precision prosca + double precision daux + +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +cgn print 1789 ,'... Noeud 1 du triangle, v1 = ',v1 +cgn print 1789 ,'... Noeud 2 du triangle, v2 = ',v2 +cgn print 1789 ,'... Noeud 3 du triangle, v3 = ',v3 +cgn print 1789 ,'... point a tester vn = ',vn +cgn 1789 format(a,4g14.7) +c +c==== +c 2. controle +c==== +c + xmin = min(v1(1),v2(1),v3(1)) + xmax = max(v1(1),v2(1),v3(1)) + ymin = min(v1(2),v2(2),v3(2)) + ymax = max(v1(2),v2(2),v3(2)) +cgn print 1789 ,'... xmin/xmax = ',xmin, xmax +cgn print 1789 ,'... ymin/ymax = ',ymin, ymax +c +c 2.1. ==> controle elementaire : le noeud doit etre dans le quadrangle +c enveloppe du triangle +c + if ( vn(1).lt.xmin .or. vn(1).gt.xmax .or. + > vn(2).lt.ymin .or. vn(2).gt.ymax ) then +c + dedans = .false. +cgn print * ,'... hors du quadrangle enveloppe du triangle ... ' +c + else +c +c 2.2. ==> n est-il dans le triangle ? +c cela est vrai si le noeud et un sommet sont du meme cote +c de l'arete formee par les deux autres sommets, et cela pour +c toutes les aretes. +c on regarde si les produits vectoriels (ab,ac) et (ab,an) +c sont de meme orientation pour les trois permutations +c circulaires sur (a,b,c), c'est-a-dire si le produit +c scalaire des deux produits vectoriels est positif. +c pour pouvoir pieger les cas ou le noeud est sur une arete, on +c teste le caractere strictement positif ou positif du produit +c scalaire, selon la demande. +c + if ( typbor.eq.0 ) then + daux = 1.d-10 + else + daux = -epsima + endif +c + dedans = .true. +c +c 2.2.1. ==> arete (s1,s2) +c pvnoeu represente le produit vectoriel s1s2 x s1s3 + pvnoeu = (v2(1)-v1(1)) * (v3(2)-v1(2)) + > - (v2(2)-v1(2)) * (v3(1)-v1(1)) +c pvtria represente le produit vectoriel s1s2 x s1n. + pvtria = (v2(1)-v1(1)) * (vn(2)-v1(2)) + > - (v2(2)-v1(2)) * (vn(1)-v1(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +c +cgn print 1789 ,'... prosca s1s2 = ',prosca + if ( prosca.le.daux ) then + dedans = .false. + goto 30 + endif +c +c 2.2.2. ==> arete (s2,s3) +c pvnoeu represente le produit vectoriel s2s3 x s2s1 + pvnoeu = (v3(1)-v2(1)) * (v1(2)-v2(2)) + > - (v3(2)-v2(2)) * (v1(1)-v2(1)) +c pvtria represente le produit vectoriel s2s3 x s2n. + pvtria = (v3(1)-v2(1)) * (vn(2)-v2(2)) + > - (v3(2)-v2(2)) * (vn(1)-v2(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +c +cgn print 1789 ,'... prosca s2s3 = ',prosca + if ( prosca.le.daux ) then + dedans = .false. + goto 30 + endif +c +c 2.2.3. ==> arete (s3,s1) +c pvnoeu represente le produit vectoriel s3s1 x s3s2 + pvnoeu = (v1(1)-v3(1)) * (v2(2)-v3(2)) + > - (v1(2)-v3(2)) * (v2(1)-v3(1)) +c pvtria represente le produit vectoriel s3s1 x s3n. + pvtria = (v1(1)-v3(1)) * (vn(2)-v3(2)) + > - (v1(2)-v3(2)) * (vn(1)-v3(1)) +c + prosca = pvtria*pvnoeu + pvtria*pvnoeu + pvtria*pvnoeu +cgn print 1789 ,'... prosca s3s1 = ',prosca +c + if ( prosca.le.daux ) then + dedans = .false. + endif +c + 30 continue +c + endif +c + end diff --git a/src/tool/Utilitaire/utulbi.F b/src/tool/Utilitaire/utulbi.F new file mode 100644 index 00000000..e78e73da --- /dev/null +++ b/src/tool/Utilitaire/utulbi.F @@ -0,0 +1,441 @@ + subroutine utulbi ( nuroul, nomflo, lnomfl, + > typfic, motcle, numer1, numer2, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Unite Logiques des BIlans +c -- - - -- +c ______________________________________________________________________ +c +c but : retourner le numero d'unite logique associe aux fichiers +c d'ecriture des bilans. +c . on ouvre le fichier et on renvoie le numero attribue. +c . la premiere cause d'erreur donnant un code de retour non nul +c est une mauvaise demande de type de fichier. +c ensuite, en cas d'erreur dans la recherche du fichier, si le +c type demande est positif, on renvoie le numero de la sortie +c standard. si le type est negatif on renvoie un code 3. +c +c Selon qu'un mot-cle a ete fourni ou non, le fichier a pour nom : +c "info".+[numer1.]+[numer2.]+suffixe(typfic) +c prefixe.+[numer1.]+[numer2.]+suffixe(typfic) +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nuroul . s . 1 . numero d'unite logique lie au fichier . +c . nomflo . s . 200 . nom local du fichier . +c . lnomfl . s . 1 . longueur du nom local du fichier . +c . typfic . e . 1 . type de fichier souhaite : . +c . . . . 1 : bilan sur les entites . +c . . . . 2 : pour xmgrace . +c . . . . 3 : histogramme sur l'indicateur d'erreur . +c . . . . 4 : postscript . +c . . . . 5 : champ en ascii . +c . . . . 6 : xfig . +c . . . . 7 : texte . +c . . . . 8 : log . +c . . . . 9 : numero d'iteration . +c . . . . 10 : valeurs brutes . +c . . . . 100 : fortran des objets stockes . +c . motcle . e . * . si longueur > 0 : remplace le prefixe . +c . . . . si longueur = 0 : on garde le prefixe . +c . numer1 . e . 1 . si >= 0 : 1er numero a intercaler . +c . . . . si < 0 : on ne fait rien . +c . numer2 . e . 1 . si >= 0 : 2nd numero a intercaler . +c . . . . si < 0 : on ne fait rien . +c . ulsort . e . 1 . unite logique de la liste standard . +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 1 : mauvais type de fichier demande . +c . . . . 3 : probleme a l'ouverture . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTULBI' ) +c +#include "nblang.h" +#include "motcle.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nuroul, lnomfl + integer typfic, numer1, numer2 +c + character*(*) nomflo + character*(*) motcle +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lnomfi, lgchai +c + character*1 slash + character*5 suffix + character*8 typobs + character*100 chaine + character*200 nomfic +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,5) = '(''Mot-cle : '',a)' + texte(1,6) = '(''Numero '',i8,'' : '',i4)' + texte(1,4) = '(''Type de fichier demande : '',i4)' + texte(1,7) = '('' --> suffixe : '',a5)' + texte(1,8) = '(''Repertoire racine : '',a)' + texte(1,9) = '(''Unite logique :'',i3)' + texte(1,10) = '(''Nom du fichier : '',a)' +c + texte(2,5) = '(''Keyword: '',a)' + texte(2,6) = '(''Number '',i8,'': '',i4)' + texte(2,4) = '(''File type: '',i4)' + texte(2,7) = '('' --> : '',a5)' + texte(2,8) = '(''Root directory: '',a)' + texte(2,9) = '(''Logical unit:'',i3)' + texte(2,10) = '(''File name: '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) typfic + write (ulsort,texte(langue,5)) motcle + write (ulsort,texte(langue,6)) 1, numer1 + write (ulsort,texte(langue,6)) 2, numer2 +#endif +c +c==== +c 2. type de fichier +c==== +c + if ( abs(typfic).eq.1 ) then + suffix = 'bilan' + elseif ( abs(typfic).eq.2 ) then + suffix = 'dat ' + elseif ( abs(typfic).eq.3 ) then + suffix = 'hist ' + elseif ( abs(typfic).eq.4 ) then + suffix = 'ps ' + elseif ( abs(typfic).eq.5 ) then + suffix = 'data ' + elseif ( abs(typfic).eq.6 ) then + suffix = 'fig ' + elseif ( abs(typfic).eq.7 ) then + suffix = 'txt ' + elseif ( abs(typfic).eq.8 ) then + suffix = 'log ' + elseif ( abs(typfic).eq.9 ) then + suffix = 'iter ' + elseif ( abs(typfic).eq.10 ) then + suffix = 'dat ' + elseif ( abs(typfic).eq.100 ) then + suffix = 'F ' + else + codret = 1 + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) suffix +#endif +c + nomfic( 1: 80) = blan80 + nomfic( 81:160) = blan80 + nomfic(161:200) = blan80(1:40) +c +c==== +c 3. Definition du repertoire des fichiers +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. Repertoire ; codret', codret +#endif +c 3.1. ==> Recherche de la donnee eventuelle +c + if ( codret.eq.0 ) then +c + typobs = mcrepi +c + call utosde ( typobs, ulsort, langue, codret ) +c + if ( codret.ne.0 ) then +c + codret = 0 + lnomfi = 1 + nomfic(1:lnomfi) = '.' +c + else +c + iaux = 0 + jaux = 1 + call utfino ( typobs, iaux, nomfic, lnomfi, + > jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2. ==> Mise en forme du nom du repertoire +c + if ( codret.eq.0 ) then +c + call dmsepf ( slash ) + lnomfi = lnomfi + 1 + nomfic(lnomfi:lnomfi) = slash +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + if ( lnomfi.gt.0 ) then + write (ulsort,90002) 'lnomfi', lnomfi + write (ulsort,texte(langue,8)) nomfic(1:lnomfi) + endif + endif +#endif +c +c==== +c 4. nom complet du fichier +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. nom du fichier ; codret', codret +#endif +c + if ( lnomfi.gt.0 ) then +c +c 4.1. ==> mot-cle a intercaler +c + if ( codret.eq.0 ) then +c + call utlgut ( lgchai, motcle, + > ulsort, langue, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nomflo( 1: 80) = blan80 + nomflo( 81:160) = blan80 + nomflo(161:200) = blan80(1:40) +c + if ( lgchai.eq.0 ) then +c + lnomfl = 4 + nomflo(1:lnomfl) = 'info' +c + else +c + lnomfl = lgchai + nomflo(1:lnomfl) = motcle(1:lgchai) +cc nomflo(1:lgchai) = motcle(1:lgchai) +cc lnomfl = lgchai +c + endif +c + endif +c +c 4.2. ==> 1ere chaine a intercaler +c En general, on impose un retour sur au moins 2 caracteres +c Pour les valeurs brutes, au moins 3 caracteres +c + if ( numer1.ge.0 ) then +c + if ( codret.eq.0 ) then +c + if ( numer1.lt.100 .and. abs(typfic).ne.10 ) then + iaux = 2 + elseif ( numer1.lt.1000 ) then + iaux = 3 + elseif ( numer1.lt.10000 ) then + iaux = 4 + else + iaux = len(chaine) + endif + call utench ( numer1, '0', lgchai, chaine(1:iaux), + > ulsort, langue, codret ) +c + endif +cgn print *,'lgchai = ',lgchai +cgn print *,'chaine = ',chaine +c + if ( codret.eq.0 ) then +c + iaux = lnomfl + 1 + lgchai + nomflo(lnomfl+1:iaux) = '.'//chaine(1:lgchai) + lnomfl = iaux +c + endif +c + endif +c +c 4.3. ==> 2ere chaine a intercaler +c Remarque : on impose un retour sur 3 caracteres +c + if ( numer2.ge.0 ) then +c + if ( codret.eq.0 ) then +c + call utench ( numer2, '0', lgchai, chaine(1:3), + > ulsort, langue, codret ) +c + endif +cgn print *,'lgchai = ',lgchai +cgn print *,'chaine = ',chaine +c + if ( codret.eq.0 ) then +c + iaux = lnomfl + 1 + lgchai + nomflo(lnomfl+1:iaux) = '.'//chaine(1:lgchai) + lnomfl = iaux +c + endif +c + endif +c +c 4.4. ==> suffixe retenu +c + if ( codret.eq.0 ) then +c + call utlgut ( lgchai, suffix, + > ulsort, langue, codret ) +c + iaux = lnomfl + 1 + lgchai + nomflo(lnomfl+1:iaux) = '.'//suffix(1:lgchai) + lnomfl = iaux +c + endif +c +c 4.5. ==> nom complet +c + if ( codret.eq.0 ) then +c + nomfic(lnomfi+1:lnomfi+1+lnomfl) = nomflo(1:lnomfl) + lnomfi = lnomfi+lnomfl +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,10)) nomflo(1:lnomfl) + write (ulsort,texte(langue,10)) nomfic(1:lnomfi) +#endif +c + endif +c +c==== +c 5. recherche de l'unite logique associee +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. unite logique ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +c 5.1. ==> rien n'a ete precise, on le met dans la sortie standard +c + if ( lnomfi.le.0 ) then +c + nuroul = ulsort +c +c 5.2. ==> recherche du numero d'unite logique associee au fichier +c soit il existe deja, soit on le cree. +c + else +c +cgn call guinfo + call gucara ( nomfic, lnomfi, nuroul, codret) +c + if ( codret.eq.0 ) then +c + if ( nuroul.eq.0 ) then + call guoufs ( nomfic, lnomfi, nuroul, codret ) + if ( codret.eq.0 ) then + call gurbbu ( nuroul, codret) + else + codret = 0 + nuroul = ulsort + endif + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,9)) nuroul +#endif +c + endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret + write (ulsort,texte(langue,4)) typfic + write (ulsort,texte(langue,5)) motcle + write (ulsort,texte(langue,6)) 1, numer1 + write (ulsort,texte(langue,6)) 2, numer2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utulfd.F b/src/tool/Utilitaire/utulfd.F new file mode 100644 index 00000000..a805227d --- /dev/null +++ b/src/tool/Utilitaire/utulfd.F @@ -0,0 +1,107 @@ + subroutine utulfd ( action, nbiter, nuroul, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Retourne le numero d'unite logique associee au fichier des donnees +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . action . e . char*8 . action courante . +c . nbiter . e . 1 . numero d'iteration courante . +c . nuroul . s . 1 . unite logique de la liste standard . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 2 : pas de mot-cle dans la base . +c . . . . 3 : fichier de la liste standard non ouvert. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "consts.h" +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbiter + integer nuroul, codret +c + character*8 action +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer ulsort + integer lnomfl +c + character*16 motcle + character*200 nomflo +c +#include "langue.h" +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c + call utulls ( ulsort, codret ) +c +c==== +c 1. Elaboration du nom de fichier associe au fichier des donnees +c==== +c + motcle = blan16 +c + if ( action(1:7).eq.'info_av' ) then + if ( nbiter.eq.0 ) then + motcle(1:4) = 'info' + else + motcle(1:10) = 'info_avant' + endif +c + elseif ( action(1:7).eq.'info_ap' ) then + motcle(1:10) = 'info_apres' +c + endif +cgn write (*,*) 'motcle = ', motcle(1:10) +c +c==== +c 2. recherche de l'unite logique associee +c==== +c + if ( codret.eq.0 ) then +c + iaux = 2 + jaux = -1 +c + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, motcle, nbiter, jaux, + > ulsort, langue, codret ) +cgn write (*,*) nuroul,codret +c + endif +c + end diff --git a/src/tool/Utilitaire/utulls.F b/src/tool/Utilitaire/utulls.F new file mode 100644 index 00000000..c3b5085a --- /dev/null +++ b/src/tool/Utilitaire/utulls.F @@ -0,0 +1,108 @@ + subroutine utulls ( ulsort, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c Retourne le numero d'unite logique associee a la liste standard +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ulsort . s . 1 . unite logique de la liste standard . +c . codret . s . 1 . code de retour . +c . . . . 0 : pas de probleme . +c . . . . 2 : pas de mot-cle dans la base . +c . . . . 3 : fichier de la liste standard non ouvert. +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer ulsort, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer lnomfi, ulsost +c + character*8 typfic + character*200 nomfic +c +#include "motcle.h" +#include "langue.h" +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +cgn write(*,*) 'debut de utulls' +c==== +c 1. recherche du nom de fichier unix associe a la liste standard +c==== +c + call gusost ( ulsost ) +cgn write(*,*) 'retour de gusost' +c + typfic = mclist + iaux = 0 +#ifdef _DEBUG_HOMARD_ + jaux = 1 +#else + jaux = 0 +#endif + call utfino ( typfic, iaux, nomfic, lnomfi, + > jaux, + > ulsost, langue, codret ) +cgn write(*,*) 'retour de utfino' +c +c==== +c 2. recherche de l'unite logique associee +c==== +c + if ( codret.eq.0 ) then +c + call gucara ( nomfic, lnomfi, ulsort, codret ) + if ( codret.eq.0 ) then + if ( ulsort.eq.0 ) then + codret = 3 + endif + endif +c + elseif ( codret.eq.2 ) then +c + ulsort = ulsost + codret = 0 +c + else +c + codret = 2 +c + endif +cgn write(*,*) 'fin de utulls' +c + end diff --git a/src/tool/Utilitaire/ututso.F b/src/tool/Utilitaire/ututso.F new file mode 100644 index 00000000..789ea1cb --- /dev/null +++ b/src/tool/Utilitaire/ututso.F @@ -0,0 +1,413 @@ + subroutine ututso ( nocsol, nocmai, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - UTilitaire sur une SOlution +c -- -- -- +c C'est un programme qui offre un canevas. +c A modifier selon les usages +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nocsol . e . char8 . nom de l'objet solution . +c . nocmai . e . char*8 . nom de l'objet maillage calcul . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTUTSO' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "esutil.h" +#include "gmenti.h" +#include "gmreel.h" +#include "gmstri.h" +c +c 0.3. ==> arguments +c + character*8 nocsol, nocmai +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c +#include "meddc0.h" +c + integer iaux + integer ideb , ifin + integer codre1, codre2, codre3, codre4, codre5 + integer codre6, codre7 + integer codre0 +c + integer sdim, mdim + integer degre, mailet, maconf, homolo, hierar, nbnomb + integer nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra + integer typnoe, typpoi, typseg, typtri, typtet + integer typqua, typhex, typpyr, typpen + integer nbcham, nbpafo, nbprof, nblopg + integer adinch, adinpf, adinpr, adinlg + integer typgeo, ngauss, nbenmx, nbtyas + integer carsup, nbtafo, typint + integer adnomb + integer advale, advalr, adobch, adprpg, adtyas + integer typcha, nbcomp, nbvapr, nbtvch + integer adnocp, adcaen, adcare, adcaca +c + integer nbmaae, nbmafe, nbmnei + integer numano, numael + integer nbma2d, nbma3d + integer nbfmed, nbfmen, ngrouc + integer nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu +c + character*8 nopafo, nocham + character*8 ncinfo, ncnoeu, nccono, nccode + character*8 nccoex, ncfami + character*8 ncequi, ncfron, ncnomb +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) +#endif +c +c==== +c 2. preliminaires +c==== +c 2.1. ==> les caracteristiques du maillage +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMC', nompro +#endif + call utnomc ( nocmai, + > sdim, mdim, + > degre, mailet, maconf, homolo, hierar, + > nbnomb, + > ncinfo, ncnoeu, nccono, nccode, + > nccoex, ncfami, + > ncequi, ncfron, ncnomb, + > ulsort, langue, codret) +c + endif +c + if ( codret.eq.0 ) then +c + call gmadoj ( ncnomb, adnomb, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNBMC', nompro +#endif + call utnbmc ( imem(adnomb), + > nbmaae, nbmafe, nbmnei, + > numano, numael, + > nbma2d, nbma3d, + > nbmapo, nbsegm, nbtria, nbtetr, + > nbquad, nbhexa, nbpent, nbpyra, + > nbfmed, nbfmen, ngrouc, + > nbequi, + > nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu, + > ulsort, langue, codret ) +c + endif +c +c 2.2. ==> grandeurs de base +c + typnoe = 0 + typpoi = edpoi1 + if ( degre.eq.1 ) then + typseg = edseg2 + typtri = edtri3 + typtet = edtet4 + typqua = edqua4 + typhex = edhex8 + typpyr = edpyr5 + typpen = edpen6 + else + typseg = edseg3 + typtri = edtri6 + typtet = edte10 + typqua = edqua8 + typhex = edhe20 + typpyr = edpy13 + typpen = edpe15 + endif +c +c==== +c 3. Creation d'un couple champ/fonction +c==== +c +c 3.1. ==> la fonction +c +c 3.1.1. ==> la structure d'accueil +c + if ( codret.eq.0 ) then +c + iaux = 1 + typgeo = typtet + ngauss = ednopg + nbenmx = nbtetr + nbvapr = -1 + nbtyas = 0 + carsup = 0 + nbtafo = 1 + typint = 0 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTALFO', nompro +#endif + call utalfo ( nopafo, iaux, + > typgeo, ngauss, nbenmx, nbvapr, nbtyas, + > carsup, nbtafo, typint, + > advale, advalr, adobch, adprpg, adtyas, + > ulsort, langue, codret ) +c + endif +c +c 3.1.2. ==> les valeurs +c + if ( codret.eq.0 ) then +c + ideb = advalr + ifin = advalr + nbenmx - 1 + do 3121 , iaux = ideb , ifin + rmem(iaux) = 100.d0 + 3121 continue + rmem(advalr+0) = 200.d0 + rmem(advalr+2) = 200.d0 + rmem(advalr+9) = 200.d0 + rmem(advalr+15) = 200.d0 +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nopafo ) + call gmprsx (nompro, nopafo//'.ValeursR' ) +#endif +c +c 3.2. ==> le champ +c +c 3.2.1. ==> la structure d'accueil +c + if ( codret.eq.0 ) then +c + call gmalot ( nocham, 'InfoCham', 0, iaux, codret ) +c + endif +c + if ( codret.eq.0 ) then +c + nbcomp = 1 + nbtvch = 1 + typcha = edint + typcha = edfl64 + call gmecat ( nocham, 1, nbcomp, codre1 ) + call gmecat ( nocham, 2, nbtvch, codre2 ) + call gmecat ( nocham, 3, typcha, codre3 ) + iaux = 4 + 2*nbcomp + call gmaloj ( nocham//'.Nom_Comp', ' ', iaux, adnocp, codre4 ) + iaux = nbinec * nbtvch + call gmaloj ( nocham//'.Cham_Ent', ' ', iaux, adcaen, codre5 ) + call gmaloj ( nocham//'.Cham_Ree', ' ', nbtvch, adcare, codre6 ) + iaux = 5 * nbtvch + call gmaloj ( nocham//'.Cham_Car', ' ', iaux, adcaca, codre7 ) +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5, + > codre6, codre7 ) +c + endif +c +c 3.2.2. ==> les valeurs +c + if ( codret.eq.0 ) then +c +c 12345678 + smem(adnocp+0) = 'INDICATE' + smem(adnocp+1) = 'UR_D_ERR' + smem(adnocp+2) = 'EUR_1 ' + smem(adnocp+3) = ' ' + smem(adnocp+4) = 'ERREUR ' + smem(adnocp+5) = ' ' +c Rappel : +c 1. type de support au sens MED +c 2. numero du pas de temps +c 3. numero d'ordre +c 4. nombre de points de Gauss +c 5. nombre d'entites support +c 6. nombre de valeurs du profil eventuel +c 7. nombre de supports associes +c 8. noeuds par elements/points de Gauss/autre +c 9. numero du 1er tableau dans la fonction +c 10. -1 ou champ elga/champ elno +c 11. type interpolation +c + imem(adcaen+0) = typgeo + imem(adcaen+1) = ednodt + imem(adcaen+2) = ednonr + imem(adcaen+3) = ednopg + imem(adcaen+4) = nbenmx + imem(adcaen+5) = -1 + imem(adcaen+6) = 0 + imem(adcaen+7) = 01 + imem(adcaen+8) = 1 + imem(adcaen+9) = -1 + imem(adcaen+10) = 0 +c + rmem(adcare) = 1792.d0 +c +c 12345678 + smem(adcaca+0) = ' ' + smem(adcaca+1) = nopafo + smem(adcaca+2) = ' ' + smem(adcaca+3) = ' ' + smem(adcaca+4) = ' ' +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocham ) + call gmprsx (nompro, nocham//'.Nom_Comp' ) + call gmprsx (nompro, nocham//'.Cham_Ent' ) + call gmprsx (nompro, nocham//'.Cham_Ree' ) + call gmprsx (nompro, nocham//'.Cham_Car' ) +#endif +c +c==== +c 4. mise en place dans la solution +c==== +c +c 4.1. ==> caracteristiques de depart +c + if ( codret.eq.0 ) then +c + call utcaso ( nocsol, + > nbcham, nbpafo, nbprof, nblopg, + > adinch, adinpf, adinpr, adinlg, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> ajout +c + if ( codret.eq.0 ) then +c + call gmmod ( nocsol//'.InfoPaFo', + > adinpf, nbpafo, nbpafo+1, 1, 1, codre1 ) + call gmmod ( nocsol//'.InfoCham', + > adinch, nbcham, nbcham+1, 1, 1, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c + smem(adinch+nbcham) = nocham + smem(adinpf+nbpafo) = nopafo +c + nbcham = nbcham + 1 + nbpafo = nbpafo + 1 + call gmecat ( nocsol, 1, nbcham, codre1 ) + call gmecat ( nocsol, 2, nbpafo, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nocsol ) + call gmprsx (nompro, nocsol//'.InfoCham' ) + call gmprsx (nompro, nocsol//'.InfoPaFo' ) + call gmprsx (nompro, nocsol//'.InfoProf' ) +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvar0.F b/src/tool/Utilitaire/utvar0.F new file mode 100644 index 00000000..f65f46e5 --- /dev/null +++ b/src/tool/Utilitaire/utvar0.F @@ -0,0 +1,457 @@ + subroutine utvar0 ( typver, numele, nbaret, listar, somare, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Verification des ARetes - 0 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . typver . e . 1 . type de verification : . +c . . . . 0 : boucle fermee . +c . . . . -1 : continuite, ouverture aux 2 extremites. +c . . . . n>0 : de l'element de type n ad-hoc . +c . numele . e . 1 . numero de l'element si typver = 0 . +c . nbaret . e . 1 . nombre d'aretes a examiner . +c . listar . e . nbaret . liste des aretes a examiner . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . ulbila . e . 1 . unite logique d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : pas assez d'arete dans la liste . +c . . . . 2 : mauvais type de verification . +c . . . . 10 : les aretes ne se suivent pas . +c . . . . 11 : la suite des aretes ne ferme pas . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVAR0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer typver, numele, nbaret + integer listar(nbaret) + integer somare(2,*) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer kvoulu + integer ulaux + integer laret1, laret2 + integer lesom1 + integer nbaref(7) + integer arsote(3,4) + integer arsohe(3,8) + integer arsopy(4,5) + integer arsope(3,6) + integer s1 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c + data nbaref / 1, 3, 6, 4, 8, 12, 9 / +c +c Pour chaque sommet j, arsoxx(i,j) donne le numero local dec +c la i-eme arete qui y aboutit. +c +c pour un tetraedre : +c +c a1 est l'arete entre s1 et s2 +c a2 est l'arete entre s1 et s3 +c a3 est l'arete entre s1 et s4 +c a4 est l'arete entre s2 et s3 +c a5 est l'arete entre s2 et s4 +c a6 est l'arete entre s3 et s4 +c + data arsote / 1, 2, 3, 1, 4, 5, 2, 4, 6, 3, 5, 6 / +c +c pour un hexaedre : +c +c a1 est l'arete entre s1 et s2 +c a2 est l'arete entre s1 et s4 +c a3 est l'arete entre s2 et s3 +c a4 est l'arete entre s3 et s4 +c a5 est l'arete entre s1 et s6 +c a6 est l'arete entre s2 et s5 +c a7 est l'arete entre s4 et s7 +c a8 est l'arete entre s3 et s8 +c a9 est l'arete entre s5 et s6 +c a10 est l'arete entre s6 et s7 +c a11 est l'arete entre s5 et s8 +c a12 est l'arete entre s7 et s8 +c + data arsohe / 1, 2, 5, 1, 3, 6, 3, 4, 8, 2, 4, 7, + > 6, 9, 11, 5, 9, 10, 7, 10, 12, 8, 11, 12 / +c +c pour une pyramide : +c +c a1 est l'arete entre s1 et s5 +c a2 est l'arete entre s2 et s5 +c a3 est l'arete entre s3 et s5 +c a4 est l'arete entre s4 et s5 +c a5 est l'arete entre s1 et s2 +c a6 est l'arete entre s2 et s3 +c a7 est l'arete entre s3 et s4 +c a8 est l'arete entre s4 et s1 +c + data arsopy / 1, 5, 8, 0, 2, 5, 6, 0, 3, 6, 7, 0, + > 4, 7, 8, 0, 1, 2, 3, 4 / +c +c pour un pentaedre : +c +c a1 est l'arete entre s1 et s3 +c a2 est l'arete entre s1 et s2 +c a3 est l'arete entre s2 et s3 +c a4 est l'arete entre s4 et s6 +c a5 est l'arete entre s4 et s5 +c a6 est l'arete entre s5 et s6 +c a7 est l'arete entre s1 et s4 +c a8 est l'arete entre s2 et s5 +c a9 est l'arete entre s3 et s6 +c + data arsope / 1, 2, 7, 2, 3, 8, 1, 3, 9, 4, 5, 7, + > 5, 6, 8, 4, 6, 9 / +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Controle des '',a)' + texte(1,5) = '(''Il faut au moins 2 aretes dans la liste !'')' + texte(1,6) = '(''Mauvais type de verification (typver) :'',i8)' + texte(1,7) = '(/,a,'' numero'',i8)' + texte(1,8) = '(''Nombre d''''aretes attendues :'',i8)' + texte(1,9) = '(''Nombre d''''aretes fournies :'',i8)' + texte(1,10) = '(''Les aretes ne se suivent pas :'')' + texte(1,11) = '(''La suite des aretes ne ferme pas :'')' + texte(1,12) = '(''La suite des aretes n''''est pas conforme :'')' + texte(1,20) = '(''Controle impossible'',/)' +c + texte(2,4) = '(5x,''Control of the '',a)' + texte(2,5) = '(''At least 2 edges in the list !'')' + texte(2,6) = '(''Bad choice for checking (typver) :'',i8)' + texte(2,7) = '(/,a,'' #'',i8)' + texte(2,8) = '(''Number of expected edges :'',i8)' + texte(2,9) = '(''Number of given edges :'',i8)' + texte(2,10) = '(''Edges are not following each other :'')' + texte(2,11) = '(''The list of edges is not closed :'')' + texte(2,12) = '(''The list of edges is not correct :'')' + texte(2,20) = '(''Control cannot be done.'',/)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) mess14(langue,3,1) +#endif +c + codret = 0 +c +c==== +c 2. verifications prealables +c==== +c +c 2.1. ==> Au moins 2 aretes dans la liste ! +c + if ( nbaret.le.1 ) then +c + write (ulsort,texte(langue,4)) mess14(langue,3,1) + write (ulsort,texte(langue,5)) + codret = 1 +c + else +c +c 2.2. ==> Le bon code de controle +c + if ( typver.lt.-1 .or. + > typver.eq.1 .or. + > typver.ge.8 ) then +c + write (ulsort,texte(langue,6)) typver + codret = 2 +c +c 2.2. ==> Le bon nombre d'aretes pour un element +c + elseif ( typver.gt.0 ) then +c + if ( nbaret.ne.nbaref(typver) ) then + write (ulsort,texte(langue,7)) mess14(langue,2,typver), + > numele + write (ulsort,texte(langue,8)) nbaref(typver) + write (ulsort,texte(langue,9)) nbaret + codret = 3 + endif +c + endif +c + endif +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,20)) + write (ulbila,texte(langue,20)) + else +c +c==== +c 3. verification pour un tetraedre +c==== +c +#ifdef _DEBUG_HOMARD_ + if ( typver.ge.3 .and. typver.le.7 ) then + write (ulsort,texte(langue,4)) mess14(langue,3,typver) + endif +#endif +c + if ( typver.eq.3 ) then +c + iaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR1', nompro +#endif + call utvar1 ( iaux, arsote, listar, somare, + > ulsort, langue, codret ) +c +c==== +c 4. verification pour un hexaedre +c==== +c + elseif ( typver.eq.6 ) then +c + iaux = 8 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR1', nompro +#endif + call utvar1 ( iaux, arsohe, listar, somare, + > ulsort, langue, codret ) +c +c==== +c 5. verification pour une pyramide +c==== +c + elseif ( typver.eq.5 ) then +c + do 51 , iaux = 1 , 5 +c +c examen du iaux-eme sommet local +c + kaux = 0 + if ( iaux.le.4 ) then + kvoulu = 2 + else + kvoulu = 3 + endif +c + do 511 , jaux = 1 , 2 +c + s1 = somare(jaux,listar(arsopy(1,iaux))) + if ( s1.eq.somare(1,listar(arsopy(2,iaux))) .or. + > s1.eq.somare(2,listar(arsopy(2,iaux))) ) then + kaux = kaux + 1 + endif + if ( s1.eq.somare(1,listar(arsopy(3,iaux))) .or. + > s1.eq.somare(2,listar(arsopy(3,iaux))) ) then + kaux = kaux + 1 + endif + if ( iaux.eq.5 ) then + if ( s1.eq.somare(1,listar(arsopy(4,iaux))) .or. + > s1.eq.somare(2,listar(arsopy(4,iaux))) ) then + kaux = kaux + 1 + endif + endif +c + 511 continue + if ( kaux.ne.kvoulu ) then + codret = 12 + endif +c + 51 continue +c +c==== +c 6. verification pour un pentaedre +c==== +c + elseif ( typver.eq.7 ) then +c + iaux = 6 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR1', nompro +#endif + call utvar1 ( iaux, arsope, listar, somare, + > ulsort, langue, codret ) +c +c==== +c 7. verification de continuite pour les autres types d'element +c==== +c + else +c +c 7.1. ==> recherche du premier sommet +c + laret1 = listar(1) + laret2 = listar(2) + if ( somare(1,laret1).eq.somare(1,laret2) ) then + lesom1 = somare(2,laret1) + jaux = 2 + elseif ( somare(1,laret1).eq.somare(2,laret2) ) then + lesom1 = somare(2,laret1) + jaux = 1 + elseif ( somare(2,laret1).eq.somare(1,laret2) ) then + lesom1 = somare(1,laret1) + jaux = 2 + elseif ( somare(2,laret1).eq.somare(2,laret2) ) then + lesom1 = somare(1,laret1) + jaux = 1 + else + codret = 10 + endif +c +c 7.2. ==> poursuite de la liste +c + do 72 , iaux = 3 , nbaret +c + if ( codret.eq.0 ) then +c + laret1 = laret2 + laret2 = listar(iaux) +c + if ( somare(jaux,laret1).eq.somare(1,laret2) ) then + jaux = 2 + elseif ( somare(jaux,laret1).eq.somare(2,laret2) ) then + jaux = 1 + else + codret = 10 + endif +c + endif +c + 72 continue +c +c 7.3. ==> bouclage +c + if ( typver.ge.0 ) then + if ( lesom1.ne.somare(jaux,laret2) ) then + codret = 11 + endif + endif +c + endif +c + endif +cgn if ( mod(numele,2).eq.0)codret=10 +c +c==== +c 8. impressions en cas d'erreur +c==== +c + if ( codret.ne.0 ) then +c + if ( ulsort.ne.ulbila ) then + jaux = 2 + else + jaux = 1 + endif +c + do 81 , kaux = 1 , jaux +c + if ( kaux.eq.1 ) then + ulaux = ulsort + else + ulaux = ulbila + endif +c + if ( typver.gt.0 ) then + write (ulaux,texte(langue,7)) mess14(langue,2,typver), numele + endif + if ( codret.ge.10 ) then + write (ulaux,texte(langue,codret)) + endif +c + write (ulaux,8000) mess14(langue,2,1), + > mess14(langue,2,-1), mess14(langue,2,-1) + do 810 , iaux = 1 , nbaret + laret1 = listar(iaux) + write (ulaux,8001) laret1, somare(1,laret1), somare(2,laret1) + 810 continue + write (ulaux,8002) +c + 81 continue +c + 8000 format( + >/,53('*') + >/,'* ',a14,'* ',a14,'1 * ',a14,'2 *' + >/, 53('*')) + 8001 format('*',i10,' *',2(i10,' *')) + 8002 format(53('*'),/) +c + endif +c +c==== +c 9. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvar1.F b/src/tool/Utilitaire/utvar1.F new file mode 100644 index 00000000..e40122ea --- /dev/null +++ b/src/tool/Utilitaire/utvar1.F @@ -0,0 +1,165 @@ + subroutine utvar1 ( nbsomm, arsoen, listar, somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Verification des ARetes - 1 +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbsomm . e . 1 . nombre de sommets de l'entite . +c . arsoen . e .nbsomm**. numero des aretes liees aux sommets . +c . listar . e . nbaret . liste des aretes a examiner . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : pas assez d'arete dans la liste . +c . . . . 2 : mauvais type de verification . +c . . . . 10 : les aretes ne se suivent pas . +c . . . . 11 : la suite des aretes ne ferme pas . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVAR1' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +c 0.3. ==> arguments +c + integer nbsomm + integer arsoen(3,nbsomm) + integer listar(*), somare(2,*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer arete1, arete2, arete3 + integer s1 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + codret = 0 +c +c==== +c 2. verifications +c==== +c + do 21 , iaux = 1 , nbsomm +c +c examen du iaux-eme sommet local +c +c arsoen(k,iaux) : numero local de la keme arete sur ce sommet +c aretek : numero global de la keme arete sur ce sommet + arete1 = listar(arsoen(1,iaux)) + arete2 = listar(arsoen(2,iaux)) + arete3 = listar(arsoen(3,iaux)) +c + kaux = 0 +c + do 211 , jaux = 1 , 2 +c +c s1 : numero global de la jaux-eme extremite de la 1ere arete + s1 = somare(jaux,arete1) +c +c s1 est-il un des sommets de la 2-eme arete ? + if ( s1.eq.somare(1,arete2) .or. s1.eq.somare(2,arete2) ) then + kaux = kaux + 1 + endif +c +c s1 est-il un des sommets de la 3-eme arete ? + if ( s1.eq.somare(1,arete3) .or. s1.eq.somare(2,arete3) ) then + kaux = kaux + 1 + endif +c + 211 continue +c +c Si ce sommet n'est pas une extremite pour les 3 aretes, kaux +c est different de 2 : probleme. + if ( kaux.ne.2 ) then + write (ulsort,90002) 'Probleme avec le sommet local numero', + > iaux + write (ulsort,90006) '... arete 1 =', arete1, + > 'de', somare(1,arete1), ' a', somare(2,arete1) + write (ulsort,90006) '... arete 2 =', arete2, + > 'de', somare(1,arete2), ' a', somare(2,arete2) + write (ulsort,90006) '... arete 3 =', arete3, + > 'de', somare(1,arete3), ' a', somare(2,arete3) + codret = 12 + endif +c + 21 continue +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvars.F b/src/tool/Utilitaire/utvars.F new file mode 100644 index 00000000..62093d4f --- /dev/null +++ b/src/tool/Utilitaire/utvars.F @@ -0,0 +1,180 @@ + subroutine utvars ( col1, col2, lgtabx, tabaux, + > somare, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Verification des ARetes Soeurs +c -- - -- - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . col1 . e . 1 . choix de la premiere colonne a controler . +c . col2 . e . 1 . choix de la seconde colonne a controler . +c . lgtabx . e . 1 . nombre de paquets a controler . +c . tabaux . a .3*lgtabx. tableau auxiliaire . +c . . . . 1 : une des aretes filles . +c . . . . 2 : l'autre arete fille . +c . . . . 3 : l'arete mere . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . nombre de problemes sinon . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVARS' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "nombar.h" +c +c 0.3. ==> arguments +c + integer col1, col2 + integer lgtabx + integer somare(2,nbarto) + integer tabaux(3,lgtabx) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer laret1, laret2 +c + integer nbmess + parameter ( nbmess = 20 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. preliminaires +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Mauvais choix de colonne :'',i10)' + texte(1,5) = '(''Examen de l''''arete'',i10)' + texte(1,6) = '('' du noeud'',i10,'' au noeud'',i10)' + texte(1,7) = + >'(''Impossible de trouver un sommet commun a ces aretes :'')' +c + texte(2,4) = '(''Bad choice for column :'',i10)' + texte(2,5) = '(''Examination of edge #'',i10)' + texte(2,6) = '('' from node #'',i10,'' to node #'',i10)' + texte(2,7) = + >'(''A common node cannot be found for these edges :'')' +c + codret = 0 +c +c==== +c 2. on verifie qu'il y a au moins un sommet commun aux deux aretes +c==== +c +c 2.1. ==> controle des numeros de colonne +c + if ( col1.lt.1 .or. col1.gt.3 ) then + write (ulsort,texte(langue,4)) col1 + codret = -1 + elseif ( col2.lt.1 .or. col2.gt.3 ) then + write (ulsort,texte(langue,4)) col1 + codret = -1 + endif +c +c 2.2. ==> +c + if ( codret.eq.0 ) then +c + do 22 , iaux = 1 , lgtabx +c + laret1 = tabaux(col1,iaux) + laret2 = tabaux(col2,iaux) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) laret1 + write (ulsort,texte(langue,6)) somare(1,laret1), somare(2,laret1) + write (ulsort,texte(langue,5)) laret2 + write (ulsort,texte(langue,6)) somare(1,laret2), somare(2,laret2) +#endif +c + if ( ( somare(1,laret1).ne.somare(1,laret2) ) .and. + > ( somare(1,laret1).ne.somare(2,laret2) ) .and. + > ( somare(2,laret1).ne.somare(1,laret2) ) .and. + > ( somare(2,laret1).ne.somare(2,laret2) ) ) then +c + write (ulsort,texte(langue,7)) + write (ulsort,texte(langue,5)) laret1 + write (ulsort,texte(langue,6)) somare(1,laret1),somare(2,laret1) + write (ulsort,texte(langue,5)) laret2 + write (ulsort,texte(langue,6)) somare(1,laret2),somare(2,laret2) + codret = codret + 1 +c + endif +c + 22 continue +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utveri.F b/src/tool/Utilitaire/utveri.F new file mode 100644 index 00000000..3659bc92 --- /dev/null +++ b/src/tool/Utilitaire/utveri.F @@ -0,0 +1,546 @@ + subroutine utveri ( action, nomail, + > nmprog, avappr, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VERIfication +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . action . e . char8 . action en cours . +c . nomail . e . char8 . nom de l'objet maillage homard a verifier . +c . nmprog . e . char* . nom du programme a pister . +c . avappr . e . 1 . 1 : impression avant l'appel a "nmprog" . +c . . . . 2 : impression apres l'appel a "nmprog" . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVERI' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "gmreel.h" +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +#include "envada.h" +c +c 0.3. ==> arguments +c + character*8 action + character*8 nomail + character*(*) nmprog +c + integer avappr +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer codre0 + integer codre1, codre2, codre3 +c + integer iaux, jaux, kaux + integer pcoono, psomar + integer paretr + integer parequ + integer phette, ptrite, pcotrt, parete + integer phethe, pquahe, pcoquh, parehe + integer phetpy, pfacpy, pcofay, parepy + integer phetpe, pfacpe, pcofap, parepe + integer sdim, mdim + integer degre, maconf, homolo, hierar + integer rafdef, nbmane, typcca, typsfr, maextr + integer mailet + integer nbnoal, nbtral, nbqual + integer nbteal, nbtaal + integer nbheal, nbhaal + integer nbpyal, nbyaal + integer nbpeal, nbpaal + integer nuroul, lnomfl +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhvois, nhsupe, nhsups + character*15 saux15 + character*200 nomflo +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''A l''''entree de '',a,'' :'',/)' + texte(1,5) = '(/,''Avant appel a '',a,'' :'')' + texte(1,6) = '(/,''Apres appel a '',a,'' :'')' + texte(1,7) = '(/,''Mauvais code pour '',a,'' : '',i8,/)' + texte(1,8) = '(''Le maillage est a corriger.'',/,27(''=''))' + texte(1,9) = '(''Action en cours : '',a)' +c + texte(2,4) = '(/,''At the beginning of '',a,'' :'',/)' + texte(2,5) = '(/,''Before calling '',a,'':'')' + texte(2,6) = '(/,''After calling '',a,'':'')' + texte(2,7) = '(/,''Bad code for '',a,'': '',i8,/)' + texte(2,8) = '(''This mesh is not correct.'',/,25(''=''))' + texte(2,9) = '(''Current action: '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + if ( avappr.ge.0 .and. avappr.le.2 ) then + write (ulsort,texte(langue,4+avappr)) nmprog + else + write (ulsort,texte(langue,7)) nmprog, avappr + endif + write (ulsort,texte(langue,9)) action +#endif +c + codret = 0 +c +c==== +c 2. recuperation des pointeurs +c==== +c +c 2.1. ==> structure generale +c + if ( codret.eq.0 ) then +c + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c 2.2. ==> tableaux +c + if ( codret.eq.0 ) then +c + call gmliat ( nhnoeu, 1, nbnoal, codre1 ) + call gmadoj ( nhnoeu//'.Coor', pcoono, iaux, codre2 ) + call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + if ( nbtrto.ne.0 ) then +c + call gmliat ( nhtria, 1, nbtral, codre1 ) + call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( nbquto.ne.0 ) then +c + call gmliat ( nhquad, 1, nbqual, codre1 ) + call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( nbteto.ne.0 ) then +c + call gmliat ( nhtetr, 1, nbteal, codre1 ) + call gmliat ( nhtetr, 2, nbtaal, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + iaux = 26 + if ( nbtaal.gt.0 ) then + iaux = iaux*31 + endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + if ( nbheto.ne.0 ) then +c + call gmliat ( nhhexa, 1, nbheal, codre1 ) + call gmliat ( nhhexa, 2, nbhaal, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + iaux = 26 + if ( nbhaal.gt.0 ) then + iaux = iaux*31 + endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + if ( nbpyto.ne.0 ) then +c + call gmliat ( nhpyra, 1, nbpyal, codre1 ) + call gmliat ( nhpyra, 2, nbyaal, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + iaux = 26 + if ( nbyaal.gt.0 ) then + iaux = iaux*31 + endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + if ( nbpeto.ne.0 ) then +c + call gmliat ( nhpent, 1, nbpeal, codre1 ) + call gmliat ( nhpent, 2, nbpaal, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + iaux = 26 + if ( nbpaal.gt.0 ) then + iaux = iaux*31 + endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 3. fichier de sortie du bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. fichier sortie ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + saux15 = 'verif_'//action + iaux = 1 + jaux = -1 + if ( rafdef.eq.31 ) then + kaux = 1 + else + kaux = nbiter + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTULBI', nompro +#endif + call utulbi ( nuroul, nomflo, lnomfl, + > iaux, saux15, kaux, jaux, + > ulsort, langue, codret ) +c + endif +c +c==== +c 4. controles +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. controles ; codret', codret +#endif +c +c 4.1. ==> les aretes +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTEARE', nompro +#endif + call uteare ( nbarto, nbnoto, imem(psomar), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c +c 4.2. ==> les triangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. tria ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbtrto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTETRI', nompro +#endif + call utetri ( nbtrto, nbtral, + > imem(paretr), imem(psomar), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.3. ==> les quadrangles +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. quad ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbquto.ne.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTEQUA', nompro +#endif + call utequa ( nbquto, nbqual, nbnoal, sdim, + > rmem(pcoono), imem(psomar), imem(parequ), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.4. ==> les tetraedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. tetr ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbteto.ne.0 ) then +c + iaux = nbteal - nbtaal +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTETET', nompro +#endif + call utetet ( nbteto, iaux, nbtaal, nbtral, + > imem(psomar), imem(paretr), + > imem(ptrite), imem(pcotrt), imem(parete), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.5. ==> les hexaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.5. hexa ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbheto.ne.0 ) then +c + iaux = nbheal - nbhaal +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTEHEX', nompro +#endif + call utehex ( nbheto, iaux, nbhaal, nbqual, + > imem(psomar), imem(parequ), + > imem(pquahe), imem(pcoquh), imem(parehe), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.6. ==> les pyramides +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.6. pyra ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpyto.ne.0 ) then +c + iaux = nbpyal - nbyaal +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTEPYR', nompro +#endif + call utepyr ( nbpyto, iaux, nbyaal, nbtral, + > imem(psomar), imem(paretr), + > imem(pfacpy), imem(pcofay), imem(parepy), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.7. ==> les pentaedres +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.7. pent ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + if ( nbpeto.ne.0 ) then +c + iaux = nbpeal - nbpaal +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTEPEN', nompro +#endif + call utepen ( nbpeto, iaux, nbpaal, nbqual, + > imem(psomar), + > imem(parequ), + > imem(pfacpe), imem(pcofap), imem(parepe), + > nmprog, avappr, nuroul, + > ulsort, langue, codret ) +c + endif +c + endif +c +c==== +c 5. fermeture du fichier de sortie du bilan +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '5. fermeture ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gufeul ( nuroul , codret ) +c + endif +c +c==== +c 6. On impose un code de retour nul si c'est un maillage avec ajout +c de joint car par construction des mailles sont aplaties +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '6. impose ; codret', codret +#endif +c + if ( rafdef.eq.31 ) then +c + codret = 0 +c + endif +c +c==== +c 7. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (nuroul,texte(langue,8)) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvga1.F b/src/tool/Utilitaire/utvga1.F new file mode 100644 index 00000000..9da93a58 --- /dev/null +++ b/src/tool/Utilitaire/utvga1.F @@ -0,0 +1,119 @@ + subroutine utvga1 ( nbnoto, nbarto, nvosom, + > somare, povoso ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - voisinage ARetes-Noeuds - phase 1 +c -- -- - - +c ______________________________________________________________________ +c +c determine le nombre d'aretes voisines de chaque sommet +c les eventuels noeuds milieux d'arete sont ignores. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnoto . e . 1 . nombre de noeuds total . +c . nbarto . e . 1 . nombre d'aretes total . +c . nvosom . s . 1 . nombre cumule d'aretes voisines de noeud . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . povoso . s .0:nbnoto. pointeur des voisins par sommet . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbnoto, nbarto, nvosom +c + integer somare(2,nbarto) + integer povoso(0:nbnoto) +c +c 0.4. ==> variables locales +c + integer lenoeu, larete +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque arete et on incremente de 1 +c le nombre de voisins de ses sommets +c==== +c +#ifdef _DEBUG_HOMARD_ +cgn print *,'nbnoto = ',nbnoto +cgn print *,'nbarto = ',nbarto +#endif + do 11 , lenoeu = 0 , nbnoto + povoso(lenoeu) = 0 + 11 continue +c + do 12 , larete = 1 , nbarto +#ifdef _DEBUG_HOMARD_ +cgn print *,'larete = ', larete +cgn print *,'sommets = ', somare(1,larete), somare(2,larete) +#endif +c + povoso(somare(1,larete)) = povoso(somare(1,larete)) + 1 + povoso(somare(2,larete)) = povoso(somare(2,larete)) + 1 +c + 12 continue +c +c==== +c 2. on initialise le pointeur dans le tableau des voisins +c +c au depart : +c povoso(0) = 0 +c povoso(i) = nombre d'aretes voisines du noeud i +c +c a l'arrivee : +c povoso(0) = 0 +c povoso(i) = position de la derniere voisine du noeud i-1 +c = nombre cumule de voisines pour les (i-1) 1ers noeuds +c +c a la fin de cette partie, pour les noeuds au milieu des aretes +c le pointeur est le meme que celui du noeud qui le suit. +c==== +c + do 21 , lenoeu = 1 , nbnoto +#ifdef _DEBUG_HOMARD_ +cgn print *,'povoso(',lenoeu,') = ',povoso(lenoeu) +#endif + povoso(lenoeu) = povoso(lenoeu-1) + povoso(lenoeu) + 21 continue +c + nvosom = povoso(nbnoto) +c + do 22 , lenoeu = nbnoto , 1 , -1 + povoso(lenoeu) = povoso(lenoeu-1) +#ifdef _DEBUG_HOMARD_ +cgn print *,'povoso(',lenoeu,') = ',povoso(lenoeu) +#endif + 22 continue +c + end diff --git a/src/tool/Utilitaire/utvga2.F b/src/tool/Utilitaire/utvga2.F new file mode 100644 index 00000000..bb0dd94e --- /dev/null +++ b/src/tool/Utilitaire/utvga2.F @@ -0,0 +1,102 @@ + subroutine utvga2 ( nbnoto, nbarto, nvosom, + > somare, povoso, voisom ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - voisinage ARetes-Noeuds - phase 2 +c -- -- - - +c ______________________________________________________________________ +c +c determine les aretes voisines de chaque sommet +c les eventuels noeuds milieux d'arete sont ignores. +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbnoto . e . 1 . nombre de noeuds total . +c . nbarto . e . 1 . nombre d'aretes total . +c . nvosom . e . 1 . nombre cumule d'aretes voisines de noeud . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . povoso . es .0:nbnoto. pointeur des voisins par sommet . +c . voisom . s . nvosom . aretes voisines de chaque noeud . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +c 0.3. ==> arguments +c + integer nbnoto, nbarto, nvosom +c + integer somare(2,nbarto) + integer povoso(0:nbnoto), voisom(nvosom) +c +c 0.4. ==> variables locales +c + integer larete, sommet +c ______________________________________________________________________ +c +c==== +c 1. on passe en revue chaque arete et on indique qu'elle est +c la voisine de ses sommets +c +c au depart : +c povoso(i) = position du dernier voisin du sommet i-1 +c = nombre cumule de voisins pour les (i-1) 1ers sommets +c a l'arrivee : +c povoso(i) = position du dernier voisin du sommet i +c = nombre cumule de voisins pour les i premiers sommets +c==== +#ifdef _DEBUG_HOMARD_ +cgn print *,'nbarto = ',nbarto +#endif +c + do 11 , larete = 1 , nbarto +c +#ifdef _DEBUG_HOMARD_ +cgn print *,'larete = ', larete +cgn print *,'sommets = ', somare(1,larete), somare(2,larete) +#endif +c + sommet = somare(1,larete) +#ifdef _DEBUG_HOMARD_ +cgn print *,'povoso(',sommet,') = ',povoso(sommet) +#endif + povoso(sommet) = povoso(sommet) + 1 + voisom(povoso(sommet)) = larete +c + sommet = somare(2,larete) +#ifdef _DEBUG_HOMARD_ +cgn print *,'povoso(',sommet,') = ',povoso(sommet) +#endif + povoso(sommet) = povoso(sommet) + 1 + voisom(povoso(sommet)) = larete +c + 11 continue +c + end diff --git a/src/tool/Utilitaire/utvgan.F b/src/tool/Utilitaire/utvgan.F new file mode 100644 index 00000000..f30d2261 --- /dev/null +++ b/src/tool/Utilitaire/utvgan.F @@ -0,0 +1,317 @@ + subroutine utvgan ( nhvois, nhnoeu, nharet, + > option, + > ppovos, pvoiso, + > ulsort, langue, codret) +c +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - VoisinaGe Aretes-Noeuds +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhvois . e . char8 . nom de l'objet voisinage . +c . nhnoeu . e . char8 . nom de l'objet decrivant les noeuds . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . option . e . 1 . pilotage des voisins des noeuds : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . ppovos . s . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . s . 1 . adresse des voisins des sommets . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 2 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGAN' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +#include "nombno.h" +#include "nombar.h" +c +c 0.3. ==> arguments +c + character*8 nhvois, nhnoeu, nharet +c + integer option + integer ppovos, pvoiso +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3 + integer codre0 +c + integer psomar + integer nvosom +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Voisinage aretes-noeuds.'')' + texte(1,5) = '(''Demande : '',i6)' + texte(1,6) = '(''Mauvaise demande.'')' + texte(1,7) = '(''. Objet '',a,'' : '',a)' +c + texte(2,4) = '(''Neighbourhood edges-nodes.'')' + texte(2,5) = '(''Request : '',i6)' + texte(2,6) = '(''Bad request.'')' + texte(2,7) = '(''. Objet '',a,'' : '',a)' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,7)) 'nhnoeu', nhnoeu + call gmprsx (nompro, nhnoeu ) + write (ulsort,texte(langue,7)) 'nharet', nharet + call gmprsx (nompro, nharet ) + call gmprot (nompro, nharet//'.ConnDesc', 1, min(2*nbarto,50) ) + write (ulsort,texte(langue,7)) 'nhvois', nhvois + call gmprsx (nompro, nhvois ) + call gmprsx (nompro, nhvois//'.0D/1D' ) +#endif +c + codret = 0 +c +c==== +c 2. Controle de l'option +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Controle option ; codret =',codret +#endif + if ( codret.eq.0 ) then +c + if ( option.lt.-1 .or. option.gt.2 ) then +c + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,6)) + codret = 2 +c + endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c remarque : on relit les nombres d'entites car les communs ne +c sont pas forcement remplis +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. recuperation ; codret =',codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nhnoeu, 1, nbnoto, codre1 ) + call gmliat ( nharet, 1, nbarto, codre2 ) + call gmadoj ( nharet//'.ConnDesc', psomar, iaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + endif +c + endif +c +c==== +c 4. Si on cree ou si on detruit, on commence par supprimer le graphe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. suppression ; codret =',codret +#endif +c + if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmobal ( nhvois//'.0D/1D', codre1 ) +c + if ( codre1.eq.0 ) then + codret = 0 +c + elseif ( codre1.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Suppression de nhvois.0D/1D' +#endif + call gmsgoj ( nhvois//'.0D/1D', codret ) +c + else + codret = 2 +c + endif +c + endif +c + endif +c +c==== +c 5. Creation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Creation ; codret =',codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 5.1. ==> Allocation de la tete +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Allocation de nhvois.0D/1D' +#endif +c + call gmaloj ( nhvois//'.0D/1D' , ' ', 0, iaux, codret ) +c + endif +c +c 5.2. ==> determination des aretes voisines des noeuds +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.2. ==> determination ... ; codret =',codret +#endif +c +c 5.2.1. ==> comptage du nombre d'aretes pour chaque noeud +c + if ( codret.eq.0 ) then +c + iaux = nbnoto+1 + call gmecat ( nhvois//'.0D/1D', 1, iaux, codre1 ) + call gmaloj ( nhvois//'.0D/1D.Pointeur', + > ' ', iaux, ppovos, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGA1', nompro +#endif +c + call utvga1 ( nbnoto, nbarto, nvosom, + > imem(psomar), imem(ppovos) ) +c + endif +c +c 5.2.2. ==> allocation du tableau des voisines a une taille +c egale au nombre cumule de voisines des noeuds, +c puis reperage des aretes voisines +c + if ( codret.eq.0 ) then +c + call gmecat ( nhvois//'.0D/1D', 2, nvosom, codre1 ) + call gmaloj ( nhvois//'.0D/1D.Table', + > ' ', nvosom, pvoiso, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, nhvois//'.0D/1D' ) +cgn call gmprot (nompro, nhvois//'.0D/1D.Pointeur', 1, 50 ) + write (ulsort,texte(langue,3)) 'UTVGA2', nompro +#endif +c + call utvga2 ( nbnoto, nbarto, nvosom, + > imem(psomar), imem(ppovos), imem(pvoiso) ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhvois//'.0D/1D' ) + call gmprot (nompro, nhvois//'.0D/1D.Pointeur', 1, 50 ) + call gmprot (nompro, nhvois//'.0D/1D.Table', 1, 50 ) +#endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgfa.F b/src/tool/Utilitaire/utvgfa.F new file mode 100644 index 00000000..5df33e74 --- /dev/null +++ b/src/tool/Utilitaire/utvgfa.F @@ -0,0 +1,311 @@ + subroutine utvgfa ( nhvois, nharet, nhtria, nhquad, + > option, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes FAces / Aretes +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhvois . e . char8 . nom de l'objet voisinage . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . option . e . 1 . pilotage des voisins des aretes : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . nbfaar . s . 1 . nombre cumule de faces par arete . +c . pposif . s . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . s . 1 . adresse des voisins des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGFA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +c +c 0.3. ==> arguments +c + character*8 nhvois, nharet, nhtria, nhquad +c + integer option + integer nbfaar, pposif, pfacar +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer codre1, codre2, codre3, codre4, codre5 + integer codre0 +c + integer nbarto, nbtrto, nbquto + integer paretr, parequ +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(5x,''Voisinage faces-aretes.'')' + texte(1,5) = '(''Demande : '',i6)' + texte(1,6) = '(''Mauvaise demande.'')' +c + texte(2,4) = '(5x,''Neighbourhood faces-edges.'')' + texte(2,5) = '(''Request : '',i6)' + texte(2,6) = '(''Bad request.'')' +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option +#endif +c + codret = 0 +c +c==== +c 2. Controle de l'option +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Controle option ; codret =',codret +#endif + if ( codret.eq.0 ) then +c + if ( option.lt.-1 .or. option.gt.2 ) then +c + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,6)) + codret = 2 +c + endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c remarque : on relit les nombres d'entites car les communs ne +c sont pas forcement remplis +c==== +c + if ( option.eq.1 .or. option.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmliat ( nharet, 1, nbarto, codre1 ) + call gmliat ( nhtria, 1, nbtrto, codre2 ) + if ( nbtrto.ne.0 ) then + call gmadoj ( nhtria//'.ConnDesc', paretr, iaux, codre3 ) + else + codre3 = 0 + endif + call gmliat ( nhquad, 1, nbquto, codre4 ) + if ( nbquto.ne.0 ) then + call gmadoj ( nhquad//'.ConnDesc', parequ, iaux, codre5 ) + else + codre5 = 0 + endif +c + codre0 = min ( codre1, codre2, codre3, codre4, codre5 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4, codre5 ) +c + endif +c + endif +c +c==== +c 4. Si on cree ou si on detruit, on commence par supprimer le graphe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. suppression ; codret =',codret +#endif +c + if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then +c + if ( codret.eq.0 ) then +c + call gmobal ( nhvois//'.1D/2D', codre1 ) +c + if ( codre1.eq.0 ) then + codret = 0 +c + elseif ( codre1.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Suppression de nhvois.1D/2D' +#endif + call gmsgoj ( nhvois//'.1D/2D', codret ) +c + else + codret = 2 +c + endif +c + endif +c + endif +c +c==== +c 5. Creation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Creation ; codret =',codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 5.1. ==> Allocation de la tete +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Allocation de nhvois.1D/2D' +#endif + call gmaloj ( nhvois//'.1D/2D' , ' ', 0, iaux, codret ) +c + endif +c +c 5.2. ==> determination des faces voisines des aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.2. ==> determination ... ; codret =',codret +#endif +c +c 5.2.1. ==> comptage du nombre de faces pour chaque arete +c + if ( codret.eq.0 ) then +c + iaux = nbarto+1 + call gmecat ( nhvois//'.1D/2D', 1, iaux, codre1 ) + call gmaloj ( nhvois//'.1D/2D.Pointeur', + > ' ', iaux, pposif, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAA1', nompro +#endif + call utfaa1 ( nbarto, nbtrto, nbquto, + > nbarto, nbtrto, nbquto, + > imem(paretr), imem(parequ), + > nbfaar, imem(pposif) ) +c + endif +c +c 5.2.2. ==> allocation du tableau des voisines a une taille +c egale au nombre cumule de voisines des aretes, +c puis reperage des faces voisines +c + if ( codret.eq.0 ) then +c + call gmecat ( nhvois//'.1D/2D', 2, nbfaar, codre1 ) + call gmaloj ( nhvois//'.1D/2D.Table', + > ' ', nbfaar, pfacar, codre2 ) + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTFAA2', nompro +#endif + call utfaa2 ( nbtrto, nbquto, + > nbtrto, nbquto, + > imem(paretr), imem(parequ), + > nbfaar, imem(pposif), imem(pfacar) ) +c +#ifdef _DEBUG_HOMARD_ + call gmprsx (nompro, nhvois//'.1D/2D' ) + call gmprot (nompro, nhvois//'.1D/2D.Pointeur', 1, 50 ) + call gmprot (nompro, nhvois//'.1D/2D.Table', 1, 50 ) +#endif +c + endif +c + endif +c +c==== +c 6. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgv1.F b/src/tool/Utilitaire/utvgv1.F new file mode 100644 index 00000000..e27680c6 --- /dev/null +++ b/src/tool/Utilitaire/utvgv1.F @@ -0,0 +1,317 @@ + subroutine utvgv1 ( nufade, nufafi, + > voltri, pypetr, + > volqua, pypequ, + > nbtetr, nbhexa, nbpyra, nbpent, + > trav1a, trav2a, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes Volumes / aretes - phase 1 +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nufade . e . 1 . numero initial de la liste des faces . +c . nufafi . e . 1 . numero final de la liste des faces . +c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . +c . . . . voltri(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : tetraedre j . +c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). +c . pypetr . e .2*lgpype. pypetr(1,j) = numero de la pyramide voisine. +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . . . . pypetr(2,j) = numero du pentaedre voisin . +c . . . . du triangle k tel que voltri(1/2,k) = -j . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbtetr . s . 1 . nombre de tetraedres voisins . +c . nbhexa . s . 1 . nombre d'hexaedres voisins . +c . nbpyra . s . 1 . nombre de pyramides voisines . +c . nbpent . s . 1 . nombre de pentaedres voisins . +c . trav1a . s . * . liste des voisins . +c . trav2a . a . * . liste des faces a examiner . +c . . . . . numero positif si triangle . +c . . . . . numero negatif si quadrangle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGV1' ) +c +#include "nblang.h" +#include "tbdim0.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombtr.h" +#include "nombqu.h" +#include "nombte.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer nufade, nufafi + integer nbtetr, nbhexa, nbpyra, nbpent + integer voltri(2,nbtrto), pypetr(2,*) + integer volqua(2,nbquto), pypequ(2,*) +c + integer trav1a(tbdim), trav2a(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer cote, laface, nuface + integer decafv +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Examen de'',i10,'' face(s).'')' + texte(1,5) = '(i10,'' voisins de type '',a)' +c + texte(2,4) = '(''Examination of'',i10,'' face(s).'')' + texte(2,5) = '(i10,'' neighbours '',a,''type'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) nufafi-nufade+1 + write (ulsort,90002) 'Numeros',(trav2a(jaux),jaux=nufade,nufafi) +#endif +#include "tbdim1.h" +c +c==== +c 2. decompte des elements de volumes voisins +c==== +c + nbtetr = 0 + nbhexa = 0 + nbpyra = 0 + nbpent = 0 +c + if ( nbteto.gt.0 .or. nbheto.gt.0 .or. + > nbpyto.gt.0 .or. nbpeto.gt.0 ) then +c + decafv = 2 * ( nufafi - nufade + 1 ) +c + do 20 , nuface = nufade, nufafi +c + laface = trav2a(nuface) +c +c 2.1. ==> La face est un triangle +c + if ( laface.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,1,2), laface +#endif +c + do 21 , cote = 1 , 2 +c + jaux = voltri(cote,laface) +c +c 2.1.1. ==> voisinage par un tetraedre +c + if ( jaux.gt.0 ) then +c + do 211 , kaux = 1 , nbtetr + if ( trav1a(kaux).eq.jaux ) then + goto 21 + endif + 211 continue + nbtetr = nbtetr + 1 + iaux = nbtetr +#include "tbdim2.h" + trav1a(iaux) = jaux +c + elseif ( jaux.lt.0 ) then +c +c 2.1.2. ==> voisinage par une pyramide +c + if ( pypetr(1,-jaux).gt.0 ) then + do 212 , kaux = 1 , nbpyra + if ( trav1a(2*decafv+kaux).eq. + > pypetr(1,-jaux) ) then + goto 21 + endif + 212 continue + nbpyra = nbpyra + 1 + iaux = 2*decafv+nbpyra +#include "tbdim2.h" + trav1a(iaux) = pypetr(1,-jaux) + endif +c +c 2.1.3. ==> voisinage par un pentaedre +c + if ( pypetr(2,-jaux).gt.0 ) then + do 213 , kaux = 1 , nbpent + if ( trav1a(3*decafv+kaux).eq. + > pypetr(2,-jaux) ) then + goto 21 + endif + 213 continue + nbpent = nbpent + 1 + iaux = 3*decafv+nbpent +#include "tbdim2.h" + trav1a(iaux) = pypetr(2,-jaux) + endif +c + endif +c + 21 continue +c +c 2.2. ==> La face est un quadrangle +c + elseif ( laface.lt.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) mess14(langue,1,4), -laface +#endif +c + do 22 , cote = 1 , 2 +c + jaux = volqua(cote,-laface) +c +c 2.2.1. ==> voisinage par un hexaedre +c + if ( jaux.gt.0 ) then +c + do 221 , kaux = 1 , nbhexa + if ( trav1a(decafv+kaux).eq.jaux ) then + goto 22 + endif + 221 continue + nbhexa = nbhexa + 1 + iaux = decafv+nbhexa +#include "tbdim2.h" + trav1a(iaux) = jaux +c + elseif ( jaux.lt.0 ) then +c +c 2.2.2. ==> voisinage par une pyramide +c + if ( pypequ(1,-jaux).gt.0 ) then + do 222 , kaux = 1 , nbpyra + if ( trav1a(2*decafv+kaux).eq. + > pypequ(1,-jaux) ) then + goto 22 + endif + 222 continue + nbpyra = nbpyra + 1 + iaux = 2*decafv+nbpyra +#include "tbdim2.h" + trav1a(iaux) = pypequ(1,-jaux) + endif +c +c 2.2.3. ==> voisinage par un pentaedre +c + if ( pypequ(2,-jaux).gt.0 ) then + do 223 , kaux = 1 , nbpent + if ( trav1a(3*decafv+kaux).eq. + > pypequ(2,-jaux) ) then + goto 22 + endif + 223 continue + nbpent = nbpent + 1 + iaux = 3*decafv+nbpent +#include "tbdim2.h" + trav1a(iaux) = pypequ(2,-jaux) + endif +c + endif +c + 22 continue +c + endif +c + 20 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) nbtetr, mess14(langue,1,3) + write (ulsort,texte(langue,5)) nbhexa, mess14(langue,1,6) + write (ulsort,texte(langue,5)) nbpyra, mess14(langue,1,5) + write (ulsort,texte(langue,5)) nbpent, mess14(langue,1,7) +#endif +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgv2.F b/src/tool/Utilitaire/utvgv2.F new file mode 100644 index 00000000..6553b2ce --- /dev/null +++ b/src/tool/Utilitaire/utvgv2.F @@ -0,0 +1,367 @@ + subroutine utvgv2 ( nbarto, nbtrto, nbquto, + > nbteto, nbtecf, nbteca, + > nbheto, nbhecf, nbheca, + > nbpyto, nbpycf, nbpyca, + > nbpeto, nbpecf, nbpeca, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > facpen, cofape, arepen, + > nbtear, pttear, + > nbhear, pthear, + > nbpyar, ptpyar, + > nbpear, ptpear, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes Volumes / aretes - phase 2 +c -- - - - - +c ______________________________________________________________________ +c +c determine le nombre de volumes voisins de chaque arete, par categorie +c En sortie : +c pttear(0) = 0 +c pttear(i) = position du dernier voisin de l'arete i-1 +c = nombre cumule de voisins pour les (i-1) 1eres aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbarto . e . 1 . nombre total d'aretes . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbteto . e . 1 . nombre de tetraedres total . +c . nbtecf . e . 1 . nombre total de tetraedres decrits par face. +c . nbteca . e . 1 . nombre total de tetras decrits par aretes . +c . nbheto . e . 1 . nombre d'hexaedres total . +c . nbhecf . e . 1 . nombre d'hexaedres decrits par faces . +c . nbheca . e . 1 . nombre d'hexaedres decrits par aretes . +c . nbpyto . e . 1 . nombre de pyramides total . +c . nbpycf . e . 1 . nombre total de pyramides decrits par faces. +c . nbpyca . e . 1 . nombre total de pyras decrits par aretes . +c . nbpeto . e . 1 . nombre de pentaedres total . +c . nbpecf . e . 1 . nombre total de pentas decrits par faces . +c . nbpeca . e . 1 . nombre total de pentas decrits par aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . nbtear . s . 1 . nombre de tetraedres voisins d'aretes . +c . pttear . s .0:nbarto. nombre de tetraedres voisins par aretes . +c . nbhear . s . 1 . nombre d'hexaedres voisins d'aretes . +c . pthear . s .0:nbarto. nombre d'hexaedres voisins par aretes . +c . nbpyar . s . 1 . nombre de pyramides voisines d'aretes . +c . ptpyar . s .0:nbarto. nombre de pyramides voisines par aretes . +c . nbpear . s . 1 . nombre de pentaedres voisins d'aretes . +c . ptpear . s .0:nbarto. nombre de pentaedres voisins par aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGV2' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbarto, nbtrto, nbquto + integer nbteto, nbtecf, nbteca + integer nbheto, nbhecf, nbheca + integer nbpyto, nbpycf, nbpyca + integer nbpeto, nbpecf, nbpeca +c + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c + integer nbtear, pttear(0:nbarto) + integer nbhear, pthear(0:nbarto) + integer nbpyar, ptpyar(0:nbarto) + integer nbpear, ptpear(0:nbarto) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux + integer letetr, lehexa, lapyra, lepent + integer listar(12) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbarto', nbarto + write (ulsort,90002) 'nbtrto', nbtrto + write (ulsort,90002) 'nbquto', nbquto + write (ulsort,90002) 'nbteto, nbtecf', nbteto, nbtecf + write (ulsort,90002) 'nbheto, nbhecf', nbheto, nbhecf + write (ulsort,90002) 'nbpyto, nbpycf', nbpyto, nbpycf + write (ulsort,90002) 'nbpeto, nbpecf', nbpeto, nbpecf +#endif +c +c==== +c 2. decompte des tetraedres voisins d'aretes +c==== +c + if ( nbteto.gt.0 ) then +c + do 21 , iaux = 0 , nbarto + pttear(iaux) = 0 + 21 continue +c + do 22 , letetr = 1 , nbteto +c + if ( letetr.le.nbtecf ) then +c + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + else +c + do 221 , iaux = 1 , 6 + listar(iaux) = aretet(letetr-nbtecf,iaux) + 221 continue +c + endif +c + do 222 , iaux = 1 , 6 + pttear(listar(iaux)) = pttear(listar(iaux)) + 1 + 222 continue +c + 22 continue +c + do 23 , iaux = 1 , nbarto + pttear(iaux) = pttear(iaux-1) + pttear(iaux) + 23 continue + nbtear = pttear(nbarto) + do 24 , iaux = nbarto , 1 , -1 + pttear(iaux) = pttear(iaux-1) + 24 continue +c + endif +c +c==== +c 3. decompte des hexaedres voisins d'aretes +c==== +c + if ( nbheto.gt.0 ) then +c + do 31 , iaux = 0 , nbarto + pthear(iaux) = 0 + 31 continue +c + do 32 , lehexa = 1 , nbheto +c + if ( lehexa.le.nbhecf ) then +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + else +c + do 321 , iaux = 1 , 12 + listar(iaux) = arehex(lehexa-nbhecf,iaux) + 321 continue +c + endif +c + do 322 , iaux = 1 , 12 + pthear(listar(iaux)) = pthear(listar(iaux)) + 1 + 322 continue +c + 32 continue +c + do 33 , iaux = 1 , nbarto + pthear(iaux) = pthear(iaux-1) + pthear(iaux) + 33 continue + nbhear = pthear(nbarto) + do 34 , iaux = nbarto , 1 , -1 + pthear(iaux) = pthear(iaux-1) + 34 continue +c + endif +c +c==== +c 4. decompte des pyramides voisines d'aretes +c==== +c + if ( nbpyto.gt.0 ) then +c + do 41 , iaux = 0 , nbarto + ptpyar(iaux) = 0 + 41 continue +c + do 42 , lapyra = 1 , nbpyto +c + if ( lapyra.le.nbpycf ) then +c + call utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) +c + else +c + do 421 , iaux = 1 , 8 + listar(iaux) = arepyr(lapyra-nbpycf,iaux) + 421 continue +c + endif +c + do 422 , iaux = 1 , 8 + ptpyar(listar(iaux)) = ptpyar(listar(iaux)) + 1 + 422 continue +c + 42 continue +c + do 43 , iaux = 1 , nbarto + ptpyar(iaux) = ptpyar(iaux-1) + ptpyar(iaux) + 43 continue + nbpyar = ptpyar(nbarto) + do 44 , iaux = nbarto , 1 , -1 + ptpyar(iaux) = ptpyar(iaux-1) + 44 continue +c + endif +c +c==== +c 5. decompte des pentaedres voisins d'aretes +c==== +c + if ( nbpeto.gt.0 ) then +c + do 51 , iaux = 0 , nbarto + ptpear(iaux) = 0 + 51 continue +c + do 52 , lepent = 1 , nbpeto +c + if ( lepent.le.nbpecf ) then +c + call utarpe ( lepent, + > nbquto, nbpecf, + > arequa, facpen, cofape, + > listar ) +c + else +c + do 521 , iaux = 1 , 9 + listar(iaux) = arepen(lepent-nbpecf,iaux) + 521 continue +c + endif +c + do 522 , iaux = 1 , 9 + ptpear(listar(iaux)) = ptpear(listar(iaux)) + 1 + 522 continue +c + 52 continue +c + do 53 , iaux = 1 , nbarto + ptpear(iaux) = ptpear(iaux-1) + ptpear(iaux) + 53 continue + nbpear = ptpear(nbarto) + do 54 , iaux = nbarto , 1 , -1 + ptpear(iaux) = ptpear(iaux-1) + 54 continue +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtear', nbtear + write (ulsort,90002) 'nbhear', nbhear + write (ulsort,90002) 'nbpyar', nbpyar + write (ulsort,90002) 'nbpear', nbpear +#endif +c +c==== +c 6. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgv3.F b/src/tool/Utilitaire/utvgv3.F new file mode 100644 index 00000000..7099cd6d --- /dev/null +++ b/src/tool/Utilitaire/utvgv3.F @@ -0,0 +1,320 @@ + subroutine utvgv3 ( nbarto, nbtrto, nbquto, + > nbteto, nbtecf, nbteca, + > nbheto, nbhecf, nbheca, + > nbpyto, nbpycf, nbpyca, + > nbpeto, nbpecf, nbpeca, + > aretri, + > arequa, + > tritet, cotrte, aretet, + > quahex, coquhe, arehex, + > facpyr, cofapy, arepyr, + > facpen, cofape, arepen, + > nbtear, pttear, tatear, + > nbhear, pthear, tahear, + > nbpyar, ptpyar, tapyar, + > nbpear, ptpear, tapear, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes Volumes / aretes - phase 3 +c -- - - - - +c ______________________________________________________________________ +c +c determine le nombre de volumes voisins de chaque arete, par categorie +c En sortie : +c pttear(i) = position du dernier voisin de l'arete i +c = nombre cumule de voisins pour les i 1eres aretes +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nbarto . e . 1 . nombre total d'aretes . +c . nbtrto . e . 1 . nombre total de triangles . +c . nbquto . e . 1 . nombre total de quadrangles . +c . nbteto . e . 1 . nombre de tetraedres total . +c . nbtecf . e . 1 . nombre total de tetraedres decrits par face. +c . nbteca . e . 1 . nombre total de tetras decrits par aretes . +c . nbheto . e . 1 . nombre d'hexaedres total . +c . nbhecf . e . 1 . nombre d'hexaedres decrits par faces . +c . nbheca . e . 1 . nombre d'hexaedres decrits par aretes . +c . nbpyto . e . 1 . nombre de pyramides total . +c . nbpycf . e . 1 . nombre total de pyramides decrits par faces. +c . nbpyca . e . 1 . nombre total de pyras decrits par aretes . +c . nbpeto . e . 1 . nombre de pentaedres total . +c . nbpecf . e . 1 . nombre total de pentas decrits par faces . +c . nbpeca . e . 1 . nombre total de pentas decrits par aretes . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c . nbtear . e . 1 . nombre de tetraedres voisins d'aretes . +c . pttear . es .0:nbarto. nombre de tetraedres voisins par aretes . +c . tatear . s . nbtear . tetraedres voisins par aretes . +c . nbhear . e . 1 . nombre d'hexaedres voisins d'aretes . +c . pthear . es .0:nbarto. nombre d'hexaedres voisins par aretes . +c . tahear . s . nbhear . hexaedres voisins par aretes . +c . nbpyar . e . 1 . nombre de pyramides voisines d'aretes . +c . ptpyar . es .0:nbarto. nombre de pyramides voisines par aretes . +c . tapyar . s . nbpyar . pyramides voisines par aretes . +c . nbpear . e . 1 . nombre de pentaedres voisins d'aretes . +c . ptpear . es .0:nbarto. nombre de pentaedres voisins par aretes . +c . tapear . s . nbpear . pentaedres voisins par aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGV3' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer nbarto, nbtrto, nbquto + integer nbteto, nbtecf, nbteca + integer nbheto, nbhecf, nbheca + integer nbpyto, nbpycf, nbpyca + integer nbpeto, nbpecf, nbpeca +c + integer aretri(nbtrto,3) + integer arequa(nbquto,4) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c + integer nbtear, pttear(0:nbarto), tatear(nbtear) + integer nbhear, pthear(0:nbarto), tahear(nbhear) + integer nbpyar, ptpyar(0:nbarto), tapyar(nbpyar) + integer nbpear, ptpear(0:nbarto), tapear(nbpear) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer letetr, lehexa, lapyra, lepent + integer listar(12) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbtear', nbtear + write (ulsort,90002) 'nbhear', nbhear + write (ulsort,90002) 'nbpyar', nbpyar + write (ulsort,90002) 'nbpear', nbpear +#endif +c +c==== +c 2. decompte des tetraedres voisins d'aretes +c==== +c + if ( nbteto.gt.0 ) then +c + do 21 , letetr = 1 , nbteto +c + if ( letetr.le.nbtecf ) then +c + call utarte ( letetr, + > nbtrto, nbtecf, + > aretri, tritet, cotrte, + > listar ) +c + else +c + do 211 , iaux = 1 , 6 + listar(iaux) = aretet(letetr-nbtecf,iaux) + 211 continue +c + endif +c + do 212 , iaux = 1 , 6 + jaux = listar(iaux) + pttear(jaux) = pttear(jaux) + 1 + tatear(pttear(jaux)) = letetr + 212 continue +c + 21 continue +c + endif +c +c==== +c 3. decompte des hexaedres voisins d'aretes +c==== +c + if ( nbheto.gt.0 ) then +c + do 31 , lehexa = 1 , nbheto +c + if ( lehexa.le.nbhecf ) then +c + call utarhe ( lehexa, + > nbquto, nbhecf, + > arequa, quahex, coquhe, + > listar ) +c + else +c + do 311 , iaux = 1 , 12 + listar(iaux) = arehex(lehexa-nbhecf,iaux) + 311 continue +c + endif +c + do 312 , iaux = 1 , 12 + jaux = listar(iaux) + pthear(jaux) = pthear(jaux) + 1 + tahear(pthear(jaux)) = lehexa + 312 continue +c + 31 continue +c + endif +c +c==== +c 4. decompte des pyramides voisines d'aretes +c==== +c + if ( nbpyto.gt.0 ) then +c + do 41 , lapyra = 1 , nbpyto +c + if ( lapyra.le.nbpycf ) then +c + call utarpy ( lapyra, + > nbtrto, nbpycf, + > aretri, facpyr, cofapy, + > listar ) +c + else +c + do 411 , iaux = 1 , 8 + listar(iaux) = arepyr(lapyra-nbpycf,iaux) + 411 continue +c + endif +c + do 412 , iaux = 1 , 8 + jaux = listar(iaux) + ptpyar(jaux) = ptpyar(jaux) + 1 + tapyar(ptpyar(jaux)) = lapyra + 412 continue +c + 41 continue +c + endif +c +c==== +c 5. decompte des pentaedres voisins d'aretes +c==== +c + if ( nbpeto.gt.0 ) then +c + do 51 , lepent = 1 , nbpeto +c + if ( lepent.le.nbpecf ) then +c + call utarpe ( lepent, + > nbquto, nbpecf, + > arequa, facpen, cofape, + > listar ) +c + else +c + do 511 , iaux = 1 , 9 + listar(iaux) = arepen(lepent-nbpecf,iaux) + 511 continue +c + endif +c + do 512 , iaux = 1 , 9 + jaux = listar(iaux) + ptpear(jaux) = ptpear(jaux) + 1 + tapear(ptpear(jaux)) = lepent + 512 continue +c + 51 continue +c + endif +c +c==== +c 6. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgva.F b/src/tool/Utilitaire/utvgva.F new file mode 100644 index 00000000..290d2312 --- /dev/null +++ b/src/tool/Utilitaire/utvgva.F @@ -0,0 +1,656 @@ + subroutine utvgva ( nhvois, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes Volumes / Aretes +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhvois . e . char8 . nom de l'objet voisinage . +c . nharet . e . char8 . nom de l'objet decrivant les aretes . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhtetr . e . char8 . nom de l'objet decrivant les tetraedres . +c . nhhexa . e . char8 . nom de l'objet decrivant les hexaedres . +c . nhpyra . e . char8 . nom de l'objet decrivant les pyramides . +c . nhpent . e . char8 . nom de l'objet decrivant les pentaedres . +c . option . e . 1 . pilotage des volumes voisins des faces : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGVA' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nhvois, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer adaux + integer codre1, codre2, codre3 + integer codre0 + integer nbarto + integer nbtrto + integer nbquto + integer nbteto, nbtecf, nbteca + integer nbheto, nbhecf, nbheca + integer nbpyto, nbpycf, nbpyca + integer nbpeto, nbpecf, nbpeca + integer phettr, paretr + integer phetqu, parequ + integer phette, ptrite, pcotrt, parete + integer phethe, pquahe, pcoquh, parehe + integer phetpy, pfacpe, pcofay, parepy + integer phetpe, pfacpy, pcofap, parepe + integer adptte, adpthe, adptpy, adptpe + integer adtate, adtahe, adtapy, adtape + integer nbtear, nbhear, nbpyar, nbpear +c + character*8 saux08 +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(''Voisinage volumes-aretes.'')' + texte(1,5) = '(''Demande : '',i6)' + texte(1,6) = '(''Mauvaise demande.'')' +c + texte(2,4) = '(''Neighbourhood volumes-edges.'')' + texte(2,5) = '(''Request : '',i6)' + texte(2,6) = '(''Bad request.'')' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option +#endif +c + codret = 0 +c +c==== +c 2. Controle de l'option +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '2. Controle option ; codret =',codret +#endif + if ( codret.eq.0 ) then +c + if ( option.lt.-1 .or. option.gt.2 ) then +c + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,6)) + codret = 2 +c + endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c remarque : on relit les nombres d'entites car les communs ne +c sont pas forcement remplis +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '3. recuperation ; codret =',codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 3.1. ==> Les tetraedres +c + if ( codret.eq.0 ) then +c + call gmliat ( nhtetr, 1, nbteto, codre1 ) + call gmliat ( nhtetr, 2, nbteca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbteto, nbteca', nbteto, nbteca +#endif +c + if ( nbteto.gt.0 ) then +c + iaux = 26 + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcotrt, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.2. ==> Les hexaedres +c + if ( codret.eq.0 ) then +c + call gmliat ( nhhexa, 1, nbheto, codre1 ) + call gmliat ( nhhexa, 2, nbheca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbheto, nbheca', nbheto, nbheca +#endif +c + if ( nbheto.gt.0 ) then +c + iaux = 26 + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcoquh, jaux, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.3. ==> Les pyramides +c + if ( codret.eq.0 ) then +c + call gmliat ( nhpyra, 1, nbpyto, codre1 ) + call gmliat ( nhpyra, 2, nbpyca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpyto, nbpyca', nbpyto, nbpyca +#endif +c + if ( nbpyto.gt.0 ) then +c + iaux = 26 + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcofay, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.4. ==> Les pentaedres +c + if ( codret.eq.0 ) then +c + call gmliat ( nhpent, 1, nbpeto, codre1 ) + call gmliat ( nhpent, 2, nbpeca, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'nbpeto, nbpeca', nbpeto, nbpeca +#endif +c + if ( nbpeto.gt.0 ) then +c + iaux = 26 + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, jaux, jaux, + > jaux, jaux, jaux, + > jaux, pcofap, jaux, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.5. ==> Bilan +c + if ( codret.eq.0 ) then +c + nbtecf = nbteto - nbteca + nbhecf = nbheto - nbheca + nbpycf = nbpyto - nbpyca + nbpecf = nbpeto - nbpeca +c + endif +c +c 3.6. ==> Les triangles si besoin +c + if ( codret.eq.0 ) then +c + if ( nbteto.gt.0 .or. nbpycf.gt.0 ) then +c + call gmliat ( nhtria, 1, nbtrto, codre0 ) +c + codret = abs(codre0) +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro +#endif + call utad02 ( iaux, nhtria, + > phettr, paretr, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.7. ==> Les quadangles si besoin +c + if ( codret.eq.0 ) then +c + if ( nbheto.gt.0 .or. nbpecf.gt.0 ) then +c + call gmliat ( nhquad, 1, nbquto, codre0 ) +c + codret = abs(codre0) +c + iaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro +#endif + call utad02 ( iaux, nhquad, + > phetqu, parequ, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 3.8. ==> Nombre d'aretes +c + if ( codret.eq.0 ) then +c + call gmliat ( nharet, 1, nbarto, codre0 ) +c + codret = abs(codre0) +c + endif +c + endif +c +c==== +c 4. Si on cree ou si on detruit, on commence par supprimer les graphes +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '4. suppression ; codret =',codret +#endif +c + if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then +c + do 41 , iaux = 1 , 4 +c + if ( codret.eq.0 ) then +c + saux08 = '.xxx/Are' + if ( iaux.eq.1 ) then + saux08(2:4) = 'Tet' + elseif ( iaux.eq.2 ) then + saux08(2:4) = 'Hex' + elseif ( iaux.eq.3 ) then + saux08(2:4) = 'Pyr' + else + saux08(2:4) = 'Pen' + endif +c + call gmobal ( nhvois//saux08, codre1 ) +c + if ( codre1.eq.0 ) then + codret = 0 +c + elseif ( codre1.eq.1 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Suppression de nhvois'//saux08 +#endif + call gmsgoj ( nhvois//saux08, codret ) +c + else + codret = 2 +c + endif +c + endif +c + 41 continue +c + endif +c +c==== +c 5. Creation +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5. Creation ; codret =',codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 5.1. ==> Allocation de la tete +c + do 51 , iaux = 1 , 4 +c + if ( codret.eq.0 ) then +c + saux08 = '.xxx/Are' + if ( iaux.eq.1 ) then + saux08(2:4) = 'Tet' + jaux = nbteto + elseif ( iaux.eq.2 ) then + saux08(2:4) = 'Hex' + jaux = nbheto + elseif ( iaux.eq.3 ) then + saux08(2:4) = 'Pyr' + jaux = nbpyto + else + saux08(2:4) = 'Pen' + jaux = nbpeto + endif +c + if ( jaux.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Allocation de nhvois'//saux08 +#endif +c + call gmaloj ( nhvois//saux08 , ' ', 0, kaux, codre1 ) + kaux = nbarto+1 + call gmecat ( nhvois//saux08, 1, kaux, codre2 ) + call gmaloj ( nhvois//saux08//'.Pointeur', + > ' ', kaux, adaux, codre3 ) +c + codre0 = min ( codre1, codre2, codre3 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3 ) +c + if ( iaux.eq.1 ) then + adptte = adaux + elseif ( iaux.eq.2 ) then + adpthe = adaux + elseif ( iaux.eq.3 ) then + adptpy = adaux + else + adptpe = adaux + endif +c + endif +c + endif +c + 51 continue +c +c 5.2. ==> Longueur des tableaux de voisinages +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.2. Longueur ; codret =',codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGV2', nompro +#endif + call utvgv2 ( nbarto, nbtrto, nbquto, + > nbteto, nbtecf, nbteca, + > nbheto, nbhecf, nbheca, + > nbpyto, nbpycf, nbpyca, + > nbpeto, nbpecf, nbpeca, + > imem(paretr), + > imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > nbtear, imem(adptte), + > nbhear, imem(adpthe), + > nbpyar, imem(adptpy), + > nbpear, imem(adptpe), + > ulsort, langue, codret ) +c + endif +c +c 5.3. ==> Allocations +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.3. Allocations ; codret =',codret +#endif +c + if ( codret.eq.0 ) then +c + do 53 , iaux = 1 , 4 +c + if ( codret.eq.0 ) then +c + saux08 = '.xxx/Are' + if ( iaux.eq.1 ) then + saux08(2:4) = 'Tet' + jaux = nbtear + elseif ( iaux.eq.2 ) then + saux08(2:4) = 'Hex' + jaux = nbhear + elseif ( iaux.eq.3 ) then + saux08(2:4) = 'Pyr' + jaux = nbpyar + else + saux08(2:4) = 'Pen' + jaux = nbpear + endif +c + if ( jaux.gt.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '.... Allocation de nhvois'//saux08 +#endif +c + call gmecat ( nhvois//saux08, 2, jaux, codre1 ) + call gmaloj ( nhvois//saux08//'.Table', + > ' ', jaux, adaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( iaux.eq.1 ) then + adtate = adaux + elseif ( iaux.eq.2 ) then + adtahe = adaux + elseif ( iaux.eq.3 ) then + adtapy = adaux + else + adtape = adaux + endif +c + endif +c + endif +c + 53 continue +c + endif +c +c 5.4. ==> Determination des voisinages +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) '5.4. Determination ; codret =',codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGV3', nompro +#endif + call utvgv3 ( nbarto, nbtrto, nbquto, + > nbteto, nbtecf, nbteca, + > nbheto, nbhecf, nbheca, + > nbpyto, nbpycf, nbpyca, + > nbpeto, nbpecf, nbpeca, + > imem(paretr), + > imem(parequ), + > imem(ptrite), imem(pcotrt), imem(parete), + > imem(pquahe), imem(pcoquh), imem(parehe), + > imem(pfacpy), imem(pcofay), imem(parepy), + > imem(pfacpe), imem(pcofap), imem(parepe), + > nbtear, imem(adptte), imem(adtate), + > nbhear, imem(adpthe), imem(adtahe), + > nbpyar, imem(adptpy), imem(adtapy), + > nbpear, imem(adptpe), imem(adtape), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ + saux08 = '.xxx/Are' + if ( nbteto.gt.0 ) then + saux08(2:4) = 'Tet' + call gmprsx(nompro//saux08//' - pt', + > nhvois//saux08//'.Pointeur') + call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table') + endif + if ( nbheto.gt.0 ) then + saux08(2:4) = 'Hex' + call gmprsx(nompro//saux08//' - pt', + > nhvois//saux08//'.Pointeur') + call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table') + endif + if ( nbpyto.gt.0 ) then + saux08(2:4) = 'Pyr' + call gmprsx(nompro//saux08//' - pt', + > nhvois//saux08//'.Pointeur') + call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table') + endif + if ( nbpeto.gt.0 ) then + saux08(2:4) = 'Pen' + call gmprsx(nompro//saux08//' - pt', + > nhvois//saux08//'.Pointeur') + call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table') + endif +#endif + endif +c + endif +c +c==== +c 6. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgvf.F b/src/tool/Utilitaire/utvgvf.F new file mode 100644 index 00000000..49b986e0 --- /dev/null +++ b/src/tool/Utilitaire/utvgvf.F @@ -0,0 +1,760 @@ + subroutine utvgvf ( nhvois, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > option, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - VoisinaGe Volumes-Face +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nhvois . e . char8 . nom de l'objet voisinage . +c . nhtria . e . char8 . nom de l'objet decrivant les triangles . +c . nhquad . e . char8 . nom de l'objet decrivant les quadrangles . +c . nhtetr . e . char8 . nom de l'objet decrivant les tetraedres . +c . nhhexa . e . char8 . nom de l'objet decrivant les hexaedres . +c . nhpyra . e . char8 . nom de l'objet decrivant les pyramides . +c . nhpent . e . char8 . nom de l'objet decrivant les pentaedres . +c . option . e . 1 . pilotage des volumes voisins des faces : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGVF' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "gmenti.h" +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nhvois, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent +c + integer option +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux + integer nbfac(2) + integer codre0 + integer codre1, codre2, codre3, codre4 +c + integer nbtrto, nbquto + integer nbteto, nbheto, nbpyto, nbpeto + integer nbteca, nbheca, nbpyca, nbpeca + integer nbtecf, nbhecf, nbpycf, nbpecf + integer ptrite, phette, parete, pfilte + integer pquahe, phethe, parehe, pfilhe, adhes2 + integer pfacpy, phetpy, parepy, pfilpy + integer pfacpe, phetpe, parepe, pfilpe, adpes2 + integer advotq, advotr, advoqu + integer lgpptq, adpptq + integer lgpptr, adpptr, nupptr + integer lgppqu, adppqu, nuppqu +c + character*9 suff(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +c 1.1. ==> messages +c + texte(1,4) = '(''Voisinage volumes-faces.'')' + texte(1,5) = '(''Demande : '',i6)' + texte(1,6) = '(''Mauvaise demande.'')' + texte(1,7) = '(''Nombre de '',a,'' : '',i10)' + texte(1,8) = '(''Voisinage '',a,''/ '',a)' +c + texte(2,4) = '(''Neighbourhood volumes-faces.'')' + texte(2,5) = '(''Request : '',i6)' + texte(2,6) = '(''Bad request.'')' + texte(2,7) = '(''Number of '',a,'' : '',i10)' + texte(2,8) = '(''Neighbourhood '',a,''/ '',a)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,4)) + write (ulsort,texte(langue,5)) option +#endif +c +c 1.2. ==> initialisations +c + suff(1) = '.Vol/Tri' + suff(2) = '.Vol/Qua' + suff(3) = '.PyPe/Tri' + suff(4) = '.PyPe/Qua' +c + codret = 0 +c +c==== +c 2. Controle de l'option +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '2. Controle option ; codret', codret +#endif + if ( codret.eq.0 ) then +c + if ( option.lt.-1 .or. option.gt.2 ) then +c + write (ulsort,texte(langue,5)) option + write (ulsort,texte(langue,6)) + codret = 2 +c + endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c remarque : on relit les nombres d'entites car les communs ne +c sont pas forcement remplis +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 3.1. ==> nombre d'entites volumiques +c + if ( codret.eq.0 ) then +c + call gmliat ( nhtetr, 1, nbteto, codre1 ) + call gmliat ( nhpyra, 1, nbpyto, codre2 ) + call gmliat ( nhhexa, 1, nbheto, codre3 ) + call gmliat ( nhpent, 1, nbpeto, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + call gmliat ( nhtetr, 2, nbteca, codre1 ) + call gmliat ( nhpyra, 2, nbpyca, codre2 ) + call gmliat ( nhhexa, 2, nbheca, codre3 ) + call gmliat ( nhpent, 2, nbpeca, codre4 ) +c + codre0 = min ( codre1, codre2, codre3, codre4 ) + codret = max ( abs(codre0), codret, + > codre1, codre2, codre3, codre4 ) +c + nbtecf = nbteto - nbteca + nbpycf = nbpyto - nbpyca + nbhecf = nbheto - nbheca + nbpecf = nbpeto - nbpeca +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,3), nbteto + write (ulsort,texte(langue,7)) mess14(langue,3,5), nbpyto + write (ulsort,texte(langue,7)) mess14(langue,3,6), nbheto + write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpeto +#endif +c +c 3.2. ==> nombre de triangles/quadrangles +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 2.2 ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c + call gmliat ( nhtria, 1, nbtrto, codre1 ) + call gmliat ( nhquad, 1, nbquto, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,7)) mess14(langue,3,2), nbtrto + write (ulsort,texte(langue,7)) mess14(langue,3,4), nbquto +#endif +c +c 3.3. ==> adresses liees aux volumes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 2.3 ; codret', codret +#endif +c + if ( nbteto.ne.0 ) then +c + if ( codret.eq.0 ) then +c + iaux = 6 + if ( nbteca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_te', nompro +#endif + call utad02 ( iaux, nhtetr, + > phette, ptrite, pfilte, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, parete, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbpyto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +ccc call gmprsx ('nhpyra dans '//nompro,nhpyra) + iaux = 6 + if ( nbpyca.gt.0 ) then + iaux = iaux*31 + endif +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_py', nompro +#endif + call utad02 ( iaux, nhpyra, + > phetpy, pfacpy, pfilpy, jaux, + > jaux, jaux, jaux, + > jaux, jaux, jaux, + > jaux, jaux, parepy, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbheto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ('nhhexa dans '//nompro,nhhexa) + iaux = 6 + if ( nbheca.gt.0 ) then + iaux = iaux*31 + endif + if ( nbpyto.ne.0 ) then + call gmobal ( nhhexa//'.InfoSup2', codre1 ) + if ( codre1.eq.2 ) then + iaux = iaux*17 + elseif ( codre1.ne.0 ) then + codret = 2 + endif + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_he', nompro +#endif + call utad02 ( iaux, nhhexa, + > phethe, pquahe, pfilhe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, adhes2, + > jaux, jaux, parehe, + > ulsort, langue, codret ) +c + endif +c + endif +c + if ( nbpeto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +cgn call gmprsx ('nhpent dans '//nompro,nhpent) + iaux = 6 + if ( nbpeca.gt.0 ) then + iaux = iaux*31 + endif + if ( nbpyto.ne.0 ) then + call gmobal ( nhpent//'.InfoSup2', codre1 ) + if ( codre1.eq.2 ) then + iaux = iaux*17 + elseif ( codre1.ne.0 ) then + codret = 2 + endif + endif +c + endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro +#endif + call utad02 ( iaux, nhpent, + > phetpe, pfacpe, pfilpe, jaux, + > jaux, jaux, jaux, + > jaux, jaux, adpes2, + > jaux, jaux, parepe, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 4. Si on cree ou si on detruit, on commence par supprimer le graphe +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. suppression ; codret', codret +#endif +c + if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then +c +c 4.1. ==> Destruction des anciennes structures +c + do 41 , iaux = 1 , 4 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Destruction eventuelle de ',suff(iaux) +#endif + if ( codret.eq.0 ) then +c + call gmobal ( nhvois//suff(iaux), codre1 ) +c + if ( codre1.eq.0 ) then + codret = 0 +c + elseif ( codre1.eq.1 ) then + call gmsgoj ( nhvois//suff(iaux), codret ) +c + elseif ( codre1.eq.2 ) then + call gmlboj ( nhvois//suff(iaux), codret ) +c + else + codret = 2 +c + endif +c + endif +c + 41 continue +c +c 4.2. ==> Attributs +c + if ( codret.eq.0 ) then +c + iaux = 0 + call gmecat ( nhvois , 1, iaux, codre1 ) + call gmecat ( nhvois , 2, iaux, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + endif +c + endif +c +c==== +c 5. Allocation des voisinages Vol/Tri et Vol/Qua +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 5 ; codret', codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c + nbfac(1) = nbtrto + nbfac(2) = nbquto +c + do 50 , iaux = 1 , 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Creation de ',suff(iaux) +#endif +c +c 5.1. ==> Allocation de la structure +c + if ( codret.eq.0 ) then +c + jaux = 2*nbfac(iaux) + call gmaloj ( nhvois//suff(iaux) , ' ', + > jaux, advotq, codret ) +c + if ( iaux.eq.1 ) then + advotr = advotq + else + advoqu = advotq + endif +c + endif +c +c 5.2. ==> A priori aucun voisin +c + if ( codret.eq.0 ) then +c + kaux = advotq + jaux - 1 + do 52 , jaux = advotq , kaux + imem(jaux) = 0 + 52 continue +c + endif +c + 50 continue +c + endif +c +c==== +c 6. Allocation des voisinages PyPe/Tri et PyPe/Qua +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 6 ; codret', codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c + do 60 , iaux = 1 , 2 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,*) 'Creation de ',suff(iaux+2) +#endif +c +c 6.1. ==> Allocation de la structure +c + if ( codret.eq.0 ) then +c + if ( iaux.eq.1 ) then + lgpptq = 4*nbpyto + 2*nbpeto + else + lgpptq = nbpyto + 3*nbpeto + endif + jaux = 2*lgpptq + call gmecat ( nhvois , 1, jaux, codre1 ) + call gmaloj ( nhvois//suff(iaux+2), ' ', + > jaux, adpptq, codre2 ) +c + codre0 = min ( codre1, codre2 ) + codret = max ( abs(codre0), codret, + > codre1, codre2 ) +c + if ( iaux.eq.1 ) then + adpptr = adpptq + lgpptr = lgpptq + else + adppqu = adpptq + lgppqu = lgpptq + endif +c + endif +c +c 6.2. ==> A priori aucun voisin +c + if ( codret.eq.0 ) then +c + kaux = adpptq + jaux - 1 + do 62 , jaux = adpptq , kaux + imem(jaux) = 0 + 62 continue +c + endif +c + 60 continue +c + endif +c +c==== +c 7. Creation des voisinages Tet/Tri et Hex/Qua +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 7 ; codret', codret +#endif +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 7.1. ==> determination des tetraedres voisins des triangles +c + if ( nbteto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), + > mess14(langue,3,3) + write (ulsort,*) 'Creation de ',suff(1) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTTETR', nompro +#endif + call uttetr ( option, + > nbtrto, nbteto, nbtecf, + > imem(ptrite), imem(phette), imem(pfilte), + > imem(advotr), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,nhvois//suff(1)) +cgn call gmprot (nompro, nhvois//suff(1), 1, nbtrto*2 ) + call gmprot (nompro, nhvois//suff(1), 1, min(10,nbtrto*2) ) +#endif +c + endif +c + endif +c +c 7.2. ==> determination des hexaedres voisins des quadrangles +c + if ( nbheto.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,4), + > mess14(langue,3,6) + write (ulsort,*) 'Creation de ',suff(2) +#endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTHEQU', nompro +#endif + call uthequ ( option, + > nbquto, nbheto, nbhecf, nbpyto, nbpycf, + > imem(pquahe), imem(phethe), imem(pfilhe), + > imem(adhes2), + > imem(pfacpy), + > imem(advoqu), + > ulsort, langue, codret ) +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro, nhvois//suff(2) ) +cgn call gmprot (nompro, nhvois//suff(2), 1, nbquto*2 ) + call gmprot (nompro, nhvois//suff(2), 1, min(20,nbquto*2) ) +#endif +c + endif +c + endif +c + endif +c +c==== +c 8. Creation des voisinages PyPe/Tri et PyPe/Qua +c==== +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) 'Etape 8 ; codret', codret + write (ulsort,90002) 'nbpyto', nbpyto + write (ulsort,90002) 'nbpyca', nbpyca + write (ulsort,90002) 'nbpeto', nbpeto + write (ulsort,90002) 'nbpeca', nbpeca +#endif +c + nupptr = 0 + nuppqu = 0 +c + if ( option.eq.1 .or. option.eq.2 ) then +c +c 8.1. ==> Determination des pyramides voisines +c + if ( nbpyto.ne.0 ) then +c +c 8.1.1. ==> Determination des pyramides voisines des triangles +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), + > mess14(langue,3,5) +#endif +c + iaux = 5 + jaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPPQT-PY_TR', nompro +#endif + call utppqt ( option, nbtrto, nbpyto, nbpycf, + > iaux, jaux, + > imem(pfacpy), imem(phetpy), + > imem(advotr), lgpptr, imem(adpptr), nupptr, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,'MaVo000h.Vol/Qua') +cgn call gmprsx (nompro,'MaVo000h.Vol/Qua', 1, 30) +cc call gmprsx (nompro,nhvois//'.PyPe/Qua') +#endif +c +c 8.1.2. ==> Determination des pyramides voisines des quadrangles +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,4), + > mess14(langue,3,5) +#endif +c + iaux = 5 + jaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPPQT-PY_QU', nompro +#endif + call utppqt ( option, nbquto, nbpyto, nbpycf, + > iaux, jaux, + > imem(pfacpy), imem(phetpy), + > imem(advoqu), lgppqu, imem(adppqu), nuppqu, + > ulsort, langue, codret ) +c + endif +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,nhvois//'.Vol/Qua') + call gmprot (nompro,nhvois//'.Vol/Qua', 1, 30) +cgn call gmprsx (nompro,nhvois//'.PyPe/Qua') + call gmprot (nompro,nhvois//'.PyPe/Qua', 1, 30) +#endif +c + endif +c +c 8.2. ==> Determination des pentaedres voisins +c + if ( nbpeto.ne.0 ) then +c +c 8.2.1. ==> Determination des pentaedres voisins des triangles +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,2), + > mess14(langue,3,7) +#endif +c + iaux = 7 + jaux = 2 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPPQT-PE_TR', nompro +#endif + call utppqt ( option, nbtrto, nbpeto, nbpecf, + > iaux, jaux, + > imem(pfacpe), imem(phetpe), + > imem(advotr), lgpptr, imem(adpptr), nupptr, + > ulsort, langue, codret ) +c + endif +c +c 8.2.2. ==> Determination des pentaedres voisins des quadrangles +c + if ( codret.eq.0 ) then +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,8)) mess14(langue,3,4), + > mess14(langue,3,7) +#endif +c + iaux = 7 + jaux = 4 +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTPPQT-PE_QU', nompro +#endif + call utppqt ( option, nbquto, nbpeto, nbpecf, + > iaux, jaux, + > imem(pfacpe), imem(phetpe), + > imem(advoqu), lgppqu, imem(adppqu), nuppqu, + > ulsort, langue, codret ) +c + endif +c + endif +c + endif +c +c==== +c 9. la fin +c==== +c +#ifdef _DEBUG_HOMARD_ +cgn call gmprsx (nompro,nhvois) + if ( codret.eq.0 ) then +cgn call gmprsx (nompro,nhvois//'.Vol/Tri') +cgn call gmprsx (nompro,nhvois//'.PyPe/Tri') +cgn call gmprsx (nompro,nhvois//'.Vol/Qua') + call gmprot (nompro,nhvois//'.Vol/Qua', 1, 30) +cgn call gmprsx (nompro,nhvois//'.PyPe/Qua') + call gmprot (nompro,nhvois//'.PyPe/Qua', 1, 30) + endif +#endif +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvgvq.F b/src/tool/Utilitaire/utvgvq.F new file mode 100644 index 00000000..80d69033 --- /dev/null +++ b/src/tool/Utilitaire/utvgvq.F @@ -0,0 +1,215 @@ + subroutine utvgvq ( lequad, + > volqua, pypequ, + > nbhexa, nbpyra, nbpent, + > livoqu, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VoisinaGes Volumes / Quadrangles +c -- - - - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lequad . e . 1 . quadrangle a traiter . +c . volqua . e .2*nbquto. numeros des 2 volumes par quadrangle . +c . . . . volqua(i,k) definit le i-eme voisin de k . +c . . . . 0 : pas de voisin . +c . . . . j>0 : hexaedre j . +c . . . . j<0 : pyramide/pentaedre dans pypequ(1/2,j). +c . pypequ . e .2*lgpype. pypequ(1,j) = numero de la pyramide voisine. +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . . . . pypequ(2,j) = numero du pentaedre voisin . +c . . . . du quadrangle k tel que volqua(1/2,k) = -j . +c . nbhexa . s . 1 . nombre d'hexaedres voisins . +c . nbpyra . s . 1 . nombre de pyramides voisines . +c . nbpent . s . 1 . nombre de pentaedres voisins . +c . livoqu . s . * . liste des voisins . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . non nul : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVGVQ' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "impr02.h" +c +#include "nombqu.h" +#include "nombhe.h" +#include "nombpy.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + integer lequad + integer nbhexa, nbpyra, nbpent + integer volqua(2,nbquto), pypequ(2,*) +c + integer livoqu(*) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux, kaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c ______________________________________________________________________ +c +c==== +c 1. initialisation +c==== +c +c 1.1. ==> messages +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c +#ifdef _DEBUG_HOMARD_ + texte(1,5) = '(''.. '',a,''numero'',i10)' + texte(1,6) = '(''.. Nombre de voisins de type '',a,'':'',i10)' +c + texte(2,5) = '(''.. '',a,''#'',i10)' + texte(2,6) = '(''.. Number of neighbours '',a,''type :'',i10)' +#endif +c +c 1.2. ==> prealables +c + codret = 0 +c + nbhexa = 0 + nbpyra = 0 + nbpent = 0 +c +c==== +c 2. decompte des elements de volumes voisins +c==== +c + if ( nbheto.gt.0 .or. + > nbpyto.gt.0 .or. nbpeto.gt.0 ) then +c + do 2 , iaux = 1 , 8 + livoqu(iaux) = 0 + 2 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,5)) mess14(langue,1,4), lequad +#endif +c + do 20 , iaux = 1 , 2 +c + jaux = volqua(iaux,lequad) +c +c 2.1. ==> voisinage par un hexaedre +c + if ( jaux.gt.0 ) then +c + do 21 , kaux = 1 , nbhexa + if ( livoqu(2+kaux).eq.jaux ) then + goto 20 + endif + 21 continue + nbhexa = nbhexa + 1 + livoqu(2+nbhexa) = jaux +c + elseif ( jaux.lt.0 ) then +c +c 2.2. ==> voisinage par une pyramide +c + if ( pypequ(1,-jaux).gt.0 ) then + do 22 , kaux = 1 , nbpyra + if ( livoqu(4+kaux).eq.pypequ(1,-jaux) ) then + goto 20 + endif + 22 continue + nbpyra = nbpyra + 1 + livoqu(4+nbpyra) = pypequ(1,-jaux) + endif +c +c 2.3. ==> voisinage par un pentaedre +c + if ( pypequ(2,-jaux).gt.0 ) then + do 23 , kaux = 1 , nbpent + if ( livoqu(6+kaux).eq.pypequ(2,-jaux) ) then + goto 20 + endif + 23 continue + nbpent = nbpent + 1 + livoqu(6+nbpent) = pypequ(2,-jaux) + endif +c + endif +c + 20 continue +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,6)) mess14(langue,1,6), nbhexa + write (ulsort,texte(langue,6)) mess14(langue,1,5), nbpyra + write (ulsort,texte(langue,6)) mess14(langue,1,7), nbpent + write (ulsort,2000) (livoqu(iaux),iaux=1,8) + 2000 format(2i10) +#endif +c + endif +c +c==== +c 3. La fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvhex.F b/src/tool/Utilitaire/utvhex.F new file mode 100644 index 00000000..72df5d44 --- /dev/null +++ b/src/tool/Utilitaire/utvhex.F @@ -0,0 +1,195 @@ + subroutine utvhex ( lehexa, volume, + > coonoe, somare, arequa, + > quahex, coquhe, arehex ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Volume d'un HEXaedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lehexa . e . 1 . numero de l'hexaedre a examiner . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . hethex . e . nbheto . historique de l'etat des hexaedres . +c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres . +c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres . +c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fractc.h" +#include "fractf.h" +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombhe.h" +c +c 0.3. ==> arguments +c + double precision volume + double precision coonoe(nbnoto,3) +c + integer lehexa + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12) +c +c 0.4. ==> variables locales +c + integer iaux + integer listar(12), listso(8) + integer s1, s2, s3, s4, s5, s6, s7,s8 +c + double precision of1(3),of2(3),of3(3),of4(3),of5(3),of6(3) + double precision centr(3), qual(24), volu(24) +c +c==== +c 1. les aretes et les sommets +c==== +c + call utashe ( lehexa, + > nbquto, nbhecf, nbheca, + > somare, arequa, + > quahex, coquhe, arehex, + > listar, listso ) +c + s1 = listso(1) + s2 = listso(2) + s3 = listso(3) + s4 = listso(4) + s5 = listso(5) + s6 = listso(6) + s7 = listso(7) + s8 = listso(8) +c +c==== +c 2. les points caracteristiques +c==== +c Le centre de l'hexaedre + centr(1) = unshu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s3,1)+coonoe(s4,1)+coonoe(s5,1) + > + coonoe(s6,1)+coonoe(s7,1)+coonoe(s8,1) ) + centr(2) = unshu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s3,2)+coonoe(s4,2)+coonoe(s5,2) + > + coonoe(s6,2)+coonoe(s7,2)+coonoe(s8,2) ) + centr(3) = unshu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s3,3)+coonoe(s4,3)+coonoe(s5,3) + > + coonoe(s6,3)+coonoe(s7,3)+coonoe(s8,3) ) +c Le centre de la face 1 + of1(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s3,1)+coonoe(s4,1)) + of1(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s3,2)+coonoe(s4,2)) + of1(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s3,3)+coonoe(s4,3)) +c Le centre de la face 2 + of2(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1) + > + coonoe(s5,1)+coonoe(s6,1)) + of2(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2) + > + coonoe(s5,2)+coonoe(s6,2)) + of2(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3) + > + coonoe(s5,3)+coonoe(s6,3)) +c Le centre de la face 3 + of3(1) = unsqu*(coonoe(s1,1)+coonoe(s4,1) + > + coonoe(s6,1)+coonoe(s7,1)) + of3(2) = unsqu*(coonoe(s1,2)+coonoe(s4,2) + > + coonoe(s6,2)+coonoe(s7,2)) + of3(3) = unsqu*(coonoe(s1,3)+coonoe(s4,3) + > + coonoe(s6,3)+coonoe(s7,3)) +c Le centre de la face 4 + of4(1) = unsqu*(coonoe(s2,1)+coonoe(s3,1) + > + coonoe(s5,1)+coonoe(s8,1)) + of4(2) = unsqu*(coonoe(s2,2)+coonoe(s3,2) + > + coonoe(s5,2)+coonoe(s8,2)) + of4(3) = unsqu*(coonoe(s2,3)+coonoe(s3,3) + > + coonoe(s5,3)+coonoe(s8,3)) +c Le centre de la face 5 + of5(1) = unsqu*(coonoe(s3,1)+coonoe(s4,1) + > + coonoe(s7,1)+coonoe(s8,1)) + of5(2) = unsqu*(coonoe(s3,2)+coonoe(s4,2) + > + coonoe(s7,2)+coonoe(s8,2)) + of5(3) = unsqu*(coonoe(s3,3)+coonoe(s4,3) + > + coonoe(s7,3)+coonoe(s8,3)) +c Le centre de la face 6 + of6(1) = unsqu*(coonoe(s5,1)+coonoe(s6,1) + > + coonoe(s7,1)+coonoe(s8,1)) + of6(2) = unsqu*(coonoe(s5,2)+coonoe(s6,2) + > + coonoe(s7,2)+coonoe(s8,2)) + of6(3) = unsqu*(coonoe(s5,3)+coonoe(s6,3) + > + coonoe(s7,3)+coonoe(s8,3)) +c +c==== +c 3. volume et qualite des tetraedres +c==== +c +c tetra touchant la face 1 + call utqte2 ( qual( 1), volu( 1), coonoe, s1, s2, centr, of1 ) + call utqte2 ( qual( 2), volu( 2), coonoe, s2, s3, centr, of1 ) + call utqte2 ( qual( 3), volu( 3), coonoe, s3, s4, centr, of1 ) + call utqte2 ( qual( 4), volu( 4), coonoe, s1, s4, centr, of1 ) +c tetra touchant la face 2 + call utqte2 ( qual( 5), volu( 5), coonoe, s1, s2, centr, of2 ) + call utqte2 ( qual( 6), volu( 6), coonoe, s2, s5, centr, of2 ) + call utqte2 ( qual( 7), volu( 7), coonoe, s5, s6, centr, of2 ) + call utqte2 ( qual( 8), volu( 8), coonoe, s1, s6, centr, of2 ) +c tetra touchant la face 3 + call utqte2 ( qual( 9), volu( 9), coonoe, s1, s4, centr, of3 ) + call utqte2 ( qual(10), volu(10), coonoe, s4, s7, centr, of3 ) + call utqte2 ( qual(11), volu(11), coonoe, s6, s7, centr, of3 ) + call utqte2 ( qual(12), volu(12), coonoe, s1, s6, centr, of3 ) +c tetra touchant la face 4 + call utqte2 ( qual(13), volu(13), coonoe, s2, s3, centr, of4 ) + call utqte2 ( qual(14), volu(14), coonoe, s3, s8, centr, of4 ) + call utqte2 ( qual(15), volu(15), coonoe, s5, s8, centr, of4 ) + call utqte2 ( qual(16), volu(16), coonoe, s2, s5, centr, of4 ) +c tetra touchant la face 5 + call utqte2 ( qual(17), volu(17), coonoe, s3, s4, centr, of5 ) + call utqte2 ( qual(18), volu(18), coonoe, s4, s7, centr, of5 ) + call utqte2 ( qual(19), volu(19), coonoe, s7, s8, centr, of5 ) + call utqte2 ( qual(20), volu(20), coonoe, s3, s8, centr, of5 ) +c tetra touchant la face 6 + call utqte2 ( qual(21), volu(21), coonoe, s5, s6, centr, of6 ) + call utqte2 ( qual(22), volu(22), coonoe, s6, s7, centr, of6 ) + call utqte2 ( qual(23), volu(23), coonoe, s7, s8, centr, of6 ) + call utqte2 ( qual(24), volu(24), coonoe, s5, s8, centr, of6 ) +c + volume = 0.d0 + do 10 , iaux = 1 , 24 + volume = volume + volu(iaux) + 10 continue +c + end diff --git a/src/tool/Utilitaire/utvoh0.F b/src/tool/Utilitaire/utvoh0.F new file mode 100644 index 00000000..28384b9c --- /dev/null +++ b/src/tool/Utilitaire/utvoh0.F @@ -0,0 +1,104 @@ + subroutine utvoh0 ( coosom, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume Hexaedre - 0 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coosom . e . 3*8 . coordonnees des noeuds . +c . volume . s . 1 . Volume de l'hexaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracte.h" +c +c 0.2. ==> communs +c 0.3. ==> arguments +c + double precision coosom(3,8) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision volcou + double precision v12(3), v13(3), v14(3), v15(3) + double precision v16(3), v17(3), v18(3) +c +c==== +c 1. le volume de l'hexaedre est la somme des volumes des 6 tetraedres +c que l'on obtient en coupant les quadrangles en 2 triangles +c on rappelle que le volume d'un tetraedre est egale au sixieme +c de la valeur absolue du produit mixte de trois des vecteurs +c representant les aretes. +c vn = v1xv2 --> volume = 1/6 * produit mixte (v1,v2,v3) +c==== +c + do 11 , iaux = 1 , 3 +c + v12(iaux) = coosom(iaux,2) - coosom(iaux,1) + v13(iaux) = coosom(iaux,3) - coosom(iaux,1) + v14(iaux) = coosom(iaux,4) - coosom(iaux,1) + v15(iaux) = coosom(iaux,5) - coosom(iaux,1) + v16(iaux) = coosom(iaux,6) - coosom(iaux,1) + v17(iaux) = coosom(iaux,7) - coosom(iaux,1) + v18(iaux) = coosom(iaux,8) - coosom(iaux,1) +c + 11 continue +c + call utprmi ( v18, v13, v12, volcou ) +c write(*,*) 'volume du premier tetraedre', volcou + volume = abs(volcou) +c + call utprmi ( v18, v12, v15, volcou ) +c write(*,*) 'volume du deuxieme tetraedre', volcou + volume = volume + abs(volcou) +c + call utprmi ( v18, v15, v16, volcou ) +c write(*,*) 'volume du troisieme tetraedre', volcou + volume = volume + abs(volcou) +c + call utprmi ( v18, v16, v17, volcou ) +c write(*,*) 'volume du quatrieme tetraedre', volcou + volume = volume + abs(volcou) +c + call utprmi ( v18, v17, v14, volcou ) +c write(*,*) 'volume du cinquieme tetraedre', volcou + volume = volume + abs(volcou) +c + call utprmi ( v18, v14, v13, volcou ) +c write(*,*) 'volume du sixieme tetraedre', volcou + volume = volume + abs(volcou) +c + volume = unssix * volume +c + end diff --git a/src/tool/Utilitaire/utvohe.F b/src/tool/Utilitaire/utvohe.F new file mode 100644 index 00000000..6a1e8b9e --- /dev/null +++ b/src/tool/Utilitaire/utvohe.F @@ -0,0 +1,83 @@ + subroutine utvohe ( coonoe, sommet, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume HExaedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . sommet . e . 8 . Liste des sommets ordonnes suivant l'hexa . +c . volume . s . 1 . Volume de l'hexaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + integer sommet(8) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision coosom(3,8) +c +c==== +c 1. Reperage des coorodonnes des sommets +c==== +c + do 11 , iaux = 1 , 3 +c + coosom(iaux,1) = coonoe(sommet(1),iaux) + coosom(iaux,2) = coonoe(sommet(2),iaux) + coosom(iaux,3) = coonoe(sommet(3),iaux) + coosom(iaux,4) = coonoe(sommet(4),iaux) + coosom(iaux,5) = coonoe(sommet(5),iaux) + coosom(iaux,6) = coonoe(sommet(6),iaux) + coosom(iaux,7) = coonoe(sommet(7),iaux) + coosom(iaux,8) = coonoe(sommet(8),iaux) +c + 11 continue +c +c==== +c 2. Programme generique +c==== +c + call utvoh0 ( coosom, volume ) +c + end diff --git a/src/tool/Utilitaire/utvois.F b/src/tool/Utilitaire/utvois.F new file mode 100644 index 00000000..a0010ef7 --- /dev/null +++ b/src/tool/Utilitaire/utvois.F @@ -0,0 +1,313 @@ + subroutine utvois ( nomail, nhvois, + > voarno, vofaar, vovoar, vovofa, + > ppovos, pvoiso, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - creation des tableaux des VOISins +c -- ---- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . nomail . e . char8 . nom de l'objet maillage homard . +c . nhvois . es . char8 . nom de la branche Voisins . +c . voarno . e . 1 . pilotage des voisins des noeuds : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . vofaar . e . 1 . pilotage des voisins des aretes : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . vovoar . e . 1 . pilotage des volumes voisins des aretes : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . vovofa . e . 1 . pilotage des volumes voisins des faces : . +c . . . . -1 : on detruit la table. . +c . . . . 0 : on ne fait rien. . +c . . . . 1 : on construit la table. . +c . . . . 2 : on construit la table et on controle . +c . ppovos . s . 1 . adresse du pointeur des vois. des sommets . +c . pvoiso . s . 1 . adresse des voisins des sommets . +c . nbfaar . s . 1 . nombre cumule de faces par arete . +c . pposif . s . 1 . adresse du pointeur des vois. des aretes . +c . pfacar . s . 1 . adresse des voisins des aretes . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : probleme . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVOIS' ) +c +#include "nblang.h" +#include "envca1.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + character*8 nomail, nhvois +c + integer voarno, vofaar, vovoar, vovofa + integer ppovos, pvoiso + integer nbfaar, pposif, pfacar +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux +c + character*8 norenu + character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad + character*8 nhtetr, nhhexa, nhpyra, nhpent + character*8 nhelig + character*8 nhsupe, nhsups +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif + texte(1,4) = '(5x,''Mise en place des voisins.'')' + texte(1,5) = '(a,'' voisins des '',a,'' : '',i6)' +c + texte(2,4) = '(5x,''Neighbourhood.'')' + texte(2,5) = '(a,'' closed to the '',a,'' : '',i6)' +c +#include "impr03.h" +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,4)) +#endif +c +c==== +c 2. Allocation de la tete des voisins. +c Il faut le faire au depart, sinon, le programme utnomh plante. +c==== +c + if ( codret.eq.0 ) then +c + call gmobal ( nomail//'.Voisins', codret ) +c + if ( codret.eq.0 ) then + call gmaloj ( nomail//'.Voisins', ' ', 0, iaux, codret ) +c + elseif ( codret.eq.1 ) then + codret = 0 +c + else + codret = 2 +c + endif +c + endif +c +c==== +c 3. recuperation des donnees du maillage d'entree +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '3. recuperation ; codret', codret +#endif +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTNOMH', nompro +#endif + call utnomh ( nomail, + > sdim, mdim, + > degre, maconf, homolo, hierar, + > rafdef, nbmane, typcca, typsfr, maextr, + > mailet, + > norenu, + > nhnoeu, nhmapo, nharet, + > nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > nhelig, + > nhvois, nhsupe, nhsups, + > ulsort, langue, codret) +c + endif +c +c==== +c 4. Traitement +c==== +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4. Traitement ; codret', codret +#endif +c 4.1. ==> determination des aretes voisines des noeuds +c +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) + > mess14(langue,3,1), mess14(langue,3,-1), voarno +#endif +c + if ( voarno.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGAN', nompro +#endif +c + call utvgan ( nhvois, nhnoeu, nharet, + > voarno, + > ppovos, pvoiso, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.2. ==> determination des faces voisines des aretes +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.2. faces/aretes ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) + > mess14(langue,3,8), mess14(langue,3,1), vofaar +#endif +c + if ( vofaar.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGFA', nompro +#endif +c + call utvgfa ( nhvois, nharet, nhtria, nhquad, + > vofaar, + > nbfaar, pposif, pfacar, + > ulsort, langue, codret ) +c + endif +c + endif +c +c 4.3. ==> reperage des volumes s'appuyant sur chaque arete +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.3. volumes/aretes ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) + > mess14(langue,3,9), mess14(langue,3,1), vovoar +#endif +c + if ( vovoar.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVA', nompro +#endif + call utvgva ( nhvois, nharet, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > vovoar, + > ulsort, langue, codret) +c + endif +c + endif +c +c 4.4. ==> reperage des volumes s'appuyant sur chaque face +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,90002) '4.4. volumes/faces ; codret', codret +#endif +#ifdef _DEBUG_HOMARD_ + write(ulsort,texte(langue,5)) + > mess14(langue,3,9), mess14(langue,3,8), vovofa +#endif +c + if ( vovofa.ne.0 ) then +c + if ( codret.eq.0 ) then +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVGVF', nompro +#endif + call utvgvf ( nhvois, nhtria, nhquad, + > nhtetr, nhhexa, nhpyra, nhpent, + > vovofa, + > ulsort, langue, codret) +c + endif +c + endif +c +c==== +c 5. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvop0.F b/src/tool/Utilitaire/utvop0.F new file mode 100644 index 00000000..27f0ad01 --- /dev/null +++ b/src/tool/Utilitaire/utvop0.F @@ -0,0 +1,93 @@ + subroutine utvop0 ( coosom, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume Pentaedre - 0 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coosom . e . 3*6 . coordonnees des noeuds . +c . volume . s . 1 . Volume du pentaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracte.h" +c +c 0.2. ==> communs +c 0.3. ==> arguments +c + double precision coosom(3,6) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision volcou + double precision v12(3), v13(3), v25(3) + double precision v26(3), v46(3) +c +c==== +c 1. le volume du pentaedre est la somme des volumes des 3 tetraedres +c que l'on obtient en coupant les quadrangles en 2 triangles +c tetraedre 1 : (S1, S2, S3, S6) +c tetraedre 2 : (S1, S2, S4, S6) +c tetraedre 3 : (S5, S2, S4, S6) +c on rappelle que le volume d'un tetraedre est egale au sixieme +c de la valeur absolue du produit mixte de trois des vecteurs +c representant les aretes. +c vn = v1xv2 --> volume = 1/6 * produit mixte (v1,v2,v3) +c==== +c + do 11 , iaux = 1 , 3 +c + v12(iaux) = coosom(iaux,2) - coosom(iaux,1) + v13(iaux) = coosom(iaux,3) - coosom(iaux,1) + v26(iaux) = coosom(iaux,6) - coosom(iaux,2) + v25(iaux) = coosom(iaux,5) - coosom(iaux,2) + v46(iaux) = coosom(iaux,6) - coosom(iaux,4) +c + 11 continue +c + call utprmi ( v26, v13, v12, volcou ) +c write(*,*) 'volume du premier tetraedre', volcou + volume = abs(volcou) +c + call utprmi ( v46, v26, v12, volcou ) +c write(*,*) 'volume du deuxieme tetraedre', volcou + volume = volume + abs(volcou) +c + call utprmi ( v46, v26, v25, volcou ) +c write(*,*) 'volume du troisieme tetraedre', volcou + volume = volume + abs(volcou) +c + volume = unssix * volume +c + end diff --git a/src/tool/Utilitaire/utvope.F b/src/tool/Utilitaire/utvope.F new file mode 100644 index 00000000..f5653300 --- /dev/null +++ b/src/tool/Utilitaire/utvope.F @@ -0,0 +1,81 @@ + subroutine utvope ( coonoe, sommet, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume PEntaedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . sommet . e . 6 . Liste des sommets ordonnes du pentaedre . +c . volume . s . 1 . Volume du pentaedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + integer sommet(6) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision coosom(3,6) +c +c==== +c 1. Reperage des coorodonnes des sommets +c==== +c + do 11 , iaux = 1 , 3 +c + coosom(iaux,1) = coonoe(sommet(1),iaux) + coosom(iaux,2) = coonoe(sommet(2),iaux) + coosom(iaux,3) = coonoe(sommet(3),iaux) + coosom(iaux,4) = coonoe(sommet(4),iaux) + coosom(iaux,5) = coonoe(sommet(5),iaux) + coosom(iaux,6) = coonoe(sommet(6),iaux) +c + 11 continue +c +c==== +c 2. Programme generique +c==== +c + call utvop0 ( coosom, volume ) +c + end diff --git a/src/tool/Utilitaire/utvopy.F b/src/tool/Utilitaire/utvopy.F new file mode 100644 index 00000000..5854e387 --- /dev/null +++ b/src/tool/Utilitaire/utvopy.F @@ -0,0 +1,80 @@ + subroutine utvopy ( coonoe, listso, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume PYramide +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . listso . e . 8 . liste des sommets ordonnes de la pyramide . +c . volume . s . 1 . Volume de la pyramide . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + integer listso(5) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision coosom(3,5) +c +c==== +c 1. Reperage des coordonnees des sommets +c==== +c + do 11 , iaux = 1 , 3 +c + coosom(iaux,1) = coonoe(listso(1),iaux) + coosom(iaux,2) = coonoe(listso(2),iaux) + coosom(iaux,3) = coonoe(listso(3),iaux) + coosom(iaux,4) = coonoe(listso(4),iaux) + coosom(iaux,5) = coonoe(listso(5),iaux) +c + 11 continue +c +c==== +c 2. Programme generique +c==== +c + call utvoy0 ( coosom, volume ) +c + end diff --git a/src/tool/Utilitaire/utvot0.F b/src/tool/Utilitaire/utvot0.F new file mode 100644 index 00000000..9c84fb66 --- /dev/null +++ b/src/tool/Utilitaire/utvot0.F @@ -0,0 +1,74 @@ + subroutine utvot0 ( coosom, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume TEtraedre - 0 +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coosom . e . 3*4 . coordonnees des noeuds . +c . volume . s . 1 . Volume du tetraedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracte.h" +c +c 0.2. ==> communs +c 0.3. ==> arguments +c + double precision coosom(3,4) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision v12(3), v13(3), v14(3) +c +c==== +c 1. on rappelle que le volume d'un tetraedre est egale au sixieme +c de la valeur absolue du produit mixte de trois des vecteurs +c representant les aretes. +c vn = v1xv2 --> volume = 1/6 * produit mixte (v1,v2,v3) +c==== +c + do 11 , iaux = 1 , 3 +c + v12(iaux) = coosom(iaux,2) - coosom(iaux,1) + v13(iaux) = coosom(iaux,3) - coosom(iaux,1) + v14(iaux) = coosom(iaux,4) - coosom(iaux,1) +c + 11 continue +c + call utprmi ( v12, v13, v14, volume ) +c + volume = unssix * abs(volume) +c + end diff --git a/src/tool/Utilitaire/utvote.F b/src/tool/Utilitaire/utvote.F new file mode 100644 index 00000000..713b229a --- /dev/null +++ b/src/tool/Utilitaire/utvote.F @@ -0,0 +1,79 @@ + subroutine utvote ( coonoe, sommet, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume TEtraedre +c -- -- -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . sommet . e . 4 . Liste des sommets ordonnes suivant le tetra. +c . volume . s . 1 . Volume du tetraedre . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "envca1.h" +c +c 0.3. ==> arguments +c + double precision coonoe(nbnoto,sdim) + integer sommet(4) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision coosom(3,4) +c +c==== +c 1. Reperage des coorodonnes des sommets +c==== +c + do 11 , iaux = 1 , 3 +c + coosom(iaux,1) = coonoe(sommet(1),iaux) + coosom(iaux,2) = coonoe(sommet(2),iaux) + coosom(iaux,3) = coonoe(sommet(3),iaux) + coosom(iaux,4) = coonoe(sommet(4),iaux) +c + 11 continue +c +c==== +c 2. Programme generique +c==== +c + call utvot0 ( coosom, volume ) +c + end diff --git a/src/tool/Utilitaire/utvoy0.F b/src/tool/Utilitaire/utvoy0.F new file mode 100644 index 00000000..99a84f23 --- /dev/null +++ b/src/tool/Utilitaire/utvoy0.F @@ -0,0 +1,85 @@ + subroutine utvoy0 ( coosom, volume ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : VOlume pYramide - 0 +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . coosom . e . 3*5 . coordonnees des noeuds . +c . volume . s . 1 . Volume de la pyramide . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +#include "fracte.h" +c +c 0.2. ==> communs +c 0.3. ==> arguments +c + double precision coosom(3,5) + double precision volume +c +c 0.4. ==> variables locales +c + integer iaux +c + double precision volcou + double precision v12(3), v13(3), v14(3), v15(3) +c +c==== +c 1. le volume de la pyramide est la somme des volumes des 2 tetraedres +c que l'on obtient en coupant sa base quadrangulaire en 2 triangles +c on rappelle que le volume d'un tetraedre est egale au sixieme +c de la valeur absolue du produit mixte de trois des vecteurs +c representant les aretes. +c vn = v1xv2 --> volume = 1/6 * produit mixte (v1,v2,v3) +c==== +c + do 11 , iaux = 1 , 3 +c + v12(iaux) = coosom(iaux,2) - coosom(iaux,1) + v13(iaux) = coosom(iaux,3) - coosom(iaux,1) + v14(iaux) = coosom(iaux,4) - coosom(iaux,1) + v15(iaux) = coosom(iaux,5) - coosom(iaux,1) +c + 11 continue +c + call utprmi ( v12, v13, v15, volcou ) +cgn write(*,*) 'volume du premier tetraedre',volcou + volume = abs(volcou) +c + call utprmi ( v14, v13, v15, volcou ) +cgn write(*,*) 'volume du deuxieme tetraedre',volcou + volume = volume + abs(volcou) +c + volume = unssix * volume +cgn write(*,*) 'volume de la pyramide',volume +c + end diff --git a/src/tool/Utilitaire/utvpen.F b/src/tool/Utilitaire/utvpen.F new file mode 100644 index 00000000..3bf24dcf --- /dev/null +++ b/src/tool/Utilitaire/utvpen.F @@ -0,0 +1,93 @@ + subroutine utvpen ( lepent, volume, + > coonoe, somare, arequa, + > facpen, cofape, arepen ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Colume d'un PENtaedre +c -- - --- +c ______________________________________________________________________ +c +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lepent . e . 1 . numero du pentaedre a examiner . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles . +c . facpen . e .nbpecf*5. numeros des 5 faces des pentaedres . +c . cofape . e .nbpecf*5. code des 5 faces des pentaedres . +c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombqu.h" +#include "nombpe.h" +c +c 0.3. ==> arguments +c + double precision volume + double precision coonoe(nbnoto,3) +c + integer lepent + integer somare(2,nbarto) + integer arequa(nbquto,4) + integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9) +c +c 0.4. ==> variables locales +c + integer listar(9), listso(6) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et les sommets +c==== +c + call utaspe ( lepent, + > nbquto, nbpecf, nbpeca, + > somare, arequa, + > facpen, cofape, arepen, + > listar, listso ) +c +c==== +c 2. volume +c==== +c + call utvope ( coonoe, listso, volume ) +c + end diff --git a/src/tool/Utilitaire/utvpyr.F b/src/tool/Utilitaire/utvpyr.F new file mode 100644 index 00000000..9ba23986 --- /dev/null +++ b/src/tool/Utilitaire/utvpyr.F @@ -0,0 +1,93 @@ + subroutine utvpyr ( lapyra, volume, + > coonoe, somare, aretri, + > facpyr, cofapy, arepyr ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Volume d'une PYRamide +c -- - --- +c ______________________________________________________________________ +c +c . Jacobien normalise +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . lapyra . e . 1 . numero de la pyramide a examiner . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides . +c . cofapy . e .nbpycf*5. codes des faces des pyramides . +c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombpy.h" +c +c 0.3. ==> arguments +c + double precision volume + double precision coonoe(nbnoto,3) +c + integer lapyra + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8) +c +c 0.4. ==> variables locales +c + integer listar(8), listso(5) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et les sommets +c==== +c + call utaspy ( lapyra, + > nbtrto, nbpycf, nbpyca, + > somare, aretri, + > facpyr, cofapy, arepyr, + > listar, listso ) +c +c==== +c 2. volume +c==== +c + call utvopy ( coonoe, listso, volume ) +c + end diff --git a/src/tool/Utilitaire/utvte0.F b/src/tool/Utilitaire/utvte0.F new file mode 100644 index 00000000..7e20bab1 --- /dev/null +++ b/src/tool/Utilitaire/utvte0.F @@ -0,0 +1,225 @@ + subroutine utvte0 ( letetr, nbtfal, nbtaal, nbtral, + > somare, aretri, + > tritet, cotrte, aretet, + > ulbila, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - Verification d'un TEtraedre +c -- - -- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . le tetraedre a controler . +c . nbtfal . e . 1 . nombre de tetrs par faces pour les allocs . +c . nbtaal . e . 1 . nbre de tetrs par aretes pour les allocs . +c . nbtral . e . 1 . nombre de triangles pour les allocations . +c . somare . e . 2*nbar . numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbtaal*6. numeros des 6 aretes des tetraedres . +c . ulbila . e . 1 . unite logitee d'ecriture du bilan . +c . ulsort . e . 1 . numero d'unite logitee de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . >0 : probleme dans le controle . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTVTE0' ) +c +#include "nblang.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +c +#include "impr02.h" +c +c 0.3. ==> arguments +c + integer letetr, nbtfal, nbtaal, nbtral + integer somare(2,*) + integer aretri(nbtral,3) + integer tritet(nbtfal,4), cotrte(nbtfal,4), aretet(nbtaal,8) +c + integer ulbila + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer f1, f2, f3, f4 + integer listar(6), listso(4) +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. messages +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = + > '(''Le tetraedre '',i10,'' a des '',a,'' identiques :'',6i10)' +c + texte(2,4) = + > '(''Tetrahedron # '',i10,'' has got similar '',a,'':'',6i10)' +c + codret = 0 +c +c==== +c 2. verification +c==== +c +c 2.1. ==> les faces doivent etre differentes ... +c + if ( letetr.le.nbtfal ) then +c + f1 = tritet(letetr,1) + f2 = tritet(letetr,2) + f3 = tritet(letetr,3) + f4 = tritet(letetr,4) +c + if ( f1.eq.f2 .or. + > f1.eq.f3 .or. + > f1.eq.f4 .or. + > f2.eq.f3 .or. + > f2.eq.f4 .or. + > f3.eq.f4 ) then + codret = 1 + write (ulsort,texte(langue,4)) letetr, mess14(langue,3,8), + > f1, f2, f3, f4 + write (ulbila,texte(langue,4)) letetr, mess14(langue,3,8), + > f1, f2, f3, f4 + endif +c + endif +c +c 2.2. ==> les aretes doivent etre differentes ... +c + if ( codret.eq.0 ) then +c + call utaste ( letetr, + > nbtral, nbtfal, nbtaal, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + endif +c + if ( codret.eq.0 ) then +c + do 221 , iaux = 1 , 5 + do 222 , jaux = iaux+1 , 6 + if ( listar(iaux).eq.listar(jaux) ) then + codret = 1 + endif + 222 continue + 221 continue +c + if ( codret.ne.0 ) then + write (ulsort,texte(langue,4)) letetr, mess14(langue,3,1), + > (listar(iaux),iaux=1,6) + write (ulbila,texte(langue,4)) letetr, mess14(langue,3,1), + > (listar(iaux),iaux=1,6) + endif +c + endif +c +c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ... +c + if ( codret.eq.0 ) then +c + iaux = 3 + jaux = 6 +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,3)) 'UTVAR0', nompro +#endif + call utvar0 ( iaux, letetr, jaux, listar, somare, + > ulbila, ulsort, langue, codret ) +c + endif +c +c 2.4. ==> les sommets doivent etre differents ... +c + if ( codret.eq.0 ) then +c + if ( listso(1).eq.listso(2) .or. + > listso(1).eq.listso(3) .or. + > listso(1).eq.listso(4) .or. + > listso(2).eq.listso(3) .or. + > listso(2).eq.listso(4) .or. + > listso(3).eq.listso(4) ) then + codret = 1 + write (ulsort,texte(langue,4)) letetr, mess14(langue,3,-1), + > listso(1), listso(2), + > listso(3), listso(4) + write (ulbila,texte(langue,4)) letetr, mess14(langue,3,-1), + > listso(1), listso(2), + > listso(3), listso(4) + endif +c + endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/Utilitaire/utvtet.F b/src/tool/Utilitaire/utvtet.F new file mode 100644 index 00000000..064b1c18 --- /dev/null +++ b/src/tool/Utilitaire/utvtet.F @@ -0,0 +1,98 @@ + subroutine utvtet ( letetr, volume, + > coonoe, somare, aretri, + > tritet, cotrte, aretet ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire : Volume d'un TETraedre +c -- - --- +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . letetr . e . 1 . numero du tetraedre a examiner . +c . volume . s . 1 . volume . +c . coonoe . e . nbnoto . coordonnees des noeuds . +c . . . * sdim . . +c . somare . e .2*nbarto. numeros des extremites d'arete . +c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles . +c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . +c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres . +c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres . +c .____________________________________________________________________. +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c +c 0.2. ==> communs +c +#include "nombno.h" +#include "nombar.h" +#include "nombtr.h" +#include "nombte.h" +c +c 0.3. ==> arguments +c + double precision volume, coonoe(nbnoto,3) +c + integer letetr + integer somare(2,nbarto) + integer aretri(nbtrto,3) + integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6) +c +c 0.4. ==> variables locales +c + integer iaux, jaux + integer listar(6), listso(4) +c + double precision coosom(3,4) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. les aretes et sommets de ce tetraedre +c==== +c + call utaste ( letetr, + > nbtrto, nbtecf, nbteca, + > somare, aretri, + > tritet, cotrte, aretet, + > listar, listso ) +c + do 11 , jaux = 1, 4 + do 111 , iaux = 1, 3 + coosom(iaux,jaux) = coonoe(listso(jaux),iaux) + 111 continue + 11 continue +c +c==== +c 2. calcul du volume du tetraedre +c==== +c + call utvot0 ( coosom, volume ) +c + end diff --git a/src/tool/Utilitaire/utwipg.F b/src/tool/Utilitaire/utwipg.F new file mode 100644 index 00000000..97b2d4c2 --- /dev/null +++ b/src/tool/Utilitaire/utwipg.F @@ -0,0 +1,325 @@ + subroutine utwipg ( ngauss, nbnorf, sdim, typgeo, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +c ______________________________________________________________________ +c +c H O M A R D +c +c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D +c +c Version originale enregistree le 18 juin 1996 sous le numero 96036 +c aupres des huissiers de justice Simart et Lavoir a Clamart +c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 +c aupres des huissiers de justice +c Lavoir, Silinski & Cherqui-Abrahmi a Clamart +c +c HOMARD est une marque deposee d'Electricite de France +c +c Copyright EDF 1996 +c Copyright EDF 1998 +c Copyright EDF 2002 +c Copyright EDF 2020 +c ______________________________________________________________________ +c +c UTilitaire - fonctions de forme WI sur les Points de Gauss +c -- -- - - +c ______________________________________________________________________ +c . . . . . +c . nom . e/s . taille . description . +c .____________________________________________________________________. +c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg . +c . nbnorf . e . 1 . nbre de noeuds de l'element de reference . +c . sdim . e . 1 . dimension de l'element de reference . +c . typgeo . e . 1 . type geometrique au sens MED . +c . conorf . e . sdim* . coordonnees des noeuds de l'element de . +c . . . nbnorf . reference . +c . copgrf . e . sdim* . coordonnees des points de Gauss . +c . . . ngauss . de l'element de reference . +c . wipg . s . nbnorf*. fonctions de forme exprimees aux points de . +c . . . ngauss . Gauss . +c . ulsort . e . 1 . numero d'unite logique de la liste standard. +c . langue . e . 1 . langue des messages . +c . . . . 1 : francais, 2 : anglais . +c . codret . es . 1 . code de retour des modules . +c . . . . 0 : pas de probleme . +c . . . . 1 : les coordonnees de l'element de . +c . . . . reference sont incorrectes . +c . . . . 2 : pas encore operationnel . +c ______________________________________________________________________ +c +c==== +c 0. declarations et dimensionnement +c==== +c +c 0.1. ==> generalites +c + implicit none + save +c + character*6 nompro + parameter ( nompro = 'UTWIPG' ) +c +#include "nblang.h" +#include "consts.h" +c +c 0.2. ==> communs +c +#include "envex1.h" +#include "precis.h" +c +#include "meddc0.h" +#include "fracta.h" +#include "fractc.h" +c +c 0.3. ==> arguments +c + integer ngauss, nbnorf, sdim, typgeo +c + double precision conorf(sdim,nbnorf), copgrf(sdim,ngauss) + double precision wipg(nbnorf,ngauss) +c + integer ulsort, langue, codret +c +c 0.4. ==> variables locales +c + integer nugaus + integer iaux, jaux +c + integer nbmess + parameter ( nbmess = 10 ) + character*80 texte(nblang,nbmess) +c +c 0.5. ==> initialisations +c ______________________________________________________________________ +c +c==== +c 1. initialisations +c==== +c +#include "impr01.h" +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Entree', nompro + call dmflsh (iaux) +#endif +c + texte(1,4) = '(/,''Type geometrique :'',i8)' + texte(1,5) = '(''Coordonnees incorrectes'')' + texte(1,5) = '(''Impossible de calculer les fonctions de forme'')' +c + texte(2,4) = '(/,''Geometrical type :'',i8)' + texte(2,5) = '(''Uncorrect coordinates'')' + texte(2,6) = '(''Functions cannot be computed'')' +c +#ifdef _DEBUG_HOMARD_ + iaux = 2 + call utimpg ( iaux, ngauss, nbnorf, sdim, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) +#endif +c + codret = 0 +c +c==== +c 2. calcul des valeurs des fonctions de forme aux points de Gauss +c==== +c 2.1. ==> triangle en degre 2 +c + if ( typgeo.eq.edtri6 ) then +c +c 2.1.1. ==> Test sur les coordonnees des points de Gauss +c + if (abs(conorf(1,1)).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,1)).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,2)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,2)).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,3)).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,3)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,4)-unsde).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,4)).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,5)-unsde).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,5)-unsde).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,6)).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,6)-unsde).gt.epsima) then + codret = 1 + endif +c +c 2.1.2. ==> Calcul +c + if ( codret.eq.0 ) then + + do 212 , nugaus = 1 , ngauss +c + wipg(1,nugaus) = -(1.d0-copgrf(1,nugaus)-copgrf(2,nugaus))* + > (1.d0-2.d0*(1.d0-copgrf(1,nugaus)-copgrf(2,nugaus))) + wipg(2,nugaus) = -copgrf(1,nugaus)* + > (1.d0-2.d0*copgrf(1,nugaus)) + wipg(3,nugaus) = -copgrf(2,nugaus)* + > (1.d0-2.d0*copgrf(2,nugaus)) + wipg(4,nugaus) = 4.d0*copgrf(1,nugaus)* + > (1.d0-copgrf(1,nugaus)-copgrf(2,nugaus)) + wipg(5,nugaus) = 4.d0*copgrf(1,nugaus)*copgrf(2,nugaus) + wipg(6,nugaus) = 4.d0*copgrf(2,nugaus)* + > (1.d0-copgrf(1,nugaus)-copgrf(2,nugaus)) +c + 212 continue +c + endif +c +c 2.2. ==> quadrangle en degre 2 +c + elseif ( typgeo.eq.edqua8 ) then +c +c 2.2.1. ==> Test sur les coordonnees des points de Gauss +c + if (abs(conorf(1,1)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,1)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,2)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,2)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,3)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,3)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,4)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,4)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,5)).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,5)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,6)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,6)).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,7)).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,7)-1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(1,8)+1.d0).gt.epsima) then + codret = 1 + elseif (abs(conorf(2,8)).gt.epsima) then + codret = 1 + endif +c +c 2.2.2. ==> Calcul +c + if ( codret.eq.0 ) then +c + do 222 , nugaus = 1 , ngauss +c + wipg(1,nugaus) = unsqu*(1.d0-copgrf(1,nugaus))* + > (1.d0-copgrf(2,nugaus))* + > (-1.d0-copgrf(1,nugaus)-copgrf(2,nugaus)) + wipg(2,nugaus) = unsqu*(1.d0+copgrf(1,nugaus))* + > (1.d0-copgrf(2,nugaus))* + > (-1.d0+copgrf(1,nugaus)-copgrf(2,nugaus)) + wipg(3,nugaus) = unsqu*(1.d0+copgrf(1,nugaus))* + > (1.d0+copgrf(2,nugaus))* + > (-1.d0+copgrf(1,nugaus)+copgrf(2,nugaus)) + wipg(4,nugaus) = unsqu*(1.d0-copgrf(1,nugaus))* + > (1.d0+copgrf(2,nugaus))* + > (-1.d0-copgrf(1,nugaus)+copgrf(2,nugaus)) + wipg(5,nugaus) = unsde*(1.d0-copgrf(1,nugaus))* + > (1.d0-copgrf(1,nugaus))* + > (1.d0-copgrf(2,nugaus)) + wipg(6,nugaus) = unsde*(1.d0+copgrf(1,nugaus))* + > (1.d0-copgrf(2,nugaus))* + > (1.d0-copgrf(2,nugaus)) + wipg(7,nugaus) = unsde*(1.d0-copgrf(1,nugaus))* + > (1.d0-copgrf(1,nugaus))* + > (1.d0+copgrf(2,nugaus)) + wipg(8,nugaus) = unsde*(1.d0-copgrf(1,nugaus))* + > (1.d0-copgrf(2,nugaus))* + > (1.d0-copgrf(2,nugaus)) +c + 222 continue +c + endif +c +c 2.3. ==> tetraedre en degre 1 +c + elseif ( typgeo.eq.edtet4 ) then +c +c 2.3.1. ==> Test sur les coordonnees des points de Gauss +c +c 2.3.2. ==> Calcul +c + if ( codret.eq.0 ) then +c + do 232 , nugaus = 1 , ngauss +c + wipg(1,nugaus) = copgrf(2,nugaus) + wipg(2,nugaus) = copgrf(3,nugaus) + wipg(3,nugaus) = 1.d0-copgrf(1,nugaus) + > -copgrf(2,nugaus) + > -copgrf(3,nugaus) + wipg(4,nugaus) = copgrf(1,nugaus) +c + 232 continue +c + endif +c +c 2.4. ==> tetraedre en degre 4 : on fait comme si ... +c + elseif ( typgeo.eq.edte10 ) then +c + codret = 0 +c +c 2.n. ==> non encore disponible +c + else +c + codret = 2 +c + endif +c +#ifdef _DEBUG_HOMARD_ + if ( codret.eq.0 ) then + iaux = 3 + call utimpg ( iaux, ngauss, nbnorf, sdim, + > conorf, copgrf, wipg, + > ulsort, langue, codret ) + endif +#endif +c +c==== +c 3. la fin +c==== +c + if ( codret.ne.0 ) then +c +#include "envex2.h" +c + iaux = 2 + call utimpg ( iaux, ngauss, nbnorf, sdim, + > conorf, copgrf, wipg, + > ulsort, langue, jaux ) + write (ulsort,texte(langue,4)) typgeo + write (ulsort,texte(langue,3+codret)) + write (ulsort,texte(langue,1)) 'Sortie', nompro + write (ulsort,texte(langue,2)) codret +c + endif +c +#ifdef _DEBUG_HOMARD_ + write (ulsort,texte(langue,1)) 'Sortie', nompro + call dmflsh (iaux) +#endif +c + end diff --git a/src/tool/homard.f b/src/tool/homard.f new file mode 100644 index 00000000..53696caa --- /dev/null +++ b/src/tool/homard.f @@ -0,0 +1,3 @@ + PROGRAM HOMARD + CALL HOPRIN + END